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
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 zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
DOUBLE PRECISION function dznrm2(N, X, INCX)
DZNRM2
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zlarfg(N, ALPHA, X, INCX, TAU)
ZLARFG generates an elementary reflector (Householder matrix).
INTEGER function idamax(N, DX, INCX)
IDAMAX
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...