74 SUBROUTINE slqt05(M,N,L,NB,RESULT)
83 INTEGER LWORK, M, N, L, NB, LDT
91 REAL,
ALLOCATABLE :: AF(:,:), Q(:,:),
92 $ r(:,:), rwork(:), work( : ), t(:,:),
93 $ cf(:,:), df(:,:), a(:,:), c(:,:), d(:,:)
97 parameter( zero = 0.0, one = 1.0 )
100 INTEGER INFO, J, K, N2, NP1,i
101 REAL ANORM, EPS, RESID, CNORM, DNORM
107 REAL SLAMCH, SLANGE, SLANSY
109 EXTERNAL slamch, slange, slansy, lsame
112 DATA iseed / 1988, 1989, 1990, 1991 /
114 eps = slamch(
'Epsilon' )
126 ALLOCATE(a(m,n2),af(m,n2),q(n2,n2),r(n2,n2),rwork(n2),
127 $ work(lwork),t(nb,m),c(n2,m),cf(n2,m),
133 CALL slaset(
'Full', m, n2, zero, zero, a, m )
134 CALL slaset(
'Full', nb, m, zero, zero, t, nb )
136 CALL slarnv( 2, iseed, m-j+1, a( j, j ) )
140 CALL slarnv( 2, iseed, m, a( 1, min(n+m,m+1) + j - 1 ) )
145 CALL slarnv( 2, iseed, m-j+1, a( j, min(n+m,n+m-l+1)
152 CALL slacpy(
'Full', m, n2, a, m, af, m )
156 CALL stplqt( m,n,l,nb,af,m,af(1,np1),m,t,ldt,work,info)
160 CALL slaset(
'Full', n2, n2, zero, one, q, n2 )
161 CALL sgemlqt(
'L',
'N', n2, n2, k, nb, af, m, t, ldt, q, n2,
166 CALL slaset(
'Full', n2, n2, zero, zero, r, n2 )
167 CALL slacpy(
'Lower', m, n2, af, m, r, n2 )
171 CALL sgemm(
'N',
'T', m, n2, n2, -one, a, m, q, n2, one, r, n2)
172 anorm = slange(
'1', m, n2, a, m, rwork )
173 resid = slange(
'1', m, n2, r, n2, rwork )
174 IF( anorm.GT.zero )
THEN
175 result( 1 ) = resid / (eps*anorm*max(1,n2))
182 CALL slaset(
'Full', n2, n2, zero, one, r, n2 )
183 CALL ssyrk(
'U',
'N', n2, n2, -one, q, n2, one, r, n2 )
184 resid = slansy(
'1',
'Upper', n2, r, n2, rwork )
185 result( 2 ) = resid / (eps*max(1,n2))
189 CALL slaset(
'Full', n2, m, zero, one, c, n2 )
191 CALL slarnv( 2, iseed, n2, c( 1, j ) )
193 cnorm = slange(
'1', n2, m, c, n2, rwork)
194 CALL slacpy(
'Full', n2, m, c, n2, cf, n2 )
198 CALL stpmlqt(
'L',
'N', n,m,k,l,nb,af(1, np1),m,t,ldt,cf,n2,
199 $ cf(np1,1),n2,work,info)
203 CALL sgemm(
'N',
'N', n2, m, n2, -one, q, n2, c, n2, one, cf, n2 )
204 resid = slange(
'1', n2, m, cf, n2, rwork )
205 IF( cnorm.GT.zero )
THEN
206 result( 3 ) = resid / (eps*max(1,n2)*cnorm)
214 CALL slacpy(
'Full', n2, m, c, n2, cf, n2 )
218 CALL stpmlqt(
'L',
'T',n,m,k,l,nb,af(1,np1),m,t,ldt,cf,n2,
219 $ cf(np1,1),n2,work,info)
223 CALL sgemm(
'T',
'N',n2,m,n2,-one,q,n2,c,n2,one,cf,n2)
224 resid = slange(
'1', n2, m, cf, n2, rwork )
226 IF( cnorm.GT.zero )
THEN
227 result( 4 ) = resid / (eps*max(1,n2)*cnorm)
235 CALL slarnv( 2, iseed, m, d( 1, j ) )
237 dnorm = slange(
'1', m, n2, d, m, rwork)
238 CALL slacpy(
'Full', m, n2, d, m, df, m )
242 CALL stpmlqt(
'R',
'N',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
243 $ df(1,np1),m,work,info)
247 CALL sgemm(
'N',
'N',m,n2,n2,-one,d,m,q,n2,one,df,m)
248 resid = slange(
'1',m, n2,df,m,rwork )
249 IF( cnorm.GT.zero )
THEN
250 result( 5 ) = resid / (eps*max(1,n2)*dnorm)
257 CALL slacpy(
'Full',m,n2,d,m,df,m )
261 CALL stpmlqt(
'R',
'T',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
262 $ df(1,np1),m,work,info)
267 CALL sgemm(
'N',
'T', m, n2, n2, -one, d, m, q, n2, one, df, m )
268 resid = slange(
'1', m, n2, df, m, rwork )
269 IF( cnorm.GT.zero )
THEN
270 result( 6 ) = resid / (eps*max(1,n2)*dnorm)
277 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
subroutine ssyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
SSYRK
subroutine sgemlqt(SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, C, LDC, WORK, INFO)
subroutine stplqt(M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, INFO)
STPLQT
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine stpmlqt(SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, A, LDA, B, LDB, WORK, INFO)
DTPMLQT
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine slqt05(M, N, L, NB, RESULT)
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.