LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ schksy_aa_2stage()

subroutine schksy_aa_2stage ( 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_2STAGE

Purpose:
 SCHKSY_AA_2STAGE tests SSYTRF_AA_2STAGE, -TRS_AA_2STAGE.
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 2017

Definition at line 173 of file schksy_aa_2stage.f.

173 *
174 * -- LAPACK test routine (version 3.8.0) --
175 * -- LAPACK is a software package provided by Univ. of Tennessee, --
176 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
177 * November 2017
178 *
179  IMPLICIT NONE
180 *
181 * .. Scalar Arguments ..
182  LOGICAL tsterr
183  INTEGER nn, nnb, nns, nmax, nout
184  REAL thresh
185 * ..
186 * .. Array Arguments ..
187  LOGICAL dotype( * )
188  INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
189  REAL a( * ), afac( * ), ainv( * ), b( * ),
190  $ rwork( * ), work( * ), x( * ), xact( * )
191 * ..
192 *
193 * =====================================================================
194 *
195 * .. Parameters ..
196  REAL zero
197  parameter( zero = 0.0e+0 )
198  INTEGER ntypes
199  parameter( ntypes = 10 )
200  INTEGER ntests
201  parameter( ntests = 9 )
202 * ..
203 * .. Local Scalars ..
204  LOGICAL zerot
205  CHARACTER dist, TYPE, uplo, xtype
206  CHARACTER*3 path, matpath
207  INTEGER i, i1, i2, imat, in, inb, info, ioff, irhs,
208  $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
209  $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
210  REAL anorm, cndnum
211 * ..
212 * .. Local Arrays ..
213  CHARACTER uplos( 2 )
214  INTEGER iseed( 4 ), iseedy( 4 )
215  REAL result( ntests )
216 * ..
217 * .. External Subroutines ..
218  EXTERNAL alaerh, alahd, alasum, serrsy, slacpy, slarhs,
221  $ 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 ) = 'S2'
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_2STAGE'
429  lwork = min(n*nb, 3*nmax*nmax)
430  CALL ssytrf_aa_2stage( uplo, n, afac, lda,
431  $ ainv, (3*nb+1)*n,
432  $ iwork, iwork( 1+n ),
433  $ work, lwork,
434  $ info )
435 *
436 * Adjust the expected value of INFO to account for
437 * pivoting.
438 *
439  IF( izero.GT.0 ) THEN
440  j = 1
441  k = izero
442  100 CONTINUE
443  IF( j.EQ.k ) THEN
444  k = iwork( j )
445  ELSE IF( iwork( j ).EQ.k ) THEN
446  k = j
447  END IF
448  IF( j.LT.k ) THEN
449  j = j + 1
450  GO TO 100
451  END IF
452  ELSE
453  k = 0
454  END IF
455 *
456 * Check error code from SSYTRF and handle error.
457 *
458  IF( info.NE.k ) THEN
459  CALL alaerh( path, 'SSYTRF_AA_2STAGE', info, k,
460  $ uplo, n, n, -1, -1, nb, imat, nfail,
461  $ nerrs, nout )
462  END IF
463 *
464 *+ TEST 1
465 * Reconstruct matrix from factors and compute residual.
466 *
467 * CALL SSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK,
468 * $ AINV, LDA, RWORK, RESULT( 1 ) )
469 * NT = 1
470  nt = 0
471 *
472 *
473 * Print information about the tests that did not pass
474 * the threshold.
475 *
476  DO 110 k = 1, nt
477  IF( result( k ).GE.thresh ) THEN
478  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
479  $ CALL alahd( nout, path )
480  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
481  $ result( k )
482  nfail = nfail + 1
483  END IF
484  110 CONTINUE
485  nrun = nrun + nt
486 *
487 * Skip solver test if INFO is not 0.
488 *
489  IF( info.NE.0 ) THEN
490  GO TO 140
491  END IF
492 *
493 * Do for each value of NRHS in NSVAL.
494 *
495  DO 130 irhs = 1, nns
496  nrhs = nsval( irhs )
497 *
498 *+ TEST 2 (Using TRS)
499 * Solve and compute residual for A * X = B.
500 *
501 * Choose a set of NRHS random solution vectors
502 * stored in XACT and set up the right hand side B
503 *
504  srnamt = 'SLARHS'
505  CALL slarhs( matpath, xtype, uplo, ' ', n, n,
506  $ kl, ku, nrhs, a, lda, xact, lda,
507  $ b, lda, iseed, info )
508  CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
509 *
510  srnamt = 'SSYTRS_AA_2STAGE'
511  lwork = max( 1, 3*n-2 )
512  CALL ssytrs_aa_2stage( uplo, n, nrhs, afac, lda,
513  $ ainv, (3*nb+1)*n, iwork, iwork( 1+n ),
514  $ x, lda, info )
515 *
516 * Check error code from SSYTRS and handle error.
517 *
518  IF( info.NE.0 ) THEN
519  IF( izero.EQ.0 ) THEN
520  CALL alaerh( path, 'SSYTRS_AA_2STAGE',
521  $ info, 0, uplo, n, n, -1, -1,
522  $ nrhs, imat, nfail, nerrs, nout )
523  END IF
524  ELSE
525  CALL slacpy( 'Full', n, nrhs, b, lda, work, lda
526  $ )
527 *
528 * Compute the residual for the solution
529 *
530  CALL spot02( uplo, n, nrhs, a, lda, x, lda,
531  $ work, lda, rwork, result( 2 ) )
532 *
533 *
534 * Print information about the tests that did not pass
535 * the threshold.
536 *
537  DO 120 k = 2, 2
538  IF( result( k ).GE.thresh ) THEN
539  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
540  $ CALL alahd( nout, path )
541  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
542  $ imat, k, result( k )
543  nfail = nfail + 1
544  END IF
545  120 CONTINUE
546  END IF
547  nrun = nrun + 1
548 *
549 * End do for each value of NRHS in NSVAL.
550 *
551  130 CONTINUE
552  140 CONTINUE
553  150 CONTINUE
554  160 CONTINUE
555  170 CONTINUE
556  180 CONTINUE
557 *
558 * Print a summary of the results.
559 *
560  CALL alasum( path, nout, nfail, nrun, nerrs )
561 *
562  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
563  $ i2, ', test ', i2, ', ratio =', g12.5 )
564  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
565  $ i2, ', test(', i2, ') =', g12.5 )
566  9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
567  $ i6 )
568  RETURN
569 *
570 * End of DCHKSY_AA_2STAGE
571 *
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 ssyt01_aa(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
SSYT01_AA
Definition: ssyt01_aa.f:127
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:122
subroutine ssytrf_aa_2stage(UPLO, N, A, LDA, TB, LTB, IPIV, IPIV2, WORK, LWORK, INFO)
SSYTRF_AA_2STAGE
subroutine ssytrs_aa_2stage(UPLO, N, NRHS, A, LDA, TB, LTB, IPIV, IPIV2, B, LDB, INFO)
SSYTRS_AA_2STAGE
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
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 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: