124 SUBROUTINE crqt01( M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK,
132 INTEGER LDA, LWORK, M, N
135 REAL RESULT( * ), RWORK( * )
136 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ r( lda, * ), tau( * ), work( lwork )
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
146 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
150 REAL ANORM, EPS, RESID
153 REAL CLANGE, CLANSY, SLAMCH
154 EXTERNAL clange, clansy, slamch
160 INTRINSIC cmplx, max, min, real
166 COMMON / srnamc / srnamt
171 eps = slamch(
'Epsilon' )
175 CALL clacpy(
'Full', m, n, a, lda, af, lda )
180 CALL cgerqf( m, n, af, lda, tau, work, lwork, info )
184 CALL claset(
'Full', n, n, rogue, rogue, q, lda )
186 IF( m.GT.0 .AND. m.LT.n )
187 $
CALL clacpy(
'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
189 $
CALL clacpy(
'Lower', m-1, m-1, af( 2, n-m+1 ), lda,
190 $ q( n-m+2, n-m+1 ), lda )
193 $
CALL clacpy(
'Lower', n-1, n-1, af( m-n+2, 1 ), lda,
200 CALL cungrq( n, n, minmn, q, lda, tau, work, lwork, info )
204 CALL claset(
'Full', m, n, cmplx( zero ), cmplx( zero ), r, lda )
207 $
CALL clacpy(
'Upper', m, m, af( 1, n-m+1 ), lda,
208 $ r( 1, n-m+1 ), lda )
210 IF( m.GT.n .AND. n.GT.0 )
211 $
CALL clacpy(
'Full', m-n, n, af, lda, r, lda )
213 $
CALL clacpy(
'Upper', n, n, af( m-n+1, 1 ), lda,
214 $ r( m-n+1, 1 ), lda )
219 CALL cgemm(
'No transpose',
'Conjugate transpose', m, n, n,
220 $ cmplx( -one ), a, lda, q, lda, cmplx( one ), r, lda )
224 anorm = clange(
'1', m, n, a, lda, rwork )
225 resid = clange(
'1', m, n, r, lda, rwork )
226 IF( anorm.GT.zero )
THEN
227 result( 1 ) = ( ( resid / real( max( 1, n ) ) ) / anorm ) / eps
234 CALL claset(
'Full', n, n, cmplx( zero ), cmplx( one ), r, lda )
235 CALL cherk(
'Upper',
'No transpose', n, n, -one, q, lda, one, r,
240 resid = clansy(
'1',
'Upper', n, r, lda, rwork )
242 result( 2 ) = ( resid / real( max( 1, n ) ) ) / eps
subroutine crqt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
CRQT01
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
subroutine cgerqf(m, n, a, lda, tau, work, lwork, info)
CGERQF
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
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 cungrq(m, n, k, a, lda, tau, work, lwork, info)
CUNGRQ