LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ schksy()

subroutine schksy ( 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

Purpose:
 SCHKSY tests SSYTRF, -TRI2, -TRS, -TRS2, -RFS, and -CON.
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
November 2013

Definition at line 172 of file schksy.f.

172 *
173 * -- LAPACK test routine (version 3.5.0) --
174 * -- LAPACK is a software package provided by Univ. of Tennessee, --
175 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176 * November 2013
177 *
178 * .. Scalar Arguments ..
179  LOGICAL tsterr
180  INTEGER nmax, nn, nnb, nns, nout
181  REAL thresh
182 * ..
183 * .. Array Arguments ..
184  LOGICAL dotype( * )
185  INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
186  REAL a( * ), afac( * ), ainv( * ), b( * ),
187  $ rwork( * ), work( * ), x( * ), xact( * )
188 * ..
189 *
190 * =====================================================================
191 *
192 * .. Parameters ..
193  REAL zero
194  parameter( zero = 0.0e+0 )
195  INTEGER ntypes
196  parameter( ntypes = 10 )
197  INTEGER ntests
198  parameter( ntests = 9 )
199 * ..
200 * .. Local Scalars ..
201  LOGICAL trfcon, zerot
202  CHARACTER dist, TYPE, uplo, xtype
203  CHARACTER*3 path
204  INTEGER i, i1, i2, imat, in, inb, info, ioff, irhs,
205  $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
206  $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
207  REAL anorm, cndnum, rcond, rcondc
208 * ..
209 * .. Local Arrays ..
210  CHARACTER uplos( 2 )
211  INTEGER iseed( 4 ), iseedy( 4 )
212  REAL result( ntests )
213 * ..
214 * .. External Functions ..
215  REAL sget06, slansy
216  EXTERNAL sget06, slansy
217 * ..
218 * .. External Subroutines ..
219  EXTERNAL alaerh, alahd, alasum, serrsy, sget04, slacpy,
223 * ..
224 * .. Intrinsic Functions ..
225  INTRINSIC max, min
226 * ..
227 * .. Scalars in Common ..
228  LOGICAL lerr, ok
229  CHARACTER*32 srnamt
230  INTEGER infot, nunit
231 * ..
232 * .. Common blocks ..
233  COMMON / infoc / infot, nunit, ok, lerr
234  COMMON / srnamc / srnamt
235 * ..
236 * .. Data statements ..
237  DATA iseedy / 1988, 1989, 1990, 1991 /
238  DATA uplos / 'U', 'L' /
239 * ..
240 * .. Executable Statements ..
241 *
242 * Initialize constants and the random number seed.
243 *
244  path( 1: 1 ) = 'Single precision'
245  path( 2: 3 ) = 'SY'
246  nrun = 0
247  nfail = 0
248  nerrs = 0
249  DO 10 i = 1, 4
250  iseed( i ) = iseedy( i )
251  10 CONTINUE
252 *
253 * Test the error exits
254 *
255  IF( tsterr )
256  $ CALL serrsy( path, nout )
257  infot = 0
258 *
259 * Set the minimum block size for which the block routine should
260 * be used, which will be later returned by ILAENV
261 *
262  CALL xlaenv( 2, 2 )
263 *
264 * Do for each value of N in NVAL
265 *
266  DO 180 in = 1, nn
267  n = nval( in )
268  lda = max( n, 1 )
269  xtype = 'N'
270  nimat = ntypes
271  IF( n.LE.0 )
272  $ nimat = 1
273 *
274  izero = 0
275 *
276 * Do for each value of matrix type IMAT
277 *
278  DO 170 imat = 1, nimat
279 *
280 * Do the tests only if DOTYPE( IMAT ) is true.
281 *
282  IF( .NOT.dotype( imat ) )
283  $ GO TO 170
284 *
285 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
286 *
287  zerot = imat.GE.3 .AND. imat.LE.6
288  IF( zerot .AND. n.LT.imat-2 )
289  $ GO TO 170
290 *
291 * Do first for UPLO = 'U', then for UPLO = 'L'
292 *
293  DO 160 iuplo = 1, 2
294  uplo = uplos( iuplo )
295 *
296 * Begin generate the test matrix A.
297 *
298 * Set up parameters with SLATB4 for the matrix generator
299 * based on the type of matrix to be generated.
300 *
301  CALL slatb4( path, imat, n, n, TYPE, kl, ku, anorm, mode,
302  $ cndnum, dist )
303 *
304 * Generate a matrix with SLATMS.
305 *
306  srnamt = 'SLATMS'
307  CALL slatms( n, n, dist, iseed, TYPE, rwork, mode,
308  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
309  $ info )
310 *
311 * Check error code from SLATMS and handle error.
312 *
313  IF( info.NE.0 ) THEN
314  CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
315  $ -1, -1, imat, nfail, nerrs, nout )
316 *
317 * Skip all tests for this generated matrix
318 *
319  GO TO 160
320  END IF
321 *
322 * For matrix types 3-6, zero one or more rows and
323 * columns of the matrix to test that INFO is returned
324 * correctly.
325 *
326  IF( zerot ) THEN
327  IF( imat.EQ.3 ) THEN
328  izero = 1
329  ELSE IF( imat.EQ.4 ) THEN
330  izero = n
331  ELSE
332  izero = n / 2 + 1
333  END IF
334 *
335  IF( imat.LT.6 ) THEN
336 *
337 * Set row and column IZERO to zero.
338 *
339  IF( iuplo.EQ.1 ) THEN
340  ioff = ( izero-1 )*lda
341  DO 20 i = 1, izero - 1
342  a( ioff+i ) = zero
343  20 CONTINUE
344  ioff = ioff + izero
345  DO 30 i = izero, n
346  a( ioff ) = zero
347  ioff = ioff + lda
348  30 CONTINUE
349  ELSE
350  ioff = izero
351  DO 40 i = 1, izero - 1
352  a( ioff ) = zero
353  ioff = ioff + lda
354  40 CONTINUE
355  ioff = ioff - izero
356  DO 50 i = izero, n
357  a( ioff+i ) = zero
358  50 CONTINUE
359  END IF
360  ELSE
361  IF( iuplo.EQ.1 ) THEN
362 *
363 * Set the first IZERO rows and columns to zero.
364 *
365  ioff = 0
366  DO 70 j = 1, n
367  i2 = min( j, izero )
368  DO 60 i = 1, i2
369  a( ioff+i ) = zero
370  60 CONTINUE
371  ioff = ioff + lda
372  70 CONTINUE
373  ELSE
374 *
375 * Set the last IZERO rows and columns to zero.
376 *
377  ioff = 0
378  DO 90 j = 1, n
379  i1 = max( j, izero )
380  DO 80 i = i1, n
381  a( ioff+i ) = zero
382  80 CONTINUE
383  ioff = ioff + lda
384  90 CONTINUE
385  END IF
386  END IF
387  ELSE
388  izero = 0
389  END IF
390 *
391 * End generate the test matrix A.
392 *
393 *
394 * Do for each value of NB in NBVAL
395 *
396  DO 150 inb = 1, nnb
397 *
398 * Set the optimal blocksize, which will be later
399 * returned by ILAENV.
400 *
401  nb = nbval( inb )
402  CALL xlaenv( 1, nb )
403 *
404 * Copy the test matrix A into matrix AFAC which
405 * will be factorized in place. This is needed to
406 * preserve the test matrix A for subsequent tests.
407 *
408  CALL slacpy( uplo, n, n, a, lda, afac, lda )
409 *
410 * Compute the L*D*L**T or U*D*U**T factorization of the
411 * matrix. IWORK stores details of the interchanges and
412 * the block structure of D. AINV is a work array for
413 * block factorization, LWORK is the length of AINV.
414 *
415  lwork = max( 2, nb )*lda
416  srnamt = 'SSYTRF'
417  CALL ssytrf( uplo, n, afac, lda, iwork, ainv, lwork,
418  $ info )
419 *
420 * Adjust the expected value of INFO to account for
421 * pivoting.
422 *
423  k = izero
424  IF( k.GT.0 ) THEN
425  100 CONTINUE
426  IF( iwork( k ).LT.0 ) THEN
427  IF( iwork( k ).NE.-k ) THEN
428  k = -iwork( k )
429  GO TO 100
430  END IF
431  ELSE IF( iwork( k ).NE.k ) THEN
432  k = iwork( k )
433  GO TO 100
434  END IF
435  END IF
436 *
437 * Check error code from SSYTRF and handle error.
438 *
439  IF( info.NE.k )
440  $ CALL alaerh( path, 'SSYTRF', info, k, uplo, n, n,
441  $ -1, -1, nb, imat, nfail, nerrs, nout )
442 *
443 * Set the condition estimate flag if the INFO is not 0.
444 *
445  IF( info.NE.0 ) THEN
446  trfcon = .true.
447  ELSE
448  trfcon = .false.
449  END IF
450 *
451 *+ TEST 1
452 * Reconstruct matrix from factors and compute residual.
453 *
454  CALL ssyt01( uplo, n, a, lda, afac, lda, iwork, ainv,
455  $ lda, rwork, result( 1 ) )
456  nt = 1
457 *
458 *+ TEST 2
459 * Form the inverse and compute the residual,
460 * if the factorization was competed without INFO > 0
461 * (i.e. there is no zero rows and columns).
462 * Do it only for the first block size.
463 *
464  IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
465  CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
466  srnamt = 'SSYTRI2'
467  lwork = (n+nb+1)*(nb+3)
468  CALL ssytri2( uplo, n, ainv, lda, iwork, work,
469  $ lwork, info )
470 *
471 * Check error code from SSYTRI2 and handle error.
472 *
473  IF( info.NE.0 )
474  $ CALL alaerh( path, 'SSYTRI2', info, -1, uplo, n,
475  $ n, -1, -1, -1, imat, nfail, nerrs,
476  $ nout )
477 *
478 * Compute the residual for a symmetric matrix times
479 * its inverse.
480 *
481  CALL spot03( uplo, n, a, lda, ainv, lda, work, lda,
482  $ rwork, rcondc, result( 2 ) )
483  nt = 2
484  END IF
485 *
486 * Print information about the tests that did not pass
487 * the threshold.
488 *
489  DO 110 k = 1, nt
490  IF( result( k ).GE.thresh ) THEN
491  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
492  $ CALL alahd( nout, path )
493  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
494  $ result( k )
495  nfail = nfail + 1
496  END IF
497  110 CONTINUE
498  nrun = nrun + nt
499 *
500 * Skip the other tests if this is not the first block
501 * size.
502 *
503  IF( inb.GT.1 )
504  $ GO TO 150
505 *
506 * Do only the condition estimate if INFO is not 0.
507 *
508  IF( trfcon ) THEN
509  rcondc = zero
510  GO TO 140
511  END IF
512 *
513 * Do for each value of NRHS in NSVAL.
514 *
515  DO 130 irhs = 1, nns
516  nrhs = nsval( irhs )
517 *
518 *+ TEST 3 (Using DSYTRS)
519 * Solve and compute residual for A * X = B.
520 *
521 * Choose a set of NRHS random solution vectors
522 * stored in XACT and set up the right hand side B
523 *
524  srnamt = 'SLARHS'
525  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
526  $ nrhs, a, lda, xact, lda, b, lda,
527  $ iseed, info )
528  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
529 *
530  srnamt = 'SSYTRS'
531  CALL ssytrs( uplo, n, nrhs, afac, lda, iwork, x,
532  $ lda, info )
533 *
534 * Check error code from SSYTRS and handle error.
535 *
536  IF( info.NE.0 )
537  $ CALL alaerh( path, 'SSYTRS', info, 0, uplo, n,
538  $ n, -1, -1, nrhs, imat, nfail,
539  $ nerrs, nout )
540 *
541  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
542 *
543 * Compute the residual for the solution
544 *
545  CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
546  $ lda, rwork, result( 3 ) )
547 *
548 *+ TEST 4 (Using DSYTRS2)
549 * Solve and compute residual for A * X = B.
550 *
551 * Choose a set of NRHS random solution vectors
552 * stored in XACT and set up the right hand side B
553 *
554  srnamt = 'SLARHS'
555  CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
556  $ nrhs, a, lda, xact, lda, b, lda,
557  $ iseed, info )
558  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
559 *
560  srnamt = 'DSYTRS2'
561  CALL ssytrs2( uplo, n, nrhs, afac, lda, iwork, x,
562  $ lda, work, info )
563 *
564 * Check error code from SSYTRS2 and handle error.
565 *
566  IF( info.NE.0 )
567  $ CALL alaerh( path, 'SSYTRS2', info, 0, uplo, n,
568  $ n, -1, -1, nrhs, imat, nfail,
569  $ nerrs, nout )
570 *
571  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
572 *
573 * Compute the residual for the solution
574 *
575  CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
576  $ lda, rwork, result( 4 ) )
577 *
578 *+ TEST 5
579 * Check solution from generated exact solution.
580 *
581  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
582  $ result( 5 ) )
583 *
584 *+ TESTS 6, 7, and 8
585 * Use iterative refinement to improve the solution.
586 *
587  srnamt = 'SSYRFS'
588  CALL ssyrfs( uplo, n, nrhs, a, lda, afac, lda,
589  $ iwork, b, lda, x, lda, rwork,
590  $ rwork( nrhs+1 ), work, iwork( n+1 ),
591  $ info )
592 *
593 * Check error code from SSYRFS and handle error.
594 *
595  IF( info.NE.0 )
596  $ CALL alaerh( path, 'SSYRFS', info, 0, uplo, n,
597  $ n, -1, -1, nrhs, imat, nfail,
598  $ nerrs, nout )
599 *
600  CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
601  $ result( 6 ) )
602  CALL spot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
603  $ xact, lda, rwork, rwork( nrhs+1 ),
604  $ result( 7 ) )
605 *
606 * Print information about the tests that did not pass
607 * the threshold.
608 *
609  DO 120 k = 3, 8
610  IF( result( k ).GE.thresh ) THEN
611  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
612  $ CALL alahd( nout, path )
613  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
614  $ imat, k, result( k )
615  nfail = nfail + 1
616  END IF
617  120 CONTINUE
618  nrun = nrun + 6
619 *
620 * End do for each value of NRHS in NSVAL.
621 *
622  130 CONTINUE
623 *
624 *+ TEST 9
625 * Get an estimate of RCOND = 1/CNDNUM.
626 *
627  140 CONTINUE
628  anorm = slansy( '1', uplo, n, a, lda, rwork )
629  srnamt = 'SSYCON'
630  CALL ssycon( uplo, n, afac, lda, iwork, anorm, rcond,
631  $ work, iwork( n+1 ), info )
632 *
633 * Check error code from SSYCON and handle error.
634 *
635  IF( info.NE.0 )
636  $ CALL alaerh( path, 'SSYCON', info, 0, uplo, n, n,
637  $ -1, -1, -1, imat, nfail, nerrs, nout )
638 *
639 * Compute the test ratio to compare to values of RCOND
640 *
641  result( 9 ) = sget06( rcond, rcondc )
642 *
643 * Print information about the tests that did not pass
644 * the threshold.
645 *
646  IF( result( 9 ).GE.thresh ) THEN
647  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
648  $ CALL alahd( nout, path )
649  WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
650  $ result( 9 )
651  nfail = nfail + 1
652  END IF
653  nrun = nrun + 1
654  150 CONTINUE
655 *
656  160 CONTINUE
657  170 CONTINUE
658  180 CONTINUE
659 *
660 * Print a summary of the results.
661 *
662  CALL alasum( path, nout, nfail, nrun, nerrs )
663 *
664  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
665  $ i2, ', test ', i2, ', ratio =', g12.5 )
666  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
667  $ i2, ', test(', i2, ') =', g12.5 )
668  9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
669  $ ', test(', i2, ') =', g12.5 )
670  RETURN
671 *
672 * End of SCHKSY
673 *
subroutine ssytri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRI2
Definition: ssytri2.f:129
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine spot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SPOT02
Definition: spot02.f:129
subroutine ssyrfs(UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SSYRFS
Definition: ssyrfs.f:193
subroutine ssycon(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SSYCON
Definition: ssycon.f:132
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine ssyt01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01
Definition: ssyt01.f:126
subroutine ssytrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SSYTRS
Definition: ssytrs.f:122
subroutine ssytrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
SSYTRF
Definition: ssytrf.f:184
subroutine ssyconv(UPLO, WAY, N, A, LDA, IPIV, E, INFO)
SSYCONV
Definition: ssyconv.f:116
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
real function sget06(RCOND, RCONDC)
SGET06
Definition: sget06.f:57
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
subroutine ssytrs2(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO)
SSYTRS2
Definition: ssytrs2.f:134
subroutine spot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
SPOT03
Definition: spot03.f:127
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
subroutine sget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
SGET04
Definition: sget04.f:104
subroutine serrsy(PATH, NUNIT)
SERRSY
Definition: serrsy.f:57
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
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:206
subroutine spot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
SPOT05
Definition: spot05.f:166
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
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, or the element of largest absolute value of a real symmetric matrix.
Definition: slansy.f:124
Here is the call graph for this function:
Here is the caller graph for this function: