stepan
/
dynare
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
dynare/mex/sources/libslicot/MB03XU.f

2339 lines
111 KiB
Fortran
Raw Blame History

SUBROUTINE MB03XU( LTRA, LTRB, N, K, NB, A, LDA, B, LDB, G, LDG,
$ Q, LDQ, XA, LDXA, XB, LDXB, XG, LDXG, XQ, LDXQ,
$ YA, LDYA, YB, LDYB, YG, LDYG, YQ, LDYQ, CSL,
$ CSR, TAUL, TAUR, DWORK )
C
C SLICOT RELEASE 5.0.
C
C Copyright (c) 2002-2009 NICONET e.V.
C
C This program is free software: you can redistribute it and/or
C modify it under the terms of the GNU General Public License as
C published by the Free Software Foundation, either version 2 of
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public License
C along with this program. If not, see
C <http://www.gnu.org/licenses/>.
C
C PURPOSE
C
C To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n)
C matrix H:
C
C [ op(A) G ]
C H = [ ],
C [ Q op(B) ]
C
C so that elements in the first nb columns below the k-th
C subdiagonal of the (k+n)-by-n matrix op(A), in the first nb
C columns and rows of the n-by-n matrix Q and in the first nb rows
C above the diagonal of the n-by-(k+n) matrix op(B) are zero.
C The reduction is performed by orthogonal symplectic
C transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA,
C XB, XG, and XQ are returned so that
C
C [ op(Aout)+U*YA'+XA*V' G+U*YG'+XG*V' ]
C UU' H VV = [ ].
C [ Qout+U*YQ'+XQ*V' op(Bout)+U*YB'+XB*V' ]
C
C This is an auxiliary routine called by MB04TB.
C
C ARGUMENTS
C
C Mode Parameters
C
C LTRA LOGICAL
C Specifies the form of op( A ) as follows:
C = .FALSE.: op( A ) = A;
C = .TRUE.: op( A ) = A'.
C
C LTRB LOGICAL
C Specifies the form of op( B ) as follows:
C = .FALSE.: op( B ) = B;
C = .TRUE.: op( B ) = B'.
C
C Input/Output Parameters
C
C N (input) INTEGER
C The order of the matrix Q. N >= 0.
C
C K (input) INTEGER
C The offset of the reduction. Elements below the K-th
C subdiagonal in the first NB columns of op(A) are
C reduced to zero. K >= 0.
C
C NB (input) INTEGER
C The number of columns/rows to be reduced. N > NB >= 0.
C
C A (input/output) DOUBLE PRECISION array, dimension
C (LDA,N) if LTRA = .FALSE.
C (LDA,K+N) if LTRA = .TRUE.
C On entry with LTRA = .FALSE., the leading (K+N)-by-N part
C of this array must contain the matrix A.
C On entry with LTRA = .TRUE., the leading N-by-(K+N) part
C of this array must contain the matrix A.
C On exit with LTRA = .FALSE., the leading (K+N)-by-N part
C of this array contains the matrix Aout and, in the zero
C parts, information about the elementary reflectors used to
C compute the reduction.
C On exit with LTRA = .TRUE., the leading N-by-(K+N) part of
C this array contains the matrix Aout and in the zero parts
C information about the elementary reflectors.
C
C LDA INTEGER
C The leading dimension of the array A.
C LDA >= MAX(1,K+N), if LTRA = .FALSE.;
C LDA >= MAX(1,N), if LTRA = .TRUE..
C
C B (input/output) DOUBLE PRECISION array, dimension
C (LDB,K+N) if LTRB = .FALSE.
C (LDB,N) if LTRB = .TRUE.
C On entry with LTRB = .FALSE., the leading N-by-(K+N) part
C of this array must contain the matrix B.
C On entry with LTRB = .TRUE., the leading (K+N)-by-N part
C of this array must contain the matrix B.
C On exit with LTRB = .FALSE., the leading N-by-(K+N) part
C of this array contains the matrix Bout and, in the zero
C parts, information about the elementary reflectors used to
C compute the reduction.
C On exit with LTRB = .TRUE., the leading (K+N)-by-N part of
C this array contains the matrix Bout and in the zero parts
C information about the elementary reflectors.
C
C LDB INTEGER
C The leading dimension of the array B.
C LDB >= MAX(1,N), if LTRB = .FALSE.;
C LDB >= MAX(1,K+N), if LTRB = .TRUE..
C
C G (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C On entry, the leading N-by-N part of this array must
C contain the matrix G.
C On exit, the leading N-by-N part of this array contains
C the matrix Gout.
C
C LDG INTEGER
C The leading dimension of the array G. LDG >= MAX(1,N).
C
C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C On entry, the leading N-by-N part of this array must
C contain the matrix Q.
C On exit, the leading N-by-N part of this array contains
C the matrix Qout and in the zero parts information about
C the elementary reflectors used to compute the reduction.
C
C LDQ INTEGER
C The leading dimension of the array Q. LDQ >= MAX(1,N).
C
C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB)
C On exit, the leading N-by-(2*NB) part of this array
C contains the matrix XA.
C
C LDXA INTEGER
C The leading dimension of the array XA. LDXA >= MAX(1,N).
C
C XB (output) DOUBLE PRECISION array, dimension (LDXB,2*NB)
C On exit, the leading (K+N)-by-(2*NB) part of this array
C contains the matrix XB.
C
C LDXB INTEGER
C The leading dimension of the array XB. LDXB >= MAX(1,K+N).
C
C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB)
C On exit, the leading (K+N)-by-(2*NB) part of this array
C contains the matrix XG.
C
C LDXG INTEGER
C The leading dimension of the array XG. LDXG >= MAX(1,K+N).
C
C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB)
C On exit, the leading N-by-(2*NB) part of this array
C contains the matrix XQ.
C
C LDXQ INTEGER
C The leading dimension of the array XQ. LDXQ >= MAX(1,N).
C
C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB)
C On exit, the leading (K+N)-by-(2*NB) part of this array
C contains the matrix YA.
C
C LDYA INTEGER
C The leading dimension of the array YA. LDYA >= MAX(1,K+N).
C
C YB (output) DOUBLE PRECISION array, dimension (LDYB,2*NB)
C On exit, the leading N-by-(2*NB) part of this array
C contains the matrix YB.
C
C LDYB INTEGER
C The leading dimension of the array YB. LDYB >= MAX(1,N).
C
C YG (output) DOUBLE PRECISION array, dimension (LDYG,2*NB)
C On exit, the leading (K+N)-by-(2*NB) part of this array
C contains the matrix YG.
C
C LDYG INTEGER
C The leading dimension of the array YG. LDYG >= MAX(1,K+N).
C
C YQ (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB)
C On exit, the leading N-by-(2*NB) part of this array
C contains the matrix YQ.
C
C LDYQ INTEGER
C The leading dimension of the array YQ. LDYQ >= MAX(1,N).
C
C CSL (output) DOUBLE PRECISION array, dimension (2*NB)
C On exit, the first 2NB elements of this array contain the
C cosines and sines of the symplectic Givens rotations
C applied from the left-hand side used to compute the
C reduction.
C
C CSR (output) DOUBLE PRECISION array, dimension (2*NB)
C On exit, the first 2NB-2 elements of this array contain
C the cosines and sines of the symplectic Givens rotations
C applied from the right-hand side used to compute the
C reduction.
C
C TAUL (output) DOUBLE PRECISION array, dimension (NB)
C On exit, the first NB elements of this array contain the
C scalar factors of some of the elementary reflectors
C applied form the left-hand side.
C
C TAUR (output) DOUBLE PRECISION array, dimension (NB)
C On exit, the first NB-1 elements of this array contain the
C scalar factors of some of the elementary reflectors
C applied form the right-hand side.
C
C Workspace
C
C DWORK DOUBLE PRECISION array, dimension (5*NB)
C
C METHOD
C
C For details regarding the representation of the orthogonal
C symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q,
C TAUL and TAUR see the description of MB04TB.
C
C The contents of A, B, G and Q on exit are illustrated by the
C following example with op(A) = A, op(B) = B, n = 5, k = 2 and
C nb = 2:
C
C ( a r r a a ) ( g g g r r g g )
C ( a r r a a ) ( g g g r r g g )
C ( r r r r r ) ( r r r r r r r )
C A = ( u2 r r r r ), G = ( r r r r r r r ),
C ( u2 u2 r a a ) ( g g g r r g g )
C ( u2 u2 r a a ) ( g g g r r g g )
C ( u2 u2 r a a ) ( g g g r r g g )
C
C ( t t v1 v1 v1 ) ( r r r r r v2 v2 )
C ( u1 t t v1 v1 ) ( r r r r r r v2 )
C Q = ( u1 u1 r q q ), B = ( b b b r r b b ).
C ( u1 u1 r q q ) ( b b b r r b b )
C ( u1 u1 r q q ) ( b b b r r b b )
C
C where a, b, g and q denote elements of the original matrices, r
C denotes a modified element, t denotes a scalar factor of an
C applied elementary reflector, ui and vi denote elements of the
C matrices U and V, respectively.
C
C NUMERICAL ASPECTS
C
C The algorithm requires ( 16*K + 32*N + 42 )*N*NB +
C ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point
C operations and is numerically backward stable.
C
C REFERENCES
C
C [1] Benner, P., Mehrmann, V., and Xu, H.
C A numerically stable, structure preserving method for
C computing the eigenvalues of real Hamiltonian or symplectic
C pencils.
C Numer. Math., Vol. 78 (3), pp. 329-358, 1998.
C
C [2] Kressner, D.
C Block algorithms for orthogonal symplectic factorizations.
C BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003.
C
C CONTRIBUTORS
C
C D. Kressner, Technical Univ. Berlin, Germany, and
C P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C REVISIONS
C
C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLASUB).
C
C KEYWORDS
C
C Elementary matrix operations, Matrix decompositions, Hamiltonian
C matrix.
C
C ******************************************************************
C
C .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
C .. Scalar Arguments ..
LOGICAL LTRA, LTRB
INTEGER K, LDA, LDB, LDG, LDQ, LDXA, LDXB, LDXG, LDXQ,
$ LDYA, LDYB, LDYG, LDYQ, N, NB
C .. Array Arguments ..
DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*),
$ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*),
$ XA(LDXA,*), XB(LDXB,*), XG(LDXG,*), XQ(LDXQ,*),
$ YA(LDYA,*), YB(LDYB,*), YG(LDYG,*), YQ(LDYQ,*)
C .. Local Scalars ..
INTEGER I, J, NB1, NB2, NB3, PDW
DOUBLE PRECISION ALPHA, C, S, TAUQ, TEMP
C .. External Functions ..
DOUBLE PRECISION DDOT
EXTERNAL DDOT
C .. External Subroutines ..
EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL
C
C .. Executable Statements ..
C
C Quick return if possible.
C
IF ( N+K.LE.0 ) THEN
RETURN
END IF
C
NB1 = NB + 1
NB2 = NB + NB
NB3 = NB2 + NB
PDW = NB3 + NB + 1
C
IF ( LTRA.AND.LTRB ) THEN
DO 90 I = 1, NB
C
C Transform first row/column of A and Q. See routine MB04TS.
C
ALPHA = Q(I,I)
CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ )
Q(I,I) = ONE
TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA )
CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA )
TEMP = A(I,K+I)
CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) )
CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) )
TEMP = A(I,K+I)
A(I,K+I) = ONE
C
C Update XQ with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ Q(I,I), 1, ZERO, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ,
$ Q(I,I), 1, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
$ DWORK, 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA,
$ Q(I,I), 1, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 )
C
C Update Q(i,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ )
C
C Update XA with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I),
$ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
$ DWORK, 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 )
C
C Update A(i+1:n,k+i).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 )
C
C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ].
C
CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S )
C
C Update XQ with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA,
$ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ,
$ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 )
C
C Update Q(i,i+1:n).
C
CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ )
C
C Update XA with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I),
$ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA,
$ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA,
$ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 )
C
C Update A(i+1:n,k+i).
C
CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 )
C
C Update XG with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ Q(I,I), 1, ZERO, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG,
$ DWORK, 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 )
C
C Update G(k+i,:).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ Q(I,1), LDQ, ONE, G(K+I,1), LDG )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG )
C
C Update XB with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB,
$ Q(I,I), 1, ZERO, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB,
$ DWORK, 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 )
C
C Update B(:,i).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ Q(I,1), LDQ, ONE, B(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, A(1,K+I), 1, ONE, B(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 )
C
C Apply rotation to [ G(k+i,:); B(:,i)' ].
C
CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S )
C
DO 10 J = 1, I-1
YG(K+I,J) = ZERO
10 CONTINUE
DO 20 J = 1, I-1
YG(K+I,NB+J) = ZERO
20 CONTINUE
DO 30 J = 1, I-1
YA(K+I,J) = ZERO
30 CONTINUE
DO 40 J = 1, I-1
YA(K+I,NB+J) = ZERO
40 CONTINUE
C
C Update XG with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 )
C
C Update G(k+i,:).
C
CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG )
C
C Update XB with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB,
$ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 )
C
C Update B(:,i).
C
CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 )
C
A(I,K+I) = TEMP
Q(I,I) = TAUQ
CSL(2*I-1) = C
CSL(2*I) = S
C
C Transform first row/column of Q and B.
C
ALPHA = Q(I,I+1)
CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ )
Q(I,I+1) = ONE
TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 )
CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 )
TEMP = B(K+I+1,I)
CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) )
S = -S
CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) )
TEMP = B(K+I+1,I)
B(K+I+1,I) = ONE
C
C Update YB with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1),
$ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ DWORK, 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 )
C
C Update B(k+i+1,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB )
C
C Update YQ with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ DWORK, 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 )
C
C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ].
C
CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S )
DO 50 J = 1, I
XB(K+I+1,J) = ZERO
50 CONTINUE
DO 60 J = 1, I
XB(K+I+1,NB+J) = ZERO
60 CONTINUE
C
C Update YB with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1),
$ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB,
$ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB,
$ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ,
$ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1),
$ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 )
C
C Update B(k+i+1,i+1:n).
C
CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB )
C
C Update YQ with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ,
$ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ,
$ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 )
C
C Update YA with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA,
$ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA,
$ DWORK, 1, ONE, YA(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB+1), 1, ONE, YA(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 )
C
C Update A(i+1,1:k+n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ Q(1,I+1), 1, ONE, A(I+1,1), LDA )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ B(K+I+1,1), LDB, ONE, A(I+1,1), LDA )
C
C Update YG with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG,
$ DWORK, 1, ONE, YG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB+1), 1, ONE, YG(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 )
DO 70 J = 1, I
XG(K+I+1,J) = ZERO
70 CONTINUE
DO 80 J = 1, I
XG(K+I+1,NB+J) = ZERO
80 CONTINUE
C
C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ].
C
CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S )
C
C Update YA with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA,
$ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 )
C
C Update A(i+1,1:k+n).
C
CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA )
C
C Update YG with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 )
C
B(K+I+1,I) = TEMP
Q(I,I+1) = TAUQ
CSR(2*I-1) = C
CSR(2*I) = S
90 CONTINUE
ELSE IF ( LTRA ) THEN
DO 180 I = 1, NB
C
C Transform first row/column of A and Q. See routine MB04TS.
C
ALPHA = Q(I,I)
CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ )
Q(I,I) = ONE
TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA )
CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA )
TEMP = A(I,K+I)
CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) )
CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) )
TEMP = A(I,K+I)
A(I,K+I) = ONE
C
C Update XQ with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ Q(I,I), 1, ZERO, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ,
$ Q(I,I), 1, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
$ DWORK, 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA,
$ Q(I,I), 1, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 )
C
C Update Q(i,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ )
C
C Update XA with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I),
$ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
$ DWORK, 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 )
C
C Update A(i+1:n,k+i).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 )
C
C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ].
C
CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S )
C
C Update XQ with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA,
$ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ,
$ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 )
C
C Update Q(i,i+1:n).
C
CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ )
C
C Update XA with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I),
$ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA,
$ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA,
$ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 )
C
C Update A(i+1:n,k+i).
C
CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 )
C
C Update XG with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ Q(I,I), 1, ZERO, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG,
$ DWORK, 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 )
C
C Update G(k+i,:).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ Q(I,1), LDQ, ONE, G(K+I,1), LDG )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG )
C
C Update XB with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB,
$ Q(I,I), 1, ZERO, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB,
$ DWORK, 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 )
C
C Update B(i,:).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ Q(I,1), LDQ, ONE, B(I,1), LDB )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, A(1,K+I), 1, ONE, B(I,1), LDB )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB )
C
C Apply rotation to [ G(k+i,:); B(i,:) ].
C
CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S )
C
DO 100 J = 1, I-1
YG(K+I,J) = ZERO
100 CONTINUE
DO 110 J = 1, I-1
YG(K+I,NB+J) = ZERO
110 CONTINUE
DO 120 J = 1, I-1
YA(K+I,J) = ZERO
120 CONTINUE
DO 130 J = 1, I-1
YA(K+I,NB+J) = ZERO
130 CONTINUE
C
C Update XG with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 )
C
C Update G(k+i,:).
C
CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG )
C
C Update XB with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB,
$ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB,
$ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 )
C
C Update B(i,:).
C
CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB )
C
A(I,K+I) = TEMP
Q(I,I) = TAUQ
CSL(2*I-1) = C
CSL(2*I) = S
C
C Transform first rows of Q and B.
C
ALPHA = Q(I,I+1)
CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ )
Q(I,I+1) = ONE
TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB )
CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB )
TEMP = B(I,K+I+1)
CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) )
S = -S
CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) )
TEMP = B(I,K+I+1)
B(I,K+I+1) = ONE
C
C Update YB with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1),
$ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ DWORK, 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 )
C
C Update B(i+1:n,k+i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 )
C
C Update YQ with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ DWORK, 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 )
C
C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ].
C
CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S )
DO 140 J = 1, I
XB(K+I+1,J) = ZERO
140 CONTINUE
DO 150 J = 1, I
XB(K+I+1,NB+J) = ZERO
150 CONTINUE
C
C Update YB with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1),
$ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB,
$ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB,
$ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ,
$ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2),
$ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 )
C
C Update B(i+1:n,k+i+1).
C
CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 )
C
C Update YQ with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ,
$ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ,
$ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 )
C
C Update YA with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA,
$ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA,
$ DWORK, 1, ONE, YA(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB+1), 1, ONE, YA(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 )
C
C Update A(i+1,1:k+n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ Q(1,I+1), 1, ONE, A(I+1,1), LDA )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ B(1,K+I+1), 1, ONE, A(I+1,1), LDA )
C
C Update YG with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG,
$ DWORK, 1, ONE, YG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB+1), 1, ONE, YG(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 )
DO 160 J = 1, I
XG(K+I+1,J) = ZERO
160 CONTINUE
DO 170 J = 1, I
XG(K+I+1,NB+J) = ZERO
170 CONTINUE
C
C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ].
C
CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S )
C
C Update YA with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA,
$ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 )
C
C Update A(i+1,1:k+n).
C
CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA )
C
C Update YG with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 )
C
B(I,K+I+1) = TEMP
Q(I,I+1) = TAUQ
CSR(2*I-1) = C
CSR(2*I) = S
180 CONTINUE
C
ELSE IF ( LTRB ) THEN
DO 270 I = 1, NB
C
C Transform first columns of A and Q. See routine MB04TS.
C
ALPHA = Q(I,I)
CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ )
Q(I,I) = ONE
TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 )
CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 )
TEMP = A(K+I,I)
CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) )
CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) )
TEMP = A(K+I,I)
A(K+I,I) = ONE
C
C Update XQ with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ Q(I,I), 1, ZERO, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ,
$ Q(I,I), 1, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
$ DWORK, 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA,
$ Q(I,I), 1, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 )
C
C Update Q(i,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ )
C
C Update XA with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA,
$ Q(I,I), 1, ZERO, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
$ DWORK, 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 )
C
C Update A(k+i,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA )
C
C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ].
C
CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S )
C
C Update XQ with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
$ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ,
$ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 )
C
C Update Q(i,i+1:n).
C
CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ )
C
C Update XA with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA,
$ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA,
$ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA,
$ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 )
C
C Update A(k+i,i+1:n).
C
CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA )
C
C Update XG with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ Q(I,I), 1, ZERO, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG,
$ DWORK, 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 )
C
C Update G(k+i,:).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ Q(I,1), LDQ, ONE, G(K+I,1), LDG )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG )
C
C Update XB with first Householder reflection.
C
CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB,
$ Q(I,I), 1, ZERO, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB,
$ DWORK, 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 )
C
C Update B(:,i).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ Q(I,1), LDQ, ONE, B(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, A(K+I,1), LDA, ONE, B(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 )
C
C Apply rotation to [ G(k+i,:); B(:,i)' ].
C
CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S )
C
DO 190 J = 1, I-1
YG(K+I,J) = ZERO
190 CONTINUE
DO 200 J = 1, I-1
YG(K+I,NB+J) = ZERO
200 CONTINUE
DO 210 J = 1, I-1
YA(K+I,J) = ZERO
210 CONTINUE
DO 220 J = 1, I-1
YA(K+I,NB+J) = ZERO
220 CONTINUE
C
C Update XG with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 )
C
C Update G(k+i,:).
C
CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG )
C
C Update XB with second Householder reflection.
C
CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB,
$ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 )
C
C Update B(:,i).
C
CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 )
C
A(K+I,I) = TEMP
Q(I,I) = TAUQ
CSL(2*I-1) = C
CSL(2*I) = S
C
C Transform first rows of Q and B.
C
ALPHA = Q(I,I+1)
CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ )
Q(I,I+1) = ONE
TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 )
CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 )
TEMP = B(K+I+1,I)
CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) )
S = -S
CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) )
TEMP = B(K+I+1,I)
B(K+I+1,I) = ONE
C
C Update YB with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1),
$ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ DWORK, 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB,
$ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 )
C
C Update B(k+i+1,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB )
C
C Update YQ with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ DWORK, 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 )
C
C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ].
C
CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S )
DO 230 J = 1, I
XB(K+I+1,J) = ZERO
230 CONTINUE
DO 240 J = 1, I
XB(K+I+1,NB+J) = ZERO
240 CONTINUE
C
C Update YB with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1),
$ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB,
$ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB,
$ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ,
$ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1),
$ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 )
C
C Update B(k+i+1,i+1:n).
C
CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB )
C
C Update YQ with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ,
$ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ,
$ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 )
C
C Update YA with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
$ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA,
$ DWORK, 1, ONE, YA(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB+1), 1, ONE, YA(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 )
C
C Update A(1:k+n,i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ Q(1,I+1), 1, ONE, A(1,I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ B(K+I+1,1), LDB, ONE, A(1,I+1), 1 )
C
C Update YG with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG,
$ DWORK, 1, ONE, YG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB+1), 1, ONE, YG(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 )
DO 250 J = 1, I
XG(K+I+1,J) = ZERO
250 CONTINUE
DO 260 J = 1, I
XG(K+I+1,NB+J) = ZERO
260 CONTINUE
C
C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ].
C
CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S )
C
C Update YA with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
$ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 )
C
C Update A(1:k+n,i+1).
C
CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 )
C
C Update YG with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG,
$ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 )
C
B(K+I+1,I) = TEMP
Q(I,I+1) = TAUQ
CSR(2*I-1) = C
CSR(2*I) = S
270 CONTINUE
C
ELSE
DO 360 I = 1, NB
C
C Transform first columns of A and Q. See routine MB04TS.
C
ALPHA = Q(I,I)
CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ )
Q(I,I) = ONE
TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 )
CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 )
TEMP = A(K+I,I)
CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) )
CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) )
TEMP = A(K+I,I)
A(K+I,I) = ONE
C
C Update XQ with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ Q(I,I), 1, ZERO, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ,
$ Q(I,I), 1, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ,
$ DWORK, 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA,
$ Q(I,I), 1, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I), 1, ONE, XQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ,
$ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 )
C
C Update Q(i,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ )
C
C Update XA with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA,
$ Q(I,I), 1, ZERO, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA,
$ DWORK, 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA,
$ Q(I,I), 1, ZERO, XA(1,I), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XA(1,I), 1, ONE, XA(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 )
C
C Update A(k+i,i+1:n).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA )
C
C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ].
C
CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S )
C
C Update XQ with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ,
$ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA,
$ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1),
$ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ,
$ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 )
C
C Update Q(i,i+1:n).
C
CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ )
C
C Update XA with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA,
$ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1),
$ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA,
$ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA,
$ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 )
C
C Update A(k+i,i+1:n).
C
CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA )
C
C Update XG with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ Q(I,I), 1, ZERO, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG,
$ DWORK, 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 )
C
C Update G(k+i,:).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ Q(I,1), LDQ, ONE, G(K+I,1), LDG )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG )
C
C Update XB with first Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB,
$ Q(I,I), 1, ZERO, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB,
$ DWORK, 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB,
$ Q(I,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 )
CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 )
C
C Update B(i,:).
C
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ Q(I,1), LDQ, ONE, B(I,1), LDB )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, A(K+I,1), LDA, ONE, B(I,1), LDB )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB )
C
C Apply rotation to [ G(k+i,:); B(i,:) ].
C
CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S )
C
DO 280 J = 1, I-1
YG(K+I,J) = ZERO
280 CONTINUE
DO 290 J = 1, I-1
YG(K+I,NB+J) = ZERO
290 CONTINUE
DO 300 J = 1, I-1
YA(K+I,J) = ZERO
300 CONTINUE
DO 310 J = 1, I-1
YA(K+I,NB+J) = ZERO
310 CONTINUE
C
C Update XG with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG,
$ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG,
$ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1),
$ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 )
C
C Update G(k+i,:).
C
CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG )
C
C Update XB with second Householder reflection.
C
CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB,
$ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB,
$ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1),
$ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB,
$ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 )
CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 )
C
C Update B(i,:).
C
CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB )
C
A(K+I,I) = TEMP
Q(I,I) = TAUQ
CSL(2*I-1) = C
CSL(2*I) = S
C
C Transform first rows of Q and B.
C
ALPHA = Q(I,I+1)
CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ )
Q(I,I+1) = ONE
TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB )
CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB )
TEMP = B(I,K+I+1)
CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) )
S = -S
CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) )
TEMP = B(I,K+I+1)
B(I,K+I+1) = ONE
C
C Update YB with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1),
$ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB,
$ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YB(1,I), 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, DWORK, 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB,
$ DWORK, 1, ONE, YB(I+1,I), 1 )
CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB,
$ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 )
C
C Update B(i+1:n,k+i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 )
C
C Update YQ with first Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ,
$ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YQ(1,I), 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ,
$ DWORK, 1, ONE, YQ(I+1,I), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 )
CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 )
C
C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ].
C
CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S )
DO 320 J = 1, I
XB(K+I+1,J) = ZERO
320 CONTINUE
DO 330 J = 1, I
XB(K+I+1,NB+J) = ZERO
330 CONTINUE
C
C Update YB with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1),
$ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB,
$ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB,
$ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ,
$ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB,
$ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2),
$ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1),
$ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 )
C
C Update B(i+1:n,k+i+1).
C
CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 )
C
C Update YQ with second Householder reflection.
C
CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ,
$ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ,
$ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ,
$ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ,
$ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1),
$ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 )
CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 )
C
C Update Q(i+1:n,i+1).
C
CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 )
C
C Update YA with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
$ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA,
$ DWORK, 1, ONE, YA(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB+1), 1, ONE, YA(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 )
C
C Update A(1:k+n,i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ Q(1,I+1), 1, ONE, A(1,I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ B(1,K+I+1), 1, ONE, A(1,I+1), 1 )
C
C Update YG with first Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG,
$ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG,
$ DWORK, 1, ONE, YG(1,I), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB+1), 1, ONE, YG(1,I), 1 )
CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 )
DO 340 J = 1, I
XG(K+I+1,J) = ZERO
340 CONTINUE
DO 350 J = 1, I
XG(K+I+1,NB+J) = ZERO
350 CONTINUE
C
C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ].
C
CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S )
C
C Update YA with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA,
$ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA,
$ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA,
$ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 )
C
C Update A(1:k+n,i+1).
C
CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 )
C
C Update YG with second Householder reflection.
C
CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG,
$ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG,
$ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 )
CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA,
$ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG,
$ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 )
CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG,
$ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 )
CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 )
C
C Update G(1:k+n,k+i+1).
C
CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 )
C
B(I,K+I+1) = TEMP
Q(I,I+1) = TAUQ
CSR(2*I-1) = C
CSR(2*I) = S
360 CONTINUE
END IF
C
RETURN
C *** Last line of MB03XU ***
END
Reference in New Issue View Git Blame Copy Permalink