177 SUBROUTINE zlaqps( 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 VN1( * ), VN2( * )
191 COMPLEX*16 A( lda, * ), AUXV( * ), F( ldf, * ), TAU( * )
197 DOUBLE PRECISION ZERO, ONE
198 COMPLEX*16 CZERO, CONE
199 parameter ( zero = 0.0d+0, one = 1.0d+0,
200 $ czero = ( 0.0d+0, 0.0d+0 ),
201 $ cone = ( 1.0d+0, 0.0d+0 ) )
204 INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
205 DOUBLE PRECISION TEMP, TEMP2, TOL3Z
212 INTRINSIC abs, dble, dconjg, max, min, nint, sqrt
216 DOUBLE PRECISION DLAMCH, DZNRM2
217 EXTERNAL idamax, dlamch, dznrm2
221 lastrk = min( m, n+offset )
224 tol3z = sqrt(dlamch(
'Epsilon'))
229 IF( ( k.LT.nb ) .AND. ( lsticc.EQ.0 ) )
THEN
235 pvt = ( k-1 ) + idamax( n-k+1, vn1( k ), 1 )
237 CALL zswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
238 CALL zswap( k-1, f( pvt, 1 ), ldf, f( k, 1 ), ldf )
240 jpvt( pvt ) = jpvt( k )
242 vn1( pvt ) = vn1( k )
243 vn2( pvt ) = vn2( k )
251 f( k, j ) = dconjg( f( k, j ) )
253 CALL zgemv(
'No transpose', m-rk+1, k-1, -cone, a( rk, 1 ),
254 $ lda, f( k, 1 ), ldf, cone, a( rk, k ), 1 )
256 f( k, j ) = dconjg( f( k, j ) )
263 CALL zlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1, tau( k ) )
265 CALL zlarfg( 1, a( rk, k ), a( rk, k ), 1, tau( k ) )
276 CALL zgemv(
'Conjugate transpose', m-rk+1, n-k, tau( k ),
277 $ a( rk, k+1 ), lda, a( rk, k ), 1, czero,
292 CALL zgemv(
'Conjugate transpose', m-rk+1, k-1, -tau( k ),
293 $ a( rk, 1 ), lda, a( rk, k ), 1, czero,
296 CALL zgemv(
'No transpose', n, k-1, cone, f( 1, 1 ), ldf,
297 $ auxv( 1 ), 1, cone, f( 1, k ), 1 )
304 CALL zgemm(
'No transpose',
'Conjugate transpose', 1, n-k,
305 $ k, -cone, a( rk, 1 ), lda, f( k+1, 1 ), ldf,
306 $ cone, a( rk, k+1 ), lda )
311 IF( rk.LT.lastrk )
THEN
313 IF( vn1( j ).NE.zero )
THEN
318 temp = abs( a( rk, j ) ) / vn1( j )
319 temp = max( zero, ( one+temp )*( one-temp ) )
320 temp2 = temp*( vn1( j ) / vn2( j ) )**2
321 IF( temp2 .LE. tol3z )
THEN
322 vn2( j ) = dble( lsticc )
325 vn1( j ) = vn1( j )*sqrt( temp )
344 IF( kb.LT.min( n, m-offset ) )
THEN
345 CALL zgemm(
'No transpose',
'Conjugate transpose', m-rk, n-kb,
346 $ kb, -cone, a( rk+1, 1 ), lda, f( kb+1, 1 ), ldf,
347 $ cone, a( rk+1, kb+1 ), lda )
353 IF( lsticc.GT.0 )
THEN
354 itemp = nint( vn2( lsticc ) )
355 vn1( lsticc ) = dznrm2( m-rk, a( rk+1, lsticc ), 1 )
361 vn2( lsticc ) = vn1( lsticc )
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zlarfg(N, ALPHA, X, INCX, TAU)
ZLARFG generates an elementary reflector (Householder matrix).
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine zlaqps(M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF)
ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BL...