1*> \brief \b CDRVHP
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 CDRVHP( 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*> CDRVHP tests the driver routines CHPSV 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
91*>                      (NMAX*(NMAX+1)/2)
92*> \endverbatim
93*>
94*> \param[out] AFAC
95*> \verbatim
96*>          AFAC is COMPLEX array, dimension
97*>                      (NMAX*(NMAX+1)/2)
98*> \endverbatim
99*>
100*> \param[out] AINV
101*> \verbatim
102*>          AINV is COMPLEX array, dimension
103*>                      (NMAX*(NMAX+1)/2)
104*> \endverbatim
105*>
106*> \param[out] B
107*> \verbatim
108*>          B is COMPLEX array, dimension (NMAX*NRHS)
109*> \endverbatim
110*>
111*> \param[out] X
112*> \verbatim
113*>          X is COMPLEX array, dimension (NMAX*NRHS)
114*> \endverbatim
115*>
116*> \param[out] XACT
117*> \verbatim
118*>          XACT is COMPLEX array, dimension (NMAX*NRHS)
119*> \endverbatim
120*>
121*> \param[out] WORK
122*> \verbatim
123*>          WORK is COMPLEX array, dimension
124*>                      (NMAX*max(2,NRHS))
125*> \endverbatim
126*>
127*> \param[out] RWORK
128*> \verbatim
129*>          RWORK is REAL array, dimension (NMAX+2*NRHS)
130*> \endverbatim
131*>
132*> \param[out] IWORK
133*> \verbatim
134*>          IWORK is INTEGER array, dimension (NMAX)
135*> \endverbatim
136*>
137*> \param[in] NOUT
138*> \verbatim
139*>          NOUT is INTEGER
140*>          The unit number for output.
141*> \endverbatim
142*
143*  Authors:
144*  ========
145*
146*> \author Univ. of Tennessee
147*> \author Univ. of California Berkeley
148*> \author Univ. of Colorado Denver
149*> \author NAG Ltd.
150*
151*> \ingroup complex_lin
152*
153*  =====================================================================
154      SUBROUTINE CDRVHP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
155     $                   A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
156     $                   NOUT )
157*
158*  -- LAPACK test routine --
159*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
160*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161*
162*     .. Scalar Arguments ..
163      LOGICAL            TSTERR
164      INTEGER            NMAX, NN, NOUT, NRHS
165      REAL               THRESH
166*     ..
167*     .. Array Arguments ..
168      LOGICAL            DOTYPE( * )
169      INTEGER            IWORK( * ), NVAL( * )
170      REAL               RWORK( * )
171      COMPLEX            A( * ), AFAC( * ), AINV( * ), B( * ),
172     $                   WORK( * ), X( * ), XACT( * )
173*     ..
174*
175*  =====================================================================
176*
177*     .. Parameters ..
178      REAL               ONE, ZERO
179      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
180      INTEGER            NTYPES, NTESTS
181      PARAMETER          ( NTYPES = 10, NTESTS = 6 )
182      INTEGER            NFACT
183      PARAMETER          ( NFACT = 2 )
184*     ..
185*     .. Local Scalars ..
186      LOGICAL            ZEROT
187      CHARACTER          DIST, FACT, PACKIT, TYPE, UPLO, XTYPE
188      CHARACTER*3        PATH
189      INTEGER            I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
190     $                   IZERO, J, K, K1, KL, KU, LDA, MODE, N, NB,
191     $                   NBMIN, NERRS, NFAIL, NIMAT, NPP, NRUN, NT
192      REAL               AINVNM, ANORM, CNDNUM, RCOND, RCONDC
193*     ..
194*     .. Local Arrays ..
195      CHARACTER          FACTS( NFACT )
196      INTEGER            ISEED( 4 ), ISEEDY( 4 )
197      REAL               RESULT( NTESTS )
198*     ..
199*     .. External Functions ..
200      REAL               CLANHP, SGET06
201      EXTERNAL           CLANHP, SGET06
202*     ..
203*     .. External Subroutines ..
204      EXTERNAL           ALADHD, ALAERH, ALASVM, CCOPY, CERRVX, CGET04,
205     $                   CHPSV, CHPSVX, CHPT01, CHPTRF, CHPTRI, CLACPY,
206     $                   CLAIPD, CLARHS, CLASET, CLATB4, CLATMS, CPPT02,
207     $                   CPPT05, XLAENV
208*     ..
209*     .. Scalars in Common ..
210      LOGICAL            LERR, OK
211      CHARACTER*32       SRNAMT
212      INTEGER            INFOT, NUNIT
213*     ..
214*     .. Common blocks ..
215      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
216      COMMON             / SRNAMC / SRNAMT
217*     ..
218*     .. Intrinsic Functions ..
219      INTRINSIC          CMPLX, MAX, MIN
220*     ..
221*     .. Data statements ..
222      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
223      DATA               FACTS / 'F', 'N' /
224*     ..
225*     .. Executable Statements ..
226*
227*     Initialize constants and the random number seed.
228*
229      PATH( 1: 1 ) = 'C'
230      PATH( 2: 3 ) = 'HP'
231      NRUN = 0
232      NFAIL = 0
233      NERRS = 0
234      DO 10 I = 1, 4
235         ISEED( I ) = ISEEDY( I )
236   10 CONTINUE
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         NPP = N*( N+1 ) / 2
257         XTYPE = 'N'
258         NIMAT = NTYPES
259         IF( N.LE.0 )
260     $      NIMAT = 1
261*
262         DO 170 IMAT = 1, NIMAT
263*
264*           Do the tests only if DOTYPE( IMAT ) is true.
265*
266            IF( .NOT.DOTYPE( IMAT ) )
267     $         GO TO 170
268*
269*           Skip types 3, 4, 5, or 6 if the matrix size is too small.
270*
271            ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
272            IF( ZEROT .AND. N.LT.IMAT-2 )
273     $         GO TO 170
274*
275*           Do first for UPLO = 'U', then for UPLO = 'L'
276*
277            DO 160 IUPLO = 1, 2
278               IF( IUPLO.EQ.1 ) THEN
279                  UPLO = 'U'
280                  PACKIT = 'C'
281               ELSE
282                  UPLO = 'L'
283                  PACKIT = 'R'
284               END IF
285*
286*              Set up parameters with CLATB4 and generate a test matrix
287*              with CLATMS.
288*
289               CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
290     $                      CNDNUM, DIST )
291*
292               SRNAMT = 'CLATMS'
293               CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
294     $                      CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
295     $                      INFO )
296*
297*              Check error code from CLATMS.
298*
299               IF( INFO.NE.0 ) THEN
300                  CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1,
301     $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
302                  GO TO 160
303               END IF
304*
305*              For types 3-6, zero one or more rows and columns of the
306*              matrix to test that INFO is returned correctly.
307*
308               IF( ZEROT ) THEN
309                  IF( IMAT.EQ.3 ) THEN
310                     IZERO = 1
311                  ELSE IF( IMAT.EQ.4 ) THEN
312                     IZERO = N
313                  ELSE
314                     IZERO = N / 2 + 1
315                  END IF
316*
317                  IF( IMAT.LT.6 ) THEN
318*
319*                    Set row and column IZERO to zero.
320*
321                     IF( IUPLO.EQ.1 ) THEN
322                        IOFF = ( IZERO-1 )*IZERO / 2
323                        DO 20 I = 1, IZERO - 1
324                           A( IOFF+I ) = ZERO
325   20                   CONTINUE
326                        IOFF = IOFF + IZERO
327                        DO 30 I = IZERO, N
328                           A( IOFF ) = ZERO
329                           IOFF = IOFF + I
330   30                   CONTINUE
331                     ELSE
332                        IOFF = IZERO
333                        DO 40 I = 1, IZERO - 1
334                           A( IOFF ) = ZERO
335                           IOFF = IOFF + N - I
336   40                   CONTINUE
337                        IOFF = IOFF - IZERO
338                        DO 50 I = IZERO, N
339                           A( IOFF+I ) = ZERO
340   50                   CONTINUE
341                     END IF
342                  ELSE
343                     IOFF = 0
344                     IF( IUPLO.EQ.1 ) THEN
345*
346*                       Set the first IZERO rows and columns to zero.
347*
348                        DO 70 J = 1, N
349                           I2 = MIN( J, IZERO )
350                           DO 60 I = 1, I2
351                              A( IOFF+I ) = ZERO
352   60                      CONTINUE
353                           IOFF = IOFF + J
354   70                   CONTINUE
355                     ELSE
356*
357*                       Set the last IZERO rows and columns to zero.
358*
359                        DO 90 J = 1, N
360                           I1 = MAX( J, IZERO )
361                           DO 80 I = I1, N
362                              A( IOFF+I ) = ZERO
363   80                      CONTINUE
364                           IOFF = IOFF + N - J
365   90                   CONTINUE
366                     END IF
367                  END IF
368               ELSE
369                  IZERO = 0
370               END IF
371*
372*              Set the imaginary part of the diagonals.
373*
374               IF( IUPLO.EQ.1 ) THEN
375                  CALL CLAIPD( N, A, 2, 1 )
376               ELSE
377                  CALL CLAIPD( N, A, N, -1 )
378               END IF
379*
380               DO 150 IFACT = 1, NFACT
381*
382*                 Do first for FACT = 'F', then for other values.
383*
384                  FACT = FACTS( IFACT )
385*
386*                 Compute the condition number for comparison with
387*                 the value returned by CHPSVX.
388*
389                  IF( ZEROT ) THEN
390                     IF( IFACT.EQ.1 )
391     $                  GO TO 150
392                     RCONDC = ZERO
393*
394                  ELSE IF( IFACT.EQ.1 ) THEN
395*
396*                    Compute the 1-norm of A.
397*
398                     ANORM = CLANHP( '1', UPLO, N, A, RWORK )
399*
400*                    Factor the matrix A.
401*
402                     CALL CCOPY( NPP, A, 1, AFAC, 1 )
403                     CALL CHPTRF( UPLO, N, AFAC, IWORK, INFO )
404*
405*                    Compute inv(A) and take its norm.
406*
407                     CALL CCOPY( NPP, AFAC, 1, AINV, 1 )
408                     CALL CHPTRI( UPLO, N, AINV, IWORK, WORK, INFO )
409                     AINVNM = CLANHP( '1', UPLO, N, AINV, RWORK )
410*
411*                    Compute the 1-norm condition number of A.
412*
413                     IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
414                        RCONDC = ONE
415                     ELSE
416                        RCONDC = ( ONE / ANORM ) / AINVNM
417                     END IF
418                  END IF
419*
420*                 Form an exact solution and set the right hand side.
421*
422                  SRNAMT = 'CLARHS'
423                  CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
424     $                         NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
425     $                         INFO )
426                  XTYPE = 'C'
427*
428*                 --- Test CHPSV  ---
429*
430                  IF( IFACT.EQ.2 ) THEN
431                     CALL CCOPY( NPP, A, 1, AFAC, 1 )
432                     CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
433*
434*                    Factor the matrix and solve the system using CHPSV.
435*
436                     SRNAMT = 'CHPSV '
437                     CALL CHPSV( UPLO, N, NRHS, AFAC, IWORK, X, LDA,
438     $                           INFO )
439*
440*                    Adjust the expected value of INFO to account for
441*                    pivoting.
442*
443                     K = IZERO
444                     IF( K.GT.0 ) THEN
445  100                   CONTINUE
446                        IF( IWORK( K ).LT.0 ) THEN
447                           IF( IWORK( K ).NE.-K ) THEN
448                              K = -IWORK( K )
449                              GO TO 100
450                           END IF
451                        ELSE IF( IWORK( K ).NE.K ) THEN
452                           K = IWORK( K )
453                           GO TO 100
454                        END IF
455                     END IF
456*
457*                    Check error code from CHPSV .
458*
459                     IF( INFO.NE.K ) THEN
460                        CALL ALAERH( PATH, 'CHPSV ', INFO, K, UPLO, N,
461     $                               N, -1, -1, NRHS, IMAT, NFAIL,
462     $                               NERRS, NOUT )
463                        GO TO 120
464                     ELSE IF( INFO.NE.0 ) THEN
465                        GO TO 120
466                     END IF
467*
468*                    Reconstruct matrix from factors and compute
469*                    residual.
470*
471                     CALL CHPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
472     $                            RWORK, RESULT( 1 ) )
473*
474*                    Compute residual of the computed solution.
475*
476                     CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
477                     CALL CPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
478     $                            RWORK, RESULT( 2 ) )
479*
480*                    Check solution from generated exact solution.
481*
482                     CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
483     $                            RESULT( 3 ) )
484                     NT = 3
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 ALADHD( NOUT, PATH )
493                           WRITE( NOUT, FMT = 9999 )'CHPSV ', UPLO, N,
494     $                        IMAT, K, RESULT( K )
495                           NFAIL = NFAIL + 1
496                        END IF
497  110                CONTINUE
498                     NRUN = NRUN + NT
499  120                CONTINUE
500                  END IF
501*
502*                 --- Test CHPSVX ---
503*
504                  IF( IFACT.EQ.2 .AND. NPP.GT.0 )
505     $               CALL CLASET( 'Full', NPP, 1, CMPLX( ZERO ),
506     $                            CMPLX( ZERO ), AFAC, NPP )
507                  CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ),
508     $                         CMPLX( ZERO ), X, LDA )
509*
510*                 Solve the system and compute the condition number and
511*                 error bounds using CHPSVX.
512*
513                  SRNAMT = 'CHPSVX'
514                  CALL CHPSVX( FACT, UPLO, N, NRHS, A, AFAC, IWORK, B,
515     $                         LDA, X, LDA, RCOND, RWORK,
516     $                         RWORK( NRHS+1 ), WORK, RWORK( 2*NRHS+1 ),
517     $                         INFO )
518*
519*                 Adjust the expected value of INFO to account for
520*                 pivoting.
521*
522                  K = IZERO
523                  IF( K.GT.0 ) THEN
524  130                CONTINUE
525                     IF( IWORK( K ).LT.0 ) THEN
526                        IF( IWORK( K ).NE.-K ) THEN
527                           K = -IWORK( K )
528                           GO TO 130
529                        END IF
530                     ELSE IF( IWORK( K ).NE.K ) THEN
531                        K = IWORK( K )
532                        GO TO 130
533                     END IF
534                  END IF
535*
536*                 Check the error code from CHPSVX.
537*
538                  IF( INFO.NE.K ) THEN
539                     CALL ALAERH( PATH, 'CHPSVX', INFO, K, FACT // UPLO,
540     $                            N, N, -1, -1, NRHS, IMAT, NFAIL,
541     $                            NERRS, NOUT )
542                     GO TO 150
543                  END IF
544*
545                  IF( INFO.EQ.0 ) THEN
546                     IF( IFACT.GE.2 ) THEN
547*
548*                       Reconstruct matrix from factors and compute
549*                       residual.
550*
551                        CALL CHPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA,
552     $                               RWORK( 2*NRHS+1 ), RESULT( 1 ) )
553                        K1 = 1
554                     ELSE
555                        K1 = 2
556                     END IF
557*
558*                    Compute residual of the computed solution.
559*
560                     CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
561                     CALL CPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA,
562     $                            RWORK( 2*NRHS+1 ), RESULT( 2 ) )
563*
564*                    Check solution from generated exact solution.
565*
566                     CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
567     $                            RESULT( 3 ) )
568*
569*                    Check the error bounds from iterative refinement.
570*
571                     CALL CPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA,
572     $                            XACT, LDA, RWORK, RWORK( NRHS+1 ),
573     $                            RESULT( 4 ) )
574                  ELSE
575                     K1 = 6
576                  END IF
577*
578*                 Compare RCOND from CHPSVX with the computed value
579*                 in RCONDC.
580*
581                  RESULT( 6 ) = SGET06( RCOND, RCONDC )
582*
583*                 Print information about the tests that did not pass
584*                 the threshold.
585*
586                  DO 140 K = K1, 6
587                     IF( RESULT( K ).GE.THRESH ) THEN
588                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
589     $                     CALL ALADHD( NOUT, PATH )
590                        WRITE( NOUT, FMT = 9998 )'CHPSVX', FACT, UPLO,
591     $                     N, IMAT, K, RESULT( K )
592                        NFAIL = NFAIL + 1
593                     END IF
594  140             CONTINUE
595                  NRUN = NRUN + 7 - K1
596*
597  150          CONTINUE
598*
599  160       CONTINUE
600  170    CONTINUE
601  180 CONTINUE
602*
603*     Print a summary of the results.
604*
605      CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
606*
607 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
608     $      ', test ', I2, ', ratio =', G12.5 )
609 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
610     $      ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
611      RETURN
612*
613*     End of CDRVHP
614*
615      END
616