LAPACK  3.8.0
LAPACK: Linear Algebra PACKage
cchkhe_aa_2stage.f
Go to the documentation of this file.
1 *> \brief \b CCHKHE_AA_2STAGE
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 CCHKHE_AA_2STAGE( DOTYPE, NN, NVAL, NNB, NBVAL,
12 * NNS, NSVAL, THRESH, TSTERR, NMAX, A,
13 * AFAC, AINV, B, X, XACT, WORK, RWORK,
14 * IWORK, NOUT )
15 *
16 * .. Scalar Arguments ..
17 * LOGICAL TSTERR
18 * INTEGER NN, NNB, NNS, NOUT
19 * REAL THRESH
20 * ..
21 * .. Array Arguments ..
22 * LOGICAL DOTYPE( * )
23 * INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
24 * REAL RWORK( * )
25 * COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
26 * $ WORK( * ), X( * ), XACT( * )
27 * ..
28 *
29 *
30 *> \par Purpose:
31 * =============
32 *>
33 *> \verbatim
34 *>
35 *> CCHKSY_AA_2STAGE tests CHETRF_AA_2STAGE, -TRS_AA_2STAGE.
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 REAL
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 COMPLEX array, dimension (NMAX*NMAX)
109 *> \endverbatim
110 *>
111 *> \param[out] AFAC
112 *> \verbatim
113 *> AFAC is COMPLEX array, dimension (NMAX*NMAX)
114 *> \endverbatim
115 *>
116 *> \param[out] AINV
117 *> \verbatim
118 *> AINV is COMPLEX array, dimension (NMAX*NMAX)
119 *> \endverbatim
120 *>
121 *> \param[out] B
122 *> \verbatim
123 *> B is COMPLEX 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 array, dimension (NMAX*NSMAX)
130 *> \endverbatim
131 *>
132 *> \param[out] XACT
133 *> \verbatim
134 *> XACT is COMPLEX array, dimension (NMAX*NSMAX)
135 *> \endverbatim
136 *>
137 *> \param[out] WORK
138 *> \verbatim
139 *> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
140 *> \endverbatim
141 *>
142 *> \param[out] RWORK
143 *> \verbatim
144 *> RWORK is REAL 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 2017
167 *
168 *
169 *> \ingroup complex_lin
170 *
171 * =====================================================================
172  SUBROUTINE cchkhe_aa_2stage( DOTYPE, NN, NVAL, NNB, NBVAL, NNS,
173  $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV,
174  $ B, X, XACT, WORK, RWORK, IWORK, NOUT )
175 *
176 * -- LAPACK test routine (version 3.8.0) --
177 * -- LAPACK is a software package provided by Univ. of Tennessee, --
178 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179 * November 2017
180 *
181  IMPLICIT NONE
182 *
183 * .. Scalar Arguments ..
184  LOGICAL TSTERR
185  INTEGER NN, NNB, NNS, NMAX, NOUT
186  REAL THRESH
187 * ..
188 * .. Array Arguments ..
189 *
190  LOGICAL DOTYPE( * )
191  INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
192  REAL RWORK( * )
193  COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
194  $ work( * ), x( * ), xact( * )
195 * ..
196 *
197 * =====================================================================
198 *
199 * .. Parameters ..
200  REAL ZERO
201  parameter( zero = 0.0e+0 )
202  COMPLEX CZERO
203  parameter( czero = ( 0.0e+0, 0.0e+0 ) )
204  INTEGER NTYPES
205  parameter( ntypes = 10 )
206  INTEGER NTESTS
207  parameter( ntests = 9 )
208 * ..
209 * .. Local Scalars ..
210  LOGICAL ZEROT
211  CHARACTER DIST, TYPE, UPLO, XTYPE
212  CHARACTER*3 PATH, MATPATH
213  INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
214  $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
215  $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
216  REAL ANORM, CNDNUM
217 * ..
218 * .. Local Arrays ..
219  CHARACTER UPLOS( 2 )
220  INTEGER ISEED( 4 ), ISEEDY( 4 )
221  REAL RESULT( ntests )
222 * ..
223 * .. External Subroutines ..
224  EXTERNAL alaerh, alahd, alasum, cerrhe, clacpy,
225  $ clarhs, clatb4, clatms, cpot02,
226  $ chetrf_aa_2stage,
228 * ..
229 * .. Intrinsic Functions ..
230  INTRINSIC max, min
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 *
250 * Test path
251 *
252  path( 1: 1 ) = 'Complex precision'
253  path( 2: 3 ) = 'H2'
254 *
255 * Path to generate matrices
256 *
257  matpath( 1: 1 ) = 'Complex precision'
258  matpath( 2: 3 ) = 'HE'
259  nrun = 0
260  nfail = 0
261  nerrs = 0
262  DO 10 i = 1, 4
263  iseed( i ) = iseedy( i )
264  10 CONTINUE
265 *
266 * Test the error exits
267 *
268  IF( tsterr )
269  $ CALL cerrhe( path, nout )
270  infot = 0
271 *
272 * Set the minimum block size for which the block routine should
273 * be used, which will be later returned by ILAENV
274 *
275  CALL xlaenv( 2, 2 )
276 *
277 * Do for each value of N in NVAL
278 *
279  DO 180 in = 1, nn
280  n = nval( in )
281  IF( n .GT. nmax ) THEN
282  nfail = nfail + 1
283  WRITE(nout, 9995) 'M ', n, nmax
284  GO TO 180
285  END IF
286  lda = max( n, 1 )
287  xtype = 'N'
288  nimat = ntypes
289  IF( n.LE.0 )
290  $ nimat = 1
291 *
292  izero = 0
293 *
294 * Do for each value of matrix type IMAT
295 *
296  DO 170 imat = 1, nimat
297 *
298 * Do the tests only if DOTYPE( IMAT ) is true.
299 *
300  IF( .NOT.dotype( imat ) )
301  $ GO TO 170
302 *
303 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
304 *
305  zerot = imat.GE.3 .AND. imat.LE.6
306  IF( zerot .AND. n.LT.imat-2 )
307  $ GO TO 170
308 *
309 * Do first for UPLO = 'U', then for UPLO = 'L'
310 *
311  DO 160 iuplo = 1, 2
312  uplo = uplos( iuplo )
313 *
314 * Begin generate the test matrix A.
315 *
316 *
317 * Set up parameters with CLATB4 for the matrix generator
318 * based on the type of matrix to be generated.
319 *
320  CALL clatb4( matpath, imat, n, n, TYPE, KL, KU,
321  $ anorm, mode, cndnum, dist )
322 *
323 * Generate a matrix with CLATMS.
324 *
325  srnamt = 'CLATMS'
326  CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
327  $ cndnum, anorm, kl, ku, uplo, a, lda, work,
328  $ info )
329 *
330 * Check error code from CLATMS and handle error.
331 *
332  IF( info.NE.0 ) THEN
333  CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
334  $ -1, -1, imat, nfail, nerrs, nout )
335 *
336 * Skip all tests for this generated matrix
337 *
338  GO TO 160
339  END IF
340 *
341 * For matrix types 3-6, zero one or more rows and
342 * columns of the matrix to test that INFO is returned
343 * correctly.
344 *
345  IF( zerot ) THEN
346  IF( imat.EQ.3 ) THEN
347  izero = 1
348  ELSE IF( imat.EQ.4 ) THEN
349  izero = n
350  ELSE
351  izero = n / 2 + 1
352  END IF
353 *
354  IF( imat.LT.6 ) THEN
355 *
356 * Set row and column IZERO to zero.
357 *
358  IF( iuplo.EQ.1 ) THEN
359  ioff = ( izero-1 )*lda
360  DO 20 i = 1, izero - 1
361  a( ioff+i ) = czero
362  20 CONTINUE
363  ioff = ioff + izero
364  DO 30 i = izero, n
365  a( ioff ) = czero
366  ioff = ioff + lda
367  30 CONTINUE
368  ELSE
369  ioff = izero
370  DO 40 i = 1, izero - 1
371  a( ioff ) = czero
372  ioff = ioff + lda
373  40 CONTINUE
374  ioff = ioff - izero
375  DO 50 i = izero, n
376  a( ioff+i ) = czero
377  50 CONTINUE
378  END IF
379  ELSE
380  IF( iuplo.EQ.1 ) THEN
381 *
382 * Set the first IZERO rows and columns to zero.
383 *
384  ioff = 0
385  DO 70 j = 1, n
386  i2 = min( j, izero )
387  DO 60 i = 1, i2
388  a( ioff+i ) = czero
389  60 CONTINUE
390  ioff = ioff + lda
391  70 CONTINUE
392  izero = 1
393  ELSE
394 *
395 * Set the last IZERO rows and columns to zero.
396 *
397  ioff = 0
398  DO 90 j = 1, n
399  i1 = max( j, izero )
400  DO 80 i = i1, n
401  a( ioff+i ) = czero
402  80 CONTINUE
403  ioff = ioff + lda
404  90 CONTINUE
405  END IF
406  END IF
407  ELSE
408  izero = 0
409  END IF
410 *
411 * End generate test matrix A.
412 *
413 *
414 * Set the imaginary part of the diagonals.
415 *
416  CALL claipd( n, a, lda+1, 0 )
417 *
418 * Do for each value of NB in NBVAL
419 *
420  DO 150 inb = 1, nnb
421 *
422 * Set the optimal blocksize, which will be later
423 * returned by ILAENV.
424 *
425  nb = nbval( inb )
426  CALL xlaenv( 1, nb )
427 *
428 * Copy the test matrix A into matrix AFAC which
429 * will be factorized in place. This is needed to
430 * preserve the test matrix A for subsequent tests.
431 *
432  CALL clacpy( uplo, n, n, a, lda, afac, lda )
433 *
434 * Compute the L*D*L**T or U*D*U**T factorization of the
435 * matrix. IWORK stores details of the interchanges and
436 * the block structure of D. AINV is a work array for
437 * block factorization, LWORK is the length of AINV.
438 *
439  srnamt = 'CHETRF_AA_2STAGE'
440  lwork = min(n*nb, 3*nmax*nmax)
441  CALL chetrf_aa_2stage( uplo, n, afac, lda,
442  $ ainv, (3*nb+1)*n,
443  $ iwork, iwork( 1+n ),
444  $ work, lwork,
445  $ info )
446 *
447 * Adjust the expected value of INFO to account for
448 * pivoting.
449 *
450  IF( izero.GT.0 ) THEN
451  j = 1
452  k = izero
453  100 CONTINUE
454  IF( j.EQ.k ) THEN
455  k = iwork( j )
456  ELSE IF( iwork( j ).EQ.k ) THEN
457  k = j
458  END IF
459  IF( j.LT.k ) THEN
460  j = j + 1
461  GO TO 100
462  END IF
463  ELSE
464  k = 0
465  END IF
466 *
467 * Check error code from CHETRF and handle error.
468 *
469  IF( info.NE.k ) THEN
470  CALL alaerh( path, 'CHETRF_AA_2STAGE', info, k,
471  $ uplo, n, n, -1, -1, nb, imat, nfail,
472  $ nerrs, nout )
473  END IF
474 *
475 *+ TEST 1
476 * Reconstruct matrix from factors and compute residual.
477 *
478 *
479 c NEED TO WRITE CHET01_AA_2STAGE
480 c CALL CHET01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK,
481 c $ AINV, LDA, RWORK, RESULT( 1 ) )
482 c NT = 1
483  nt = 0
484 *
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 solver test if INFO is not 0.
501 *
502  IF( info.NE.0 ) THEN
503  GO TO 140
504  END IF
505 *
506 * Do for each value of NRHS in NSVAL.
507 *
508  DO 130 irhs = 1, nns
509  nrhs = nsval( irhs )
510 *
511 *+ TEST 2 (Using TRS)
512 * Solve and compute residual for A * X = B.
513 *
514 * Choose a set of NRHS random solution vectors
515 * stored in XACT and set up the right hand side B
516 *
517  srnamt = 'CLARHS'
518  CALL clarhs( matpath, xtype, uplo, ' ', n, n,
519  $ kl, ku, nrhs, a, lda, xact, lda,
520  $ b, lda, iseed, info )
521  CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
522 *
523  srnamt = 'CHETRS_AA_2STAGE'
524  lwork = max( 1, 3*n-2 )
525  CALL chetrs_aa_2stage( uplo, n, nrhs, afac, lda,
526  $ ainv, (3*nb+1)*n, iwork, iwork( 1+n ),
527  $ x, lda, info )
528 *
529 * Check error code from CHETRS and handle error.
530 *
531  IF( info.NE.0 ) THEN
532  IF( izero.EQ.0 ) THEN
533  CALL alaerh( path, 'CHETRS_AA_2STAGE',
534  $ info, 0, uplo, n, n, -1, -1,
535  $ nrhs, imat, nfail, nerrs, nout )
536  END IF
537  ELSE
538  CALL clacpy( 'Full', n, nrhs, b, lda, work, lda
539  $ )
540 *
541 * Compute the residual for the solution
542 *
543  CALL cpot02( uplo, n, nrhs, a, lda, x, lda,
544  $ work, lda, rwork, result( 2 ) )
545 *
546 * Print information about the tests that did not pass
547 * the threshold.
548 *
549  DO 120 k = 2, 2
550  IF( result( k ).GE.thresh ) THEN
551  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
552  $ CALL alahd( nout, path )
553  WRITE( nout, fmt = 9998 )uplo, n, nrhs,
554  $ imat, k, result( k )
555  nfail = nfail + 1
556  END IF
557  120 CONTINUE
558  END IF
559  nrun = nrun + 1
560 *
561 * End do for each value of NRHS in NSVAL.
562 *
563  130 CONTINUE
564  140 CONTINUE
565  150 CONTINUE
566  160 CONTINUE
567  170 CONTINUE
568  180 CONTINUE
569 *
570 * Print a summary of the results.
571 *
572  CALL alasum( path, nout, nfail, nrun, nerrs )
573 *
574  9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
575  $ i2, ', test ', i2, ', ratio =', g12.5 )
576  9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
577  $ i2, ', test(', i2, ') =', g12.5 )
578  9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
579  $ i6 )
580  RETURN
581 *
582 * End of CCHKSY_AA_2STAGE
583 *
584  END
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine cchkhe_aa_2stage(DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, NOUT)
CCHKHE_AA_2STAGE
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
Definition: claipd.f:85
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:149
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
Definition: cpot02.f:129
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:83
subroutine chetrf_aa_2stage(UPLO, N, A, LDA, TB, LTB, IPIV, IPIV2, WORK, LWORK, INFO)
CHETRF_AA_2STAGE
subroutine cerrhe(PATH, NUNIT)
CERRHE
Definition: cerrhe.f:57
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 clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine chetrs_aa_2stage(UPLO, N, NRHS, A, LDA, TB, LTB, IPIV, IPIV2, B, LDB, INFO)
CHETRS_AA_2STAGE
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 alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:75
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
Definition: clatb4.f:123