LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ sdrvsy_aa()

subroutine sdrvsy_aa ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NRHS,
real  THRESH,
logical  TSTERR,
integer  NMAX,
real, dimension( * )  A,
real, dimension( * )  AFAC,
real, dimension( * )  AINV,
real, dimension( * )  B,
real, dimension( * )  X,
real, dimension( * )  XACT,
real, dimension( * )  WORK,
real, dimension( * )  RWORK,
integer, dimension( * )  IWORK,
integer  NOUT 
)

SDRVSY_AA

Purpose:
 SDRVSY_AA tests the driver routine SSYSV_AA.
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[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]NRHS
          NRHS is INTEGER
          The number of right hand side vectors to be generated for
          each linear system.
[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.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[in]NMAX
          NMAX is INTEGER
          The maximum value permitted for N, used in dimensioning the
          work arrays.
[out]A
          A is REAL array, dimension (NMAX*NMAX)
[out]AFAC
          AFAC is REAL array, dimension (NMAX*NMAX)
[out]AINV
          AINV is REAL array, dimension (NMAX*NMAX)
[out]B
          B is REAL array, dimension (NMAX*NRHS)
[out]X
          X is REAL array, dimension (NMAX*NRHS)
[out]XACT
          XACT is REAL array, dimension (NMAX*NRHS)
[out]WORK
          WORK is REAL array, dimension (NMAX*max(2,NRHS))
[out]RWORK
          RWORK is REAL array, dimension (NMAX+2*NRHS)
[out]IWORK
          IWORK is INTEGER array, dimension (2*NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2017

Definition at line 154 of file sdrvsy_aa.f.

154 *
155 * -- LAPACK test routine (version 3.8.0) --
156 * -- LAPACK is a software package provided by Univ. of Tennessee, --
157 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158 * November 2017
159 *
160 * .. Scalar Arguments ..
161  LOGICAL TSTERR
162  INTEGER NMAX, NN, NOUT, NRHS
163  REAL THRESH
164 * ..
165 * .. Array Arguments ..
166  LOGICAL DOTYPE( * )
167  INTEGER IWORK( * ), NVAL( * )
168  REAL A( * ), AFAC( * ), AINV( * ), B( * ),
169  $ RWORK( * ), WORK( * ), X( * ), XACT( * )
170 * ..
171 *
172 * =====================================================================
173 *
174 * .. Parameters ..
175  REAL ONE, ZERO
176  parameter( one = 1.0e+0, zero = 0.0e+0 )
177  INTEGER NTYPES, NTESTS
178  parameter( ntypes = 10, ntests = 3 )
179  INTEGER NFACT
180  parameter( nfact = 2 )
181 * ..
182 * .. Local Scalars ..
183  LOGICAL ZEROT
184  CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
185  CHARACTER*3 MATPATH, PATH
186  INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
187  $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
188  $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
189  REAL ANORM, CNDNUM
190 * ..
191 * .. Local Arrays ..
192  CHARACTER FACTS( NFACT ), UPLOS( 2 )
193  INTEGER ISEED( 4 ), ISEEDY( 4 )
194  REAL RESULT( NTESTS )
195 * ..
196 * .. External Functions ..
197  REAL DGET06, SLANSY
198  EXTERNAL dget06, slansy
199 * ..
200 * .. External Subroutines ..
201  EXTERNAL aladhd, alaerh, alasvm, serrvx, sget04, slacpy,
202  $ slarhs, slaset, slatb4, slatms, spot02,
203  $ ssysv_aa, ssyt01_aa, ssytrf_aa, xlaenv
204 * ..
205 * .. Scalars in Common ..
206  LOGICAL LERR, OK
207  CHARACTER*32 SRNAMT
208  INTEGER INFOT, NUNIT
209 * ..
210 * .. Common blocks ..
211  COMMON / infoc / infot, nunit, ok, lerr
212  COMMON / srnamc / srnamt
213 * ..
214 * .. Intrinsic Functions ..
215  INTRINSIC max, min
216 * ..
217 * .. Data statements ..
218  DATA iseedy / 1988, 1989, 1990, 1991 /
219  DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
220 * ..
221 * .. Executable Statements ..
222 *
223 * Initialize constants and the random number seed.
224 *
225 * Test path
226 *
227  path( 1: 1 ) = 'Single precision'
228  path( 2: 3 ) = 'SA'
229 *
230 * Path to generate matrices
231 *
232  matpath( 1: 1 ) = 'Single precision'
233  matpath( 2: 3 ) = 'SY'
234 *
235  nrun = 0
236  nfail = 0
237  nerrs = 0
238  DO 10 i = 1, 4
239  iseed( i ) = iseedy( i )
240  10 CONTINUE
241 *
242 * Test the error exits
243 *
244  IF( tsterr )
245  $ CALL serrvx( path, nout )
246  infot = 0
247 *
248 * Set the block size and minimum block size for testing.
249 *
250  nb = 1
251  nbmin = 2
252  CALL xlaenv( 1, nb )
253  CALL xlaenv( 2, nbmin )
254 *
255 * Do for each value of N in NVAL
256 *
257  DO 180 in = 1, nn
258  n = nval( in )
259  lwork = max( 3*n-2, n*(1+nb) )
260  lwork = max( lwork, 1 )
261  lda = max( n, 1 )
262  xtype = 'N'
263  nimat = ntypes
264  IF( n.LE.0 )
265  $ nimat = 1
266 *
267  DO 170 imat = 1, nimat
268 *
269 * Do the tests only if DOTYPE( IMAT ) is true.
270 *
271  IF( .NOT.dotype( imat ) )
272  $ GO TO 170
273 *
274 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
275 *
276  zerot = imat.GE.3 .AND. imat.LE.6
277  IF( zerot .AND. n.LT.imat-2 )
278  $ GO TO 170
279 *
280 * Do first for UPLO = 'U', then for UPLO = 'L'
281 *
282  DO 160 iuplo = 1, 2
283  uplo = uplos( iuplo )
284 *
285 * Set up parameters with SLATB4 and generate a test matrix
286 * with SLATMS.
287 *
288  CALL slatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
289  $ MODE, CNDNUM, DIST )
290 *
291  srnamt = 'SLATMS'
292  CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
293  $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
294  $ INFO )
295 *
296 * Check error code from SLATMS.
297 *
298  IF( info.NE.0 ) THEN
299  CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
300  $ -1, -1, imat, nfail, nerrs, nout )
301  GO TO 160
302  END IF
303 *
304 * For types 3-6, zero one or more rows and columns of the
305 * matrix to test that INFO is returned correctly.
306 *
307  IF( zerot ) THEN
308  IF( imat.EQ.3 ) THEN
309  izero = 1
310  ELSE IF( imat.EQ.4 ) THEN
311  izero = n
312  ELSE
313  izero = n / 2 + 1
314  END IF
315 *
316  IF( imat.LT.6 ) THEN
317 *
318 * Set row and column IZERO to zero.
319 *
320  IF( iuplo.EQ.1 ) THEN
321  ioff = ( izero-1 )*lda
322  DO 20 i = 1, izero - 1
323  a( ioff+i ) = zero
324  20 CONTINUE
325  ioff = ioff + izero
326  DO 30 i = izero, n
327  a( ioff ) = zero
328  ioff = ioff + lda
329  30 CONTINUE
330  ELSE
331  ioff = izero
332  DO 40 i = 1, izero - 1
333  a( ioff ) = zero
334  ioff = ioff + lda
335  40 CONTINUE
336  ioff = ioff - izero
337  DO 50 i = izero, n
338  a( ioff+i ) = zero
339  50 CONTINUE
340  END IF
341  ELSE
342  ioff = 0
343  IF( iuplo.EQ.1 ) THEN
344 *
345 * Set the first IZERO rows and columns to zero.
346 *
347  DO 70 j = 1, n
348  i2 = min( j, izero )
349  DO 60 i = 1, i2
350  a( ioff+i ) = zero
351  60 CONTINUE
352  ioff = ioff + lda
353  70 CONTINUE
354  izero = 1
355  ELSE
356 *
357 * Set the last IZERO rows and columns to zero.
358 *
359  DO 90 j = 1, n
360  i1 = max( j, izero )
361  DO 80 i = i1, n
362  a( ioff+i ) = zero
363  80 CONTINUE
364  ioff = ioff + lda
365  90 CONTINUE
366  END IF
367  END IF
368  ELSE
369  izero = 0
370  END IF
371 *
372  DO 150 ifact = 1, nfact
373 *
374 * Do first for FACT = 'F', then for other values.
375 *
376  fact = facts( ifact )
377 *
378 * Form an exact solution and set the right hand side.
379 *
380  srnamt = 'SLARHS'
381  CALL slarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
382  $ nrhs, a, lda, xact, lda, b, lda, iseed,
383  $ info )
384  xtype = 'C'
385 *
386 * --- Test SSYSV_AA ---
387 *
388  IF( ifact.EQ.2 ) THEN
389  CALL slacpy( uplo, n, n, a, lda, afac, lda )
390  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
391 *
392 * Factor the matrix and solve the system using SSYSV_AA.
393 *
394  srnamt = 'SSYSV_AA'
395  CALL ssysv_aa( uplo, n, nrhs, afac, lda, iwork,
396  $ x, lda, work, lwork, info )
397 *
398 * Adjust the expected value of INFO to account for
399 * pivoting.
400 *
401  IF( izero.GT.0 ) THEN
402  j = 1
403  k = izero
404  100 CONTINUE
405  IF( j.EQ.k ) THEN
406  k = iwork( j )
407  ELSE IF( iwork( j ).EQ.k ) THEN
408  k = j
409  END IF
410  IF( j.LT.k ) THEN
411  j = j + 1
412  GO TO 100
413  END IF
414  ELSE
415  k = 0
416  END IF
417 *
418 * Check error code from SSYSV_AA .
419 *
420  IF( info.NE.k ) THEN
421  CALL alaerh( path, 'SSYSV_AA ', info, k,
422  $ uplo, n, n, -1, -1, nrhs,
423  $ imat, nfail, nerrs, nout )
424  GO TO 120
425  ELSE IF( info.NE.0 ) THEN
426  GO TO 120
427  END IF
428 *
429 * Reconstruct matrix from factors and compute
430 * residual.
431 *
432  CALL ssyt01_aa( uplo, n, a, lda, afac, lda,
433  $ iwork, ainv, lda, rwork,
434  $ result( 1 ) )
435 *
436 * Compute residual of the computed solution.
437 *
438  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
439  CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
440  $ lda, rwork, result( 2 ) )
441  nt = 2
442 *
443 * Print information about the tests that did not pass
444 * the threshold.
445 *
446  DO 110 k = 1, nt
447  IF( result( k ).GE.thresh ) THEN
448  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
449  $ CALL aladhd( nout, path )
450  WRITE( nout, fmt = 9999 )'SSYSV_AA ',
451  $ uplo, n, imat, k, result( k )
452  nfail = nfail + 1
453  END IF
454  110 CONTINUE
455  nrun = nrun + nt
456  120 CONTINUE
457  END IF
458 *
459  150 CONTINUE
460 *
461  160 CONTINUE
462  170 CONTINUE
463  180 CONTINUE
464 *
465 * Print a summary of the results.
466 *
467  CALL alasvm( path, nout, nfail, nrun, nerrs )
468 *
469  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
470  $ ', test ', i2, ', ratio =', g12.5 )
471  RETURN
472 *
473 * End of SDRVSY_AA
474 *
Here is the call graph for this function:
Here is the caller graph for this function:
dget06
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:57
slarhs
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
alasvm
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
spot02
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
Definition: spot02.f:129
slacpy
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
ssysv_aa
subroutine ssysv_aa(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
SSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices
Definition: ssysv_aa.f:164
aladhd
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:92
slaset
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.
Definition: slaset.f:112
sget04
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
slansy
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,...
Definition: slansy.f:124
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
ssytrf_aa
subroutine ssytrf_aa(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF_AA
Definition: ssytrf_aa.f:134
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
ssyt01_aa
subroutine ssyt01_aa(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01_AA
Definition: ssyt01_aa.f:127
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
serrvx
subroutine serrvx(PATH, NUNIT)
SERRVX
Definition: serrvx.f:57