LAPACK  3.9.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.
Date
June 2017

Definition at line 120 of file sdrvrf3.f.

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