claqps()

subroutine claqps	(	integer	m,
		integer	n,
		integer	offset,
		integer	nb,
		integer	kb,
		complex, dimension( lda, * )	a,
		integer	lda,
		integer, dimension( * )	jpvt,
		complex, dimension( * )	tau,
		real, dimension( * )	vn1,
		real, dimension( * )	vn2,
		complex, dimension( * )	auxv,
		complex, dimension( ldf, * )	f,
		integer	ldf )

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

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

Purpose:

!>
!> CLAQPS 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 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 array, dimension (KB) !> The scalar factors of the elementary reflectors. !>
[in,out]	VN1	!> VN1 is REAL array, dimension (N) !> The vector with the partial column norms. !>
[in,out]	VN2	!> VN2 is REAL array, dimension (N) !> The vector with the exact column norms. !>
[in,out]	AUXV	!> AUXV is COMPLEX array, dimension (NB) !> Auxiliary vector. !>
[in,out]	F	!> F is COMPLEX 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.

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 172 of file claqps.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            KB, LDA, LDF, M, N, NB, OFFSET
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      REAL               VN1( * ), VN2( * )
      COMPLEX            A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      COMPLEX            CZERO, CONE
      parameter( zero = 0.0e+0, one = 1.0e+0,
     $                   czero = ( 0.0e+0, 0.0e+0 ),
     $                   cone = ( 1.0e+0, 0.0e+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
      REAL               TEMP, TEMP2, TOL3Z
      COMPLEX            AKK
*     ..
*     .. External Subroutines ..
      EXTERNAL           cgemm, cgemv, clarfg, cswap
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, conjg, max, min, nint, real, sqrt
*     ..
*     .. External Functions ..
      INTEGER            ISAMAX
      REAL               SCNRM2, SLAMCH
      EXTERNAL           isamax, scnrm2, slamch
*     ..
*     .. Executable Statements ..
*
      lastrk = min( m, n+offset )
      lsticc = 0
      k = 0
      tol3z = sqrt(slamch('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 ) + isamax( n-k+1, vn1( k ), 1 )
         IF( pvt.NE.k ) THEN
            CALL cswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
            CALL cswap( 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 ) = conjg( f( k, j ) )
   20       CONTINUE
            CALL cgemv( '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 ) = conjg( f( k, j ) )
   30       CONTINUE
         END IF
*
*        Generate elementary reflector H(k).
*
         IF( rk.LT.m ) THEN
            CALL clarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1,
     $                   tau( k ) )
         ELSE
            CALL clarfg( 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 cgemv( '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 cgemv( 'Conjugate transpose', m-rk+1, k-1,
     $                  -tau( k ),
     $                  a( rk, 1 ), lda, a( rk, k ), 1, czero,
     $                  auxv( 1 ), 1 )
*
            CALL cgemv( '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 cgemm( '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 ) = real( 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 cgemm( '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 ) = scnrm2( 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 CLAQPS
*

Here is the call graph for this function:

Here is the caller graph for this function: