LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ schksy_aa()

subroutine schksy_aa ( logical, dimension( * )  DOTYPE,
integer  NN,
integer, dimension( * )  NVAL,
integer  NNB,
integer, dimension( * )  NBVAL,
integer  NNS,
integer, dimension( * )  NSVAL,
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 
)

SCHKSY_AA

Purpose: 
 SCHKSY_AA tests SSYTRF_AA, -TRS_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]NNB
          NNB is INTEGER
          The number of values of NB contained in the vector NBVAL.
[in]NBVAL
          NBVAL is INTEGER array, dimension (NBVAL)
          The values of the blocksize NB.
[in]NNS
          NNS is INTEGER
          The number of values of NRHS contained in the vector NSVAL.
[in]NSVAL
          NSVAL is INTEGER array, dimension (NNS)
          The values of the number of right hand sides NRHS.
[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*NSMAX)
          where NSMAX is the largest entry in NSVAL.
[out]X
          X is REAL array, dimension (NMAX*NSMAX)
[out]XACT
          XACT is REAL array, dimension (NMAX*NSMAX)
[out]WORK
          WORK is REAL array, dimension (NMAX*max(3,NSMAX))
[out]RWORK
          RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
[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
June 2017

Definition at line 174 of file schksy_aa.f.

174 *
175 * -- LAPACK test routine (version 3.7.1) --
176 * -- LAPACK is a software package provided by Univ. of Tennessee, --
177 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
178 * June 2017
179 *
180  IMPLICIT NONE
181 *
182 * .. Scalar Arguments ..
183  LOGICAL tsterr
184  INTEGER nn, nnb, nns, nmax, nout
185  REAL thresh
186 * ..
187 * .. Array Arguments ..
188  LOGICAL dotype( * )
189  INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
190  REAL a( * ), afac( * ), ainv( * ), b( * ),
191  $ rwork( * ), work( * ), x( * ), xact( * )
192 * ..
193 *
194 * =====================================================================
195 *
196 * .. Parameters ..
197  REAL zero
198  parameter( zero = 0.0e+0 )
199  INTEGER ntypes
200  parameter( ntypes = 10 )
201  INTEGER ntests
202  parameter( ntests = 9 )
203 * ..
204 * .. Local Scalars ..
205  LOGICAL zerot
206  CHARACTER dist, TYPE, uplo, xtype
207  CHARACTER*3 path, matpath
208  INTEGER i, i1, i2, imat, in, inb, info, ioff, irhs,
209  $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
210  $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
211  REAL anorm, cndnum
212 * ..
213 * .. Local Arrays ..
214  CHARACTER uplos( 2 )
215  INTEGER iseed( 4 ), iseedy( 4 )
216  REAL result( ntests )
217 * ..
218 * .. External Subroutines ..
219  EXTERNAL alaerh, alahd, alasum, serrsy, slacpy, slarhs,
220  $ slatb4, slatms, spot02, ssyt01_aa, ssytrf_aa,
221  $ ssytrs_aa, xlaenv
222 * ..
223 * .. Intrinsic Functions ..
224  INTRINSIC max, min
225 * ..
226 * .. Scalars in Common ..
227  LOGICAL lerr, ok
228  CHARACTER*32 srnamt
229  INTEGER infot, nunit
230 * ..
231 * .. Common blocks ..
232  COMMON / infoc / infot, nunit, ok, lerr
233  COMMON / srnamc / srnamt
234 * ..
235 * .. Data statements ..
236  DATA iseedy / 1988, 1989, 1990, 1991 /
237  DATA uplos / 'U', 'L' /
238 * ..
239 * .. Executable Statements ..
240 *
241 * Initialize constants and the random number seed.
242 *
243 *
244 * Test path
245 *
246  path( 1: 1 ) = 'Single precision'
247  path( 2: 3 ) = 'SA'
248 *
249 * Path to generate matrices
250 *
251  matpath( 1: 1 ) = 'Single precision'
252  matpath( 2: 3 ) = 'SY'
253  nrun = 0
254  nfail = 0
255  nerrs = 0
256  DO 10 i = 1, 4
257  iseed( i ) = iseedy( i )
258  10 CONTINUE
259 *
260 * Test the error exits
261 *
262  IF( tsterr )
263  $ CALL serrsy( path, nout )
264  infot = 0
265 *
266 * Set the minimum block size for which the block routine should
267 * be used, which will be later returned by ILAENV
268 *
269  CALL xlaenv( 2, 2 )
270 *
271 * Do for each value of N in NVAL
272 *
273  DO 180 in = 1, nn
274  n = nval( in )
275  IF( n .GT. nmax ) THEN
276  nfail = nfail + 1
277  WRITE(nout, 9995) 'M ', n, nmax
278  GO TO 180
279  END IF
280  lda = max( n, 1 )
281  xtype = 'N'
282  nimat = ntypes
283  IF( n.LE.0 )
284  $ nimat = 1
285 *
286  izero = 0
287 *
288 * Do for each value of matrix type IMAT
289 *
290  DO 170 imat = 1, nimat
291 *
292 * Do the tests only if DOTYPE( IMAT ) is true.
293 *
294  IF( .NOT.dotype( imat ) )
295  $ GO TO 170
296 *
297 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
298 *
299  zerot = imat.GE.3 .AND. imat.LE.6
300  IF( zerot .AND. n.LT.imat-2 )
301  $ GO TO 170
302 *
303 * Do first for UPLO = 'U', then for UPLO = 'L'
304 *
305  DO 160 iuplo = 1, 2
306  uplo = uplos( iuplo )
307 *
308 * Begin generate the test matrix A.
309 *
310 *
311 * Set up parameters with SLATB4 for the matrix generator
312 * based on the type of matrix to be generated.
313 *
314  CALL slatb4( matpath, imat, n, n, TYPE, kl, ku,
315  $ anorm, mode, cndnum, dist )
316 *
317 * Generate a matrix with SLATMS.
318 *
319  srnamt = 'SLATMS'
320  CALL slatms( n, n, dist, iseed, TYPE, rwork, mode,
321  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
322  $ info )
323 *
324 * Check error code from SLATMS and handle error.
325 *
326  IF( info.NE.0 ) THEN
327  CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
328  $ -1, -1, imat, nfail, nerrs, nout )
329 *
330 * Skip all tests for this generated matrix
331 *
332  GO TO 160
333  END IF
334 *
335 * For matrix types 3-6, zero one or more rows and
336 * columns of the matrix to test that INFO is returned
337 * correctly.
338 *
339  IF( zerot ) THEN
340  IF( imat.EQ.3 ) THEN
341  izero = 1
342  ELSE IF( imat.EQ.4 ) THEN
343  izero = n
344  ELSE
345  izero = n / 2 + 1
346  END IF
347 *
348  IF( imat.LT.6 ) THEN
349 *
350 * Set row and column IZERO to zero.
351 *
352  IF( iuplo.EQ.1 ) THEN
353  ioff = ( izero-1 )*lda
354  DO 20 i = 1, izero - 1
355  a( ioff+i ) = zero
356  20 CONTINUE
357  ioff = ioff + izero
358  DO 30 i = izero, n
359  a( ioff ) = zero
360  ioff = ioff + lda
361  30 CONTINUE
362  ELSE
363  ioff = izero
364  DO 40 i = 1, izero - 1
365  a( ioff ) = zero
366  ioff = ioff + lda
367  40 CONTINUE
368  ioff = ioff - izero
369  DO 50 i = izero, n
370  a( ioff+i ) = zero
371  50 CONTINUE
372  END IF
373  ELSE
374  IF( iuplo.EQ.1 ) THEN
375 *
376 * Set the first IZERO rows and columns to zero.
377 *
378  ioff = 0
379  DO 70 j = 1, n
380  i2 = min( j, izero )
381  DO 60 i = 1, i2
382  a( ioff+i ) = zero
383  60 CONTINUE
384  ioff = ioff + lda
385  70 CONTINUE
386  izero = 1
387  ELSE
388 *
389 * Set the last IZERO rows and columns to zero.
390 *
391  ioff = 0
392  DO 90 j = 1, n
393  i1 = max( j, izero )
394  DO 80 i = i1, n
395  a( ioff+i ) = zero
396  80 CONTINUE
397  ioff = ioff + lda
398  90 CONTINUE
399  END IF
400  END IF
401  ELSE
402  izero = 0
403  END IF
404 *
405 * End generate the test matrix A.
406 *
407 * Do for each value of NB in NBVAL
408 *
409  DO 150 inb = 1, nnb
410 *
411 * Set the optimal blocksize, which will be later
412 * returned by ILAENV.
413 *
414  nb = nbval( inb )
415  CALL xlaenv( 1, nb )
416 *
417 * Copy the test matrix A into matrix AFAC which
418 * will be factorized in place. This is needed to
419 * preserve the test matrix A for subsequent tests.
420 *
421  CALL slacpy( uplo, n, n, a, lda, afac, lda )
422 *
423 * Compute the L*D*L**T or U*D*U**T factorization of the
424 * matrix. IWORK stores details of the interchanges and
425 * the block structure of D. AINV is a work array for
426 * block factorization, LWORK is the length of AINV.
427 *
428  srnamt = 'SSYTRF_AA'
429  lwork = max( 1, n*nb + n )
430  CALL ssytrf_aa( uplo, n, afac, lda, iwork, ainv,
431  $ lwork, info )
432 *
433 * Adjust the expected value of INFO to account for
434 * pivoting.
435 *
436 c IF( IZERO.GT.0 ) THEN
437 c J = 1
438 c K = IZERO
439 c 100 CONTINUE
440 c IF( J.EQ.K ) THEN
441 c K = IWORK( J )
442 c ELSE IF( IWORK( J ).EQ.K ) THEN
443 c K = J
444 c END IF
445 c IF( J.LT.K ) THEN
446 c J = J + 1
447 c GO TO 100
448 c END IF
449 c ELSE
450  k = 0
451 c END IF
452 *
453 * Check error code from SSYTRF and handle error.
454 *
455  IF( info.NE.k ) THEN
456  CALL alaerh( path, 'SSYTRF_AA', info, k, uplo,
457  $ n, n, -1, -1, nb, imat, nfail, nerrs,
458  $ nout )
459  END IF
460 *
461 *+ TEST 1
462 * Reconstruct matrix from factors and compute residual.
463 *
464  CALL ssyt01_aa( uplo, n, a, lda, afac, lda, iwork,
465  $ ainv, lda, rwork, result( 1 ) )
466  nt = 1
467 *
468 *
469 * Print information about the tests that did not pass
470 * the threshold.
471 *
472  DO 110 k = 1, nt
473  IF( result( k ).GE.thresh ) THEN
474  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475  $ CALL alahd( nout, path )
476  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
477  $ result( k )
478  nfail = nfail + 1
479  END IF
480  110 CONTINUE
481  nrun = nrun + nt
482 *
483 * Skip solver test if INFO is not 0.
484 *
485  IF( info.NE.0 ) THEN
486  GO TO 140
487  END IF
488 *
489 * Do for each value of NRHS in NSVAL.
490 *
491  DO 130 irhs = 1, nns
492  nrhs = nsval( irhs )
493 *
494 *+ TEST 2 (Using TRS)
495 * Solve and compute residual for A * X = B.
496 *
497 * Choose a set of NRHS random solution vectors
498 * stored in XACT and set up the right hand side B
499 *
500  srnamt = 'SLARHS'
501  CALL slarhs( matpath, xtype, uplo, ' ', n, n,
502  $ kl, ku, nrhs, a, lda, xact, lda,
503  $ b, lda, iseed, info )
504  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
505 *
506  srnamt = 'SSYTRS_AA'
507  lwork = max( 1, 3*n-2 )
508  CALL ssytrs_aa( uplo, n, nrhs, afac, lda,
509  $ iwork, x, lda, work, lwork,
510  $ info )
511 *
512 * Check error code from SSYTRS and handle error.
513 *
514  IF( info.NE.0 ) THEN
515  IF( izero.EQ.0 ) THEN
516  CALL alaerh( path, 'SSYTRS_AA', info, 0,
517  $ uplo, n, n, -1, -1, nrhs, imat,
518  $ nfail, nerrs, nout )
519  END IF
520  ELSE
521  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda
522  $ )
523 *
524 * Compute the residual for the solution
525 *
526  CALL spot02( uplo, n, nrhs, a, lda, x, lda,
527  $ work, lda, rwork, result( 2 ) )
528 *
529 *
530 * Print information about the tests that did not pass
531 * the threshold.
532 *
533  DO 120 k = 2, 2
534  IF( result( k ).GE.thresh ) THEN
535  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
536  $ CALL alahd( nout, path )
537  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
538  $ imat, k, result( k )
539  nfail = nfail + 1
540  END IF
541  120 CONTINUE
542  END IF
543  nrun = nrun + 1
544 *
545 * End do for each value of NRHS in NSVAL.
546 *
547  130 CONTINUE
548  140 CONTINUE
549  150 CONTINUE
550  160 CONTINUE
551  170 CONTINUE
552  180 CONTINUE
553 *
554 * Print a summary of the results.
555 *
556  CALL alasum( path, nout, nfail, nrun, nerrs )
557 *
558  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
559  $ i2, ', test ', i2, ', ratio =', g12.5 )
560  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
561  $ i2, ', test(', i2, ') =', g12.5 )
562  9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
563  $ i6 )
564  RETURN
565 *
566 * End of SCHKSY_AA
567 *
alahd
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
ssytrf_aa
subroutine ssytrf_aa(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF_AA
Definition: ssytrf_aa.f:134
spot02
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
Definition: spot02.f:129
ssyt01_aa
subroutine ssyt01_aa(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01_AA
Definition: ssyt01_aa.f:127
alaerh
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
slatb4
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
xlaenv
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
slatms
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
serrsy
subroutine serrsy(PATH, NUNIT)
SERRSY
Definition: serrsy.f:57
ssytrs_aa
subroutine ssytrs_aa(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
SSYTRS_AA
Definition: ssytrs_aa.f:131
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
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
alasum
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
Here is the call graph for this function:
Here is the caller graph for this function: