#:include "common.fypp"
submodule(stdlib_lapack_base) stdlib_lapack_householder_reflectors
implicit none
contains
#:for ik,it,ii in LINALG_INT_KINDS_TYPES
pure module subroutine stdlib${ii}$_slarf( side, m, n, v, incv, tau, c, ldc, work )
!! SLARF applies a real elementary reflector H to a real m by n matrix
!! C, from either the left or the right. H is represented in the form
!! H = I - tau * v * v**T
!! where tau is a real scalar and v is a real vector.
!! If tau = 0, then H is taken to be the unit matrix.
! -- 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) :: side
integer(${ik}$), intent(in) :: incv, ldc, m, n
real(sp), intent(in) :: tau
! Array Arguments
real(sp), intent(inout) :: c(ldc,*)
real(sp), intent(in) :: v(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: applyleft
integer(${ik}$) :: i, lastv, lastc
! Executable Statements
applyleft = stdlib_lsame( side, 'L' )
lastv = 0_${ik}$
lastc = 0_${ik}$
if( tau/=zero ) then
! set up variables for scanning v. lastv begins pointing to the end
! of v.
if( applyleft ) then
lastv = m
else
lastv = n
end if
if( incv>0_${ik}$ ) then
i = 1_${ik}$ + (lastv-1) * incv
else
i = 1_${ik}$
end if
! look for the last non-zero row in v.
do while( lastv>0 .and. v( i )==zero )
lastv = lastv - 1_${ik}$
i = i - incv
end do
if( applyleft ) then
! scan for the last non-zero column in c(1:lastv,:).
lastc = stdlib${ii}$_ilaslc(lastv, n, c, ldc)
else
! scan for the last non-zero row in c(:,1:lastv).
lastc = stdlib${ii}$_ilaslr(m, lastv, c, ldc)
end if
end if
! note that lastc.eq.0_sp renders the blas operations null; no special
! case is needed at this level.
if( applyleft ) then
! form h * c
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastv,1:lastc)**t * v(1:lastv,1)
call stdlib${ii}$_sgemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1_${ik}$ &
)
! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**t
call stdlib${ii}$_sger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc )
end if
else
! form c * h
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1)
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,&
1_${ik}$ )
! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**t
call stdlib${ii}$_sger( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc )
end if
end if
return
end subroutine stdlib${ii}$_slarf
pure module subroutine stdlib${ii}$_dlarf( side, m, n, v, incv, tau, c, ldc, work )
!! DLARF applies a real elementary reflector H to a real m by n matrix
!! C, from either the left or the right. H is represented in the form
!! H = I - tau * v * v**T
!! where tau is a real scalar and v is a real vector.
!! If tau = 0, then H is taken to be the unit matrix.
! -- 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) :: side
integer(${ik}$), intent(in) :: incv, ldc, m, n
real(dp), intent(in) :: tau
! Array Arguments
real(dp), intent(inout) :: c(ldc,*)
real(dp), intent(in) :: v(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: applyleft
integer(${ik}$) :: i, lastv, lastc
! Executable Statements
applyleft = stdlib_lsame( side, 'L' )
lastv = 0_${ik}$
lastc = 0_${ik}$
if( tau/=zero ) then
! set up variables for scanning v. lastv begins pointing to the end
! of v.
if( applyleft ) then
lastv = m
else
lastv = n
end if
if( incv>0_${ik}$ ) then
i = 1_${ik}$ + (lastv-1) * incv
else
i = 1_${ik}$
end if
! look for the last non-zero row in v.
do while( lastv>0 .and. v( i )==zero )
lastv = lastv - 1_${ik}$
i = i - incv
end do
if( applyleft ) then
! scan for the last non-zero column in c(1:lastv,:).
lastc = stdlib${ii}$_iladlc(lastv, n, c, ldc)
else
! scan for the last non-zero row in c(:,1:lastv).
lastc = stdlib${ii}$_iladlr(m, lastv, c, ldc)
end if
end if
! note that lastc.eq.0_dp renders the blas operations null; no special
! case is needed at this level.
if( applyleft ) then
! form h * c
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastv,1:lastc)**t * v(1:lastv,1)
call stdlib${ii}$_dgemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1_${ik}$ &
)
! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**t
call stdlib${ii}$_dger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc )
end if
else
! form c * h
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1)
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,&
1_${ik}$ )
! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**t
call stdlib${ii}$_dger( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc )
end if
end if
return
end subroutine stdlib${ii}$_dlarf
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$larf( side, m, n, v, incv, tau, c, ldc, work )
!! DLARF: applies a real elementary reflector H to a real m by n matrix
!! C, from either the left or the right. H is represented in the form
!! H = I - tau * v * v**T
!! where tau is a real scalar and v is a real vector.
!! If tau = 0, then H is taken to be the unit matrix.
! -- 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) :: side
integer(${ik}$), intent(in) :: incv, ldc, m, n
real(${rk}$), intent(in) :: tau
! Array Arguments
real(${rk}$), intent(inout) :: c(ldc,*)
real(${rk}$), intent(in) :: v(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: applyleft
integer(${ik}$) :: i, lastv, lastc
! Executable Statements
applyleft = stdlib_lsame( side, 'L' )
lastv = 0_${ik}$
lastc = 0_${ik}$
if( tau/=zero ) then
! set up variables for scanning v. lastv begins pointing to the end
! of v.
if( applyleft ) then
lastv = m
else
lastv = n
end if
if( incv>0_${ik}$ ) then
i = 1_${ik}$ + (lastv-1) * incv
else
i = 1_${ik}$
end if
! look for the last non-zero row in v.
do while( lastv>0 .and. v( i )==zero )
lastv = lastv - 1_${ik}$
i = i - incv
end do
if( applyleft ) then
! scan for the last non-zero column in c(1:lastv,:).
lastc = stdlib${ii}$_ila${ri}$lc(lastv, n, c, ldc)
else
! scan for the last non-zero row in c(:,1:lastv).
lastc = stdlib${ii}$_ila${ri}$lr(m, lastv, c, ldc)
end if
end if
! note that lastc.eq.0_${rk}$ renders the blas operations null; no special
! case is needed at this level.
if( applyleft ) then
! form h * c
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastv,1:lastc)**t * v(1:lastv,1)
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1_${ik}$ &
)
! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**t
call stdlib${ii}$_${ri}$ger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc )
end if
else
! form c * h
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1)
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,&
1_${ik}$ )
! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**t
call stdlib${ii}$_${ri}$ger( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc )
end if
end if
return
end subroutine stdlib${ii}$_${ri}$larf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clarf( side, m, n, v, incv, tau, c, ldc, work )
!! CLARF applies a complex elementary reflector H to a complex M-by-N
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**H
!! where tau is a complex scalar and v is a complex vector.
!! If tau = 0, then H is taken to be the unit matrix.
!! To apply H**H (the conjugate transpose of H), supply conjg(tau) instead
!! tau.
! -- 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) :: side
integer(${ik}$), intent(in) :: incv, ldc, m, n
complex(sp), intent(in) :: tau
! Array Arguments
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(in) :: v(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: applyleft
integer(${ik}$) :: i, lastv, lastc
! Executable Statements
applyleft = stdlib_lsame( side, 'L' )
lastv = 0_${ik}$
lastc = 0_${ik}$
if( tau/=czero ) then
! set up variables for scanning v. lastv begins pointing to the end
! of v.
if( applyleft ) then
lastv = m
else
lastv = n
end if
if( incv>0_${ik}$ ) then
i = 1_${ik}$ + (lastv-1) * incv
else
i = 1_${ik}$
end if
! look for the last non-czero row in v.
do while( lastv>0 .and. v( i )==czero )
lastv = lastv - 1_${ik}$
i = i - incv
end do
if( applyleft ) then
! scan for the last non-czero column in c(1:lastv,:).
lastc = stdlib${ii}$_ilaclc(lastv, n, c, ldc)
else
! scan for the last non-czero row in c(:,1:lastv).
lastc = stdlib${ii}$_ilaclr(m, lastv, c, ldc)
end if
end if
! note that lastc.eq.0_sp renders the blas operations null; no special
! case is needed at this level.
if( applyleft ) then
! form h * c
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1)
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, &
czero, work, 1_${ik}$ )
! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h
call stdlib${ii}$_cgerc( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc )
end if
else
! form c * h
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1)
call stdlib${ii}$_cgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, &
work, 1_${ik}$ )
! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h
call stdlib${ii}$_cgerc( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc )
end if
end if
return
end subroutine stdlib${ii}$_clarf
pure module subroutine stdlib${ii}$_zlarf( side, m, n, v, incv, tau, c, ldc, work )
!! ZLARF applies a complex elementary reflector H to a complex M-by-N
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**H
!! where tau is a complex scalar and v is a complex vector.
!! If tau = 0, then H is taken to be the unit matrix.
!! To apply H**H, supply conjg(tau) instead
!! tau.
! -- 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) :: side
integer(${ik}$), intent(in) :: incv, ldc, m, n
complex(dp), intent(in) :: tau
! Array Arguments
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(in) :: v(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: applyleft
integer(${ik}$) :: i, lastv, lastc
! Executable Statements
applyleft = stdlib_lsame( side, 'L' )
lastv = 0_${ik}$
lastc = 0_${ik}$
if( tau/=czero ) then
! set up variables for scanning v. lastv begins pointing to the end
! of v.
if( applyleft ) then
lastv = m
else
lastv = n
end if
if( incv>0_${ik}$ ) then
i = 1_${ik}$ + (lastv-1) * incv
else
i = 1_${ik}$
end if
! look for the last non-czero row in v.
do while( lastv>0 .and. v( i )==czero )
lastv = lastv - 1_${ik}$
i = i - incv
end do
if( applyleft ) then
! scan for the last non-czero column in c(1:lastv,:).
lastc = stdlib${ii}$_ilazlc(lastv, n, c, ldc)
else
! scan for the last non-czero row in c(:,1:lastv).
lastc = stdlib${ii}$_ilazlr(m, lastv, c, ldc)
end if
end if
! note that lastc.eq.0_dp renders the blas operations null; no special
! case is needed at this level.
if( applyleft ) then
! form h * c
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1)
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, &
czero, work, 1_${ik}$ )
! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h
call stdlib${ii}$_zgerc( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc )
end if
else
! form c * h
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1)
call stdlib${ii}$_zgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, &
work, 1_${ik}$ )
! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h
call stdlib${ii}$_zgerc( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc )
end if
end if
return
end subroutine stdlib${ii}$_zlarf
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$larf( side, m, n, v, incv, tau, c, ldc, work )
!! ZLARF: applies a complex elementary reflector H to a complex M-by-N
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**H
!! where tau is a complex scalar and v is a complex vector.
!! If tau = 0, then H is taken to be the unit matrix.
!! To apply H**H, supply conjg(tau) instead
!! tau.
! -- 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) :: side
integer(${ik}$), intent(in) :: incv, ldc, m, n
complex(${ck}$), intent(in) :: tau
! Array Arguments
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(in) :: v(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
logical(lk) :: applyleft
integer(${ik}$) :: i, lastv, lastc
! Executable Statements
applyleft = stdlib_lsame( side, 'L' )
lastv = 0_${ik}$
lastc = 0_${ik}$
if( tau/=czero ) then
! set up variables for scanning v. lastv begins pointing to the end
! of v.
if( applyleft ) then
lastv = m
else
lastv = n
end if
if( incv>0_${ik}$ ) then
i = 1_${ik}$ + (lastv-1) * incv
else
i = 1_${ik}$
end if
! look for the last non-czero row in v.
do while( lastv>0 .and. v( i )==czero )
lastv = lastv - 1_${ik}$
i = i - incv
end do
if( applyleft ) then
! scan for the last non-czero column in c(1:lastv,:).
lastc = stdlib${ii}$_ila${ci}$lc(lastv, n, c, ldc)
else
! scan for the last non-czero row in c(:,1:lastv).
lastc = stdlib${ii}$_ila${ci}$lr(m, lastv, c, ldc)
end if
end if
! note that lastc.eq.0_${ck}$ renders the blas operations null; no special
! case is needed at this level.
if( applyleft ) then
! form h * c
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1)
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, &
czero, work, 1_${ik}$ )
! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h
call stdlib${ii}$_${ci}$gerc( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc )
end if
else
! form c * h
if( lastv>0_${ik}$ ) then
! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1)
call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, &
work, 1_${ik}$ )
! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h
call stdlib${ii}$_${ci}$gerc( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc )
end if
end if
return
end subroutine stdlib${ii}$_${ci}$larf
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slarfx( side, m, n, v, tau, c, ldc, work )
!! SLARFX applies a real elementary reflector H to a real m by n
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**T
!! where tau is a real scalar and v is a real vector.
!! If tau = 0, then H is taken to be the unit matrix
!! This version uses inline code if H has order < 11.
! -- 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) :: side
integer(${ik}$), intent(in) :: ldc, m, n
real(sp), intent(in) :: tau
! Array Arguments
real(sp), intent(inout) :: c(ldc,*)
real(sp), intent(in) :: v(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j
real(sp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, &
v7, v8, v9
! Executable Statements
if( tau==zero )return
if( stdlib_lsame( side, 'L' ) ) then
! form h * c, where h has order m.
go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m
! code for general m
call stdlib${ii}$_slarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
10 continue
! special code for 1 x 1 householder
t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ )
do j = 1, n
c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j )
end do
go to 410
30 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
end do
go to 410
50 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
end do
go to 410
70 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
end do
go to 410
90 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
end do
go to 410
110 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
end do
go to 410
130 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
end do
go to 410
150 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
end do
go to 410
170 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
end do
go to 410
190 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
v10 = v( 10_${ik}$ )
t10 = tau*v10
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10
end do
go to 410
else
! form c * h, where h has order n.
go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n
! code for general n
call stdlib${ii}$_slarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
210 continue
! special code for 1 x 1 householder
t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ )
do j = 1, m
c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ )
end do
go to 410
230 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
end do
go to 410
250 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
end do
go to 410
270 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
end do
go to 410
290 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
end do
go to 410
310 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
end do
go to 410
330 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
end do
go to 410
350 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
end do
go to 410
370 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
end do
go to 410
390 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
v10 = v( 10_${ik}$ )
t10 = tau*v10
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10
end do
go to 410
end if
410 return
end subroutine stdlib${ii}$_slarfx
pure module subroutine stdlib${ii}$_dlarfx( side, m, n, v, tau, c, ldc, work )
!! DLARFX applies a real elementary reflector H to a real m by n
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**T
!! where tau is a real scalar and v is a real vector.
!! If tau = 0, then H is taken to be the unit matrix
!! This version uses inline code if H has order < 11.
! -- 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) :: side
integer(${ik}$), intent(in) :: ldc, m, n
real(dp), intent(in) :: tau
! Array Arguments
real(dp), intent(inout) :: c(ldc,*)
real(dp), intent(in) :: v(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j
real(dp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, &
v7, v8, v9
! Executable Statements
if( tau==zero )return
if( stdlib_lsame( side, 'L' ) ) then
! form h * c, where h has order m.
go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m
! code for general m
call stdlib${ii}$_dlarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
10 continue
! special code for 1 x 1 householder
t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ )
do j = 1, n
c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j )
end do
go to 410
30 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
end do
go to 410
50 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
end do
go to 410
70 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
end do
go to 410
90 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
end do
go to 410
110 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
end do
go to 410
130 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
end do
go to 410
150 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
end do
go to 410
170 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
end do
go to 410
190 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
v10 = v( 10_${ik}$ )
t10 = tau*v10
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10
end do
go to 410
else
! form c * h, where h has order n.
go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n
! code for general n
call stdlib${ii}$_dlarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
210 continue
! special code for 1 x 1 householder
t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ )
do j = 1, m
c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ )
end do
go to 410
230 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
end do
go to 410
250 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
end do
go to 410
270 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
end do
go to 410
290 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
end do
go to 410
310 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
end do
go to 410
330 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
end do
go to 410
350 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
end do
go to 410
370 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
end do
go to 410
390 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
v10 = v( 10_${ik}$ )
t10 = tau*v10
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10
end do
go to 410
end if
410 continue
return
end subroutine stdlib${ii}$_dlarfx
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$larfx( side, m, n, v, tau, c, ldc, work )
!! DLARFX: applies a real elementary reflector H to a real m by n
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**T
!! where tau is a real scalar and v is a real vector.
!! If tau = 0, then H is taken to be the unit matrix
!! This version uses inline code if H has order < 11.
! -- 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) :: side
integer(${ik}$), intent(in) :: ldc, m, n
real(${rk}$), intent(in) :: tau
! Array Arguments
real(${rk}$), intent(inout) :: c(ldc,*)
real(${rk}$), intent(in) :: v(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j
real(${rk}$) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, &
v7, v8, v9
! Executable Statements
if( tau==zero )return
if( stdlib_lsame( side, 'L' ) ) then
! form h * c, where h has order m.
go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m
! code for general m
call stdlib${ii}$_${ri}$larf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
10 continue
! special code for 1 x 1 householder
t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ )
do j = 1, n
c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j )
end do
go to 410
30 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
end do
go to 410
50 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
end do
go to 410
70 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
end do
go to 410
90 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
end do
go to 410
110 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
end do
go to 410
130 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
end do
go to 410
150 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
end do
go to 410
170 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
end do
go to 410
190 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
v10 = v( 10_${ik}$ )
t10 = tau*v10
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10
end do
go to 410
else
! form c * h, where h has order n.
go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n
! code for general n
call stdlib${ii}$_${ri}$larf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
210 continue
! special code for 1 x 1 householder
t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ )
do j = 1, m
c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ )
end do
go to 410
230 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
end do
go to 410
250 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
end do
go to 410
270 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
end do
go to 410
290 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
end do
go to 410
310 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
end do
go to 410
330 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
end do
go to 410
350 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
end do
go to 410
370 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
end do
go to 410
390 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*v1
v2 = v( 2_${ik}$ )
t2 = tau*v2
v3 = v( 3_${ik}$ )
t3 = tau*v3
v4 = v( 4_${ik}$ )
t4 = tau*v4
v5 = v( 5_${ik}$ )
t5 = tau*v5
v6 = v( 6_${ik}$ )
t6 = tau*v6
v7 = v( 7_${ik}$ )
t7 = tau*v7
v8 = v( 8_${ik}$ )
t8 = tau*v8
v9 = v( 9_${ik}$ )
t9 = tau*v9
v10 = v( 10_${ik}$ )
t10 = tau*v10
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10
end do
go to 410
end if
410 continue
return
end subroutine stdlib${ii}$_${ri}$larfx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clarfx( side, m, n, v, tau, c, ldc, work )
!! CLARFX applies a complex elementary reflector H to a complex m by n
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**H
!! where tau is a complex scalar and v is a complex vector.
!! If tau = 0, then H is taken to be the unit matrix
!! This version uses inline code if H has order < 11.
! -- 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) :: side
integer(${ik}$), intent(in) :: ldc, m, n
complex(sp), intent(in) :: tau
! Array Arguments
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(in) :: v(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j
complex(sp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, &
v6, v7, v8, v9
! Intrinsic Functions
! Executable Statements
if( tau==czero )return
if( stdlib_lsame( side, 'L' ) ) then
! form h * c, where h has order m.
go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m
! code for general m
call stdlib${ii}$_clarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
10 continue
! special code for 1 x 1 householder
t1 = cone - tau*v( 1_${ik}$ )*conjg( v( 1_${ik}$ ) )
do j = 1, n
c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j )
end do
go to 410
30 continue
! special code for 2 x 2 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
end do
go to 410
50 continue
! special code for 3 x 3 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
end do
go to 410
70 continue
! special code for 4 x 4 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
end do
go to 410
90 continue
! special code for 5 x 5 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
end do
go to 410
110 continue
! special code for 6 x 6 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
end do
go to 410
130 continue
! special code for 7 x 7 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
end do
go to 410
150 continue
! special code for 8 x 8 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
end do
go to 410
170 continue
! special code for 9 x 9 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
v9 = conjg( v( 9_${ik}$ ) )
t9 = tau*conjg( v9 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
end do
go to 410
190 continue
! special code for 10 x 10 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
v9 = conjg( v( 9_${ik}$ ) )
t9 = tau*conjg( v9 )
v10 = conjg( v( 10_${ik}$ ) )
t10 = tau*conjg( v10 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10
end do
go to 410
else
! form c * h, where h has order n.
go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n
! code for general n
call stdlib${ii}$_clarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
210 continue
! special code for 1 x 1 householder
t1 = cone - tau*v( 1_${ik}$ )*conjg( v( 1_${ik}$ ) )
do j = 1, m
c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ )
end do
go to 410
230 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
end do
go to 410
250 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
end do
go to 410
270 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
end do
go to 410
290 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
end do
go to 410
310 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
end do
go to 410
330 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
end do
go to 410
350 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
end do
go to 410
370 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
v9 = v( 9_${ik}$ )
t9 = tau*conjg( v9 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
end do
go to 410
390 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
v9 = v( 9_${ik}$ )
t9 = tau*conjg( v9 )
v10 = v( 10_${ik}$ )
t10 = tau*conjg( v10 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10
end do
go to 410
end if
410 return
end subroutine stdlib${ii}$_clarfx
pure module subroutine stdlib${ii}$_zlarfx( side, m, n, v, tau, c, ldc, work )
!! ZLARFX applies a complex elementary reflector H to a complex m by n
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**H
!! where tau is a complex scalar and v is a complex vector.
!! If tau = 0, then H is taken to be the unit matrix
!! This version uses inline code if H has order < 11.
! -- 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) :: side
integer(${ik}$), intent(in) :: ldc, m, n
complex(dp), intent(in) :: tau
! Array Arguments
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(in) :: v(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j
complex(dp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, &
v6, v7, v8, v9
! Intrinsic Functions
! Executable Statements
if( tau==czero )return
if( stdlib_lsame( side, 'L' ) ) then
! form h * c, where h has order m.
go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m
! code for general m
call stdlib${ii}$_zlarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
10 continue
! special code for 1 x 1 householder
t1 = cone - tau*v( 1_${ik}$ )*conjg( v( 1_${ik}$ ) )
do j = 1, n
c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j )
end do
go to 410
30 continue
! special code for 2 x 2 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
end do
go to 410
50 continue
! special code for 3 x 3 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
end do
go to 410
70 continue
! special code for 4 x 4 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
end do
go to 410
90 continue
! special code for 5 x 5 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
end do
go to 410
110 continue
! special code for 6 x 6 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
end do
go to 410
130 continue
! special code for 7 x 7 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
end do
go to 410
150 continue
! special code for 8 x 8 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
end do
go to 410
170 continue
! special code for 9 x 9 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
v9 = conjg( v( 9_${ik}$ ) )
t9 = tau*conjg( v9 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
end do
go to 410
190 continue
! special code for 10 x 10 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
v9 = conjg( v( 9_${ik}$ ) )
t9 = tau*conjg( v9 )
v10 = conjg( v( 10_${ik}$ ) )
t10 = tau*conjg( v10 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10
end do
go to 410
else
! form c * h, where h has order n.
go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n
! code for general n
call stdlib${ii}$_zlarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
210 continue
! special code for 1 x 1 householder
t1 = cone - tau*v( 1_${ik}$ )*conjg( v( 1_${ik}$ ) )
do j = 1, m
c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ )
end do
go to 410
230 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
end do
go to 410
250 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
end do
go to 410
270 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
end do
go to 410
290 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
end do
go to 410
310 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
end do
go to 410
330 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
end do
go to 410
350 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
end do
go to 410
370 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
v9 = v( 9_${ik}$ )
t9 = tau*conjg( v9 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
end do
go to 410
390 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
v9 = v( 9_${ik}$ )
t9 = tau*conjg( v9 )
v10 = v( 10_${ik}$ )
t10 = tau*conjg( v10 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10
end do
go to 410
end if
410 continue
return
end subroutine stdlib${ii}$_zlarfx
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$larfx( side, m, n, v, tau, c, ldc, work )
!! ZLARFX: applies a complex elementary reflector H to a complex m by n
!! matrix C, from either the left or the right. H is represented in the
!! form
!! H = I - tau * v * v**H
!! where tau is a complex scalar and v is a complex vector.
!! If tau = 0, then H is taken to be the unit matrix
!! This version uses inline code if H has order < 11.
! -- 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) :: side
integer(${ik}$), intent(in) :: ldc, m, n
complex(${ck}$), intent(in) :: tau
! Array Arguments
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(in) :: v(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j
complex(${ck}$) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, &
v6, v7, v8, v9
! Intrinsic Functions
! Executable Statements
if( tau==czero )return
if( stdlib_lsame( side, 'L' ) ) then
! form h * c, where h has order m.
go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m
! code for general m
call stdlib${ii}$_${ci}$larf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
10 continue
! special code for 1 x 1 householder
t1 = cone - tau*v( 1_${ik}$ )*conjg( v( 1_${ik}$ ) )
do j = 1, n
c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j )
end do
go to 410
30 continue
! special code for 2 x 2 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
end do
go to 410
50 continue
! special code for 3 x 3 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
end do
go to 410
70 continue
! special code for 4 x 4 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
end do
go to 410
90 continue
! special code for 5 x 5 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
end do
go to 410
110 continue
! special code for 6 x 6 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
end do
go to 410
130 continue
! special code for 7 x 7 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
end do
go to 410
150 continue
! special code for 8 x 8 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
end do
go to 410
170 continue
! special code for 9 x 9 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
v9 = conjg( v( 9_${ik}$ ) )
t9 = tau*conjg( v9 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
end do
go to 410
190 continue
! special code for 10 x 10 householder
v1 = conjg( v( 1_${ik}$ ) )
t1 = tau*conjg( v1 )
v2 = conjg( v( 2_${ik}$ ) )
t2 = tau*conjg( v2 )
v3 = conjg( v( 3_${ik}$ ) )
t3 = tau*conjg( v3 )
v4 = conjg( v( 4_${ik}$ ) )
t4 = tau*conjg( v4 )
v5 = conjg( v( 5_${ik}$ ) )
t5 = tau*conjg( v5 )
v6 = conjg( v( 6_${ik}$ ) )
t6 = tau*conjg( v6 )
v7 = conjg( v( 7_${ik}$ ) )
t7 = tau*conjg( v7 )
v8 = conjg( v( 8_${ik}$ ) )
t8 = tau*conjg( v8 )
v9 = conjg( v( 9_${ik}$ ) )
t9 = tau*conjg( v9 )
v10 = conjg( v( 10_${ik}$ ) )
t10 = tau*conjg( v10 )
do j = 1, n
sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + &
v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j )
c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1
c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2
c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3
c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4
c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5
c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6
c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7
c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8
c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9
c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10
end do
go to 410
else
! form c * h, where h has order n.
go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n
! code for general n
call stdlib${ii}$_${ci}$larf( side, m, n, v, 1_${ik}$, tau, c, ldc, work )
go to 410
210 continue
! special code for 1 x 1 householder
t1 = cone - tau*v( 1_${ik}$ )*conjg( v( 1_${ik}$ ) )
do j = 1, m
c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ )
end do
go to 410
230 continue
! special code for 2 x 2 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
end do
go to 410
250 continue
! special code for 3 x 3 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
end do
go to 410
270 continue
! special code for 4 x 4 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
end do
go to 410
290 continue
! special code for 5 x 5 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
end do
go to 410
310 continue
! special code for 6 x 6 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
end do
go to 410
330 continue
! special code for 7 x 7 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
end do
go to 410
350 continue
! special code for 8 x 8 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
end do
go to 410
370 continue
! special code for 9 x 9 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
v9 = v( 9_${ik}$ )
t9 = tau*conjg( v9 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
end do
go to 410
390 continue
! special code for 10 x 10 householder
v1 = v( 1_${ik}$ )
t1 = tau*conjg( v1 )
v2 = v( 2_${ik}$ )
t2 = tau*conjg( v2 )
v3 = v( 3_${ik}$ )
t3 = tau*conjg( v3 )
v4 = v( 4_${ik}$ )
t4 = tau*conjg( v4 )
v5 = v( 5_${ik}$ )
t5 = tau*conjg( v5 )
v6 = v( 6_${ik}$ )
t6 = tau*conjg( v6 )
v7 = v( 7_${ik}$ )
t7 = tau*conjg( v7 )
v8 = v( 8_${ik}$ )
t8 = tau*conjg( v8 )
v9 = v( 9_${ik}$ )
t9 = tau*conjg( v9 )
v10 = v( 10_${ik}$ )
t10 = tau*conjg( v10 )
do j = 1, m
sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + &
v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ )
c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1
c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2
c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3
c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4
c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5
c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6
c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7
c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8
c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9
c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10
end do
go to 410
end if
410 continue
return
end subroutine stdlib${ii}$_${ci}$larfx
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slarfy( uplo, n, v, incv, tau, c, ldc, work )
!! SLARFY applies an elementary reflector, or Householder matrix, H,
!! to an n x n symmetric matrix C, from both the left and the right.
!! H is represented in the form
!! H = I - tau * v * v'
!! where tau is a scalar and v is a vector.
!! If tau is zero, then H is taken to be the unit matrix.
! -- lapack test routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incv, ldc, n
real(sp), intent(in) :: tau
! Array Arguments
real(sp), intent(inout) :: c(ldc,*)
real(sp), intent(in) :: v(*)
real(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
real(sp) :: alpha
! Executable Statements
if( tau==zero )return
! form w:= c * v
call stdlib${ii}$_ssymv( uplo, n, one, c, ldc, v, incv, zero, work, 1_${ik}$ )
alpha = -half*tau*stdlib${ii}$_sdot( n, work, 1_${ik}$, v, incv )
call stdlib${ii}$_saxpy( n, alpha, v, incv, work, 1_${ik}$ )
! c := c - v * w' - w * v'
call stdlib${ii}$_ssyr2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc )
return
end subroutine stdlib${ii}$_slarfy
pure module subroutine stdlib${ii}$_dlarfy( uplo, n, v, incv, tau, c, ldc, work )
!! DLARFY applies an elementary reflector, or Householder matrix, H,
!! to an n x n symmetric matrix C, from both the left and the right.
!! H is represented in the form
!! H = I - tau * v * v'
!! where tau is a scalar and v is a vector.
!! If tau is zero, then H is taken to be the unit matrix.
! -- lapack test routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incv, ldc, n
real(dp), intent(in) :: tau
! Array Arguments
real(dp), intent(inout) :: c(ldc,*)
real(dp), intent(in) :: v(*)
real(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
real(dp) :: alpha
! Executable Statements
if( tau==zero )return
! form w:= c * v
call stdlib${ii}$_dsymv( uplo, n, one, c, ldc, v, incv, zero, work, 1_${ik}$ )
alpha = -half*tau*stdlib${ii}$_ddot( n, work, 1_${ik}$, v, incv )
call stdlib${ii}$_daxpy( n, alpha, v, incv, work, 1_${ik}$ )
! c := c - v * w' - w * v'
call stdlib${ii}$_dsyr2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc )
return
end subroutine stdlib${ii}$_dlarfy
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$larfy( uplo, n, v, incv, tau, c, ldc, work )
!! DLARFY: applies an elementary reflector, or Householder matrix, H,
!! to an n x n symmetric matrix C, from both the left and the right.
!! H is represented in the form
!! H = I - tau * v * v'
!! where tau is a scalar and v is a vector.
!! If tau is zero, then H is taken to be the unit matrix.
! -- lapack test routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incv, ldc, n
real(${rk}$), intent(in) :: tau
! Array Arguments
real(${rk}$), intent(inout) :: c(ldc,*)
real(${rk}$), intent(in) :: v(*)
real(${rk}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
real(${rk}$) :: alpha
! Executable Statements
if( tau==zero )return
! form w:= c * v
call stdlib${ii}$_${ri}$symv( uplo, n, one, c, ldc, v, incv, zero, work, 1_${ik}$ )
alpha = -half*tau*stdlib${ii}$_${ri}$dot( n, work, 1_${ik}$, v, incv )
call stdlib${ii}$_${ri}$axpy( n, alpha, v, incv, work, 1_${ik}$ )
! c := c - v * w' - w * v'
call stdlib${ii}$_${ri}$syr2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc )
return
end subroutine stdlib${ii}$_${ri}$larfy
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clarfy( uplo, n, v, incv, tau, c, ldc, work )
!! CLARFY applies an elementary reflector, or Householder matrix, H,
!! to an n x n Hermitian matrix C, from both the left and the right.
!! H is represented in the form
!! H = I - tau * v * v'
!! where tau is a scalar and v is a vector.
!! If tau is zero, then H is taken to be the unit matrix.
! -- lapack test routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incv, ldc, n
complex(sp), intent(in) :: tau
! Array Arguments
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(in) :: v(*)
complex(sp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
complex(sp) :: alpha
! Executable Statements
if( tau==czero )return
! form w:= c * v
call stdlib${ii}$_chemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1_${ik}$ )
alpha = -chalf*tau*stdlib${ii}$_cdotc( n, work, 1_${ik}$, v, incv )
call stdlib${ii}$_caxpy( n, alpha, v, incv, work, 1_${ik}$ )
! c := c - v * w' - w * v'
call stdlib${ii}$_cher2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc )
return
end subroutine stdlib${ii}$_clarfy
pure module subroutine stdlib${ii}$_zlarfy( uplo, n, v, incv, tau, c, ldc, work )
!! ZLARFY applies an elementary reflector, or Householder matrix, H,
!! to an n x n Hermitian matrix C, from both the left and the right.
!! H is represented in the form
!! H = I - tau * v * v'
!! where tau is a scalar and v is a vector.
!! If tau is zero, then H is taken to be the unit matrix.
! -- lapack test routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incv, ldc, n
complex(dp), intent(in) :: tau
! Array Arguments
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(in) :: v(*)
complex(dp), intent(out) :: work(*)
! =====================================================================
! Local Scalars
complex(dp) :: alpha
! Executable Statements
if( tau==czero )return
! form w:= c * v
call stdlib${ii}$_zhemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1_${ik}$ )
alpha = -chalf*tau*stdlib${ii}$_zdotc( n, work, 1_${ik}$, v, incv )
call stdlib${ii}$_zaxpy( n, alpha, v, incv, work, 1_${ik}$ )
! c := c - v * w' - w * v'
call stdlib${ii}$_zher2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc )
return
end subroutine stdlib${ii}$_zlarfy
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$larfy( uplo, n, v, incv, tau, c, ldc, work )
!! ZLARFY: applies an elementary reflector, or Householder matrix, H,
!! to an n x n Hermitian matrix C, from both the left and the right.
!! H is represented in the form
!! H = I - tau * v * v'
!! where tau is a scalar and v is a vector.
!! If tau is zero, then H is taken to be the unit matrix.
! -- lapack test routine --
! -- lapack is a software package provided by univ. of tennessee, --
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
! Scalar Arguments
character, intent(in) :: uplo
integer(${ik}$), intent(in) :: incv, ldc, n
complex(${ck}$), intent(in) :: tau
! Array Arguments
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(in) :: v(*)
complex(${ck}$), intent(out) :: work(*)
! =====================================================================
! Local Scalars
complex(${ck}$) :: alpha
! Executable Statements
if( tau==czero )return
! form w:= c * v
call stdlib${ii}$_${ci}$hemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1_${ik}$ )
alpha = -chalf*tau*stdlib${ii}$_${ci}$dotc( n, work, 1_${ik}$, v, incv )
call stdlib${ii}$_${ci}$axpy( n, alpha, v, incv, work, 1_${ik}$ )
! c := c - v * w' - w * v'
call stdlib${ii}$_${ci}$her2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc )
return
end subroutine stdlib${ii}$_${ci}$larfy
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, &
!! SLARFB applies a real block reflector H or its transpose H**T to a
!! real m by n matrix C, from either the left or the right.
work, ldwork )
! -- 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) :: direct, side, storev, trans
integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n
! Array Arguments
real(sp), intent(inout) :: c(ldc,*)
real(sp), intent(in) :: t(ldt,*), v(ldv,*)
real(sp), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
character :: transt
integer(${ik}$) :: i, j
! Executable Statements
! quick return if possible
if( m<=0 .or. n<=0 )return
if( stdlib_lsame( trans, 'N' ) ) then
transt = 'T'
else
transt = 'N'
end if
if( stdlib_lsame( storev, 'C' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 ) (first k rows)
! ( v2 )
! where v1 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work)
! w := c1**t
do j = 1, k
call stdlib${ii}$_scopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,&
work, ldwork )
if( m>k ) then
! w := w + c2**t * v2
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1_${ik}$ ),&
ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v * w**t
if( m>k ) then
! c2 := c2 - v2 * w**t
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1_${ik}$ )&
, ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1**t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, &
work, ldwork )
! c1 := c1 - w**t
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_scopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,&
work, ldwork )
if( n>k ) then
! w := w + c2 * v2
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+&
1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v**t
if( n>k ) then
! c2 := c2 - w * v2**t
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v( k+1, 1_${ik}$ ), ldv, one,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1**t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, &
work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 )
! ( v2 ) (last k rows)
! where v2 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work)
! w := c2**t
do j = 1, k
call stdlib${ii}$_scopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+&
1_${ik}$, 1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**t * v1
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, &
ldv, one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v * w**t
if( m>k ) then
! c1 := c1 - v1 * w**t
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, &
work, ldwork, one, c, ldc )
end if
! w := w * v2**t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, &
1_${ik}$ ), ldv, work, ldwork )
! c2 := c2 - w**t
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h' where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_scopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+&
1_${ik}$, 1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, &
v, ldv, one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v**t
if( n>k ) then
! c1 := c1 - w * v1**t
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v, ldv, one, c, ldc )
end if
! w := w * v2**t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, &
1_${ik}$ ), ldv, work, ldwork )
! c2 := c2 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
else if( stdlib_lsame( storev, 'R' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 v2 ) (v1: first k columns)
! where v1 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work)
! w := c1**t
do j = 1, k
call stdlib${ii}$_scopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, &
work, ldwork )
if( m>k ) then
! w := w + c2**t * v2**t
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1_${ik}$ ), &
ldc, v( 1_${ik}$, k+1 ), ldv, one,work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v**t * w**t
if( m>k ) then
! c2 := c2 - v2**t * w**t
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1_${ik}$, k+1 ), &
ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,&
work, ldwork )
! c1 := c1 - w**t
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_scopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, &
work, ldwork )
if( n>k ) then
! w := w + c2 * v2**t
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+1 ),&
ldc, v( 1_${ik}$, k+1 ), ldv,one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c2 := c2 - w * v2
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v( 1_${ik}$, k+1 ), ldv, one,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1
call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,&
work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 v2 ) (v2: last k columns)
! where v2 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work)
! w := c2**t
do j = 1, k
call stdlib${ii}$_scopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1_${ik}$, m-k+&
1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**t * v1**t
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,&
one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v**t * w**t
if( m>k ) then
! c1 := c1 - v1**t * w**t
call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, &
ldwork, one, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1_${ik}$, &
m-k+1 ), ldv, work, ldwork )
! c2 := c2 - w**t
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_scopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1_${ik}$, n-k+&
1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1**t
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, &
ldv, one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c1 := c1 - w * v1
call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v, ldv, one, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1_${ik}$, &
n-k+1 ), ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_slarfb
pure module subroutine stdlib${ii}$_dlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, &
!! DLARFB applies a real block reflector H or its transpose H**T to a
!! real m by n matrix C, from either the left or the right.
work, ldwork )
! -- 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) :: direct, side, storev, trans
integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n
! Array Arguments
real(dp), intent(inout) :: c(ldc,*)
real(dp), intent(in) :: t(ldt,*), v(ldv,*)
real(dp), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
character :: transt
integer(${ik}$) :: i, j
! Executable Statements
! quick return if possible
if( m<=0 .or. n<=0 )return
if( stdlib_lsame( trans, 'N' ) ) then
transt = 'T'
else
transt = 'N'
end if
if( stdlib_lsame( storev, 'C' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 ) (first k rows)
! ( v2 )
! where v1 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work)
! w := c1**t
do j = 1, k
call stdlib${ii}$_dcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,&
work, ldwork )
if( m>k ) then
! w := w + c2**t * v2
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1_${ik}$ ),&
ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v * w**t
if( m>k ) then
! c2 := c2 - v2 * w**t
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1_${ik}$ )&
, ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, &
work, ldwork )
! c1 := c1 - w**t
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_dcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,&
work, ldwork )
if( n>k ) then
! w := w + c2 * v2
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+&
1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v**t
if( n>k ) then
! c2 := c2 - w * v2**t
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v( k+1, 1_${ik}$ ), ldv, one,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, &
work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 )
! ( v2 ) (last k rows)
! where v2 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work)
! w := c2**t
do j = 1, k
call stdlib${ii}$_dcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+&
1_${ik}$, 1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**t * v1
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, &
ldv, one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v * w**t
if( m>k ) then
! c1 := c1 - v1 * w**t
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, &
work, ldwork, one, c, ldc )
end if
! w := w * v2**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, &
1_${ik}$ ), ldv, work, ldwork )
! c2 := c2 - w**t
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_dcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+&
1_${ik}$, 1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, &
v, ldv, one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v**t
if( n>k ) then
! c1 := c1 - w * v1**t
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v, ldv, one, c, ldc )
end if
! w := w * v2**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, &
1_${ik}$ ), ldv, work, ldwork )
! c2 := c2 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
else if( stdlib_lsame( storev, 'R' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 v2 ) (v1: first k columns)
! where v1 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work)
! w := c1**t
do j = 1, k
call stdlib${ii}$_dcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, &
work, ldwork )
if( m>k ) then
! w := w + c2**t * v2**t
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1_${ik}$ ), &
ldc, v( 1_${ik}$, k+1 ), ldv, one,work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v**t * w**t
if( m>k ) then
! c2 := c2 - v2**t * w**t
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1_${ik}$, k+1 ), &
ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,&
work, ldwork )
! c1 := c1 - w**t
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_dcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, &
work, ldwork )
if( n>k ) then
! w := w + c2 * v2**t
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+1 ),&
ldc, v( 1_${ik}$, k+1 ), ldv,one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c2 := c2 - w * v2
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v( 1_${ik}$, k+1 ), ldv, one,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1
call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,&
work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 v2 ) (v2: last k columns)
! where v2 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work)
! w := c2**t
do j = 1, k
call stdlib${ii}$_dcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1_${ik}$, m-k+&
1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**t * v1**t
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,&
one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v**t * w**t
if( m>k ) then
! c1 := c1 - v1**t * w**t
call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, &
ldwork, one, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1_${ik}$, &
m-k+1 ), ldv, work, ldwork )
! c2 := c2 - w**t
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h' where c = ( c1 c2 )
! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_dcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1_${ik}$, n-k+&
1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1**t
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, &
ldv, one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c1 := c1 - w * v1
call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v, ldv, one, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1_${ik}$, &
n-k+1 ), ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_dlarfb
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, &
!! DLARFB: applies a real block reflector H or its transpose H**T to a
!! real m by n matrix C, from either the left or the right.
work, ldwork )
! -- 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) :: direct, side, storev, trans
integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n
! Array Arguments
real(${rk}$), intent(inout) :: c(ldc,*)
real(${rk}$), intent(in) :: t(ldt,*), v(ldv,*)
real(${rk}$), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
character :: transt
integer(${ik}$) :: i, j
! Executable Statements
! quick return if possible
if( m<=0 .or. n<=0 )return
if( stdlib_lsame( trans, 'N' ) ) then
transt = 'T'
else
transt = 'N'
end if
if( stdlib_lsame( storev, 'C' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 ) (first k rows)
! ( v2 )
! where v1 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work)
! w := c1**t
do j = 1, k
call stdlib${ii}$_${ri}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,&
work, ldwork )
if( m>k ) then
! w := w + c2**t * v2
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1_${ik}$ ),&
ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v * w**t
if( m>k ) then
! c2 := c2 - v2 * w**t
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1_${ik}$ )&
, ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, &
work, ldwork )
! c1 := c1 - w**t
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,&
work, ldwork )
if( n>k ) then
! w := w + c2 * v2
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+&
1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v**t
if( n>k ) then
! c2 := c2 - w * v2**t
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v( k+1, 1_${ik}$ ), ldv, one,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, &
work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 )
! ( v2 ) (last k rows)
! where v2 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work)
! w := c2**t
do j = 1, k
call stdlib${ii}$_${ri}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+&
1_${ik}$, 1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**t * v1
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, &
ldv, one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v * w**t
if( m>k ) then
! c1 := c1 - v1 * w**t
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, &
work, ldwork, one, c, ldc )
end if
! w := w * v2**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, &
1_${ik}$ ), ldv, work, ldwork )
! c2 := c2 - w**t
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+&
1_${ik}$, 1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, &
v, ldv, one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v**t
if( n>k ) then
! c1 := c1 - w * v1**t
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v, ldv, one, c, ldc )
end if
! w := w * v2**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, &
1_${ik}$ ), ldv, work, ldwork )
! c2 := c2 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
else if( stdlib_lsame( storev, 'R' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 v2 ) (v1: first k columns)
! where v1 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work)
! w := c1**t
do j = 1, k
call stdlib${ii}$_${ri}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, &
work, ldwork )
if( m>k ) then
! w := w + c2**t * v2**t
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1_${ik}$ ), &
ldc, v( 1_${ik}$, k+1 ), ldv, one,work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v**t * w**t
if( m>k ) then
! c2 := c2 - v2**t * w**t
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1_${ik}$, k+1 ), &
ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,&
work, ldwork )
! c1 := c1 - w**t
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**t where c = ( c1 c2 )
! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, &
work, ldwork )
if( n>k ) then
! w := w + c2 * v2**t
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+1 ),&
ldc, v( 1_${ik}$, k+1 ), ldv,one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c2 := c2 - w * v2
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v( 1_${ik}$, k+1 ), ldv, one,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,&
work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 v2 ) (v2: last k columns)
! where v2 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**t * c where c = ( c1 )
! ( c2 )
! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work)
! w := c2**t
do j = 1, k
call stdlib${ii}$_${ri}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1_${ik}$, m-k+&
1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**t * v1**t
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,&
one, work, ldwork )
end if
! w := w * t**t or w * t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, &
work, ldwork )
! c := c - v**t * w**t
if( m>k ) then
! c1 := c1 - v1**t * w**t
call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, &
ldwork, one, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1_${ik}$, &
m-k+1 ), ldv, work, ldwork )
! c2 := c2 - w**t
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) - work( i, j )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h' where c = ( c1 c2 )
! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1_${ik}$, n-k+&
1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1**t
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, &
ldv, one, work, ldwork )
end if
! w := w * t or w * t**t
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c1 := c1 - w * v1
call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, &
ldwork, v, ldv, one, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1_${ik}$, &
n-k+1 ), ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ri}$larfb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, &
work, ldwork )
!! CLARFB applies a complex block reflector H or its transpose H**H to a
!! complex M-by-N matrix C, from either the left or the right.
! -- 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) :: direct, side, storev, trans
integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n
! Array Arguments
complex(sp), intent(inout) :: c(ldc,*)
complex(sp), intent(in) :: t(ldt,*), v(ldv,*)
complex(sp), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
character :: transt
integer(${ik}$) :: i, j
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0 .or. n<=0 )return
if( stdlib_lsame( trans, 'N' ) ) then
transt = 'C'
else
transt = 'N'
end if
if( stdlib_lsame( storev, 'C' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 ) (first k rows)
! ( v2 )
! where v1 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work)
! w := c1**h
do j = 1, k
call stdlib${ii}$_ccopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, &
ldv, work, ldwork )
if( m>k ) then
! w := w + c2**h *v2
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, &
c( k+1, 1_${ik}$ ), ldc,v( k+1, 1_${ik}$ ), ldv, cone, work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v * w**h
if( m>k ) then
! c2 := c2 - v2 * w**h
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, &
v( k+1, 1_${ik}$ ), ldv, work,ldwork, cone, c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v, ldv, work, ldwork )
! c1 := c1 - w**h
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_ccopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, &
ldv, work, ldwork )
if( n>k ) then
! w := w + c2 * v2
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1_${ik}$, k+&
1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v**h
if( n>k ) then
! c2 := c2 - w * v2**h
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, &
work, ldwork, v( k+1, 1_${ik}$ ),ldv, cone, c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v, ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 )
! ( v2 ) (last k rows)
! where v2 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work)
! w := c2**h
do j = 1, k
call stdlib${ii}$_ccopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-&
k+1, 1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**h * v1
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, &
c, ldc, v, ldv, cone, work,ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v * w**h
if( m>k ) then
! c1 := c1 - v1 * w**h
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, &
v, ldv, work, ldwork,cone, c, ldc )
end if
! w := w * v2**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v( m-k+1, 1_${ik}$ ), ldv, work,ldwork )
! c2 := c2 - w**h
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) -conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_ccopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-&
k+1, 1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, &
v, ldv, cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v**h
if( n>k ) then
! c1 := c1 - w * v1**h
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, &
work, ldwork, v, ldv, cone,c, ldc )
end if
! w := w * v2**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v( n-k+1, 1_${ik}$ ), ldv, work,ldwork )
! c2 := c2 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
else if( stdlib_lsame( storev, 'R' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 v2 ) (v1: first k columns)
! where v1 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work)
! w := c1**h
do j = 1, k
call stdlib${ii}$_ccopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v, ldv, work, ldwork )
if( m>k ) then
! w := w + c2**h * v2**h
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, &
cone,c( k+1, 1_${ik}$ ), ldc, v( 1_${ik}$, k+1 ), ldv, cone,work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v**h * w**h
if( m>k ) then
! c2 := c2 - v2**h * w**h
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, &
-cone,v( 1_${ik}$, k+1 ), ldv, work, ldwork, cone,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, &
ldv, work, ldwork )
! c1 := c1 - w**h
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_ccopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v, ldv, work, ldwork )
if( n>k ) then
! w := w + c2 * v2**h
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, &
c( 1_${ik}$, k+1 ), ldc,v( 1_${ik}$, k+1 ), ldv, cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c2 := c2 - w * v2
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, &
ldwork, v( 1_${ik}$, k+1 ), ldv, cone,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1
call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, &
ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 v2 ) (v2: last k columns)
! where v2 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work)
! w := c2**h
do j = 1, k
call stdlib${ii}$_ccopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v( 1_${ik}$, m-k+1 ), ldv, work,ldwork )
if( m>k ) then
! w := w + c1**h * v1**h
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, &
cone, c,ldc, v, ldv, cone, work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v**h * w**h
if( m>k ) then
! c1 := c1 - v1**h * w**h
call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, &
-cone, v,ldv, work, ldwork, cone, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1_${ik}$, &
m-k+1 ), ldv, work, ldwork )
! c2 := c2 - w**h
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) -conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_ccopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v( 1_${ik}$, n-k+1 ), ldv, work,ldwork )
if( n>k ) then
! w := w + c1 * v1**h
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, &
c, ldc, v, ldv, cone, work,ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c1 := c1 - w * v1
call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, &
ldwork, v, ldv, cone, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1_${ik}$, &
n-k+1 ), ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_clarfb
pure module subroutine stdlib${ii}$_zlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, &
!! ZLARFB applies a complex block reflector H or its transpose H**H to a
!! complex M-by-N matrix C, from either the left or the right.
work, ldwork )
! -- 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) :: direct, side, storev, trans
integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n
! Array Arguments
complex(dp), intent(inout) :: c(ldc,*)
complex(dp), intent(in) :: t(ldt,*), v(ldv,*)
complex(dp), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
character :: transt
integer(${ik}$) :: i, j
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0 .or. n<=0 )return
if( stdlib_lsame( trans, 'N' ) ) then
transt = 'C'
else
transt = 'N'
end if
if( stdlib_lsame( storev, 'C' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 ) (first k rows)
! ( v2 )
! where v1 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work)
! w := c1**h
do j = 1, k
call stdlib${ii}$_zcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, &
ldv, work, ldwork )
if( m>k ) then
! w := w + c2**h * v2
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, &
c( k+1, 1_${ik}$ ), ldc,v( k+1, 1_${ik}$ ), ldv, cone, work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v * w**h
if( m>k ) then
! c2 := c2 - v2 * w**h
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, &
v( k+1, 1_${ik}$ ), ldv, work,ldwork, cone, c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v, ldv, work, ldwork )
! c1 := c1 - w**h
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_zcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, &
ldv, work, ldwork )
if( n>k ) then
! w := w + c2 * v2
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1_${ik}$, k+&
1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v**h
if( n>k ) then
! c2 := c2 - w * v2**h
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, &
work, ldwork, v( k+1, 1_${ik}$ ),ldv, cone, c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v, ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 )
! ( v2 ) (last k rows)
! where v2 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work)
! w := c2**h
do j = 1, k
call stdlib${ii}$_zcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-&
k+1, 1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**h * v1
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, &
c, ldc, v, ldv, cone, work,ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v * w**h
if( m>k ) then
! c1 := c1 - v1 * w**h
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, &
v, ldv, work, ldwork,cone, c, ldc )
end if
! w := w * v2**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v( m-k+1, 1_${ik}$ ), ldv, work,ldwork )
! c2 := c2 - w**h
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) -conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_zcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-&
k+1, 1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, &
v, ldv, cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v**h
if( n>k ) then
! c1 := c1 - w * v1**h
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, &
work, ldwork, v, ldv, cone,c, ldc )
end if
! w := w * v2**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v( n-k+1, 1_${ik}$ ), ldv, work,ldwork )
! c2 := c2 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
else if( stdlib_lsame( storev, 'R' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 v2 ) (v1: first k columns)
! where v1 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work)
! w := c1**h
do j = 1, k
call stdlib${ii}$_zcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v, ldv, work, ldwork )
if( m>k ) then
! w := w + c2**h * v2**h
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, &
cone,c( k+1, 1_${ik}$ ), ldc, v( 1_${ik}$, k+1 ), ldv, cone,work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v**h * w**h
if( m>k ) then
! c2 := c2 - v2**h * w**h
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, &
-cone,v( 1_${ik}$, k+1 ), ldv, work, ldwork, cone,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, &
ldv, work, ldwork )
! c1 := c1 - w**h
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_zcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v, ldv, work, ldwork )
if( n>k ) then
! w := w + c2 * v2**h
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, &
c( 1_${ik}$, k+1 ), ldc,v( 1_${ik}$, k+1 ), ldv, cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c2 := c2 - w * v2
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, &
ldwork, v( 1_${ik}$, k+1 ), ldv, cone,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1
call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, &
ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 v2 ) (v2: last k columns)
! where v2 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work)
! w := c2**h
do j = 1, k
call stdlib${ii}$_zcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v( 1_${ik}$, m-k+1 ), ldv, work,ldwork )
if( m>k ) then
! w := w + c1**h * v1**h
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, &
cone, c,ldc, v, ldv, cone, work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v**h * w**h
if( m>k ) then
! c1 := c1 - v1**h * w**h
call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, &
-cone, v,ldv, work, ldwork, cone, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1_${ik}$, &
m-k+1 ), ldv, work, ldwork )
! c2 := c2 - w**h
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) -conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_zcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v( 1_${ik}$, n-k+1 ), ldv, work,ldwork )
if( n>k ) then
! w := w + c1 * v1**h
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, &
c, ldc, v, ldv, cone, work,ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c1 := c1 - w * v1
call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, &
ldwork, v, ldv, cone, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1_${ik}$, &
n-k+1 ), ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_zlarfb
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, &
!! ZLARFB: applies a complex block reflector H or its transpose H**H to a
!! complex M-by-N matrix C, from either the left or the right.
work, ldwork )
! -- 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) :: direct, side, storev, trans
integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n
! Array Arguments
complex(${ck}$), intent(inout) :: c(ldc,*)
complex(${ck}$), intent(in) :: t(ldt,*), v(ldv,*)
complex(${ck}$), intent(out) :: work(ldwork,*)
! =====================================================================
! Local Scalars
character :: transt
integer(${ik}$) :: i, j
! Intrinsic Functions
! Executable Statements
! quick return if possible
if( m<=0 .or. n<=0 )return
if( stdlib_lsame( trans, 'N' ) ) then
transt = 'C'
else
transt = 'N'
end if
if( stdlib_lsame( storev, 'C' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 ) (first k rows)
! ( v2 )
! where v1 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work)
! w := c1**h
do j = 1, k
call stdlib${ii}$_${ci}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, &
ldv, work, ldwork )
if( m>k ) then
! w := w + c2**h * v2
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, &
c( k+1, 1_${ik}$ ), ldc,v( k+1, 1_${ik}$ ), ldv, cone, work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v * w**h
if( m>k ) then
! c2 := c2 - v2 * w**h
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, &
v( k+1, 1_${ik}$ ), ldv, work,ldwork, cone, c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v, ldv, work, ldwork )
! c1 := c1 - w**h
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, &
ldv, work, ldwork )
if( n>k ) then
! w := w + c2 * v2
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1_${ik}$, k+&
1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v**h
if( n>k ) then
! c2 := c2 - w * v2**h
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, &
work, ldwork, v( k+1, 1_${ik}$ ),ldv, cone, c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v, ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 )
! ( v2 ) (last k rows)
! where v2 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work)
! w := c2**h
do j = 1, k
call stdlib${ii}$_${ci}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-&
k+1, 1_${ik}$ ), ldv, work, ldwork )
if( m>k ) then
! w := w + c1**h * v1
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, &
c, ldc, v, ldv, cone, work,ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v * w**h
if( m>k ) then
! c1 := c1 - v1 * w**h
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, &
v, ldv, work, ldwork,cone, c, ldc )
end if
! w := w * v2**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v( m-k+1, 1_${ik}$ ), ldv, work,ldwork )
! c2 := c2 - w**h
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) -conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v = (c1*v1 + c2*v2) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-&
k+1, 1_${ik}$ ), ldv, work, ldwork )
if( n>k ) then
! w := w + c1 * v1
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, &
v, ldv, cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v**h
if( n>k ) then
! c1 := c1 - w * v1**h
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, &
work, ldwork, v, ldv, cone,c, ldc )
end if
! w := w * v2**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v( n-k+1, 1_${ik}$ ), ldv, work,ldwork )
! c2 := c2 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
else if( stdlib_lsame( storev, 'R' ) ) then
if( stdlib_lsame( direct, 'F' ) ) then
! let v = ( v1 v2 ) (v1: first k columns)
! where v1 is unit upper triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work)
! w := c1**h
do j = 1, k
call stdlib${ii}$_${ci}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v, ldv, work, ldwork )
if( m>k ) then
! w := w + c2**h * v2**h
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, &
cone,c( k+1, 1_${ik}$ ), ldc, v( 1_${ik}$, k+1 ), ldv, cone,work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v**h * w**h
if( m>k ) then
! c2 := c2 - v2**h * w**h
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, &
-cone,v( 1_${ik}$, k+1 ), ldv, work, ldwork, cone,c( k+1, 1_${ik}$ ), ldc )
end if
! w := w * v1
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, &
ldv, work, ldwork )
! c1 := c1 - w**h
do j = 1, k
do i = 1, n
c( j, i ) = c( j, i ) - conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work)
! w := c1
do j = 1, k
call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v1**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v, ldv, work, ldwork )
if( n>k ) then
! w := w + c2 * v2**h
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, &
c( 1_${ik}$, k+1 ), ldc,v( 1_${ik}$, k+1 ), ldv, cone, work, ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c2 := c2 - w * v2
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, &
ldwork, v( 1_${ik}$, k+1 ), ldv, cone,c( 1_${ik}$, k+1 ), ldc )
end if
! w := w * v1
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, &
ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, j ) = c( i, j ) - work( i, j )
end do
end do
end if
else
! let v = ( v1 v2 ) (v2: last k columns)
! where v2 is unit lower triangular.
if( stdlib_lsame( side, 'L' ) ) then
! form h * c or h**h * c where c = ( c1 )
! ( c2 )
! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work)
! w := c2**h
do j = 1, k
call stdlib${ii}$_${ci}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ )
call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,&
v( 1_${ik}$, m-k+1 ), ldv, work,ldwork )
if( m>k ) then
! w := w + c1**h * v1**h
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, &
cone, c,ldc, v, ldv, cone, work, ldwork )
end if
! w := w * t**h or w * t
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, &
work, ldwork )
! c := c - v**h * w**h
if( m>k ) then
! c1 := c1 - v1**h * w**h
call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, &
-cone, v,ldv, work, ldwork, cone, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1_${ik}$, &
m-k+1 ), ldv, work, ldwork )
! c2 := c2 - w**h
do j = 1, k
do i = 1, n
c( m-k+j, i ) = c( m-k+j, i ) -conjg( work( i, j ) )
end do
end do
else if( stdlib_lsame( side, 'R' ) ) then
! form c * h or c * h**h where c = ( c1 c2 )
! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work)
! w := c2
do j = 1, k
call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ )
end do
! w := w * v2**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,&
v( 1_${ik}$, n-k+1 ), ldv, work,ldwork )
if( n>k ) then
! w := w + c1 * v1**h
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, &
c, ldc, v, ldv, cone, work,ldwork )
end if
! w := w * t or w * t**h
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, &
work, ldwork )
! c := c - w * v
if( n>k ) then
! c1 := c1 - w * v1
call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, &
ldwork, v, ldv, cone, c, ldc )
end if
! w := w * v2
call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1_${ik}$, &
n-k+1 ), ldv, work, ldwork )
! c1 := c1 - w
do j = 1, k
do i = 1, m
c( i, n-k+j ) = c( i, n-k+j ) - work( i, j )
end do
end do
end if
end if
end if
return
end subroutine stdlib${ii}$_${ci}$larfb
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slarfg( n, alpha, x, incx, tau )
!! SLARFG generates a real elementary reflector H of order n, such
!! that
!! H * ( alpha ) = ( beta ), H**T * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, and x is an (n-1)-element real
!! vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**T ) ,
!! ( v )
!! where tau is a real scalar and v is a real (n-1)-element
!! vector.
!! If the elements of x are all zero, then tau = 0 and H is taken to be
!! the unit matrix.
!! Otherwise 1 <= tau <= 2.
! -- 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) :: incx, n
real(sp), intent(inout) :: alpha
real(sp), intent(out) :: tau
! Array Arguments
real(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(sp) :: beta, rsafmn, safmin, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=1_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_snrm2( n-1, x, incx )
if( xnorm==zero ) then
! h = i
tau = zero
else
! general case
beta = -sign( stdlib${ii}$_slapy2( alpha, xnorm ), alpha )
safmin = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'E' )
knt = 0_${ik}$
if( abs( beta )<safmin ) then
! xnorm, beta may be inaccurate; scale x and recompute them
rsafmn = one / safmin
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_sscal( n-1, rsafmn, x, incx )
beta = beta*rsafmn
alpha = alpha*rsafmn
if( (abs( beta )<safmin) .and. (knt < 20) )go to 10
! new beta is at most 1, at least safmin
xnorm = stdlib${ii}$_snrm2( n-1, x, incx )
beta = -sign( stdlib${ii}$_slapy2( alpha, xnorm ), alpha )
end if
tau = ( beta-alpha ) / beta
call stdlib${ii}$_sscal( n-1, one / ( alpha-beta ), x, incx )
! if alpha is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*safmin
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_slarfg
pure module subroutine stdlib${ii}$_dlarfg( n, alpha, x, incx, tau )
!! DLARFG generates a real elementary reflector H of order n, such
!! that
!! H * ( alpha ) = ( beta ), H**T * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, and x is an (n-1)-element real
!! vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**T ) ,
!! ( v )
!! where tau is a real scalar and v is a real (n-1)-element
!! vector.
!! If the elements of x are all zero, then tau = 0 and H is taken to be
!! the unit matrix.
!! Otherwise 1 <= tau <= 2.
! -- 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) :: incx, n
real(dp), intent(inout) :: alpha
real(dp), intent(out) :: tau
! Array Arguments
real(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(dp) :: beta, rsafmn, safmin, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=1_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_dnrm2( n-1, x, incx )
if( xnorm==zero ) then
! h = i
tau = zero
else
! general case
beta = -sign( stdlib${ii}$_dlapy2( alpha, xnorm ), alpha )
safmin = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'E' )
knt = 0_${ik}$
if( abs( beta )<safmin ) then
! xnorm, beta may be inaccurate; scale x and recompute them
rsafmn = one / safmin
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_dscal( n-1, rsafmn, x, incx )
beta = beta*rsafmn
alpha = alpha*rsafmn
if( (abs( beta )<safmin) .and. (knt < 20) )go to 10
! new beta is at most 1, at least safmin
xnorm = stdlib${ii}$_dnrm2( n-1, x, incx )
beta = -sign( stdlib${ii}$_dlapy2( alpha, xnorm ), alpha )
end if
tau = ( beta-alpha ) / beta
call stdlib${ii}$_dscal( n-1, one / ( alpha-beta ), x, incx )
! if alpha is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*safmin
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_dlarfg
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$larfg( n, alpha, x, incx, tau )
!! DLARFG: generates a real elementary reflector H of order n, such
!! that
!! H * ( alpha ) = ( beta ), H**T * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, and x is an (n-1)-element real
!! vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**T ) ,
!! ( v )
!! where tau is a real scalar and v is a real (n-1)-element
!! vector.
!! If the elements of x are all zero, then tau = 0 and H is taken to be
!! the unit matrix.
!! Otherwise 1 <= tau <= 2.
! -- 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) :: incx, n
real(${rk}$), intent(inout) :: alpha
real(${rk}$), intent(out) :: tau
! Array Arguments
real(${rk}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(${rk}$) :: beta, rsafmn, safmin, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=1_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_${ri}$nrm2( n-1, x, incx )
if( xnorm==zero ) then
! h = i
tau = zero
else
! general case
beta = -sign( stdlib${ii}$_${ri}$lapy2( alpha, xnorm ), alpha )
safmin = stdlib${ii}$_${ri}$lamch( 'S' ) / stdlib${ii}$_${ri}$lamch( 'E' )
knt = 0_${ik}$
if( abs( beta )<safmin ) then
! xnorm, beta may be inaccurate; scale x and recompute them
rsafmn = one / safmin
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_${ri}$scal( n-1, rsafmn, x, incx )
beta = beta*rsafmn
alpha = alpha*rsafmn
if( (abs( beta )<safmin) .and. (knt < 20) )go to 10
! new beta is at most 1, at least safmin
xnorm = stdlib${ii}$_${ri}$nrm2( n-1, x, incx )
beta = -sign( stdlib${ii}$_${ri}$lapy2( alpha, xnorm ), alpha )
end if
tau = ( beta-alpha ) / beta
call stdlib${ii}$_${ri}$scal( n-1, one / ( alpha-beta ), x, incx )
! if alpha is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*safmin
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_${ri}$larfg
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clarfg( n, alpha, x, incx, tau )
!! CLARFG generates a complex elementary reflector H of order n, such
!! that
!! H**H * ( alpha ) = ( beta ), H**H * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, with beta real, and x is an
!! (n-1)-element complex vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**H ) ,
!! ( v )
!! where tau is a complex scalar and v is a complex (n-1)-element
!! vector. Note that H is not hermitian.
!! If the elements of x are all zero and alpha is real, then tau = 0
!! and H is taken to be the unit matrix.
!! Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
! -- 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) :: incx, n
complex(sp), intent(inout) :: alpha
complex(sp), intent(out) :: tau
! Array Arguments
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(sp) :: alphi, alphr, beta, rsafmn, safmin, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_scnrm2( n-1, x, incx )
alphr = real( alpha,KIND=sp)
alphi = aimag( alpha )
if( xnorm==zero .and. alphi==zero ) then
! h = i
tau = zero
else
! general case
beta = -sign( stdlib${ii}$_slapy3( alphr, alphi, xnorm ), alphr )
safmin = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'E' )
rsafmn = one / safmin
knt = 0_${ik}$
if( abs( beta )<safmin ) then
! xnorm, beta may be inaccurate; scale x and recompute them
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_csscal( n-1, rsafmn, x, incx )
beta = beta*rsafmn
alphi = alphi*rsafmn
alphr = alphr*rsafmn
if( (abs( beta )<safmin) .and. (knt < 20) )go to 10
! new beta is at most 1, at least safmin
xnorm = stdlib${ii}$_scnrm2( n-1, x, incx )
alpha = cmplx( alphr, alphi,KIND=sp)
beta = -sign( stdlib${ii}$_slapy3( alphr, alphi, xnorm ), alphr )
end if
tau = cmplx( ( beta-alphr ) / beta, -alphi / beta,KIND=sp)
alpha = stdlib${ii}$_cladiv( cmplx( one,KIND=sp), alpha-beta )
call stdlib${ii}$_cscal( n-1, alpha, x, incx )
! if alpha is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*safmin
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_clarfg
pure module subroutine stdlib${ii}$_zlarfg( n, alpha, x, incx, tau )
!! ZLARFG generates a complex elementary reflector H of order n, such
!! that
!! H**H * ( alpha ) = ( beta ), H**H * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, with beta real, and x is an
!! (n-1)-element complex vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**H ) ,
!! ( v )
!! where tau is a complex scalar and v is a complex (n-1)-element
!! vector. Note that H is not hermitian.
!! If the elements of x are all zero and alpha is real, then tau = 0
!! and H is taken to be the unit matrix.
!! Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
! -- 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) :: incx, n
complex(dp), intent(inout) :: alpha
complex(dp), intent(out) :: tau
! Array Arguments
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(dp) :: alphi, alphr, beta, rsafmn, safmin, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_dznrm2( n-1, x, incx )
alphr = real( alpha,KIND=dp)
alphi = aimag( alpha )
if( xnorm==zero .and. alphi==zero ) then
! h = i
tau = zero
else
! general case
beta = -sign( stdlib${ii}$_dlapy3( alphr, alphi, xnorm ), alphr )
safmin = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'E' )
rsafmn = one / safmin
knt = 0_${ik}$
if( abs( beta )<safmin ) then
! xnorm, beta may be inaccurate; scale x and recompute them
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_zdscal( n-1, rsafmn, x, incx )
beta = beta*rsafmn
alphi = alphi*rsafmn
alphr = alphr*rsafmn
if( (abs( beta )<safmin) .and. (knt < 20) )go to 10
! new beta is at most 1, at least safmin
xnorm = stdlib${ii}$_dznrm2( n-1, x, incx )
alpha = cmplx( alphr, alphi,KIND=dp)
beta = -sign( stdlib${ii}$_dlapy3( alphr, alphi, xnorm ), alphr )
end if
tau = cmplx( ( beta-alphr ) / beta, -alphi / beta,KIND=dp)
alpha = stdlib${ii}$_zladiv( cmplx( one,KIND=dp), alpha-beta )
call stdlib${ii}$_zscal( n-1, alpha, x, incx )
! if alpha is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*safmin
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_zlarfg
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$larfg( n, alpha, x, incx, tau )
!! ZLARFG: generates a complex elementary reflector H of order n, such
!! that
!! H**H * ( alpha ) = ( beta ), H**H * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, with beta real, and x is an
!! (n-1)-element complex vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**H ) ,
!! ( v )
!! where tau is a complex scalar and v is a complex (n-1)-element
!! vector. Note that H is not hermitian.
!! If the elements of x are all zero and alpha is real, then tau = 0
!! and H is taken to be the unit matrix.
!! Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .
! -- 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) :: incx, n
complex(${ck}$), intent(inout) :: alpha
complex(${ck}$), intent(out) :: tau
! Array Arguments
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(${ck}$) :: alphi, alphr, beta, rsafmn, safmin, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_${c2ri(ci)}$znrm2( n-1, x, incx )
alphr = real( alpha,KIND=${ck}$)
alphi = aimag( alpha )
if( xnorm==zero .and. alphi==zero ) then
! h = i
tau = zero
else
! general case
beta = -sign( stdlib${ii}$_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr )
safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )
rsafmn = one / safmin
knt = 0_${ik}$
if( abs( beta )<safmin ) then
! xnorm, beta may be inaccurate; scale x and recompute them
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_${ci}$dscal( n-1, rsafmn, x, incx )
beta = beta*rsafmn
alphi = alphi*rsafmn
alphr = alphr*rsafmn
if( (abs( beta )<safmin) .and. (knt < 20) )go to 10
! new beta is at most 1, at least safmin
xnorm = stdlib${ii}$_${c2ri(ci)}$znrm2( n-1, x, incx )
alpha = cmplx( alphr, alphi,KIND=${ck}$)
beta = -sign( stdlib${ii}$_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr )
end if
tau = cmplx( ( beta-alphr ) / beta, -alphi / beta,KIND=${ck}$)
alpha = stdlib${ii}$_${ci}$ladiv( cmplx( one,KIND=${ck}$), alpha-beta )
call stdlib${ii}$_${ci}$scal( n-1, alpha, x, incx )
! if alpha is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*safmin
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_${ci}$larfg
#:endif
#:endfor
module subroutine stdlib${ii}$_slarfgp( n, alpha, x, incx, tau )
!! SLARFGP generates a real elementary reflector H of order n, such
!! that
!! H * ( alpha ) = ( beta ), H**T * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, beta is non-negative, and x is
!! an (n-1)-element real vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**T ) ,
!! ( v )
!! where tau is a real scalar and v is a real (n-1)-element
!! vector.
!! If the elements of x are all zero, then tau = 0 and H is taken to be
!! the unit matrix.
! -- 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) :: incx, n
real(sp), intent(inout) :: alpha
real(sp), intent(out) :: tau
! Array Arguments
real(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(sp) :: beta, bignum, savealpha, smlnum, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_snrm2( n-1, x, incx )
if( xnorm==zero ) then
! h = [+/-1, 0; i], sign chosen so alpha >= 0.
if( alpha>=zero ) then
! when tau.eq.zero, the vector is special-cased to be
! all zeros in the application routines. we do not need
! to clear it.
tau = zero
else
! however, the application routines rely on explicit
! zero checks when tau.ne.zero, and we must clear x.
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$
end do
alpha = -alpha
end if
else
! general case
beta = sign( stdlib${ii}$_slapy2( alpha, xnorm ), alpha )
smlnum = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'E' )
knt = 0_${ik}$
if( abs( beta )<smlnum ) then
! xnorm, beta may be inaccurate; scale x and recompute them
bignum = one / smlnum
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_sscal( n-1, bignum, x, incx )
beta = beta*bignum
alpha = alpha*bignum
if( (abs( beta )<smlnum) .and. (knt < 20) )go to 10
! new beta is at most 1, at least smlnum
xnorm = stdlib${ii}$_snrm2( n-1, x, incx )
beta = sign( stdlib${ii}$_slapy2( alpha, xnorm ), alpha )
end if
savealpha = alpha
alpha = alpha + beta
if( beta<zero ) then
beta = -beta
tau = -alpha / beta
else
alpha = xnorm * (xnorm/alpha)
tau = alpha / beta
alpha = -alpha
end if
if ( abs(tau)<=smlnum ) then
! in the case where the computed tau ends up being a denormalized number,
! it loses relative accuracy. this is a big problem. solution: flush tau
! to zero. this explains the next if statement.
! (bug report provided by pat quillen from mathworks on jul 29, 2009.)
! (thanks pat. thanks mathworks.)
if( savealpha>=zero ) then
tau = zero
else
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$
end do
beta = -savealpha
end if
else
! this is the general case.
call stdlib${ii}$_sscal( n-1, one / alpha, x, incx )
end if
! if beta is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*smlnum
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_slarfgp
module subroutine stdlib${ii}$_dlarfgp( n, alpha, x, incx, tau )
!! DLARFGP generates a real elementary reflector H of order n, such
!! that
!! H * ( alpha ) = ( beta ), H**T * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, beta is non-negative, and x is
!! an (n-1)-element real vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**T ) ,
!! ( v )
!! where tau is a real scalar and v is a real (n-1)-element
!! vector.
!! If the elements of x are all zero, then tau = 0 and H is taken to be
!! the unit matrix.
! -- 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) :: incx, n
real(dp), intent(inout) :: alpha
real(dp), intent(out) :: tau
! Array Arguments
real(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(dp) :: beta, bignum, savealpha, smlnum, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_dnrm2( n-1, x, incx )
if( xnorm==zero ) then
! h = [+/-1, 0; i], sign chosen so alpha >= 0
if( alpha>=zero ) then
! when tau.eq.zero, the vector is special-cased to be
! all zeros in the application routines. we do not need
! to clear it.
tau = zero
else
! however, the application routines rely on explicit
! zero checks when tau.ne.zero, and we must clear x.
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$
end do
alpha = -alpha
end if
else
! general case
beta = sign( stdlib${ii}$_dlapy2( alpha, xnorm ), alpha )
smlnum = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'E' )
knt = 0_${ik}$
if( abs( beta )<smlnum ) then
! xnorm, beta may be inaccurate; scale x and recompute them
bignum = one / smlnum
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_dscal( n-1, bignum, x, incx )
beta = beta*bignum
alpha = alpha*bignum
if( (abs( beta )<smlnum) .and. (knt < 20) )go to 10
! new beta is at most 1, at least smlnum
xnorm = stdlib${ii}$_dnrm2( n-1, x, incx )
beta = sign( stdlib${ii}$_dlapy2( alpha, xnorm ), alpha )
end if
savealpha = alpha
alpha = alpha + beta
if( beta<zero ) then
beta = -beta
tau = -alpha / beta
else
alpha = xnorm * (xnorm/alpha)
tau = alpha / beta
alpha = -alpha
end if
if ( abs(tau)<=smlnum ) then
! in the case where the computed tau ends up being a denormalized number,
! it loses relative accuracy. this is a big problem. solution: flush tau
! to zero. this explains the next if statement.
! (bug report provided by pat quillen from mathworks on jul 29, 2009.)
! (thanks pat. thanks mathworks.)
if( savealpha>=zero ) then
tau = zero
else
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$
end do
beta = -savealpha
end if
else
! this is the general case.
call stdlib${ii}$_dscal( n-1, one / alpha, x, incx )
end if
! if beta is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*smlnum
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_dlarfgp
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
module subroutine stdlib${ii}$_${ri}$larfgp( n, alpha, x, incx, tau )
!! DLARFGP: generates a real elementary reflector H of order n, such
!! that
!! H * ( alpha ) = ( beta ), H**T * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, beta is non-negative, and x is
!! an (n-1)-element real vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**T ) ,
!! ( v )
!! where tau is a real scalar and v is a real (n-1)-element
!! vector.
!! If the elements of x are all zero, then tau = 0 and H is taken to be
!! the unit matrix.
! -- 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) :: incx, n
real(${rk}$), intent(inout) :: alpha
real(${rk}$), intent(out) :: tau
! Array Arguments
real(${rk}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(${rk}$) :: beta, bignum, savealpha, smlnum, xnorm
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_${ri}$nrm2( n-1, x, incx )
if( xnorm==zero ) then
! h = [+/-1, 0; i], sign chosen so alpha >= 0
if( alpha>=zero ) then
! when tau.eq.zero, the vector is special-cased to be
! all zeros in the application routines. we do not need
! to clear it.
tau = zero
else
! however, the application routines rely on explicit
! zero checks when tau.ne.zero, and we must clear x.
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$
end do
alpha = -alpha
end if
else
! general case
beta = sign( stdlib${ii}$_${ri}$lapy2( alpha, xnorm ), alpha )
smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / stdlib${ii}$_${ri}$lamch( 'E' )
knt = 0_${ik}$
if( abs( beta )<smlnum ) then
! xnorm, beta may be inaccurate; scale x and recompute them
bignum = one / smlnum
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_${ri}$scal( n-1, bignum, x, incx )
beta = beta*bignum
alpha = alpha*bignum
if( (abs( beta )<smlnum) .and. (knt < 20) )go to 10
! new beta is at most 1, at least smlnum
xnorm = stdlib${ii}$_${ri}$nrm2( n-1, x, incx )
beta = sign( stdlib${ii}$_${ri}$lapy2( alpha, xnorm ), alpha )
end if
savealpha = alpha
alpha = alpha + beta
if( beta<zero ) then
beta = -beta
tau = -alpha / beta
else
alpha = xnorm * (xnorm/alpha)
tau = alpha / beta
alpha = -alpha
end if
if ( abs(tau)<=smlnum ) then
! in the case where the computed tau ends up being a denormalized number,
! it loses relative accuracy. this is a big problem. solution: flush tau
! to zero. this explains the next if statement.
! (bug report provided by pat quillen from mathworks on jul 29, 2009.)
! (thanks pat. thanks mathworks.)
if( savealpha>=zero ) then
tau = zero
else
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$
end do
beta = -savealpha
end if
else
! this is the general case.
call stdlib${ii}$_${ri}$scal( n-1, one / alpha, x, incx )
end if
! if beta is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*smlnum
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_${ri}$larfgp
#:endif
#:endfor
module subroutine stdlib${ii}$_clarfgp( n, alpha, x, incx, tau )
!! CLARFGP generates a complex elementary reflector H of order n, such
!! that
!! H**H * ( alpha ) = ( beta ), H**H * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, beta is real and non-negative, and
!! x is an (n-1)-element complex vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**H ) ,
!! ( v )
!! where tau is a complex scalar and v is a complex (n-1)-element
!! vector. Note that H is not hermitian.
!! If the elements of x are all zero and alpha is real, then tau = 0
!! and H is taken to be the unit matrix.
! -- 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) :: incx, n
complex(sp), intent(inout) :: alpha
complex(sp), intent(out) :: tau
! Array Arguments
complex(sp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(sp) :: alphi, alphr, beta, bignum, smlnum, xnorm
complex(sp) :: savealpha
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_scnrm2( n-1, x, incx )
alphr = real( alpha,KIND=sp)
alphi = aimag( alpha )
if( xnorm==zero ) then
! h = [1-alpha/abs(alpha) 0; 0 i], sign chosen so alpha >= 0.
if( alphi==zero ) then
if( alphr>=zero ) then
! when tau.eq.zero, the vector is special-cased to be
! all zeros in the application routines. we do not need
! to clear it.
tau = zero
else
! however, the application routines rely on explicit
! zero checks when tau.ne.zero, and we must clear x.
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
alpha = -alpha
end if
else
! only "reflecting" the diagonal entry to be real and non-negative.
xnorm = stdlib${ii}$_slapy2( alphr, alphi )
tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=sp)
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
alpha = xnorm
end if
else
! general case
beta = sign( stdlib${ii}$_slapy3( alphr, alphi, xnorm ), alphr )
smlnum = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'E' )
bignum = one / smlnum
knt = 0_${ik}$
if( abs( beta )<smlnum ) then
! xnorm, beta may be inaccurate; scale x and recompute them
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_csscal( n-1, bignum, x, incx )
beta = beta*bignum
alphi = alphi*bignum
alphr = alphr*bignum
if( (abs( beta )<smlnum) .and. (knt < 20) )go to 10
! new beta is at most 1, at least smlnum
xnorm = stdlib${ii}$_scnrm2( n-1, x, incx )
alpha = cmplx( alphr, alphi,KIND=sp)
beta = sign( stdlib${ii}$_slapy3( alphr, alphi, xnorm ), alphr )
end if
savealpha = alpha
alpha = alpha + beta
if( beta<zero ) then
beta = -beta
tau = -alpha / beta
else
alphr = alphi * (alphi/real( alpha,KIND=sp))
alphr = alphr + xnorm * (xnorm/real( alpha,KIND=sp))
tau = cmplx( alphr/beta, -alphi/beta,KIND=sp)
alpha = cmplx( -alphr, alphi,KIND=sp)
end if
alpha = stdlib${ii}$_cladiv( cmplx( one,KIND=sp), alpha )
if ( abs(tau)<=smlnum ) then
! in the case where the computed tau ends up being a denormalized number,
! it loses relative accuracy. this is a big problem. solution: flush tau
! to zero (or two or whatever makes a nonnegative real number for beta).
! (bug report provided by pat quillen from mathworks on jul 29, 2009.)
! (thanks pat. thanks mathworks.)
alphr = real( savealpha,KIND=sp)
alphi = aimag( savealpha )
if( alphi==zero ) then
if( alphr>=zero ) then
tau = zero
else
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
beta = real( -savealpha,KIND=sp)
end if
else
xnorm = stdlib${ii}$_slapy2( alphr, alphi )
tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=sp)
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
beta = xnorm
end if
else
! this is the general case.
call stdlib${ii}$_cscal( n-1, alpha, x, incx )
end if
! if beta is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*smlnum
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_clarfgp
module subroutine stdlib${ii}$_zlarfgp( n, alpha, x, incx, tau )
!! ZLARFGP generates a complex elementary reflector H of order n, such
!! that
!! H**H * ( alpha ) = ( beta ), H**H * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, beta is real and non-negative, and
!! x is an (n-1)-element complex vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**H ) ,
!! ( v )
!! where tau is a complex scalar and v is a complex (n-1)-element
!! vector. Note that H is not hermitian.
!! If the elements of x are all zero and alpha is real, then tau = 0
!! and H is taken to be the unit matrix.
! -- 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) :: incx, n
complex(dp), intent(inout) :: alpha
complex(dp), intent(out) :: tau
! Array Arguments
complex(dp), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(dp) :: alphi, alphr, beta, bignum, smlnum, xnorm
complex(dp) :: savealpha
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_dznrm2( n-1, x, incx )
alphr = real( alpha,KIND=dp)
alphi = aimag( alpha )
if( xnorm==zero ) then
! h = [1-alpha/abs(alpha) 0; 0 i], sign chosen so alpha >= 0.
if( alphi==zero ) then
if( alphr>=zero ) then
! when tau.eq.zero, the vector is special-cased to be
! all zeros in the application routines. we do not need
! to clear it.
tau = zero
else
! however, the application routines rely on explicit
! zero checks when tau.ne.zero, and we must clear x.
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
alpha = -alpha
end if
else
! only "reflecting" the diagonal entry to be real and non-negative.
xnorm = stdlib${ii}$_dlapy2( alphr, alphi )
tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=dp)
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
alpha = xnorm
end if
else
! general case
beta = sign( stdlib${ii}$_dlapy3( alphr, alphi, xnorm ), alphr )
smlnum = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'E' )
bignum = one / smlnum
knt = 0_${ik}$
if( abs( beta )<smlnum ) then
! xnorm, beta may be inaccurate; scale x and recompute them
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_zdscal( n-1, bignum, x, incx )
beta = beta*bignum
alphi = alphi*bignum
alphr = alphr*bignum
if( (abs( beta )<smlnum) .and. (knt < 20) )go to 10
! new beta is at most 1, at least smlnum
xnorm = stdlib${ii}$_dznrm2( n-1, x, incx )
alpha = cmplx( alphr, alphi,KIND=dp)
beta = sign( stdlib${ii}$_dlapy3( alphr, alphi, xnorm ), alphr )
end if
savealpha = alpha
alpha = alpha + beta
if( beta<zero ) then
beta = -beta
tau = -alpha / beta
else
alphr = alphi * (alphi/real( alpha,KIND=dp))
alphr = alphr + xnorm * (xnorm/real( alpha,KIND=dp))
tau = cmplx( alphr/beta, -alphi/beta,KIND=dp)
alpha = cmplx( -alphr, alphi,KIND=dp)
end if
alpha = stdlib${ii}$_zladiv( cmplx( one,KIND=dp), alpha )
if ( abs(tau)<=smlnum ) then
! in the case where the computed tau ends up being a denormalized number,
! it loses relative accuracy. this is a big problem. solution: flush tau
! to zero (or two or whatever makes a nonnegative real number for beta).
! (bug report provided by pat quillen from mathworks on jul 29, 2009.)
! (thanks pat. thanks mathworks.)
alphr = real( savealpha,KIND=dp)
alphi = aimag( savealpha )
if( alphi==zero ) then
if( alphr>=zero ) then
tau = zero
else
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
beta = real( -savealpha,KIND=dp)
end if
else
xnorm = stdlib${ii}$_dlapy2( alphr, alphi )
tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=dp)
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
beta = xnorm
end if
else
! this is the general case.
call stdlib${ii}$_zscal( n-1, alpha, x, incx )
end if
! if beta is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*smlnum
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_zlarfgp
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
module subroutine stdlib${ii}$_${ci}$larfgp( n, alpha, x, incx, tau )
!! ZLARFGP: generates a complex elementary reflector H of order n, such
!! that
!! H**H * ( alpha ) = ( beta ), H**H * H = I.
!! ( x ) ( 0 )
!! where alpha and beta are scalars, beta is real and non-negative, and
!! x is an (n-1)-element complex vector. H is represented in the form
!! H = I - tau * ( 1 ) * ( 1 v**H ) ,
!! ( v )
!! where tau is a complex scalar and v is a complex (n-1)-element
!! vector. Note that H is not hermitian.
!! If the elements of x are all zero and alpha is real, then tau = 0
!! and H is taken to be the unit matrix.
! -- 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) :: incx, n
complex(${ck}$), intent(inout) :: alpha
complex(${ck}$), intent(out) :: tau
! Array Arguments
complex(${ck}$), intent(inout) :: x(*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: j, knt
real(${ck}$) :: alphi, alphr, beta, bignum, smlnum, xnorm
complex(${ck}$) :: savealpha
! Intrinsic Functions
! Executable Statements
if( n<=0_${ik}$ ) then
tau = zero
return
end if
xnorm = stdlib${ii}$_${c2ri(ci)}$znrm2( n-1, x, incx )
alphr = real( alpha,KIND=${ck}$)
alphi = aimag( alpha )
if( xnorm==zero ) then
! h = [1-alpha/abs(alpha) 0; 0 i], sign chosen so alpha >= 0.
if( alphi==zero ) then
if( alphr>=zero ) then
! when tau.eq.zero, the vector is special-cased to be
! all zeros in the application routines. we do not need
! to clear it.
tau = zero
else
! however, the application routines rely on explicit
! zero checks when tau.ne.zero, and we must clear x.
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
alpha = -alpha
end if
else
! only "reflecting" the diagonal entry to be real and non-negative.
xnorm = stdlib${ii}$_${c2ri(ci)}$lapy2( alphr, alphi )
tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=${ck}$)
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
alpha = xnorm
end if
else
! general case
beta = sign( stdlib${ii}$_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr )
smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'E' )
bignum = one / smlnum
knt = 0_${ik}$
if( abs( beta )<smlnum ) then
! xnorm, beta may be inaccurate; scale x and recompute them
10 continue
knt = knt + 1_${ik}$
call stdlib${ii}$_${ci}$dscal( n-1, bignum, x, incx )
beta = beta*bignum
alphi = alphi*bignum
alphr = alphr*bignum
if( (abs( beta )<smlnum) .and. (knt < 20) )go to 10
! new beta is at most 1, at least smlnum
xnorm = stdlib${ii}$_${c2ri(ci)}$znrm2( n-1, x, incx )
alpha = cmplx( alphr, alphi,KIND=${ck}$)
beta = sign( stdlib${ii}$_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr )
end if
savealpha = alpha
alpha = alpha + beta
if( beta<zero ) then
beta = -beta
tau = -alpha / beta
else
alphr = alphi * (alphi/real( alpha,KIND=${ck}$))
alphr = alphr + xnorm * (xnorm/real( alpha,KIND=${ck}$))
tau = cmplx( alphr/beta, -alphi/beta,KIND=${ck}$)
alpha = cmplx( -alphr, alphi,KIND=${ck}$)
end if
alpha = stdlib${ii}$_${ci}$ladiv( cmplx( one,KIND=${ck}$), alpha )
if ( abs(tau)<=smlnum ) then
! in the case where the computed tau ends up being a denormalized number,
! it loses relative accuracy. this is a big problem. solution: flush tau
! to zero (or two or whatever makes a nonnegative real number for beta).
! (bug report provided by pat quillen from mathworks on jul 29, 2009.)
! (thanks pat. thanks mathworks.)
alphr = real( savealpha,KIND=${ck}$)
alphi = aimag( savealpha )
if( alphi==zero ) then
if( alphr>=zero ) then
tau = zero
else
tau = two
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
beta = real( -savealpha,KIND=${ck}$)
end if
else
xnorm = stdlib${ii}$_${c2ri(ci)}$lapy2( alphr, alphi )
tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=${ck}$)
do j = 1, n-1
x( 1_${ik}$ + (j-1)*incx ) = zero
end do
beta = xnorm
end if
else
! this is the general case.
call stdlib${ii}$_${ci}$scal( n-1, alpha, x, incx )
end if
! if beta is subnormal, it may lose relative accuracy
do j = 1, knt
beta = beta*smlnum
end do
alpha = beta
end if
return
end subroutine stdlib${ii}$_${ci}$larfgp
#:endif
#:endfor
pure module subroutine stdlib${ii}$_slarft( direct, storev, n, k, v, ldv, tau, t, ldt )
!! SLARFT forms the triangular factor T of a real block reflector H
!! of order n, which is defined as a product of k elementary reflectors.
!! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!! If STOREV = 'C', the vector which defines the elementary reflector
!! H(i) is stored in the i-th column of the array V, and
!! H = I - V * T * V**T
!! If STOREV = 'R', the vector which defines the elementary reflector
!! H(i) is stored in the i-th row of the array V, and
!! H = I - V**T * T * V
! -- 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) :: direct, storev
integer(${ik}$), intent(in) :: k, ldt, ldv, n
! Array Arguments
real(sp), intent(out) :: t(ldt,*)
real(sp), intent(in) :: tau(*), v(ldv,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, prevlastv, lastv
! Executable Statements
! quick return if possible
if( n==0 )return
if( stdlib_lsame( direct, 'F' ) ) then
prevlastv = n
do i = 1, k
prevlastv = max( i, prevlastv )
if( tau( i )==zero ) then
! h(i) = i
do j = 1, i
t( j, i ) = zero
end do
else
! general case
if( stdlib_lsame( storev, 'C' ) ) then
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( lastv, i )/=zero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( i , j )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**t * v(i:j,i)
call stdlib${ii}$_sgemv( 'TRANSPOSE', j-i, i-1, -tau( i ),v( i+1, 1_${ik}$ ), ldv, v( i+&
1_${ik}$, i ), 1_${ik}$, one,t( 1_${ik}$, i ), 1_${ik}$ )
else
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( i, lastv )/=zero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( j , i )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**t
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', i-1, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v(&
i, i+1 ), ldv,one, t( 1_${ik}$, i ), 1_${ik}$ )
end if
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i)
call stdlib${ii}$_strmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),&
1_${ik}$ )
t( i, i ) = tau( i )
if( i>1_${ik}$ ) then
prevlastv = max( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
end do
else
prevlastv = 1_${ik}$
do i = k, 1, -1
if( tau( i )==zero ) then
! h(i) = i
do j = i, k
t( j, i ) = zero
end do
else
! general case
if( i<k ) then
if( stdlib_lsame( storev, 'C' ) ) then
! skip any leading zeros.
do lastv = 1, i-1
if( v( lastv, i )/=zero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( n-k+i , j )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**t * v(j:n-k+i,i)
call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), &
ldv, v( j, i ), 1_${ik}$, one,t( i+1, i ), 1_${ik}$ )
else
! skip any leading zeros.
do lastv = 1, i-1
if( v( i, lastv )/=zero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( j, n-k+i )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**t
call stdlib${ii}$_sgemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), &
ldv, v( i, j ), ldv,one, t( i+1, i ), 1_${ik}$ )
end if
! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i)
call stdlib${ii}$_strmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), &
ldt, t( i+1, i ), 1_${ik}$ )
if( i>1_${ik}$ ) then
prevlastv = min( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
t( i, i ) = tau( i )
end if
end do
end if
return
end subroutine stdlib${ii}$_slarft
pure module subroutine stdlib${ii}$_dlarft( direct, storev, n, k, v, ldv, tau, t, ldt )
!! DLARFT forms the triangular factor T of a real block reflector H
!! of order n, which is defined as a product of k elementary reflectors.
!! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!! If STOREV = 'C', the vector which defines the elementary reflector
!! H(i) is stored in the i-th column of the array V, and
!! H = I - V * T * V**T
!! If STOREV = 'R', the vector which defines the elementary reflector
!! H(i) is stored in the i-th row of the array V, and
!! H = I - V**T * T * V
! -- 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) :: direct, storev
integer(${ik}$), intent(in) :: k, ldt, ldv, n
! Array Arguments
real(dp), intent(out) :: t(ldt,*)
real(dp), intent(in) :: tau(*), v(ldv,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, prevlastv, lastv
! Executable Statements
! quick return if possible
if( n==0 )return
if( stdlib_lsame( direct, 'F' ) ) then
prevlastv = n
do i = 1, k
prevlastv = max( i, prevlastv )
if( tau( i )==zero ) then
! h(i) = i
do j = 1, i
t( j, i ) = zero
end do
else
! general case
if( stdlib_lsame( storev, 'C' ) ) then
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( lastv, i )/=zero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( i , j )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**t * v(i:j,i)
call stdlib${ii}$_dgemv( 'TRANSPOSE', j-i, i-1, -tau( i ),v( i+1, 1_${ik}$ ), ldv, v( i+&
1_${ik}$, i ), 1_${ik}$, one,t( 1_${ik}$, i ), 1_${ik}$ )
else
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( i, lastv )/=zero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( j , i )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**t
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', i-1, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v(&
i, i+1 ), ldv, one,t( 1_${ik}$, i ), 1_${ik}$ )
end if
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i)
call stdlib${ii}$_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),&
1_${ik}$ )
t( i, i ) = tau( i )
if( i>1_${ik}$ ) then
prevlastv = max( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
end do
else
prevlastv = 1_${ik}$
do i = k, 1, -1
if( tau( i )==zero ) then
! h(i) = i
do j = i, k
t( j, i ) = zero
end do
else
! general case
if( i<k ) then
if( stdlib_lsame( storev, 'C' ) ) then
! skip any leading zeros.
do lastv = 1, i-1
if( v( lastv, i )/=zero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( n-k+i , j )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**t * v(j:n-k+i,i)
call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), &
ldv, v( j, i ), 1_${ik}$, one,t( i+1, i ), 1_${ik}$ )
else
! skip any leading zeros.
do lastv = 1, i-1
if( v( i, lastv )/=zero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( j, n-k+i )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**t
call stdlib${ii}$_dgemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), &
ldv, v( i, j ), ldv,one, t( i+1, i ), 1_${ik}$ )
end if
! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i)
call stdlib${ii}$_dtrmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), &
ldt, t( i+1, i ), 1_${ik}$ )
if( i>1_${ik}$ ) then
prevlastv = min( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
t( i, i ) = tau( i )
end if
end do
end if
return
end subroutine stdlib${ii}$_dlarft
#:for rk,rt,ri in REAL_KINDS_TYPES
#:if not rk in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ri}$larft( direct, storev, n, k, v, ldv, tau, t, ldt )
!! DLARFT: forms the triangular factor T of a real block reflector H
!! of order n, which is defined as a product of k elementary reflectors.
!! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!! If STOREV = 'C', the vector which defines the elementary reflector
!! H(i) is stored in the i-th column of the array V, and
!! H = I - V * T * V**T
!! If STOREV = 'R', the vector which defines the elementary reflector
!! H(i) is stored in the i-th row of the array V, and
!! H = I - V**T * T * V
! -- 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) :: direct, storev
integer(${ik}$), intent(in) :: k, ldt, ldv, n
! Array Arguments
real(${rk}$), intent(out) :: t(ldt,*)
real(${rk}$), intent(in) :: tau(*), v(ldv,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, prevlastv, lastv
! Executable Statements
! quick return if possible
if( n==0 )return
if( stdlib_lsame( direct, 'F' ) ) then
prevlastv = n
do i = 1, k
prevlastv = max( i, prevlastv )
if( tau( i )==zero ) then
! h(i) = i
do j = 1, i
t( j, i ) = zero
end do
else
! general case
if( stdlib_lsame( storev, 'C' ) ) then
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( lastv, i )/=zero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( i , j )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**t * v(i:j,i)
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', j-i, i-1, -tau( i ),v( i+1, 1_${ik}$ ), ldv, v( i+&
1_${ik}$, i ), 1_${ik}$, one,t( 1_${ik}$, i ), 1_${ik}$ )
else
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( i, lastv )/=zero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( j , i )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**t
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', i-1, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v(&
i, i+1 ), ldv, one,t( 1_${ik}$, i ), 1_${ik}$ )
end if
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i)
call stdlib${ii}$_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),&
1_${ik}$ )
t( i, i ) = tau( i )
if( i>1_${ik}$ ) then
prevlastv = max( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
end do
else
prevlastv = 1_${ik}$
do i = k, 1, -1
if( tau( i )==zero ) then
! h(i) = i
do j = i, k
t( j, i ) = zero
end do
else
! general case
if( i<k ) then
if( stdlib_lsame( storev, 'C' ) ) then
! skip any leading zeros.
do lastv = 1, i-1
if( v( lastv, i )/=zero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( n-k+i , j )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**t * v(j:n-k+i,i)
call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), &
ldv, v( j, i ), 1_${ik}$, one,t( i+1, i ), 1_${ik}$ )
else
! skip any leading zeros.
do lastv = 1, i-1
if( v( i, lastv )/=zero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( j, n-k+i )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**t
call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), &
ldv, v( i, j ), ldv,one, t( i+1, i ), 1_${ik}$ )
end if
! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i)
call stdlib${ii}$_${ri}$trmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), &
ldt, t( i+1, i ), 1_${ik}$ )
if( i>1_${ik}$ ) then
prevlastv = min( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
t( i, i ) = tau( i )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ri}$larft
#:endif
#:endfor
pure module subroutine stdlib${ii}$_clarft( direct, storev, n, k, v, ldv, tau, t, ldt )
!! CLARFT forms the triangular factor T of a complex block reflector H
!! of order n, which is defined as a product of k elementary reflectors.
!! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!! If STOREV = 'C', the vector which defines the elementary reflector
!! H(i) is stored in the i-th column of the array V, and
!! H = I - V * T * V**H
!! If STOREV = 'R', the vector which defines the elementary reflector
!! H(i) is stored in the i-th row of the array V, and
!! H = I - V**H * T * V
! -- 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) :: direct, storev
integer(${ik}$), intent(in) :: k, ldt, ldv, n
! Array Arguments
complex(sp), intent(out) :: t(ldt,*)
complex(sp), intent(in) :: tau(*), v(ldv,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, prevlastv, lastv
! Executable Statements
! quick return if possible
if( n==0 )return
if( stdlib_lsame( direct, 'F' ) ) then
prevlastv = n
do i = 1, k
prevlastv = max( prevlastv, i )
if( tau( i )==czero ) then
! h(i) = i
do j = 1, i
t( j, i ) = czero
end do
else
! general case
if( stdlib_lsame( storev, 'C' ) ) then
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( lastv, i )/=czero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * conjg( v( i , j ) )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**h * v(i:j,i)
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', j-i, i-1,-tau( i ), v( i+1, 1_${ik}$ ), &
ldv,v( i+1, i ), 1_${ik}$,cone, t( 1_${ik}$, i ), 1_${ik}$ )
else
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( i, lastv )/=czero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( j , i )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**h
call stdlib${ii}$_cgemm( 'N', 'C', i-1, 1_${ik}$, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v( i,&
i+1 ), ldv,cone, t( 1_${ik}$, i ), ldt )
end if
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i)
call stdlib${ii}$_ctrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),&
1_${ik}$ )
t( i, i ) = tau( i )
if( i>1_${ik}$ ) then
prevlastv = max( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
end do
else
prevlastv = 1_${ik}$
do i = k, 1, -1
if( tau( i )==czero ) then
! h(i) = i
do j = i, k
t( j, i ) = czero
end do
else
! general case
if( i<k ) then
if( stdlib_lsame( storev, 'C' ) ) then
! skip any leading zeros.
do lastv = 1, i-1
if( v( lastv, i )/=czero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * conjg( v( n-k+i , j ) )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i)
call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, &
i+1 ), ldv, v( j, i ),1_${ik}$, cone, t( i+1, i ), 1_${ik}$ )
else
! skip any leading zeros.
do lastv = 1, i-1
if( v( i, lastv )/=czero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( j, n-k+i )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h
call stdlib${ii}$_cgemm( 'N', 'C', k-i, 1_${ik}$, n-k+i-j, -tau( i ),v( i+1, j ), &
ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt )
end if
! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i)
call stdlib${ii}$_ctrmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), &
ldt, t( i+1, i ), 1_${ik}$ )
if( i>1_${ik}$ ) then
prevlastv = min( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
t( i, i ) = tau( i )
end if
end do
end if
return
end subroutine stdlib${ii}$_clarft
pure module subroutine stdlib${ii}$_zlarft( direct, storev, n, k, v, ldv, tau, t, ldt )
!! ZLARFT forms the triangular factor T of a complex block reflector H
!! of order n, which is defined as a product of k elementary reflectors.
!! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!! If STOREV = 'C', the vector which defines the elementary reflector
!! H(i) is stored in the i-th column of the array V, and
!! H = I - V * T * V**H
!! If STOREV = 'R', the vector which defines the elementary reflector
!! H(i) is stored in the i-th row of the array V, and
!! H = I - V**H * T * V
! -- 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) :: direct, storev
integer(${ik}$), intent(in) :: k, ldt, ldv, n
! Array Arguments
complex(dp), intent(out) :: t(ldt,*)
complex(dp), intent(in) :: tau(*), v(ldv,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, prevlastv, lastv
! Executable Statements
! quick return if possible
if( n==0 )return
if( stdlib_lsame( direct, 'F' ) ) then
prevlastv = n
do i = 1, k
prevlastv = max( prevlastv, i )
if( tau( i )==czero ) then
! h(i) = i
do j = 1, i
t( j, i ) = czero
end do
else
! general case
if( stdlib_lsame( storev, 'C' ) ) then
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( lastv, i )/=czero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * conjg( v( i , j ) )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**h * v(i:j,i)
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', j-i, i-1,-tau( i ), v( i+1, 1_${ik}$ ), &
ldv,v( i+1, i ), 1_${ik}$, cone, t( 1_${ik}$, i ), 1_${ik}$ )
else
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( i, lastv )/=czero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( j , i )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**h
call stdlib${ii}$_zgemm( 'N', 'C', i-1, 1_${ik}$, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v( i,&
i+1 ), ldv,cone, t( 1_${ik}$, i ), ldt )
end if
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i)
call stdlib${ii}$_ztrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),&
1_${ik}$ )
t( i, i ) = tau( i )
if( i>1_${ik}$ ) then
prevlastv = max( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
end do
else
prevlastv = 1_${ik}$
do i = k, 1, -1
if( tau( i )==czero ) then
! h(i) = i
do j = i, k
t( j, i ) = czero
end do
else
! general case
if( i<k ) then
if( stdlib_lsame( storev, 'C' ) ) then
! skip any leading zeros.
do lastv = 1, i-1
if( v( lastv, i )/=czero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * conjg( v( n-k+i , j ) )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i)
call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, &
i+1 ), ldv, v( j, i ),1_${ik}$, cone, t( i+1, i ), 1_${ik}$ )
else
! skip any leading zeros.
do lastv = 1, i-1
if( v( i, lastv )/=czero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( j, n-k+i )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h
call stdlib${ii}$_zgemm( 'N', 'C', k-i, 1_${ik}$, n-k+i-j, -tau( i ),v( i+1, j ), &
ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt )
end if
! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i)
call stdlib${ii}$_ztrmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), &
ldt, t( i+1, i ), 1_${ik}$ )
if( i>1_${ik}$ ) then
prevlastv = min( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
t( i, i ) = tau( i )
end if
end do
end if
return
end subroutine stdlib${ii}$_zlarft
#:for ck,ct,ci in CMPLX_KINDS_TYPES
#:if not ck in ["sp","dp"]
pure module subroutine stdlib${ii}$_${ci}$larft( direct, storev, n, k, v, ldv, tau, t, ldt )
!! ZLARFT: forms the triangular factor T of a complex block reflector H
!! of order n, which is defined as a product of k elementary reflectors.
!! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!! If STOREV = 'C', the vector which defines the elementary reflector
!! H(i) is stored in the i-th column of the array V, and
!! H = I - V * T * V**H
!! If STOREV = 'R', the vector which defines the elementary reflector
!! H(i) is stored in the i-th row of the array V, and
!! H = I - V**H * T * V
! -- 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) :: direct, storev
integer(${ik}$), intent(in) :: k, ldt, ldv, n
! Array Arguments
complex(${ck}$), intent(out) :: t(ldt,*)
complex(${ck}$), intent(in) :: tau(*), v(ldv,*)
! =====================================================================
! Local Scalars
integer(${ik}$) :: i, j, prevlastv, lastv
! Executable Statements
! quick return if possible
if( n==0 )return
if( stdlib_lsame( direct, 'F' ) ) then
prevlastv = n
do i = 1, k
prevlastv = max( prevlastv, i )
if( tau( i )==czero ) then
! h(i) = i
do j = 1, i
t( j, i ) = czero
end do
else
! general case
if( stdlib_lsame( storev, 'C' ) ) then
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( lastv, i )/=czero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * conjg( v( i , j ) )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**h * v(i:j,i)
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', j-i, i-1,-tau( i ), v( i+1, 1_${ik}$ ), &
ldv,v( i+1, i ), 1_${ik}$, cone, t( 1_${ik}$, i ), 1_${ik}$ )
else
! skip any trailing zeros.
do lastv = n, i+1, -1
if( v( i, lastv )/=czero ) exit
end do
do j = 1, i-1
t( j, i ) = -tau( i ) * v( j , i )
end do
j = min( lastv, prevlastv )
! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**h
call stdlib${ii}$_${ci}$gemm( 'N', 'C', i-1, 1_${ik}$, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v( i,&
i+1 ), ldv,cone, t( 1_${ik}$, i ), ldt )
end if
! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i)
call stdlib${ii}$_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),&
1_${ik}$ )
t( i, i ) = tau( i )
if( i>1_${ik}$ ) then
prevlastv = max( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
end do
else
prevlastv = 1_${ik}$
do i = k, 1, -1
if( tau( i )==czero ) then
! h(i) = i
do j = i, k
t( j, i ) = czero
end do
else
! general case
if( i<k ) then
if( stdlib_lsame( storev, 'C' ) ) then
! skip any leading zeros.
do lastv = 1, i-1
if( v( lastv, i )/=czero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * conjg( v( n-k+i , j ) )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i)
call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, &
i+1 ), ldv, v( j, i ),1_${ik}$, cone, t( i+1, i ), 1_${ik}$ )
else
! skip any leading zeros.
do lastv = 1, i-1
if( v( i, lastv )/=czero ) exit
end do
do j = i+1, k
t( j, i ) = -tau( i ) * v( j, n-k+i )
end do
j = max( lastv, prevlastv )
! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h
call stdlib${ii}$_${ci}$gemm( 'N', 'C', k-i, 1_${ik}$, n-k+i-j, -tau( i ),v( i+1, j ), &
ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt )
end if
! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i)
call stdlib${ii}$_${ci}$trmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), &
ldt, t( i+1, i ), 1_${ik}$ )
if( i>1_${ik}$ ) then
prevlastv = min( prevlastv, lastv )
else
prevlastv = lastv
end if
end if
t( i, i ) = tau( i )
end if
end do
end if
return
end subroutine stdlib${ii}$_${ci}$larft
#:endif
#:endfor
#:endfor
end submodule stdlib_lapack_householder_reflectors
