LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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  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 *
real function slarnd(IDIST, ISEED)
SLARND
Definition: slarnd.f:73
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
subroutine sgeqlf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQLF
Definition: sgeqlf.f:138
subroutine sgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGEQRF
Definition: sgeqrf.f:145
subroutine sgelqf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
SGELQF
Definition: sgelqf.f:143
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
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
subroutine strsm(SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, B, LDB)
STRSM
Definition: strsm.f:181
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: