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 dgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGEMV
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 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...
subroutine dlarfg(N, ALPHA, X, INCX, TAU)
DLARFG generates an elementary reflector (Householder matrix).