SQRT05 tests STPLQT and STPMLQT.
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
112 DATA iseed / 1988, 1989, 1990, 1991 /
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
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slansy(NORM, UPLO, N, A, LDA, WORK)
SLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.