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