LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
sdrvrf3.f
Go to the documentation of this file.
1 *> \brief \b SDRVRF3
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
12 * + S_WORK_SLANGE, S_WORK_SGEQRF, TAU )
13 *
14 * .. Scalar Arguments ..
15 * INTEGER LDA, NN, NOUT
16 * REAL THRESH
17 * ..
18 * .. Array Arguments ..
19 * INTEGER NVAL( NN )
20 * REAL A( LDA, * ), ARF( * ), B1( LDA, * ),
21 * + B2( LDA, * ), S_WORK_SGEQRF( * ),
22 * + S_WORK_SLANGE( * ), TAU( * )
23 * ..
24 *
25 *
26 *> \par Purpose:
27 * =============
28 *>
29 *> \verbatim
30 *>
31 *> SDRVRF3 tests the LAPACK RFP routines:
32 *> STFSM
33 *> \endverbatim
34 *
35 * Arguments:
36 * ==========
37 *
38 *> \param[in] NOUT
39 *> \verbatim
40 *> NOUT is INTEGER
41 *> The unit number for output.
42 *> \endverbatim
43 *>
44 *> \param[in] NN
45 *> \verbatim
46 *> NN is INTEGER
47 *> The number of values of N contained in the vector NVAL.
48 *> \endverbatim
49 *>
50 *> \param[in] NVAL
51 *> \verbatim
52 *> NVAL is INTEGER array, dimension (NN)
53 *> The values of the matrix dimension N.
54 *> \endverbatim
55 *>
56 *> \param[in] THRESH
57 *> \verbatim
58 *> THRESH is REAL
59 *> The threshold value for the test ratios. A result is
60 *> included in the output file if RESULT >= THRESH. To have
61 *> every test ratio printed, use THRESH = 0.
62 *> \endverbatim
63 *>
64 *> \param[out] A
65 *> \verbatim
66 *> A is REAL array, dimension (LDA,NMAX)
67 *> \endverbatim
68 *>
69 *> \param[in] LDA
70 *> \verbatim
71 *> LDA is INTEGER
72 *> The leading dimension of the array A. LDA >= max(1,NMAX).
73 *> \endverbatim
74 *>
75 *> \param[out] ARF
76 *> \verbatim
77 *> ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
78 *> \endverbatim
79 *>
80 *> \param[out] B1
81 *> \verbatim
82 *> B1 is REAL array, dimension (LDA,NMAX)
83 *> \endverbatim
84 *>
85 *> \param[out] B2
86 *> \verbatim
87 *> B2 is REAL array, dimension (LDA,NMAX)
88 *> \endverbatim
89 *>
90 *> \param[out] S_WORK_SLANGE
91 *> \verbatim
92 *> S_WORK_SLANGE is REAL array, dimension (NMAX)
93 *> \endverbatim
94 *>
95 *> \param[out] S_WORK_SGEQRF
96 *> \verbatim
97 *> S_WORK_SGEQRF is REAL array, dimension (NMAX)
98 *> \endverbatim
99 *>
100 *> \param[out] TAU
101 *> \verbatim
102 *> TAU is REAL array, dimension (NMAX)
103 *> \endverbatim
104 *
105 * Authors:
106 * ========
107 *
108 *> \author Univ. of Tennessee
109 *> \author Univ. of California Berkeley
110 *> \author Univ. of Colorado Denver
111 *> \author NAG Ltd.
112 *
113 *> \ingroup single_lin
114 *
115 * =====================================================================
116  SUBROUTINE sdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
117  + S_WORK_SLANGE, S_WORK_SGEQRF, TAU )
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  REAL SLAMCH, SLANGE, SLARND
157  EXTERNAL slamch, slange, slarnd
158 * ..
159 * .. External Subroutines ..
160  EXTERNAL strttf, sgeqrf, sgeqlf, stfsm, strsm
161 * ..
162 * .. Intrinsic Functions ..
163  INTRINSIC max, sqrt
164 * ..
165 * .. Scalars in Common ..
166  CHARACTER*32 SRNAMT
167 * ..
168 * .. Common blocks ..
169  COMMON / srnamc / srnamt
170 * ..
171 * .. Data statements ..
172  DATA iseedy / 1988, 1989, 1990, 1991 /
173  DATA uplos / 'U', 'L' /
174  DATA forms / 'N', 'T' /
175  DATA sides / 'L', 'R' /
176  DATA transs / 'N', 'T' /
177  DATA diags / 'N', 'U' /
178 * ..
179 * .. Executable Statements ..
180 *
181 * Initialize constants and the random number seed.
182 *
183  nrun = 0
184  nfail = 0
185  info = 0
186  DO 10 i = 1, 4
187  iseed( i ) = iseedy( i )
188  10 CONTINUE
189  eps = slamch( 'Precision' )
190 *
191  DO 170 iim = 1, nn
192 *
193  m = nval( iim )
194 *
195  DO 160 iin = 1, nn
196 *
197  n = nval( iin )
198 *
199  DO 150 iform = 1, 2
200 *
201  cform = forms( iform )
202 *
203  DO 140 iuplo = 1, 2
204 *
205  uplo = uplos( iuplo )
206 *
207  DO 130 iside = 1, 2
208 *
209  side = sides( iside )
210 *
211  DO 120 itrans = 1, 2
212 *
213  trans = transs( itrans )
214 *
215  DO 110 idiag = 1, 2
216 *
217  diag = diags( idiag )
218 *
219  DO 100 ialpha = 1, 3
220 *
221  IF ( ialpha.EQ. 1) THEN
222  alpha = zero
223  ELSE IF ( ialpha.EQ. 2) THEN
224  alpha = one
225  ELSE
226  alpha = slarnd( 2, iseed )
227  END IF
228 *
229 * All the parameters are set:
230 * CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
231 * and ALPHA
232 * READY TO TEST!
233 *
234  nrun = nrun + 1
235 *
236  IF ( iside.EQ.1 ) THEN
237 *
238 * The case ISIDE.EQ.1 is when SIDE.EQ.'L'
239 * -> A is M-by-M ( B is M-by-N )
240 *
241  na = m
242 *
243  ELSE
244 *
245 * The case ISIDE.EQ.2 is when SIDE.EQ.'R'
246 * -> A is N-by-N ( B is M-by-N )
247 *
248  na = n
249 *
250  END IF
251 *
252 * Generate A our NA--by--NA triangular
253 * matrix.
254 * Our test is based on forward error so we
255 * do want A to be well conditioned! To get
256 * a well-conditioned triangular matrix, we
257 * take the R factor of the QR/LQ factorization
258 * of a random matrix.
259 *
260  DO j = 1, na
261  DO i = 1, na
262  a( i, j) = slarnd( 2, iseed )
263  END DO
264  END DO
265 *
266  IF ( iuplo.EQ.1 ) THEN
267 *
268 * The case IUPLO.EQ.1 is when SIDE.EQ.'U'
269 * -> QR factorization.
270 *
271  srnamt = 'SGEQRF'
272  CALL sgeqrf( na, na, a, lda, tau,
273  + s_work_sgeqrf, lda,
274  + info )
275  ELSE
276 *
277 * The case IUPLO.EQ.2 is when SIDE.EQ.'L'
278 * -> QL factorization.
279 *
280  srnamt = 'SGELQF'
281  CALL sgelqf( na, na, a, lda, tau,
282  + s_work_sgeqrf, lda,
283  + info )
284  END IF
285 *
286 * Store a copy of A in RFP format (in ARF).
287 *
288  srnamt = 'STRTTF'
289  CALL strttf( cform, uplo, na, a, lda, arf,
290  + info )
291 *
292 * Generate B1 our M--by--N right-hand side
293 * and store a copy in B2.
294 *
295  DO j = 1, n
296  DO i = 1, m
297  b1( i, j) = slarnd( 2, iseed )
298  b2( i, j) = b1( i, j)
299  END DO
300  END DO
301 *
302 * Solve op( A ) X = B or X op( A ) = B
303 * with STRSM
304 *
305  srnamt = 'STRSM'
306  CALL strsm( side, uplo, trans, diag, m, n,
307  + alpha, a, lda, b1, lda )
308 *
309 * Solve op( A ) X = B or X op( A ) = B
310 * with STFSM
311 *
312  srnamt = 'STFSM'
313  CALL stfsm( cform, side, uplo, trans,
314  + diag, m, n, alpha, arf, b2,
315  + lda )
316 *
317 * Check that the result agrees.
318 *
319  DO j = 1, n
320  DO i = 1, m
321  b1( i, j) = b2( i, j ) - b1( i, j )
322  END DO
323  END DO
324 *
325  result(1) = slange( 'I', m, n, b1, lda,
326  + s_work_slange )
327 *
328  result(1) = result(1) / sqrt( eps )
329  + / max( max( m, n), 1 )
330 *
331  IF( result(1).GE.thresh ) THEN
332  IF( nfail.EQ.0 ) THEN
333  WRITE( nout, * )
334  WRITE( nout, fmt = 9999 )
335  END IF
336  WRITE( nout, fmt = 9997 ) 'STFSM',
337  + cform, side, uplo, trans, diag, m,
338  + n, result(1)
339  nfail = nfail + 1
340  END IF
341 *
342  100 CONTINUE
343  110 CONTINUE
344  120 CONTINUE
345  130 CONTINUE
346  140 CONTINUE
347  150 CONTINUE
348  160 CONTINUE
349  170 CONTINUE
350 *
351 * Print a summary of the results.
352 *
353  IF ( nfail.EQ.0 ) THEN
354  WRITE( nout, fmt = 9996 ) 'STFSM', nrun
355  ELSE
356  WRITE( nout, fmt = 9995 ) 'STFSM', nfail, nrun
357  END IF
358 *
359  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing STFSM
360  + ***')
361  9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
362  + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
363  + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
364  9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
365  + 'threshold ( ',i5,' tests run)')
366  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
367  + ' tests failed to pass the threshold')
368 *
369  RETURN
370 *
371 * End of SDRVRF3
372 *
373  END
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
sgelqf
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
Definition: sgelqf.f:143
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
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
strsm
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:181
sdrvrf3
subroutine sdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, S_WORK_SLANGE, S_WORK_SGEQRF, TAU)
SDRVRF3
Definition: sdrvrf3.f:118