91 COMPLEX,
ALLOCATABLE :: AF(:,:), Q(:,:),
92 $ r(:,:), rwork(:), work( : ), t(:,:),
93 $ cf(:,:), df(:,:), a(:,:), c(:,:), d(:,:)
98 parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
101 INTEGER INFO, J, K, L, LWORK
102 REAL ANORM, EPS, RESID, CNORM, DNORM
111 EXTERNAL slamch, clange, clansy, lsame
117 DATA iseed / 1988, 1989, 1990, 1991 /
119 eps = slamch(
'Epsilon' )
122 lwork = max(2,l)*max(2,l)*nb
126 ALLOCATE ( a(m,n), af(m,n), q(m,m), r(m,l), rwork(l),
127 $ work(lwork), t(nb,n), c(m,n), cf(m,n),
134 CALL
clarnv( 2, iseed, m, a( 1, j ) )
136 CALL
clacpy(
'Full', m, n, a, m, af, m )
140 CALL
cgeqrt( m, n, nb, af, m, t, ldt, work, info )
144 CALL
claset(
'Full', m, m, czero, one, q, m )
145 CALL
cgemqrt(
'R',
'N', m, m, k, nb, af, m, t, ldt, q, m,
150 CALL
claset(
'Full', m, n, czero, czero, r, m )
151 CALL
clacpy(
'Upper', m, n, af, m, r, m )
155 CALL
cgemm(
'C',
'N', m, n, m, -one, q, m, a, m, one, r, m )
156 anorm = clange(
'1', m, n, a, m, rwork )
157 resid = clange(
'1', m, n, r, m, rwork )
158 IF( anorm.GT.zero )
THEN
159 result( 1 ) = resid / (eps*max(1,m)*anorm)
166 CALL
claset(
'Full', m, m, czero, one, r, m )
167 CALL
cherk(
'U',
'C', m, m,
REAL(-ONE), Q, M,
REAL(ONE), R, M )
168 resid = clansy(
'1',
'Upper', m, r, m, rwork )
169 result( 2 ) = resid / (eps*max(1,m))
174 CALL
clarnv( 2, iseed, m, c( 1, j ) )
176 cnorm = clange(
'1', m, n, c, m, rwork)
177 CALL
clacpy(
'Full', m, n, c, m, cf, m )
181 CALL
cgemqrt(
'L',
'N', m, n, k, nb, af, m, t, nb, cf, m,
186 CALL
cgemm(
'N',
'N', m, n, m, -one, q, m, c, m, one, cf, m )
187 resid = clange(
'1', m, n, cf, m, rwork )
188 IF( cnorm.GT.zero )
THEN
189 result( 3 ) = resid / (eps*max(1,m)*cnorm)
196 CALL
clacpy(
'Full', m, n, c, m, cf, m )
200 CALL
cgemqrt(
'L',
'C', m, n, k, nb, af, m, t, nb, cf, m,
205 CALL
cgemm(
'C',
'N', m, n, m, -one, q, m, c, m, one, cf, m )
206 resid = clange(
'1', m, n, cf, m, rwork )
207 IF( cnorm.GT.zero )
THEN
208 result( 4 ) = resid / (eps*max(1,m)*cnorm)
216 CALL
clarnv( 2, iseed, n, d( 1, j ) )
218 dnorm = clange(
'1', n, m, d, n, rwork)
219 CALL
clacpy(
'Full', n, m, d, n, df, n )
223 CALL
cgemqrt(
'R',
'N', n, m, k, nb, af, m, t, nb, df, n,
228 CALL
cgemm(
'N',
'N', n, m, m, -one, d, n, q, m, one, df, n )
229 resid = clange(
'1', n, m, df, n, rwork )
230 IF( cnorm.GT.zero )
THEN
231 result( 5 ) = resid / (eps*max(1,m)*dnorm)
238 CALL
clacpy(
'Full', n, m, d, n, df, n )
242 CALL
cgemqrt(
'R',
'C', n, m, k, nb, af, m, t, nb, df, n,
247 CALL
cgemm(
'N',
'C', n, m, m, -one, d, n, q, m, one, df, n )
248 resid = clange(
'1', n, m, df, n, rwork )
249 IF( cnorm.GT.zero )
THEN
250 result( 6 ) = resid / (eps*max(1,m)*dnorm)
257 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
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 clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cgeqrt(M, N, NB, A, LDA, T, LDT, WORK, INFO)
CGEQRT
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
subroutine cqrt04(M, N, NB, RESULT)
CQRT04
subroutine cgemqrt(SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, C, LDC, WORK, INFO)
CGEMQRT