slaqps()

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) !> Auxiliary 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.

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 slaqps.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               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: