subroutine slaqps	(	integer	M,
		integer	N,
		integer	OFFSET,
		integer	NB,
		integer	KB,
		real, dimension( lda, * )	A,
		integer	LDA,
		integer, dimension( * )	JPVT,
		real, dimension( * )	TAU,
		real, dimension( * )	VN1,
		real, dimension( * )	VN2,
		real, dimension( * )	AUXV,
		real, dimension( ldf, * )	F,
		integer	LDF
	)

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

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

Purpose:

 SLAQPS computes a step of QR factorization with column pivoting
 of a real 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 REAL 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 REAL 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 REAL array, dimension (NB) Auxiliar vector.
[in,out]	F	F is REAL array, dimension (LDF,NB) Matrix F**T = L*Y**T*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

September 2012

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 180 of file slaqps.f.

*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER            kb, lda, ldf, m, n, nb, offset
*     ..
*     .. Array Arguments ..
      INTEGER            jpvt( * )
      REAL               a( lda, * ), auxv( * ), f( ldf, * ), tau( * ),
     $                   vn1( * ), vn2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               zero, one
      parameter                ( zero = 0.0e+0, one = 1.0e+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            itemp, j, k, lastrk, lsticc, pvt, rk
      REAL               akk, temp, temp2, tol3z
*     ..
*     .. External Subroutines ..
      EXTERNAL           sgemm, sgemv, slarfg, sswap
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min, nint, REAL, sqrt
*     ..
*     .. External Functions ..
      INTEGER            isamax
      REAL               slamch, snrm2
      EXTERNAL           isamax, slamch, snrm2
*     ..
*     .. 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 sswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
            CALL sswap( 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)**T.
*
         IF( k.GT.1 ) THEN
            CALL sgemv( 'No transpose', m-rk+1, k-1, -one, a( rk, 1 ),
     $                  lda, f( k, 1 ), ldf, one, a( rk, k ), 1 )
         END IF
*
*        Generate elementary reflector H(k).
*
         IF( rk.LT.m ) THEN
            CALL slarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1, tau( k ) )
         ELSE
            CALL slarfg( 1, a( rk, k ), a( rk, k ), 1, tau( k ) )
         END IF
*
         akk = a( rk, k )
         a( rk, k ) = one
*
*        Compute Kth column of F:
*
*        Compute  F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K).
*
         IF( k.LT.n ) THEN
            CALL sgemv( 'Transpose', m-rk+1, n-k, tau( k ),
     $                  a( rk, k+1 ), lda, a( rk, k ), 1, zero,
     $                  f( k+1, k ), 1 )
         END IF
*
*        Padding F(1:K,K) with zeros.
*
         DO 20 j = 1, k
            f( j, k ) = zero
   20    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)**T
*                    *A(RK:M,K).
*
         IF( k.GT.1 ) THEN
            CALL sgemv( 'Transpose', m-rk+1, k-1, -tau( k ), a( rk, 1 ),
     $                  lda, a( rk, k ), 1, zero, auxv( 1 ), 1 )
*
            CALL sgemv( 'No transpose', n, k-1, one, f( 1, 1 ), ldf,
     $                  auxv( 1 ), 1, one, 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)**T.
*
         IF( k.LT.n ) THEN
            CALL sgemv( 'No transpose', n-k, k, -one, f( k+1, 1 ), ldf,
     $                  a( rk, 1 ), lda, one, a( rk, k+1 ), lda )
         END IF
*
*        Update partial column norms.
*
         IF( rk.LT.lastrk ) THEN
            DO 30 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
   30       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)**T.
*
      IF( kb.LT.min( n, m-offset ) ) THEN
         CALL sgemm( 'No transpose', 'Transpose', m-rk, n-kb, kb, -one,
     $               a( rk+1, 1 ), lda, f( kb+1, 1 ), ldf, one,
     $               a( rk+1, kb+1 ), lda )
      END IF
*
*     Recomputation of difficult columns.
*
   40 CONTINUE
      IF( lsticc.GT.0 ) THEN
         itemp = nint( vn2( lsticc ) )
         vn1( lsticc ) = snrm2( 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 40
      END IF
*
      RETURN
*
*     End of SLAQPS
*

Here is the call graph for this function:

Here is the caller graph for this function: