LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
dchksy_rook.f
Go to the documentation of this file.
1 *> \brief \b DCHKSY_ROOK
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE DCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
12 * THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
13 * XACT, WORK, RWORK, IWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NMAX, NN, NNB, NNS, NOUT
18 * DOUBLE PRECISION THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
23 * DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
24 * $ RWORK( * ), WORK( * ), X( * ), XACT( * )
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> DCHKSY_ROOK tests DSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
34 *> and -CON_ROOK.
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[in] DOTYPE
41 *> \verbatim
42 *> DOTYPE is LOGICAL array, dimension (NTYPES)
43 *> The matrix types to be used for testing. Matrices of type j
44 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46 *> \endverbatim
47 *>
48 *> \param[in] NN
49 *> \verbatim
50 *> NN is INTEGER
51 *> The number of values of N contained in the vector NVAL.
52 *> \endverbatim
53 *>
54 *> \param[in] NVAL
55 *> \verbatim
56 *> NVAL is INTEGER array, dimension (NN)
57 *> The values of the matrix dimension N.
58 *> \endverbatim
59 *>
60 *> \param[in] NNB
61 *> \verbatim
62 *> NNB is INTEGER
63 *> The number of values of NB contained in the vector NBVAL.
64 *> \endverbatim
65 *>
66 *> \param[in] NBVAL
67 *> \verbatim
68 *> NBVAL is INTEGER array, dimension (NBVAL)
69 *> The values of the blocksize NB.
70 *> \endverbatim
71 *>
72 *> \param[in] NNS
73 *> \verbatim
74 *> NNS is INTEGER
75 *> The number of values of NRHS contained in the vector NSVAL.
76 *> \endverbatim
77 *>
78 *> \param[in] NSVAL
79 *> \verbatim
80 *> NSVAL is INTEGER array, dimension (NNS)
81 *> The values of the number of right hand sides NRHS.
82 *> \endverbatim
83 *>
84 *> \param[in] THRESH
85 *> \verbatim
86 *> THRESH is DOUBLE PRECISION
87 *> The threshold value for the test ratios. A result is
88 *> included in the output file if RESULT >= THRESH. To have
89 *> every test ratio printed, use THRESH = 0.
90 *> \endverbatim
91 *>
92 *> \param[in] TSTERR
93 *> \verbatim
94 *> TSTERR is LOGICAL
95 *> Flag that indicates whether error exits are to be tested.
96 *> \endverbatim
97 *>
98 *> \param[in] NMAX
99 *> \verbatim
100 *> NMAX is INTEGER
101 *> The maximum value permitted for N, used in dimensioning the
102 *> work arrays.
103 *> \endverbatim
104 *>
105 *> \param[out] A
106 *> \verbatim
107 *> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
108 *> \endverbatim
109 *>
110 *> \param[out] AFAC
111 *> \verbatim
112 *> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
113 *> \endverbatim
114 *>
115 *> \param[out] AINV
116 *> \verbatim
117 *> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
118 *> \endverbatim
119 *>
120 *> \param[out] B
121 *> \verbatim
122 *> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
123 *> where NSMAX is the largest entry in NSVAL.
124 *> \endverbatim
125 *>
126 *> \param[out] X
127 *> \verbatim
128 *> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
129 *> \endverbatim
130 *>
131 *> \param[out] XACT
132 *> \verbatim
133 *> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
134 *> \endverbatim
135 *>
136 *> \param[out] WORK
137 *> \verbatim
138 *> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX))
139 *> \endverbatim
140 *>
141 *> \param[out] RWORK
142 *> \verbatim
143 *> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
144 *> \endverbatim
145 *>
146 *> \param[out] IWORK
147 *> \verbatim
148 *> IWORK is INTEGER array, dimension (2*NMAX)
149 *> \endverbatim
150 *>
151 *> \param[in] NOUT
152 *> \verbatim
153 *> NOUT is INTEGER
154 *> The unit number for output.
155 *> \endverbatim
156 *
157 * Authors:
158 * ========
159 *
160 *> \author Univ. of Tennessee
161 *> \author Univ. of California Berkeley
162 *> \author Univ. of Colorado Denver
163 *> \author NAG Ltd.
164 *
165 *> \date November 2013
166 *
167 *> \ingroup double_lin
168 *
169 * =====================================================================
170  SUBROUTINE dchksy_rook( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
171  $ thresh, tsterr, nmax, a, afac, ainv, b, x,
172  $ xact, work, rwork, iwork, nout )
173 *
174 * -- LAPACK test routine (version 3.5.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 2013
178 *
179 * .. Scalar Arguments ..
180  LOGICAL tsterr
181  INTEGER nmax, nn, nnb, nns, nout
182  DOUBLE PRECISION thresh
183 * ..
184 * .. Array Arguments ..
185  LOGICAL dotype( * )
186  INTEGER iwork( * ), nbval( * ), nsval( * ), nval( * )
187  DOUBLE PRECISION a( * ), afac( * ), ainv( * ), b( * ),
188  $ rwork( * ), work( * ), x( * ), xact( * )
189 * ..
190 *
191 * =====================================================================
192 *
193 * .. Parameters ..
194  DOUBLE PRECISION zero, one
195  parameter( zero = 0.0d+0, one = 1.0d+0 )
196  DOUBLE PRECISION eight, sevten
197  parameter( eight = 8.0d+0, sevten = 17.0d+0 )
198  INTEGER ntypes
199  parameter( ntypes = 10 )
200  INTEGER ntests
201  parameter( ntests = 7 )
202 * ..
203 * .. Local Scalars ..
204  LOGICAL trfcon, zerot
205  CHARACTER dist, type, uplo, xtype
206  CHARACTER*3 path, matpath
207  INTEGER i, i1, i2, imat, in, inb, info, ioff, irhs,
208  $ itemp, iuplo, izero, j, k, kl, ku, lda, lwork,
209  $ mode, n, nb, nerrs, nfail, nimat, nrhs, nrun,
210  $ nt
211  DOUBLE PRECISION alpha, anorm, cndnum, const, dtemp, lam_max,
212  $ lam_min, rcond, rcondc
213 * ..
214 * .. Local Arrays ..
215  CHARACTER uplos( 2 )
216  INTEGER idummy( 1 ), iseed( 4 ), iseedy( 4 )
217  DOUBLE PRECISION ddummy( 1 ), result( ntests )
218 * ..
219 * .. External Functions ..
220  DOUBLE PRECISION dget06, dlange, dlansy
221  EXTERNAL dget06, dlange, dlansy
222 * ..
223 * .. External Subroutines ..
224  EXTERNAL alaerh, alahd, alasum, derrsy, dget04, dlacpy,
228 * ..
229 * .. Intrinsic Functions ..
230  INTRINSIC abs, max, min, sqrt
231 * ..
232 * .. Scalars in Common ..
233  LOGICAL lerr, ok
234  CHARACTER*32 srnamt
235  INTEGER infot, nunit
236 * ..
237 * .. Common blocks ..
238  COMMON / infoc / infot, nunit, ok, lerr
239  COMMON / srnamc / srnamt
240 * ..
241 * .. Data statements ..
242  DATA iseedy / 1988, 1989, 1990, 1991 /
243  DATA uplos / 'U', 'L' /
244 * ..
245 * .. Executable Statements ..
246 *
247 * Initialize constants and the random number seed.
248 *
249  alpha = ( one+sqrt( sevten ) ) / eight
250 *
251 * Test path
252 *
253  path( 1: 1 ) = 'Double precision'
254  path( 2: 3 ) = 'SR'
255 *
256 * Path to generate matrices
257 *
258  matpath( 1: 1 ) = 'Double precision'
259  matpath( 2: 3 ) = 'SY'
260 *
261  nrun = 0
262  nfail = 0
263  nerrs = 0
264  DO 10 i = 1, 4
265  iseed( i ) = iseedy( i )
266  10 CONTINUE
267 *
268 * Test the error exits
269 *
270  IF( tsterr )
271  $ CALL derrsy( path, nout )
272  infot = 0
273 *
274 * Set the minimum block size for which the block routine should
275 * be used, which will be later returned by ILAENV
276 *
277  CALL xlaenv( 2, 2 )
278 *
279 * Do for each value of N in NVAL
280 *
281  DO 270 in = 1, nn
282  n = nval( in )
283  lda = max( n, 1 )
284  xtype = 'N'
285  nimat = ntypes
286  IF( n.LE.0 )
287  $ nimat = 1
288 *
289  izero = 0
290 *
291 * Do for each value of matrix type IMAT
292 *
293  DO 260 imat = 1, nimat
294 *
295 * Do the tests only if DOTYPE( IMAT ) is true.
296 *
297  IF( .NOT.dotype( imat ) )
298  $ go to 260
299 *
300 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
301 *
302  zerot = imat.GE.3 .AND. imat.LE.6
303  IF( zerot .AND. n.LT.imat-2 )
304  $ go to 260
305 *
306 * Do first for UPLO = 'U', then for UPLO = 'L'
307 *
308  DO 250 iuplo = 1, 2
309  uplo = uplos( iuplo )
310 *
311 * Begin generate the test matrix A.
312 *
313 * Set up parameters with DLATB4 for the matrix generator
314 * based on the type of matrix to be generated.
315 *
316  CALL dlatb4( matpath, imat, n, n, type, kl, ku, anorm,
317  $ mode, cndnum, dist )
318 *
319 * Generate a matrix with DLATMS.
320 *
321  srnamt = 'DLATMS'
322  CALL dlatms( n, n, dist, iseed, type, rwork, mode,
323  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
324  $ info )
325 *
326 * Check error code from DLATMS and handle error.
327 *
328  IF( info.NE.0 ) THEN
329  CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
330  $ -1, -1, imat, nfail, nerrs, nout )
331 *
332 * Skip all tests for this generated matrix
333 *
334  go to 250
335  END IF
336 *
337 * For matrix types 3-6, zero one or more rows and
338 * columns of the matrix to test that INFO is returned
339 * correctly.
340 *
341  IF( zerot ) THEN
342  IF( imat.EQ.3 ) THEN
343  izero = 1
344  ELSE IF( imat.EQ.4 ) THEN
345  izero = n
346  ELSE
347  izero = n / 2 + 1
348  END IF
349 *
350  IF( imat.LT.6 ) THEN
351 *
352 * Set row and column IZERO to zero.
353 *
354  IF( iuplo.EQ.1 ) THEN
355  ioff = ( izero-1 )*lda
356  DO 20 i = 1, izero - 1
357  a( ioff+i ) = zero
358  20 CONTINUE
359  ioff = ioff + izero
360  DO 30 i = izero, n
361  a( ioff ) = zero
362  ioff = ioff + lda
363  30 CONTINUE
364  ELSE
365  ioff = izero
366  DO 40 i = 1, izero - 1
367  a( ioff ) = zero
368  ioff = ioff + lda
369  40 CONTINUE
370  ioff = ioff - izero
371  DO 50 i = izero, n
372  a( ioff+i ) = zero
373  50 CONTINUE
374  END IF
375  ELSE
376  IF( iuplo.EQ.1 ) THEN
377 *
378 * Set the first IZERO rows and columns to zero.
379 *
380  ioff = 0
381  DO 70 j = 1, n
382  i2 = min( j, izero )
383  DO 60 i = 1, i2
384  a( ioff+i ) = zero
385  60 CONTINUE
386  ioff = ioff + lda
387  70 CONTINUE
388  ELSE
389 *
390 * Set the last IZERO rows and columns to zero.
391 *
392  ioff = 0
393  DO 90 j = 1, n
394  i1 = max( j, izero )
395  DO 80 i = i1, n
396  a( ioff+i ) = zero
397  80 CONTINUE
398  ioff = ioff + lda
399  90 CONTINUE
400  END IF
401  END IF
402  ELSE
403  izero = 0
404  END IF
405 *
406 * End generate the test matrix A.
407 *
408 *
409 * Do for each value of NB in NBVAL
410 *
411  DO 240 inb = 1, nnb
412 *
413 * Set the optimal blocksize, which will be later
414 * returned by ILAENV.
415 *
416  nb = nbval( inb )
417  CALL xlaenv( 1, nb )
418 *
419 * Copy the test matrix A into matrix AFAC which
420 * will be factorized in place. This is needed to
421 * preserve the test matrix A for subsequent tests.
422 *
423  CALL dlacpy( uplo, n, n, a, lda, afac, lda )
424 *
425 * Compute the L*D*L**T or U*D*U**T factorization of the
426 * matrix. IWORK stores details of the interchanges and
427 * the block structure of D. AINV is a work array for
428 * block factorization, LWORK is the length of AINV.
429 *
430  lwork = max( 2, nb )*lda
431  srnamt = 'DSYTRF_ROOK'
432  CALL dsytrf_rook( uplo, n, afac, lda, iwork, ainv,
433  $ lwork, info )
434 *
435 * Adjust the expected value of INFO to account for
436 * pivoting.
437 *
438  k = izero
439  IF( k.GT.0 ) THEN
440  100 CONTINUE
441  IF( iwork( k ).LT.0 ) THEN
442  IF( iwork( k ).NE.-k ) THEN
443  k = -iwork( k )
444  go to 100
445  END IF
446  ELSE IF( iwork( k ).NE.k ) THEN
447  k = iwork( k )
448  go to 100
449  END IF
450  END IF
451 *
452 * Check error code from DSYTRF_ROOK and handle error.
453 *
454  IF( info.NE.k)
455  $ CALL alaerh( path, 'DSYTRF_ROOK', info, k,
456  $ uplo, n, n, -1, -1, nb, imat,
457  $ nfail, nerrs, nout )
458 *
459 * Set the condition estimate flag if the INFO is not 0.
460 *
461  IF( info.NE.0 ) THEN
462  trfcon = .true.
463  ELSE
464  trfcon = .false.
465  END IF
466 *
467 *+ TEST 1
468 * Reconstruct matrix from factors and compute residual.
469 *
470  CALL dsyt01_rook( uplo, n, a, lda, afac, lda, iwork,
471  $ ainv, lda, rwork, result( 1 ) )
472  nt = 1
473 *
474 *+ TEST 2
475 * Form the inverse and compute the residual,
476 * if the factorization was competed without INFO > 0
477 * (i.e. there is no zero rows and columns).
478 * Do it only for the first block size.
479 *
480  IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
481  CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
482  srnamt = 'DSYTRI_ROOK'
483  CALL dsytri_rook( uplo, n, ainv, lda, iwork, work,
484  $ info )
485 *
486 * Check error code from DSYTRI_ROOK and handle error.
487 *
488  IF( info.NE.0 )
489  $ CALL alaerh( path, 'DSYTRI_ROOK', info, -1,
490  $ uplo, n, n, -1, -1, -1, imat,
491  $ nfail, nerrs, nout )
492 *
493 * Compute the residual for a symmetric matrix times
494 * its inverse.
495 *
496  CALL dpot03( uplo, n, a, lda, ainv, lda, work, lda,
497  $ rwork, rcondc, result( 2 ) )
498  nt = 2
499  END IF
500 *
501 * Print information about the tests that did not pass
502 * the threshold.
503 *
504  DO 110 k = 1, nt
505  IF( result( k ).GE.thresh ) THEN
506  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
507  $ CALL alahd( nout, path )
508  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
509  $ result( k )
510  nfail = nfail + 1
511  END IF
512  110 CONTINUE
513  nrun = nrun + nt
514 *
515 *+ TEST 3
516 * Compute largest element in U or L
517 *
518  result( 3 ) = zero
519  dtemp = zero
520 *
521  const = one / ( one-alpha )
522 *
523  IF( iuplo.EQ.1 ) THEN
524 *
525 * Compute largest element in U
526 *
527  k = n
528  120 CONTINUE
529  IF( k.LE.1 )
530  $ go to 130
531 *
532  IF( iwork( k ).GT.zero ) THEN
533 *
534 * Get max absolute value from elements
535 * in column k in in U
536 *
537  dtemp = dlange( 'M', k-1, 1,
538  $ afac( ( k-1 )*lda+1 ), lda, rwork )
539  ELSE
540 *
541 * Get max absolute value from elements
542 * in columns k and k-1 in U
543 *
544  dtemp = dlange( 'M', k-2, 2,
545  $ afac( ( k-2 )*lda+1 ), lda, rwork )
546  k = k - 1
547 *
548  END IF
549 *
550 * DTEMP should be bounded by CONST
551 *
552  dtemp = dtemp - const + thresh
553  IF( dtemp.GT.result( 3 ) )
554  $ result( 3 ) = dtemp
555 *
556  k = k - 1
557 *
558  go to 120
559  130 CONTINUE
560 *
561  ELSE
562 *
563 * Compute largest element in L
564 *
565  k = 1
566  140 CONTINUE
567  IF( k.GE.n )
568  $ go to 150
569 *
570  IF( iwork( k ).GT.zero ) THEN
571 *
572 * Get max absolute value from elements
573 * in column k in in L
574 *
575  dtemp = dlange( 'M', n-k, 1,
576  $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
577  ELSE
578 *
579 * Get max absolute value from elements
580 * in columns k and k+1 in L
581 *
582  dtemp = dlange( 'M', n-k-1, 2,
583  $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
584  k = k + 1
585 *
586  END IF
587 *
588 * DTEMP should be bounded by CONST
589 *
590  dtemp = dtemp - const + thresh
591  IF( dtemp.GT.result( 3 ) )
592  $ result( 3 ) = dtemp
593 *
594  k = k + 1
595 *
596  go to 140
597  150 CONTINUE
598  END IF
599 *
600 *
601 *+ TEST 4
602 * Compute largest 2-Norm of 2-by-2 diag blocks
603 *
604  result( 4 ) = zero
605  dtemp = zero
606 *
607  const = ( one+alpha ) / ( one-alpha )
608  CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
609 *
610  IF( iuplo.EQ.1 ) THEN
611 *
612 * Loop backward for UPLO = 'U'
613 *
614  k = n
615  160 CONTINUE
616  IF( k.LE.1 )
617  $ go to 170
618 *
619  IF( iwork( k ).LT.zero ) THEN
620 *
621 * Get the two eigenvalues of a 2-by-2 block,
622 * store them in RWORK array
623 *
624  CALL dsyevx( 'N', 'A', uplo, 2,
625  $ ainv( ( k-2 )*lda+k-1 ), lda, dtemp,
626  $ dtemp, itemp, itemp, zero, itemp,
627  $ rwork, ddummy, 1, work, 16,
628  $ iwork( n+1 ), idummy, info )
629 *
630  lam_max = max( abs( rwork( 1 ) ),
631  $ abs( rwork( 2 ) ) )
632  lam_min = min( abs( rwork( 1 ) ),
633  $ abs( rwork( 2 ) ) )
634 *
635  dtemp = lam_max / lam_min
636 *
637 * DTEMP should be bounded by CONST
638 *
639  dtemp = abs( dtemp ) - const + thresh
640  IF( dtemp.GT.result( 4 ) )
641  $ result( 4 ) = dtemp
642  k = k - 1
643 *
644  END IF
645 *
646  k = k - 1
647 *
648  go to 160
649  170 CONTINUE
650 *
651  ELSE
652 *
653 * Loop forward for UPLO = 'L'
654 *
655  k = 1
656  180 CONTINUE
657  IF( k.GE.n )
658  $ go to 190
659 *
660  IF( iwork( k ).LT.zero ) THEN
661 *
662 * Get the two eigenvalues of a 2-by-2 block,
663 * store them in RWORK array
664 *
665  CALL dsyevx( 'N', 'A', uplo, 2,
666  $ ainv( ( k-1 )*lda+k ), lda, dtemp,
667  $ dtemp, itemp, itemp, zero, itemp,
668  $ rwork, ddummy, 1, work, 16,
669  $ iwork( n+1 ), idummy, info )
670 *
671  lam_max = max( abs( rwork( 1 ) ),
672  $ abs( rwork( 2 ) ) )
673  lam_min = min( abs( rwork( 1 ) ),
674  $ abs( rwork( 2 ) ) )
675 *
676  dtemp = lam_max / lam_min
677 *
678 * DTEMP should be bounded by CONST
679 *
680  dtemp = abs( dtemp ) - const + thresh
681  IF( dtemp.GT.result( 4 ) )
682  $ result( 4 ) = dtemp
683  k = k + 1
684 *
685  END IF
686 *
687  k = k + 1
688 *
689  go to 180
690  190 CONTINUE
691  END IF
692 *
693 * Print information about the tests that did not pass
694 * the threshold.
695 *
696  DO 200 k = 3, 4
697  IF( result( k ).GE.thresh ) THEN
698  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
699  $ CALL alahd( nout, path )
700  WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
701  $ result( k )
702  nfail = nfail + 1
703  END IF
704  200 CONTINUE
705  nrun = nrun + 2
706 *
707 * Skip the other tests if this is not the first block
708 * size.
709 *
710  IF( inb.GT.1 )
711  $ go to 240
712 *
713 * Do only the condition estimate if INFO is not 0.
714 *
715  IF( trfcon ) THEN
716  rcondc = zero
717  go to 230
718  END IF
719 *
720 * Do for each value of NRHS in NSVAL.
721 *
722  DO 220 irhs = 1, nns
723  nrhs = nsval( irhs )
724 *
725 *+ TEST 5 ( Using TRS_ROOK)
726 * Solve and compute residual for A * X = B.
727 *
728 * Choose a set of NRHS random solution vectors
729 * stored in XACT and set up the right hand side B
730 *
731  srnamt = 'DLARHS'
732  CALL dlarhs( matpath, xtype, uplo, ' ', n, n,
733  $ kl, ku, nrhs, a, lda, xact, lda,
734  $ b, lda, iseed, info )
735  CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
736 *
737  srnamt = 'DSYTRS_ROOK'
738  CALL dsytrs_rook( uplo, n, nrhs, afac, lda, iwork,
739  $ x, lda, info )
740 *
741 * Check error code from DSYTRS_ROOK and handle error.
742 *
743  IF( info.NE.0 )
744  $ CALL alaerh( path, 'DSYTRS_ROOK', info, 0,
745  $ uplo, n, n, -1, -1, nrhs, imat,
746  $ nfail, nerrs, nout )
747 *
748  CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
749 *
750 * Compute the residual for the solution
751 *
752  CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
753  $ lda, rwork, result( 5 ) )
754 *
755 *+ TEST 6
756 * Check solution from generated exact solution.
757 *
758  CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
759  $ result( 6 ) )
760 *
761 * Print information about the tests that did not pass
762 * the threshold.
763 *
764  DO 210 k = 5, 6
765  IF( result( k ).GE.thresh ) THEN
766  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
767  $ CALL alahd( nout, path )
768  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
769  $ imat, k, result( k )
770  nfail = nfail + 1
771  END IF
772  210 CONTINUE
773  nrun = nrun + 2
774 *
775 * End do for each value of NRHS in NSVAL.
776 *
777  220 CONTINUE
778 *
779 *+ TEST 7
780 * Get an estimate of RCOND = 1/CNDNUM.
781 *
782  230 CONTINUE
783  anorm = dlansy( '1', uplo, n, a, lda, rwork )
784  srnamt = 'DSYCON_ROOK'
785  CALL dsycon_rook( uplo, n, afac, lda, iwork, anorm,
786  $ rcond, work, iwork( n+1 ), info )
787 *
788 * Check error code from DSYCON_ROOK and handle error.
789 *
790  IF( info.NE.0 )
791  $ CALL alaerh( path, 'DSYCON_ROOK', info, 0,
792  $ uplo, n, n, -1, -1, -1, imat,
793  $ nfail, nerrs, nout )
794 *
795 * Compute the test ratio to compare to values of RCOND
796 *
797  result( 7 ) = dget06( rcond, rcondc )
798 *
799 * Print information about the tests that did not pass
800 * the threshold.
801 *
802  IF( result( 7 ).GE.thresh ) THEN
803  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
804  $ CALL alahd( nout, path )
805  WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
806  $ result( 7 )
807  nfail = nfail + 1
808  END IF
809  nrun = nrun + 1
810  240 CONTINUE
811 *
812  250 CONTINUE
813  260 CONTINUE
814  270 CONTINUE
815 *
816 * Print a summary of the results.
817 *
818  CALL alasum( path, nout, nfail, nrun, nerrs )
819 *
820  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
821  $ i2, ', test ', i2, ', ratio =', g12.5 )
822  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
823  $ i2, ', test(', i2, ') =', g12.5 )
824  9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
825  $ ', test(', i2, ') =', g12.5 )
826  RETURN
827 *
828 * End of DCHKSY_ROOK
829 *
830  END
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:94
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:321
subroutine dsytrs_rook(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DSYTRS_ROOK
Definition: dsytrs_rook.f:136
subroutine dpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
DPOT02
Definition: dpot02.f:127
subroutine derrsy(PATH, NUNIT)
DERRSY
Definition: derrsy.f:56
subroutine dsytrf_rook(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
DSYTRF_ROOK
Definition: dsytrf_rook.f:209
subroutine dsyevx(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices ...
Definition: dsyevx.f:245
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
subroutine dlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
DLARHS
Definition: dlarhs.f:204
subroutine dlatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
DLATB4
Definition: dlatb4.f:120
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:74
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlange.f:115
double precision function dget06(RCOND, RCONDC)
DGET06
Definition: dget06.f:56
subroutine dpot03(UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK, RWORK, RCOND, RESID)
DPOT03
Definition: dpot03.f:125
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:82
subroutine dsyt01_rook(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
DSYT01_ROOK
Definition: dsyt01_rook.f:124
subroutine dsycon_rook(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DSYCON_ROOK
Definition: dsycon_rook.f:144
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
Definition: xerbla-fortran:9
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY 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: dlansy.f:123
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:104
subroutine dget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
DGET04
Definition: dget04.f:103
subroutine dsytri_rook(UPLO, N, A, LDA, IPIV, WORK, INFO)
DSYTRI_ROOK
Definition: dsytri_rook.f:130
subroutine dchksy_rook(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
DCHKSY_ROOK
Definition: dchksy_rook.f:170