dlaqps()

subroutine dlaqps	(	integer	m,
		integer	n,
		integer	offset,
		integer	nb,
		integer	kb,
		double precision, dimension( lda, * )	a,
		integer	lda,
		integer, dimension( * )	jpvt,
		double precision, dimension( * )	tau,
		double precision, dimension( * )	vn1,
		double precision, dimension( * )	vn2,
		double precision, dimension( * )	auxv,
		double precision, dimension( ldf, * )	f,
		integer	ldf )

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

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

Purpose:

!>
!> DLAQPS 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (NB) !> Auxiliary vector. !>
[in,out]	F	!> F is DOUBLE PRECISION 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 171 of file dlaqps.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( * )
      DOUBLE PRECISION   A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
     $                   VN1( * ), VN2( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      parameter( zero = 0.0d+0, one = 1.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            ITEMP, J, K, LASTRK, LSTICC, PVT, RK
      DOUBLE PRECISION   AKK, TEMP, TEMP2, TOL3Z
*     ..
*     .. External Subroutines ..
      EXTERNAL           dgemm, dgemv, dlarfg, dswap
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, dble, max, min, nint, sqrt
*     ..
*     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DNRM2
      EXTERNAL           idamax, dlamch, dnrm2
*     ..
*     .. 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 dswap( m, a( 1, pvt ), 1, a( 1, k ), 1 )
            CALL dswap( 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 dgemv( '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 dlarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1,
     $                   tau( k ) )
         ELSE
            CALL dlarfg( 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 dgemv( '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 dgemv( 'Transpose', m-rk+1, k-1, -tau( k ), a( rk,
     $                  1 ),
     $                  lda, a( rk, k ), 1, zero, auxv( 1 ), 1 )
*
            CALL dgemv( '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 dgemv( '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 ) = dble( 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 dgemm( '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 ) = dnrm2( 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 DLAQPS
*

Here is the call graph for this function:

Here is the caller graph for this function: