177 SUBROUTINE dlaqps( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
178 $ vn2, auxv, f, ldf )
186 INTEGER KB, LDA, LDF, M, N, NB, OFFSET
190 DOUBLE PRECISION A( lda, * ), AUXV( * ), F( ldf, * ), TAU( * ),
197 DOUBLE PRECISION ZERO, ONE
198 parameter( zero = 0.0d+0, one = 1.0d+0 )
201 INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
202 DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z
208 INTRINSIC abs, dble, max, min, nint, sqrt
212 DOUBLE PRECISION DLAMCH, DNRM2
213 EXTERNAL idamax, dlamch, dnrm2
217 lastrk = min( m, n+offset )
220 tol3z = sqrt(dlamch(
'Epsilon'))
225 IF( ( k.LT.nb ) .AND. ( lsticc.EQ.0 ) )
THEN
231 pvt = ( k-1 ) + idamax( n-k+1, vn1( k ), 1 )
233 CALL
dswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
234 CALL
dswap( k-1, f( pvt, 1 ), ldf, f( k, 1 ), ldf )
236 jpvt( pvt ) = jpvt( k )
238 vn1( pvt ) = vn1( k )
239 vn2( pvt ) = vn2( k )
246 CALL
dgemv(
'No transpose', m-rk+1, k-1, -one, a( rk, 1 ),
247 $ lda, f( k, 1 ), ldf, one, a( rk, k ), 1 )
253 CALL
dlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1, tau( k ) )
255 CALL
dlarfg( 1, a( rk, k ), a( rk, k ), 1, tau( k ) )
266 CALL
dgemv(
'Transpose', m-rk+1, n-k, tau( k ),
267 $ a( rk, k+1 ), lda, a( rk, k ), 1, zero,
282 CALL
dgemv(
'Transpose', m-rk+1, k-1, -tau( k ), a( rk, 1 ),
283 $ lda, a( rk, k ), 1, zero, auxv( 1 ), 1 )
285 CALL
dgemv(
'No transpose', n, k-1, one, f( 1, 1 ), ldf,
286 $ auxv( 1 ), 1, one, f( 1, k ), 1 )
293 CALL
dgemv(
'No transpose', n-k, k, -one, f( k+1, 1 ), ldf,
294 $ a( rk, 1 ), lda, one, a( rk, k+1 ), lda )
299 IF( rk.LT.lastrk )
THEN
301 IF( vn1( j ).NE.zero )
THEN
306 temp = abs( a( rk, j ) ) / vn1( j )
307 temp = max( zero, ( one+temp )*( one-temp ) )
308 temp2 = temp*( vn1( j ) / vn2( j ) )**2
309 IF( temp2 .LE. tol3z )
THEN
310 vn2( j ) = dble( lsticc )
313 vn1( j ) = vn1( j )*sqrt( temp )
332 IF( kb.LT.min( n, m-offset ) )
THEN
333 CALL
dgemm(
'No transpose',
'Transpose', m-rk, n-kb, kb, -one,
334 $ a( rk+1, 1 ), lda, f( kb+1, 1 ), ldf, one,
335 $ a( rk+1, kb+1 ), lda )
341 IF( lsticc.GT.0 )
THEN
342 itemp = nint( vn2( lsticc ) )
343 vn1( lsticc ) = dnrm2( m-rk, a( rk+1, lsticc ), 1 )
349 vn2( lsticc ) = vn1( lsticc )
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dswap(N, DX, INCX, DY, INCY)
DSWAP
subroutine dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
subroutine dlaqps(M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF)
DLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BL...