126 SUBROUTINE crqt01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
135 INTEGER lda, lwork, m, n
138 REAL result( * ), rwork( * )
139 COMPLEX a( lda, * ), af( lda, * ), q( lda, * ),
140 $ r( lda, * ), tau( * ), work( lwork )
147 parameter( zero = 0.0e+0, one = 1.0e+0 )
149 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
153 REAL anorm, eps, resid
163 INTRINSIC cmplx, max, min, real
169 COMMON / srnamc / srnamt
178 CALL
clacpy(
'Full', m, n, a, lda, af, lda )
183 CALL
cgerqf( m, n, af, lda, tau, work, lwork, info )
187 CALL
claset(
'Full', n, n, rogue, rogue, q, lda )
189 IF( m.GT.0 .AND. m.LT.n )
190 $ CALL
clacpy(
'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
192 $ CALL
clacpy(
'Lower', m-1, m-1, af( 2, n-m+1 ), lda,
193 $ q( n-m+2, n-m+1 ), lda )
196 $ CALL
clacpy(
'Lower', n-1, n-1, af( m-n+2, 1 ), lda,
203 CALL
cungrq( n, n, minmn, q, lda, tau, work, lwork, info )
207 CALL
claset(
'Full', m, n, cmplx( zero ), cmplx( zero ), r, lda )
210 $ CALL
clacpy(
'Upper', m, m, af( 1, n-m+1 ), lda,
211 $ r( 1, n-m+1 ), lda )
213 IF( m.GT.n .AND. n.GT.0 )
214 $ CALL
clacpy(
'Full', m-n, n, af, lda, r, lda )
216 $ CALL
clacpy(
'Upper', n, n, af( m-n+1, 1 ), lda,
217 $ r( m-n+1, 1 ), lda )
222 CALL
cgemm(
'No transpose',
'Conjugate transpose', m, n, n,
223 $ cmplx( -one ), a, lda, q, lda, cmplx( one ), r, lda )
227 anorm =
clange(
'1', m, n, a, lda, rwork )
228 resid =
clange(
'1', m, n, r, lda, rwork )
229 IF( anorm.GT.zero )
THEN
230 result( 1 ) = ( ( resid /
REAL( MAX( 1, N ) ) ) / anorm ) / eps
237 CALL
claset(
'Full', n, n, cmplx( zero ), cmplx( one ), r, lda )
238 CALL
cherk(
'Upper',
'No transpose', n, n, -one, q, lda, one, r,
243 resid =
clansy(
'1',
'Upper', n, r, lda, rwork )
245 result( 2 ) = ( resid /
REAL( MAX( 1, N ) ) ) / eps
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine crqt01(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
CRQT01
REAL function slamch(CMACH)
SLAMCH
subroutine cungrq(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGRQ
subroutine cgerqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
CGERQF
REAL function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
REAL function clansy(NORM, UPLO, N, A, LDA, WORK)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex symmetric matrix.
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK