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
117 DATA iseed / 1988, 1989, 1990, 1991 /
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...
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 ...
logical function lsame(CA, CB)
LSAME
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
real function slamch(CMACH)
SLAMCH
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
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 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 cgemqrt(SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, C, LDC, WORK, INFO)
CGEMQRT