zlaqps()

subroutine zlaqps	(	integer	M,
		integer	N,
		integer	OFFSET,
		integer	NB,
		integer	KB,
		complex*16, dimension( lda, * )	A,
		integer	LDA,
		integer, dimension( * )	JPVT,
		complex*16, dimension( * )	TAU,
		double precision, dimension( * )	VN1,
		double precision, dimension( * )	VN2,
		complex*16, dimension( * )	AUXV,
		complex*16, dimension( ldf, * )	F,
		integer	LDF
	)

ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by using BLAS level 3.

Download ZLAQPS + dependencies [TGZ] [ZIP] [TXT]

Purpose:

 ZLAQPS computes a step of QR factorization with column pivoting
 of a complex M-by-N matrix A by using Blas-3.  It tries to factorize
 NB columns from A starting from the row OFFSET+1, and updates all
 of the matrix with Blas-3 xGEMM.

 In some cases, due to catastrophic cancellations, it cannot
 factorize NB columns.  Hence, the actual number of factorized
 columns is returned in KB.

 Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.

Parameters

[in]	M	M is INTEGER The number of rows of the matrix A. M >= 0.
[in]	N	N is INTEGER The number of columns of the matrix A. N >= 0
[in]	OFFSET	OFFSET is INTEGER The number of rows of A that have been factorized in previous steps.
[in]	NB	NB is INTEGER The number of columns to factorize.
[out]	KB	KB is INTEGER The number of columns actually factorized.
[in,out]	A	A is COMPLEX*16 array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, block A(OFFSET+1:M,1:KB) is the triangular factor obtained and block A(1:OFFSET,1:N) has been accordingly pivoted, but no factorized. The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has been updated.
[in]	LDA	LDA is INTEGER The leading dimension of the array A. LDA >= max(1,M).
[in,out]	JPVT	JPVT is INTEGER array, dimension (N) JPVT(I) = K <==> Column K of the full matrix A has been permuted into position I in AP.
[out]	TAU	TAU is COMPLEX*16 array, dimension (KB) The scalar factors of the elementary reflectors.
[in,out]	VN1	VN1 is DOUBLE PRECISION array, dimension (N) The vector with the partial column norms.
[in,out]	VN2	VN2 is DOUBLE PRECISION array, dimension (N) The vector with the exact column norms.
[in,out]	AUXV	AUXV is COMPLEX*16 array, dimension (NB) Auxiliary vector.
[in,out]	F	F is COMPLEX*16 array, dimension (LDF,NB) Matrix F**H = L * Y**H * A.
[in]	LDF	LDF is INTEGER The leading dimension of the array F. LDF >= max(1,N).

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Date

December 2016

Contributors:

G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain X. Sun, Computer Science Dept., Duke University, USA
Partial column norm updating strategy modified on April 2011 Z. Drmac and Z. Bujanovic, Dept. of Mathematics, University of Zagreb, Croatia.

References:

LAPACK Working Note 176 [PDF]

Definition at line 179 of file zlaqps.f.

*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   VN1( * ), VN2( * )
      COMPLEX*16         A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      COMPLEX*16         CZERO, CONE
      parameter( zero = 0.0d+0, one = 1.0d+0,
     $                   czero = ( 0.0d+0, 0.0d+0 ),
     $                   cone = ( 1.0d+0, 0.0d+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
      DOUBLE PRECISION   TEMP, TEMP2, TOL3Z
      COMPLEX*16         AKK
*     ..
*     .. External Subroutines ..
      EXTERNAL           zgemm, zgemv, zlarfg, zswap
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, dconjg, max, min, nint, sqrt
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DZNRM2
      EXTERNAL           idamax, dlamch, dznrm2
*     ..
*     .. Executable Statements ..
*
      lastrk = min( m, n+offset )
      lsticc = 0
      k = 0
      tol3z = sqrt(dlamch('Epsilon'))
*
*     Beginning of while loop.
*
   10 CONTINUE
      IF( ( k.LT.nb ) .AND. ( lsticc.EQ.0 ) ) THEN
         k = k + 1
         rk = offset + k
*
*        Determine ith pivot column and swap if necessary
*
         pvt = ( k-1 ) + idamax( n-k+1, vn1( k ), 1 )
         IF( pvt.NE.k ) THEN
            CALL zswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
            CALL zswap( k-1, f( pvt, 1 ), ldf, f( k, 1 ), ldf )
            itemp = jpvt( pvt )
            jpvt( pvt ) = jpvt( k )
            jpvt( k ) = itemp
            vn1( pvt ) = vn1( k )
            vn2( pvt ) = vn2( k )
         END IF
*
*        Apply previous Householder reflectors to column K:
*        A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**H.
*
         IF( k.GT.1 ) THEN
            DO 20 j = 1, k - 1
               f( k, j ) = dconjg( f( k, j ) )
   20       CONTINUE
            CALL zgemv( 'No transpose', m-rk+1, k-1, -cone, a( rk, 1 ),
     $                  lda, f( k, 1 ), ldf, cone, a( rk, k ), 1 )
            DO 30 j = 1, k - 1
               f( k, j ) = dconjg( f( k, j ) )
   30       CONTINUE
         END IF
*
*        Generate elementary reflector H(k).
*
         IF( rk.LT.m ) THEN
            CALL zlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1, tau( k ) )
         ELSE
            CALL zlarfg( 1, a( rk, k ), a( rk, k ), 1, tau( k ) )
         END IF
*
         akk = a( rk, k )
         a( rk, k ) = cone
*
*        Compute Kth column of F:
*
*        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K).
*
         IF( k.LT.n ) THEN
            CALL zgemv( 'Conjugate transpose', m-rk+1, n-k, tau( k ),
     $                  a( rk, k+1 ), lda, a( rk, k ), 1, czero,
     $                  f( k+1, k ), 1 )
         END IF
*
*        Padding F(1:K,K) with zeros.
*
         DO 40 j = 1, k
            f( j, k ) = czero
   40    CONTINUE
*
*        Incremental updating of F:
*        F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**H
*                    *A(RK:M,K).
*
         IF( k.GT.1 ) THEN
            CALL zgemv( 'Conjugate transpose', m-rk+1, k-1, -tau( k ),
     $                  a( rk, 1 ), lda, a( rk, k ), 1, czero,
     $                  auxv( 1 ), 1 )
*
            CALL zgemv( 'No transpose', n, k-1, cone, f( 1, 1 ), ldf,
     $                  auxv( 1 ), 1, cone, f( 1, k ), 1 )
         END IF
*
*        Update the current row of A:
*        A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**H.
*
         IF( k.LT.n ) THEN
            CALL zgemm( 'No transpose', 'Conjugate transpose', 1, n-k,
     $                  k, -cone, a( rk, 1 ), lda, f( k+1, 1 ), ldf,
     $                  cone, a( rk, k+1 ), lda )
         END IF
*
*        Update partial column norms.
*
         IF( rk.LT.lastrk ) THEN
            DO 50 j = k + 1, n
               IF( vn1( j ).NE.zero ) THEN
*
*                 NOTE: The following 4 lines follow from the analysis in
*                 Lapack Working Note 176.
*
                  temp = abs( a( rk, j ) ) / vn1( j )
                  temp = max( zero, ( one+temp )*( one-temp ) )
                  temp2 = temp*( vn1( j ) / vn2( j ) )**2
                  IF( temp2 .LE. tol3z ) THEN
                     vn2( j ) = dble( lsticc )
                     lsticc = j
                  ELSE
                     vn1( j ) = vn1( j )*sqrt( temp )
                  END IF
               END IF
   50       CONTINUE
         END IF
*
         a( rk, k ) = akk
*
*        End of while loop.
*
         GO TO 10
      END IF
      kb = k
      rk = offset + kb
*
*     Apply the block reflector to the rest of the matrix:
*     A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
*                         A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**H.
*
      IF( kb.LT.min( n, m-offset ) ) THEN
         CALL zgemm( 'No transpose', 'Conjugate transpose', m-rk, n-kb,
     $               kb, -cone, a( rk+1, 1 ), lda, f( kb+1, 1 ), ldf,
     $               cone, a( rk+1, kb+1 ), lda )
      END IF
*
*     Recomputation of difficult columns.
*
   60 CONTINUE
      IF( lsticc.GT.0 ) THEN
         itemp = nint( vn2( lsticc ) )
         vn1( lsticc ) = dznrm2( m-rk, a( rk+1, lsticc ), 1 )
*
*        NOTE: The computation of VN1( LSTICC ) relies on the fact that
*        SNRM2 does not fail on vectors with norm below the value of
*        SQRT(DLAMCH('S'))
*
         vn2( lsticc ) = vn1( lsticc )
         lsticc = itemp
         GO TO 60
      END IF
*
      RETURN
*
*     End of ZLAQPS
*

Here is the call graph for this function:

Here is the caller graph for this function: