LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ sdrvrf3()

subroutine sdrvrf3 ( integer  nout,
integer  nn,
integer, dimension( nn )  nval,
real  thresh,
real, dimension( lda, * )  a,
integer  lda,
real, dimension( * )  arf,
real, dimension( lda, * )  b1,
real, dimension( lda, * )  b2,
real, dimension( * )  s_work_slange,
real, dimension( * )  s_work_sgeqrf,
real, dimension( * )  tau 
)

SDRVRF3

Purpose:
 SDRVRF3 tests the LAPACK RFP routines:
     STFSM
Parameters
[in]NOUT
          NOUT is INTEGER
                The unit number for output.
[in]NN
          NN is INTEGER
                The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
                The values of the matrix dimension N.
[in]THRESH
          THRESH is REAL
                The threshold value for the test ratios.  A result is
                included in the output file if RESULT >= THRESH.  To have
                every test ratio printed, use THRESH = 0.
[out]A
          A is REAL array, dimension (LDA,NMAX)
[in]LDA
          LDA is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]ARF
          ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
[out]B1
          B1 is REAL array, dimension (LDA,NMAX)
[out]B2
          B2 is REAL array, dimension (LDA,NMAX)
[out]S_WORK_SLANGE
          S_WORK_SLANGE is REAL array, dimension (NMAX)
[out]S_WORK_SGEQRF
          S_WORK_SGEQRF is REAL array, dimension (NMAX)
[out]TAU
          TAU is REAL array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 116 of file sdrvrf3.f.

118*
119* -- LAPACK test routine --
120* -- LAPACK is a software package provided by Univ. of Tennessee, --
121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123* .. Scalar Arguments ..
124 INTEGER LDA, NN, NOUT
125 REAL THRESH
126* ..
127* .. Array Arguments ..
128 INTEGER NVAL( NN )
129 REAL A( LDA, * ), ARF( * ), B1( LDA, * ),
130 + B2( LDA, * ), S_WORK_SGEQRF( * ),
131 + S_WORK_SLANGE( * ), TAU( * )
132* ..
133*
134* =====================================================================
135* ..
136* .. Parameters ..
137 REAL ZERO, ONE
138 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
139 + one = ( 1.0e+0, 0.0e+0 ) )
140 INTEGER NTESTS
141 parameter( ntests = 1 )
142* ..
143* .. Local Scalars ..
144 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
145 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
146 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
147 REAL EPS, ALPHA
148* ..
149* .. Local Arrays ..
150 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
151 + DIAGS( 2 ), SIDES( 2 )
152 INTEGER ISEED( 4 ), ISEEDY( 4 )
153 REAL RESULT( NTESTS )
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 REAL SLAMCH, SLANGE, SLARND
158 EXTERNAL slamch, slange, slarnd, lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL strttf, sgeqrf, sgeqlf, stfsm, strsm
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC max, sqrt
165* ..
166* .. Scalars in Common ..
167 CHARACTER*32 SRNAMT
168* ..
169* .. Common blocks ..
170 COMMON / srnamc / srnamt
171* ..
172* .. Data statements ..
173 DATA iseedy / 1988, 1989, 1990, 1991 /
174 DATA uplos / 'U', 'L' /
175 DATA forms / 'N', 'T' /
176 DATA sides / 'L', 'R' /
177 DATA transs / 'N', 'T' /
178 DATA diags / 'N', 'U' /
179* ..
180* .. Executable Statements ..
181*
182* Initialize constants and the random number seed.
183*
184 nrun = 0
185 nfail = 0
186 info = 0
187 DO 10 i = 1, 4
188 iseed( i ) = iseedy( i )
189 10 CONTINUE
190 eps = slamch( 'Precision' )
191*
192 DO 170 iim = 1, nn
193*
194 m = nval( iim )
195*
196 DO 160 iin = 1, nn
197*
198 n = nval( iin )
199*
200 DO 150 iform = 1, 2
201*
202 cform = forms( iform )
203*
204 DO 140 iuplo = 1, 2
205*
206 uplo = uplos( iuplo )
207*
208 DO 130 iside = 1, 2
209*
210 side = sides( iside )
211*
212 DO 120 itrans = 1, 2
213*
214 trans = transs( itrans )
215*
216 DO 110 idiag = 1, 2
217*
218 diag = diags( idiag )
219*
220 DO 100 ialpha = 1, 3
221*
222 IF ( ialpha.EQ.1 ) THEN
223 alpha = zero
224 ELSE IF ( ialpha.EQ.2 ) THEN
225 alpha = one
226 ELSE
227 alpha = slarnd( 2, iseed )
228 END IF
229*
230* All the parameters are set:
231* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
232* and ALPHA
233* READY TO TEST!
234*
235 nrun = nrun + 1
236*
237 IF ( iside.EQ.1 ) THEN
238*
239* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
240* -> A is M-by-M ( B is M-by-N )
241*
242 na = m
243*
244 ELSE
245*
246* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
247* -> A is N-by-N ( B is M-by-N )
248*
249 na = n
250*
251 END IF
252*
253* Generate A our NA--by--NA triangular
254* matrix.
255* Our test is based on forward error so we
256* do want A to be well conditioned! To get
257* a well-conditioned triangular matrix, we
258* take the R factor of the QR/LQ factorization
259* of a random matrix.
260*
261 DO j = 1, na
262 DO i = 1, na
263 a( i, j ) = slarnd( 2, iseed )
264 END DO
265 END DO
266*
267 IF ( iuplo.EQ.1 ) THEN
268*
269* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
270* -> QR factorization.
271*
272 srnamt = 'SGEQRF'
273 CALL sgeqrf( na, na, a, lda, tau,
274 + s_work_sgeqrf, lda,
275 + info )
276*
277* Forcing main diagonal of test matrix to
278* be unit makes it ill-conditioned for
279* some test cases
280*
281 IF ( lsame( diag, 'U' ) ) THEN
282 DO j = 1, na
283 DO i = 1, j
284 a( i, j ) = a( i, j ) /
285 + ( 2.0 * a( j, j ) )
286 END DO
287 END DO
288 END IF
289*
290 ELSE
291*
292* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
293* -> QL factorization.
294*
295 srnamt = 'SGELQF'
296 CALL sgelqf( na, na, a, lda, tau,
297 + s_work_sgeqrf, lda,
298 + info )
299*
300* Forcing main diagonal of test matrix to
301* be unit makes it ill-conditioned for
302* some test cases
303*
304 IF ( lsame( diag, 'U' ) ) THEN
305 DO i = 1, na
306 DO j = 1, i
307 a( i, j ) = a( i, j ) /
308 + ( 2.0 * a( i, i ) )
309 END DO
310 END DO
311 END IF
312*
313 END IF
314*
315* Store a copy of A in RFP format (in ARF).
316*
317 srnamt = 'STRTTF'
318 CALL strttf( cform, uplo, na, a, lda, arf,
319 + info )
320*
321* Generate B1 our M--by--N right-hand side
322* and store a copy in B2.
323*
324 DO j = 1, n
325 DO i = 1, m
326 b1( i, j ) = slarnd( 2, iseed )
327 b2( i, j ) = b1( i, j )
328 END DO
329 END DO
330*
331* Solve op( A ) X = B or X op( A ) = B
332* with STRSM
333*
334 srnamt = 'STRSM'
335 CALL strsm( side, uplo, trans, diag, m, n,
336 + alpha, a, lda, b1, lda )
337*
338* Solve op( A ) X = B or X op( A ) = B
339* with STFSM
340*
341 srnamt = 'STFSM'
342 CALL stfsm( cform, side, uplo, trans,
343 + diag, m, n, alpha, arf, b2,
344 + lda )
345*
346* Check that the result agrees.
347*
348 DO j = 1, n
349 DO i = 1, m
350 b1( i, j ) = b2( i, j ) - b1( i, j )
351 END DO
352 END DO
353*
354 result( 1 ) = slange( 'I', m, n, b1, lda,
355 + s_work_slange )
356*
357 result( 1 ) = result( 1 ) / sqrt( eps )
358 + / max( max( m, n ), 1 )
359*
360 IF( result( 1 ).GE.thresh ) THEN
361 IF( nfail.EQ.0 ) THEN
362 WRITE( nout, * )
363 WRITE( nout, fmt = 9999 )
364 END IF
365 WRITE( nout, fmt = 9997 ) 'STFSM',
366 + cform, side, uplo, trans, diag, m,
367 + n, result( 1 )
368 nfail = nfail + 1
369 END IF
370*
371 100 CONTINUE
372 110 CONTINUE
373 120 CONTINUE
374 130 CONTINUE
375 140 CONTINUE
376 150 CONTINUE
377 160 CONTINUE
378 170 CONTINUE
379*
380* Print a summary of the results.
381*
382 IF ( nfail.EQ.0 ) THEN
383 WRITE( nout, fmt = 9996 ) 'STFSM', nrun
384 ELSE
385 WRITE( nout, fmt = 9995 ) 'STFSM', nfail, nrun
386 END IF
387*
388 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing STFSM
389 + ***')
390 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
391 + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
392 + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
393 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
394 + 'threshold ( ',i5,' tests run)')
395 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
396 + ' tests failed to pass the threshold')
397*
398 RETURN
399*
400* End of SDRVRF3
401*
sgelqf
subroutine sgelqf(m, n, a, lda, tau, work, lwork, info)
SGELQF
Definition sgelqf.f:143
sgeqlf
subroutine sgeqlf(m, n, a, lda, tau, work, lwork, info)
SGEQLF
Definition sgeqlf.f:138
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
slange
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 ...
Definition slange.f:114
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
stfsm
subroutine stfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition stfsm.f:277
strsm
subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRSM
Definition strsm.f:181
strttf
subroutine strttf(transr, uplo, n, a, lda, arf, info)
STRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition strttf.f:194
slarnd
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73
Here is the call graph for this function:
Here is the caller graph for this function: