81 SUBROUTINE clqt05(M,N,L,NB,RESULT)
90 INTEGER LWORK, M, N, L, NB, LDT
98 COMPLEX,
ALLOCATABLE :: AF(:,:), Q(:,:),
99 $ r(:,:), rwork(:), work( : ), t(:,:),
100 $ cf(:,:), df(:,:), a(:,:), c(:,:), d(:,:)
105 parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
108 INTEGER INFO, J, K, N2, NP1,i
109 REAL ANORM, EPS, RESID, CNORM, DNORM
118 EXTERNAL slamch, clange, clansy, lsame
121 DATA iseed / 1988, 1989, 1990, 1991 /
123 eps = slamch(
'Epsilon' )
135 ALLOCATE(a(m,n2),af(m,n2),q(n2,n2),r(n2,n2),rwork(n2),
136 $ work(lwork),t(nb,m),c(n2,m),cf(n2,m),
142 CALL claset(
'Full', m, n2, czero, czero, a, m )
143 CALL claset(
'Full', nb, m, czero, czero, t, nb )
145 CALL clarnv( 2, iseed, m-j+1, a( j, j ) )
149 CALL clarnv( 2, iseed, m, a( 1, min(n+m,m+1) + j - 1 ) )
154 CALL clarnv( 2, iseed, m-j+1, a( j, min(n+m,n+m-l+1)
161 CALL clacpy(
'Full', m, n2, a, m, af, m )
165 CALL ctplqt( m,n,l,nb,af,m,af(1,np1),m,t,ldt,work,info)
169 CALL claset(
'Full', n2, n2, czero, one, q, n2 )
170 CALL cgemlqt(
'L',
'N', n2, n2, k, nb, af, m, t, ldt, q, n2,
175 CALL claset(
'Full', n2, n2, czero, czero, r, n2 )
176 CALL clacpy(
'Lower', m, n2, af, m, r, n2 )
180 CALL cgemm(
'N',
'C', m, n2, n2, -one, a, m, q, n2, one, r, n2)
181 anorm = clange(
'1', m, n2, a, m, rwork )
182 resid = clange(
'1', m, n2, r, n2, rwork )
183 IF( anorm.GT.zero )
THEN
184 result( 1 ) = resid / (eps*anorm*max(1,n2))
191 CALL claset(
'Full', n2, n2, czero, one, r, n2 )
192 CALL cherk(
'U',
'N', n2, n2,
REAL(-ONE), Q, N2,
REAL(ONE),
194 resid = clansy(
'1',
'Upper', n2, r, n2, rwork )
195 result( 2 ) = resid / (eps*max(1,n2))
199 CALL claset(
'Full', n2, m, czero, one, c, n2 )
201 CALL clarnv( 2, iseed, n2, c( 1, j ) )
203 cnorm = clange(
'1', n2, m, c, n2, rwork)
204 CALL clacpy(
'Full', n2, m, c, n2, cf, n2 )
208 CALL ctpmlqt(
'L',
'N', n,m,k,l,nb,af(1, np1),m,t,ldt,cf,n2,
209 $ cf(np1,1),n2,work,info)
213 CALL cgemm(
'N',
'N', n2, m, n2, -one, q, n2, c, n2, one, cf, n2 )
214 resid = clange(
'1', n2, m, cf, n2, rwork )
215 IF( cnorm.GT.zero )
THEN
216 result( 3 ) = resid / (eps*max(1,n2)*cnorm)
224 CALL clacpy(
'Full', n2, m, c, n2, cf, n2 )
228 CALL ctpmlqt(
'L',
'C',n,m,k,l,nb,af(1,np1),m,t,ldt,cf,n2,
229 $ cf(np1,1),n2,work,info)
233 CALL cgemm(
'C',
'N',n2,m,n2,-one,q,n2,c,n2,one,cf,n2)
234 resid = clange(
'1', n2, m, cf, n2, rwork )
236 IF( cnorm.GT.zero )
THEN
237 result( 4 ) = resid / (eps*max(1,n2)*cnorm)
245 CALL clarnv( 2, iseed, m, d( 1, j ) )
247 dnorm = clange(
'1', m, n2, d, m, rwork)
248 CALL clacpy(
'Full', m, n2, d, m, df, m )
252 CALL ctpmlqt(
'R',
'N',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
253 $ df(1,np1),m,work,info)
257 CALL cgemm(
'N',
'N',m,n2,n2,-one,d,m,q,n2,one,df,m)
258 resid = clange(
'1',m, n2,df,m,rwork )
259 IF( cnorm.GT.zero )
THEN
260 result( 5 ) = resid / (eps*max(1,n2)*dnorm)
267 CALL clacpy(
'Full',m,n2,d,m,df,m )
271 CALL ctpmlqt(
'R',
'C',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
272 $ df(1,np1),m,work,info)
277 CALL cgemm(
'N',
'C', m, n2, n2, -one, d, m, q, n2, one, df, m )
278 resid = clange(
'1', m, n2, df, m, rwork )
279 IF( cnorm.GT.zero )
THEN
280 result( 6 ) = resid / (eps*max(1,n2)*dnorm)
287 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
subroutine ctpmlqt(SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, A, LDA, B, LDB, WORK, INFO)
subroutine ctplqt(M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, INFO)
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 clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
subroutine clqt05(M, N, L, NB, RESULT)
CLQT05
subroutine cgemlqt(SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, C, LDC, WORK, INFO)
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