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