LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
cdrvhe.f
Go to the documentation of this file.
1 *> \brief \b CDRVHE
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 CDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
12 * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
13 * NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NMAX, NN, NOUT, NRHS
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), NVAL( * )
23 * REAL RWORK( * )
24 * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
25 * $ WORK( * ), X( * ), XACT( * )
26 * ..
27 *
28 *
29 *> \par Purpose:
30 * =============
31 *>
32 *> \verbatim
33 *>
34 *> CDRVHE tests the driver routines CHESV and -SVX.
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] NRHS
61 *> \verbatim
62 *> NRHS is INTEGER
63 *> The number of right hand side vectors to be generated for
64 *> each linear system.
65 *> \endverbatim
66 *>
67 *> \param[in] THRESH
68 *> \verbatim
69 *> THRESH is REAL
70 *> The threshold value for the test ratios. A result is
71 *> included in the output file if RESULT >= THRESH. To have
72 *> every test ratio printed, use THRESH = 0.
73 *> \endverbatim
74 *>
75 *> \param[in] TSTERR
76 *> \verbatim
77 *> TSTERR is LOGICAL
78 *> Flag that indicates whether error exits are to be tested.
79 *> \endverbatim
80 *>
81 *> \param[in] NMAX
82 *> \verbatim
83 *> NMAX is INTEGER
84 *> The maximum value permitted for N, used in dimensioning the
85 *> work arrays.
86 *> \endverbatim
87 *>
88 *> \param[out] A
89 *> \verbatim
90 *> A is COMPLEX array, dimension (NMAX*NMAX)
91 *> \endverbatim
92 *>
93 *> \param[out] AFAC
94 *> \verbatim
95 *> AFAC is COMPLEX array, dimension (NMAX*NMAX)
96 *> \endverbatim
97 *>
98 *> \param[out] AINV
99 *> \verbatim
100 *> AINV is COMPLEX array, dimension (NMAX*NMAX)
101 *> \endverbatim
102 *>
103 *> \param[out] B
104 *> \verbatim
105 *> B is COMPLEX array, dimension (NMAX*NRHS)
106 *> \endverbatim
107 *>
108 *> \param[out] X
109 *> \verbatim
110 *> X is COMPLEX array, dimension (NMAX*NRHS)
111 *> \endverbatim
112 *>
113 *> \param[out] XACT
114 *> \verbatim
115 *> XACT is COMPLEX array, dimension (NMAX*NRHS)
116 *> \endverbatim
117 *>
118 *> \param[out] WORK
119 *> \verbatim
120 *> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
121 *> \endverbatim
122 *>
123 *> \param[out] RWORK
124 *> \verbatim
125 *> RWORK is REAL array, dimension (NMAX+2*NRHS)
126 *> \endverbatim
127 *>
128 *> \param[out] IWORK
129 *> \verbatim
130 *> IWORK is INTEGER array, dimension (NMAX)
131 *> \endverbatim
132 *>
133 *> \param[in] NOUT
134 *> \verbatim
135 *> NOUT is INTEGER
136 *> The unit number for output.
137 *> \endverbatim
138 *
139 * Authors:
140 * ========
141 *
142 *> \author Univ. of Tennessee
143 *> \author Univ. of California Berkeley
144 *> \author Univ. of Colorado Denver
145 *> \author NAG Ltd.
146 *
147 *> \date November 2013
148 *
149 *> \ingroup complex_lin
150 *
151 * =====================================================================
152  SUBROUTINE cdrvhe( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
153  $ a, afac, ainv, b, x, xact, work, rwork, iwork,
154  $ nout )
155 *
156 * -- LAPACK test routine (version 3.5.0) --
157 * -- LAPACK is a software package provided by Univ. of Tennessee, --
158 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159 * November 2013
160 *
161 * .. Scalar Arguments ..
162  LOGICAL TSTERR
163  INTEGER NMAX, NN, NOUT, NRHS
164  REAL THRESH
165 * ..
166 * .. Array Arguments ..
167  LOGICAL DOTYPE( * )
168  INTEGER IWORK( * ), NVAL( * )
169  REAL RWORK( * )
170  COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
171  $ work( * ), x( * ), xact( * )
172 * ..
173 *
174 * =====================================================================
175 *
176 * .. Parameters ..
177  REAL ONE, ZERO
178  parameter ( one = 1.0e+0, zero = 0.0e+0 )
179  INTEGER NTYPES, NTESTS
180  parameter ( ntypes = 10, ntests = 6 )
181  INTEGER NFACT
182  parameter ( nfact = 2 )
183 * ..
184 * .. Local Scalars ..
185  LOGICAL ZEROT
186  CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
187  CHARACTER*3 PATH
188  INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
189  $ izero, j, k, k1, kl, ku, lda, lwork, mode, n,
190  $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
191  REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
192 * ..
193 * .. Local Arrays ..
194  CHARACTER FACTS( nfact ), UPLOS( 2 )
195  INTEGER ISEED( 4 ), ISEEDY( 4 )
196  REAL RESULT( ntests )
197 * ..
198 * .. External Functions ..
199  REAL CLANHE, SGET06
200  EXTERNAL clanhe, sget06
201 * ..
202 * .. External Subroutines ..
203  EXTERNAL aladhd, alaerh, alasvm, cerrvx, cget04, chesv,
206  $ cpot05, xlaenv
207 * ..
208 * .. Scalars in Common ..
209  LOGICAL LERR, OK
210  CHARACTER*32 SRNAMT
211  INTEGER INFOT, NUNIT
212 * ..
213 * .. Common blocks ..
214  COMMON / infoc / infot, nunit, ok, lerr
215  COMMON / srnamc / srnamt
216 * ..
217 * .. Intrinsic Functions ..
218  INTRINSIC cmplx, max, min
219 * ..
220 * .. Data statements ..
221  DATA iseedy / 1988, 1989, 1990, 1991 /
222  DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
223 * ..
224 * .. Executable Statements ..
225 *
226 * Initialize constants and the random number seed.
227 *
228  path( 1: 1 ) = 'Complex precision'
229  path( 2: 3 ) = 'HE'
230  nrun = 0
231  nfail = 0
232  nerrs = 0
233  DO 10 i = 1, 4
234  iseed( i ) = iseedy( i )
235  10 CONTINUE
236  lwork = max( 2*nmax, nmax*nrhs )
237 *
238 * Test the error exits
239 *
240  IF( tsterr )
241  $ CALL cerrvx( path, nout )
242  infot = 0
243 *
244 * Set the block size and minimum block size for testing.
245 *
246  nb = 1
247  nbmin = 2
248  CALL xlaenv( 1, nb )
249  CALL xlaenv( 2, nbmin )
250 *
251 * Do for each value of N in NVAL
252 *
253  DO 180 in = 1, nn
254  n = nval( in )
255  lda = max( n, 1 )
256  xtype = 'N'
257  nimat = ntypes
258  IF( n.LE.0 )
259  $ nimat = 1
260 *
261  DO 170 imat = 1, nimat
262 *
263 * Do the tests only if DOTYPE( IMAT ) is true.
264 *
265  IF( .NOT.dotype( imat ) )
266  $ GO TO 170
267 *
268 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
269 *
270  zerot = imat.GE.3 .AND. imat.LE.6
271  IF( zerot .AND. n.LT.imat-2 )
272  $ GO TO 170
273 *
274 * Do first for UPLO = 'U', then for UPLO = 'L'
275 *
276  DO 160 iuplo = 1, 2
277  uplo = uplos( iuplo )
278 *
279 * Set up parameters with CLATB4 and generate a test matrix
280 * with CLATMS.
281 *
282  CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
283  $ cndnum, dist )
284 *
285  srnamt = 'CLATMS'
286  CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
287  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
288  $ info )
289 *
290 * Check error code from CLATMS.
291 *
292  IF( info.NE.0 ) THEN
293  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
294  $ -1, -1, imat, nfail, nerrs, nout )
295  GO TO 160
296  END IF
297 *
298 * For types 3-6, zero one or more rows and columns of the
299 * matrix to test that INFO is returned correctly.
300 *
301  IF( zerot ) THEN
302  IF( imat.EQ.3 ) THEN
303  izero = 1
304  ELSE IF( imat.EQ.4 ) THEN
305  izero = n
306  ELSE
307  izero = n / 2 + 1
308  END IF
309 *
310  IF( imat.LT.6 ) THEN
311 *
312 * Set row and column IZERO to zero.
313 *
314  IF( iuplo.EQ.1 ) THEN
315  ioff = ( izero-1 )*lda
316  DO 20 i = 1, izero - 1
317  a( ioff+i ) = zero
318  20 CONTINUE
319  ioff = ioff + izero
320  DO 30 i = izero, n
321  a( ioff ) = zero
322  ioff = ioff + lda
323  30 CONTINUE
324  ELSE
325  ioff = izero
326  DO 40 i = 1, izero - 1
327  a( ioff ) = zero
328  ioff = ioff + lda
329  40 CONTINUE
330  ioff = ioff - izero
331  DO 50 i = izero, n
332  a( ioff+i ) = zero
333  50 CONTINUE
334  END IF
335  ELSE
336  ioff = 0
337  IF( iuplo.EQ.1 ) THEN
338 *
339 * Set the first IZERO rows and columns to zero.
340 *
341  DO 70 j = 1, n
342  i2 = min( j, izero )
343  DO 60 i = 1, i2
344  a( ioff+i ) = zero
345  60 CONTINUE
346  ioff = ioff + lda
347  70 CONTINUE
348  ELSE
349 *
350 * Set the last IZERO rows and columns to zero.
351 *
352  DO 90 j = 1, n
353  i1 = max( j, izero )
354  DO 80 i = i1, n
355  a( ioff+i ) = zero
356  80 CONTINUE
357  ioff = ioff + lda
358  90 CONTINUE
359  END IF
360  END IF
361  ELSE
362  izero = 0
363  END IF
364 *
365 * Set the imaginary part of the diagonals.
366 *
367  CALL claipd( n, a, lda+1, 0 )
368 *
369  DO 150 ifact = 1, nfact
370 *
371 * Do first for FACT = 'F', then for other values.
372 *
373  fact = facts( ifact )
374 *
375 * Compute the condition number for comparison with
376 * the value returned by CHESVX.
377 *
378  IF( zerot ) THEN
379  IF( ifact.EQ.1 )
380  $ GO TO 150
381  rcondc = zero
382 *
383  ELSE IF( ifact.EQ.1 ) THEN
384 *
385 * Compute the 1-norm of A.
386 *
387  anorm = clanhe( '1', uplo, n, a, lda, rwork )
388 *
389 * Factor the matrix A.
390 *
391  CALL clacpy( uplo, n, n, a, lda, afac, lda )
392  CALL chetrf( uplo, n, afac, lda, iwork, work,
393  $ lwork, info )
394 *
395 * Compute inv(A) and take its norm.
396 *
397  CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
398  lwork = (n+nb+1)*(nb+3)
399  CALL chetri2( uplo, n, ainv, lda, iwork, work,
400  $ lwork, info )
401  ainvnm = clanhe( '1', uplo, n, ainv, lda, rwork )
402 *
403 * Compute the 1-norm condition number of A.
404 *
405  IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
406  rcondc = one
407  ELSE
408  rcondc = ( one / anorm ) / ainvnm
409  END IF
410  END IF
411 *
412 * Form an exact solution and set the right hand side.
413 *
414  srnamt = 'CLARHS'
415  CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
416  $ nrhs, a, lda, xact, lda, b, lda, iseed,
417  $ info )
418  xtype = 'C'
419 *
420 * --- Test CHESV ---
421 *
422  IF( ifact.EQ.2 ) THEN
423  CALL clacpy( uplo, n, n, a, lda, afac, lda )
424  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
425 *
426 * Factor the matrix and solve the system using CHESV.
427 *
428  srnamt = 'CHESV '
429  CALL chesv( uplo, n, nrhs, afac, lda, iwork, x,
430  $ lda, work, lwork, info )
431 *
432 * Adjust the expected value of INFO to account for
433 * pivoting.
434 *
435  k = izero
436  IF( k.GT.0 ) THEN
437  100 CONTINUE
438  IF( iwork( k ).LT.0 ) THEN
439  IF( iwork( k ).NE.-k ) THEN
440  k = -iwork( k )
441  GO TO 100
442  END IF
443  ELSE IF( iwork( k ).NE.k ) THEN
444  k = iwork( k )
445  GO TO 100
446  END IF
447  END IF
448 *
449 * Check error code from CHESV .
450 *
451  IF( info.NE.k ) THEN
452  CALL alaerh( path, 'CHESV ', info, k, uplo, n,
453  $ n, -1, -1, nrhs, imat, nfail,
454  $ nerrs, nout )
455  GO TO 120
456  ELSE IF( info.NE.0 ) THEN
457  GO TO 120
458  END IF
459 *
460 * Reconstruct matrix from factors and compute
461 * residual.
462 *
463  CALL chet01( uplo, n, a, lda, afac, lda, iwork,
464  $ ainv, lda, rwork, result( 1 ) )
465 *
466 * Compute residual of the computed solution.
467 *
468  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
469  CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
470  $ lda, rwork, result( 2 ) )
471 *
472 * Check solution from generated exact solution.
473 *
474  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
475  $ result( 3 ) )
476  nt = 3
477 *
478 * Print information about the tests that did not pass
479 * the threshold.
480 *
481  DO 110 k = 1, nt
482  IF( result( k ).GE.thresh ) THEN
483  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
484  $ CALL aladhd( nout, path )
485  WRITE( nout, fmt = 9999 )'CHESV ', uplo, n,
486  $ imat, k, result( k )
487  nfail = nfail + 1
488  END IF
489  110 CONTINUE
490  nrun = nrun + nt
491  120 CONTINUE
492  END IF
493 *
494 * --- Test CHESVX ---
495 *
496  IF( ifact.EQ.2 )
497  $ CALL claset( uplo, n, n, cmplx( zero ),
498  $ cmplx( zero ), afac, lda )
499  CALL claset( 'Full', n, nrhs, cmplx( zero ),
500  $ cmplx( zero ), x, lda )
501 *
502 * Solve the system and compute the condition number and
503 * error bounds using CHESVX.
504 *
505  srnamt = 'CHESVX'
506  CALL chesvx( fact, uplo, n, nrhs, a, lda, afac, lda,
507  $ iwork, b, lda, x, lda, rcond, rwork,
508  $ rwork( nrhs+1 ), work, lwork,
509  $ rwork( 2*nrhs+1 ), info )
510 *
511 * Adjust the expected value of INFO to account for
512 * pivoting.
513 *
514  k = izero
515  IF( k.GT.0 ) THEN
516  130 CONTINUE
517  IF( iwork( k ).LT.0 ) THEN
518  IF( iwork( k ).NE.-k ) THEN
519  k = -iwork( k )
520  GO TO 130
521  END IF
522  ELSE IF( iwork( k ).NE.k ) THEN
523  k = iwork( k )
524  GO TO 130
525  END IF
526  END IF
527 *
528 * Check the error code from CHESVX.
529 *
530  IF( info.NE.k ) THEN
531  CALL alaerh( path, 'CHESVX', info, k, fact // uplo,
532  $ n, n, -1, -1, nrhs, imat, nfail,
533  $ nerrs, nout )
534  GO TO 150
535  END IF
536 *
537  IF( info.EQ.0 ) THEN
538  IF( ifact.GE.2 ) THEN
539 *
540 * Reconstruct matrix from factors and compute
541 * residual.
542 *
543  CALL chet01( uplo, n, a, lda, afac, lda, iwork,
544  $ ainv, lda, rwork( 2*nrhs+1 ),
545  $ result( 1 ) )
546  k1 = 1
547  ELSE
548  k1 = 2
549  END IF
550 *
551 * Compute residual of the computed solution.
552 *
553  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
554  CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
555  $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
556 *
557 * Check solution from generated exact solution.
558 *
559  CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
560  $ result( 3 ) )
561 *
562 * Check the error bounds from iterative refinement.
563 *
564  CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
565  $ xact, lda, rwork, rwork( nrhs+1 ),
566  $ result( 4 ) )
567  ELSE
568  k1 = 6
569  END IF
570 *
571 * Compare RCOND from CHESVX with the computed value
572 * in RCONDC.
573 *
574  result( 6 ) = sget06( rcond, rcondc )
575 *
576 * Print information about the tests that did not pass
577 * the threshold.
578 *
579  DO 140 k = k1, 6
580  IF( result( k ).GE.thresh ) THEN
581  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
582  $ CALL aladhd( nout, path )
583  WRITE( nout, fmt = 9998 )'CHESVX', fact, uplo,
584  $ n, imat, k, result( k )
585  nfail = nfail + 1
586  END IF
587  140 CONTINUE
588  nrun = nrun + 7 - k1
589 *
590  150 CONTINUE
591 *
592  160 CONTINUE
593  170 CONTINUE
594  180 CONTINUE
595 *
596 * Print a summary of the results.
597 *
598  CALL alasvm( path, nout, nfail, nrun, nerrs )
599 *
600  9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
601  $ ', test ', i2, ', ratio =', g12.5 )
602  9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
603  $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
604  RETURN
605 *
606 * End of CDRVHE
607 *
608  END
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:75
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
Definition: clarhs.f:211
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
subroutine cdrvhe(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CDRVHE
Definition: cdrvhe.f:155
subroutine cerrvx(PATH, NUNIT)
CERRVX
Definition: cerrvx.f:57
subroutine chesv(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO)
CHESV computes the solution to system of linear equations A * X = B for HE matrices ...
Definition: chesv.f:173
subroutine chesvx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO)
CHESVX computes the solution to system of linear equations A * X = B for HE matrices ...
Definition: chesvx.f:287
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
Definition: cpot02.f:129
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: claset.f:108
subroutine chetrf(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRF
Definition: chetrf.f:179
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine aladhd(IOUNIT, PATH)
ALADHD
Definition: aladhd.f:80
subroutine chet01(UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC, RWORK, RESID)
CHET01
Definition: chet01.f:128
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
subroutine cpot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPOT05
Definition: cpot05.f:167
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123
subroutine chetri2(UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO)
CHETRI2
Definition: chetri2.f:129
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
Definition: cget04.f:104