version 1.4, 2010/08/06 15:32:28
|
version 1.9, 2011/07/22 07:38:07
|
Line 1
|
Line 1
|
SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, |
SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, |
$ VN2, AUXV, F, LDF ) |
$ VN2, AUXV, F, LDF ) |
* |
* |
* -- LAPACK auxiliary routine (version 3.2) -- |
* -- LAPACK auxiliary routine (version 3.3.1) -- |
* -- LAPACK is a software package provided by Univ. of Tennessee, -- |
* -- LAPACK is a software package provided by Univ. of Tennessee, -- |
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- |
* November 2006 |
* -- April 2011 -- |
* |
* |
* .. Scalar Arguments .. |
* .. Scalar Arguments .. |
INTEGER KB, LDA, LDF, M, N, NB, OFFSET |
INTEGER KB, LDA, LDF, M, N, NB, OFFSET |
Line 76
|
Line 76
|
* Auxiliar vector. |
* Auxiliar vector. |
* |
* |
* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB) |
* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB) |
* Matrix F' = L*Y'*A. |
* Matrix F**T = L*Y**T*A. |
* |
* |
* LDF (input) INTEGER |
* LDF (input) INTEGER |
* The leading dimension of the array F. LDF >= max(1,N). |
* The leading dimension of the array F. LDF >= max(1,N). |
Line 91
|
Line 91
|
* Partial column norm updating strategy modified by |
* Partial column norm updating strategy modified by |
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, |
* Z. Drmac and Z. Bujanovic, Dept. of Mathematics, |
* University of Zagreb, Croatia. |
* University of Zagreb, Croatia. |
* June 2006. |
* -- April 2011 -- |
* For more details see LAPACK Working Note 176. |
* For more details see LAPACK Working Note 176. |
* ===================================================================== |
* ===================================================================== |
* |
* |
Line 104
|
Line 104
|
DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z |
DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z |
* .. |
* .. |
* .. External Subroutines .. |
* .. External Subroutines .. |
EXTERNAL DGEMM, DGEMV, DLARFP, DSWAP |
EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP |
* .. |
* .. |
* .. Intrinsic Functions .. |
* .. Intrinsic Functions .. |
INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT |
INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT |
Line 142
|
Line 142
|
END IF |
END IF |
* |
* |
* Apply previous Householder reflectors to column K: |
* 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)'. |
* 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 |
IF( K.GT.1 ) THEN |
CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), |
CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ), |
Line 152
|
Line 152
|
* Generate elementary reflector H(k). |
* Generate elementary reflector H(k). |
* |
* |
IF( RK.LT.M ) THEN |
IF( RK.LT.M ) THEN |
CALL DLARFP( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) |
CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) ) |
ELSE |
ELSE |
CALL DLARFP( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) |
CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) ) |
END IF |
END IF |
* |
* |
AKK = A( RK, K ) |
AKK = A( RK, K ) |
Line 162
|
Line 162
|
* |
* |
* Compute Kth column of F: |
* Compute Kth column of F: |
* |
* |
* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). |
* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). |
* |
* |
IF( K.LT.N ) THEN |
IF( K.LT.N ) THEN |
CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), |
CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ), |
Line 177
|
Line 177
|
20 CONTINUE |
20 CONTINUE |
* |
* |
* Incremental updating of F: |
* 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)' |
* 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). |
* *A(RK:M,K). |
* |
* |
IF( K.GT.1 ) THEN |
IF( K.GT.1 ) THEN |
Line 189
|
Line 189
|
END IF |
END IF |
* |
* |
* Update the current row of A: |
* 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)'. |
* 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 |
IF( K.LT.N ) THEN |
CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, |
CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF, |
Line 229
|
Line 229
|
* |
* |
* Apply the block reflector to the rest of the matrix: |
* 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,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - |
* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. |
* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. |
* |
* |
IF( KB.LT.MIN( N, M-OFFSET ) ) THEN |
IF( KB.LT.MIN( N, M-OFFSET ) ) THEN |
CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, |
CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE, |