1*> \brief \b SCHKPO
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 SCHKPO( 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*       REAL               THRESH
19*       ..
20*       .. Array Arguments ..
21*       LOGICAL            DOTYPE( * )
22*       INTEGER            IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
23*       REAL               A( * ), AFAC( * ), AINV( * ), B( * ),
24*      $                   RWORK( * ), WORK( * ), X( * ), XACT( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> SCHKPO tests SPOTRF, -TRI, -TRS, -RFS, and -CON
34*> \endverbatim
35*
36*  Arguments:
37*  ==========
38*
39*> \param[in] DOTYPE
40*> \verbatim
41*>          DOTYPE is LOGICAL array, dimension (NTYPES)
42*>          The matrix types to be used for testing.  Matrices of type j
43*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
45*> \endverbatim
46*>
47*> \param[in] NN
48*> \verbatim
49*>          NN is INTEGER
50*>          The number of values of N contained in the vector NVAL.
51*> \endverbatim
52*>
53*> \param[in] NVAL
54*> \verbatim
55*>          NVAL is INTEGER array, dimension (NN)
56*>          The values of the matrix dimension N.
57*> \endverbatim
58*>
59*> \param[in] NNB
60*> \verbatim
61*>          NNB is INTEGER
62*>          The number of values of NB contained in the vector NBVAL.
63*> \endverbatim
64*>
65*> \param[in] NBVAL
66*> \verbatim
67*>          NBVAL is INTEGER array, dimension (NBVAL)
68*>          The values of the blocksize NB.
69*> \endverbatim
70*>
71*> \param[in] NNS
72*> \verbatim
73*>          NNS is INTEGER
74*>          The number of values of NRHS contained in the vector NSVAL.
75*> \endverbatim
76*>
77*> \param[in] NSVAL
78*> \verbatim
79*>          NSVAL is INTEGER array, dimension (NNS)
80*>          The values of the number of right hand sides NRHS.
81*> \endverbatim
82*>
83*> \param[in] THRESH
84*> \verbatim
85*>          THRESH is REAL
86*>          The threshold value for the test ratios.  A result is
87*>          included in the output file if RESULT >= THRESH.  To have
88*>          every test ratio printed, use THRESH = 0.
89*> \endverbatim
90*>
91*> \param[in] TSTERR
92*> \verbatim
93*>          TSTERR is LOGICAL
94*>          Flag that indicates whether error exits are to be tested.
95*> \endverbatim
96*>
97*> \param[in] NMAX
98*> \verbatim
99*>          NMAX is INTEGER
100*>          The maximum value permitted for N, used in dimensioning the
101*>          work arrays.
102*> \endverbatim
103*>
104*> \param[out] A
105*> \verbatim
106*>          A is REAL array, dimension (NMAX*NMAX)
107*> \endverbatim
108*>
109*> \param[out] AFAC
110*> \verbatim
111*>          AFAC is REAL array, dimension (NMAX*NMAX)
112*> \endverbatim
113*>
114*> \param[out] AINV
115*> \verbatim
116*>          AINV is REAL array, dimension (NMAX*NMAX)
117*> \endverbatim
118*>
119*> \param[out] B
120*> \verbatim
121*>          B is REAL array, dimension (NMAX*NSMAX)
122*>          where NSMAX is the largest entry in NSVAL.
123*> \endverbatim
124*>
125*> \param[out] X
126*> \verbatim
127*>          X is REAL array, dimension (NMAX*NSMAX)
128*> \endverbatim
129*>
130*> \param[out] XACT
131*> \verbatim
132*>          XACT is REAL array, dimension (NMAX*NSMAX)
133*> \endverbatim
134*>
135*> \param[out] WORK
136*> \verbatim
137*>          WORK is REAL array, dimension
138*>                      (NMAX*max(3,NSMAX))
139*> \endverbatim
140*>
141*> \param[out] RWORK
142*> \verbatim
143*>          RWORK is REAL array, dimension
144*>                      (max(NMAX,2*NSMAX))
145*> \endverbatim
146*>
147*> \param[out] IWORK
148*> \verbatim
149*>          IWORK is INTEGER array, dimension (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 2011
167*
168*> \ingroup single_lin
169*
170*  =====================================================================
171      SUBROUTINE SCHKPO( 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.4.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 2011
179*
180*     .. Scalar Arguments ..
181      LOGICAL            TSTERR
182      INTEGER            NMAX, NN, NNB, NNS, NOUT
183      REAL               THRESH
184*     ..
185*     .. Array Arguments ..
186      LOGICAL            DOTYPE( * )
187      INTEGER            IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
188      REAL               A( * ), AFAC( * ), AINV( * ), B( * ),
189     $                   RWORK( * ), WORK( * ), X( * ), XACT( * )
190*     ..
191*
192*  =====================================================================
193*
194*     .. Parameters ..
195      REAL               ZERO
196      PARAMETER          ( ZERO = 0.0E+0 )
197      INTEGER            NTYPES
198      PARAMETER          ( NTYPES = 9 )
199      INTEGER            NTESTS
200      PARAMETER          ( NTESTS = 8 )
201*     ..
202*     .. Local Scalars ..
203      LOGICAL            ZEROT
204      CHARACTER          DIST, TYPE, UPLO, XTYPE
205      CHARACTER*3        PATH
206      INTEGER            I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
207     $                   IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS,
208     $                   NFAIL, NIMAT, NRHS, NRUN
209      REAL               ANORM, CNDNUM, RCOND, RCONDC
210*     ..
211*     .. Local Arrays ..
212      CHARACTER          UPLOS( 2 )
213      INTEGER            ISEED( 4 ), ISEEDY( 4 )
214      REAL               RESULT( NTESTS )
215*     ..
216*     .. External Functions ..
217      REAL               SGET06, SLANSY
218      EXTERNAL           SGET06, SLANSY
219*     ..
220*     .. External Subroutines ..
221      EXTERNAL           ALAERH, ALAHD, ALASUM, SERRPO, SGET04, SLACPY,
222     $                   SLARHS, SLATB4, SLATMS, SPOCON, SPORFS, SPOT01,
223     $                   SPOT02, SPOT03, SPOT05, SPOTRF, SPOTRI, SPOTRS,
224     $                   XLAENV
225*     ..
226*     .. Scalars in Common ..
227      LOGICAL            LERR, OK
228      CHARACTER*32       SRNAMT
229      INTEGER            INFOT, NUNIT
230*     ..
231*     .. Common blocks ..
232      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
233      COMMON             / SRNAMC / SRNAMT
234*     ..
235*     .. Intrinsic Functions ..
236      INTRINSIC          MAX
237*     ..
238*     .. Data statements ..
239      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
240      DATA               UPLOS / 'U', 'L' /
241*     ..
242*     .. Executable Statements ..
243*
244*     Initialize constants and the random number seed.
245*
246      PATH( 1: 1 ) = 'Single precision'
247      PATH( 2: 3 ) = 'PO'
248      NRUN = 0
249      NFAIL = 0
250      NERRS = 0
251      DO 10 I = 1, 4
252         ISEED( I ) = ISEEDY( I )
253   10 CONTINUE
254*
255*     Test the error exits
256*
257      IF( TSTERR )
258     $   CALL SERRPO( PATH, NOUT )
259      INFOT = 0
260      CALL XLAENV( 2, 2 )
261*
262*     Do for each value of N in NVAL
263*
264      DO 120 IN = 1, NN
265         N = NVAL( IN )
266         LDA = MAX( N, 1 )
267         XTYPE = 'N'
268         NIMAT = NTYPES
269         IF( N.LE.0 )
270     $      NIMAT = 1
271*
272         IZERO = 0
273         DO 110 IMAT = 1, NIMAT
274*
275*           Do the tests only if DOTYPE( IMAT ) is true.
276*
277            IF( .NOT.DOTYPE( IMAT ) )
278     $         GO TO 110
279*
280*           Skip types 3, 4, or 5 if the matrix size is too small.
281*
282            ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
283            IF( ZEROT .AND. N.LT.IMAT-2 )
284     $         GO TO 110
285*
286*           Do first for UPLO = 'U', then for UPLO = 'L'
287*
288            DO 100 IUPLO = 1, 2
289               UPLO = UPLOS( IUPLO )
290*
291*              Set up parameters with SLATB4 and generate a test matrix
292*              with SLATMS.
293*
294               CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
295     $                      CNDNUM, DIST )
296*
297               SRNAMT = 'SLATMS'
298               CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
299     $                      CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
300     $                      INFO )
301*
302*              Check error code from SLATMS.
303*
304               IF( INFO.NE.0 ) THEN
305                  CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
306     $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
307                  GO TO 100
308               END IF
309*
310*              For types 3-5, zero one row and column of the matrix to
311*              test that INFO is returned correctly.
312*
313               IF( ZEROT ) THEN
314                  IF( IMAT.EQ.3 ) THEN
315                     IZERO = 1
316                  ELSE IF( IMAT.EQ.4 ) THEN
317                     IZERO = N
318                  ELSE
319                     IZERO = N / 2 + 1
320                  END IF
321                  IOFF = ( IZERO-1 )*LDA
322*
323*                 Set row and column IZERO of A to 0.
324*
325                  IF( IUPLO.EQ.1 ) THEN
326                     DO 20 I = 1, IZERO - 1
327                        A( IOFF+I ) = ZERO
328   20                CONTINUE
329                     IOFF = IOFF + IZERO
330                     DO 30 I = IZERO, N
331                        A( IOFF ) = ZERO
332                        IOFF = IOFF + LDA
333   30                CONTINUE
334                  ELSE
335                     IOFF = IZERO
336                     DO 40 I = 1, IZERO - 1
337                        A( IOFF ) = ZERO
338                        IOFF = IOFF + LDA
339   40                CONTINUE
340                     IOFF = IOFF - IZERO
341                     DO 50 I = IZERO, N
342                        A( IOFF+I ) = ZERO
343   50                CONTINUE
344                  END IF
345               ELSE
346                  IZERO = 0
347               END IF
348*
349*              Do for each value of NB in NBVAL
350*
351               DO 90 INB = 1, NNB
352                  NB = NBVAL( INB )
353                  CALL XLAENV( 1, NB )
354*
355*                 Compute the L*L' or U'*U factorization of the matrix.
356*
357                  CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
358                  SRNAMT = 'SPOTRF'
359                  CALL SPOTRF( UPLO, N, AFAC, LDA, INFO )
360*
361*                 Check error code from SPOTRF.
362*
363                  IF( INFO.NE.IZERO ) THEN
364                     CALL ALAERH( PATH, 'SPOTRF', INFO, IZERO, UPLO, N,
365     $                            N, -1, -1, NB, IMAT, NFAIL, NERRS,
366     $                            NOUT )
367                     GO TO 90
368                  END IF
369*
370*                 Skip the tests if INFO is not 0.
371*
372                  IF( INFO.NE.0 )
373     $               GO TO 90
374*
375*+    TEST 1
376*                 Reconstruct matrix from factors and compute residual.
377*
378                  CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
379                  CALL SPOT01( UPLO, N, A, LDA, AINV, LDA, RWORK,
380     $                         RESULT( 1 ) )
381*
382*+    TEST 2
383*                 Form the inverse and compute the residual.
384*
385                  CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
386                  SRNAMT = 'SPOTRI'
387                  CALL SPOTRI( UPLO, N, AINV, LDA, INFO )
388*
389*                 Check error code from SPOTRI.
390*
391                  IF( INFO.NE.0 )
392     $               CALL ALAERH( PATH, 'SPOTRI', INFO, 0, UPLO, N, N,
393     $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
394*
395                  CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
396     $                         RWORK, RCONDC, RESULT( 2 ) )
397*
398*                 Print information about the tests that did not pass
399*                 the threshold.
400*
401                  DO 60 K = 1, 2
402                     IF( RESULT( K ).GE.THRESH ) THEN
403                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
404     $                     CALL ALAHD( NOUT, PATH )
405                        WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
406     $                     RESULT( K )
407                        NFAIL = NFAIL + 1
408                     END IF
409   60             CONTINUE
410                  NRUN = NRUN + 2
411*
412*                 Skip the rest of the tests unless this is the first
413*                 blocksize.
414*
415                  IF( INB.NE.1 )
416     $               GO TO 90
417*
418                  DO 80 IRHS = 1, NNS
419                     NRHS = NSVAL( IRHS )
420*
421*+    TEST 3
422*                 Solve and compute residual for A * X = B .
423*
424                     SRNAMT = 'SLARHS'
425                     CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
426     $                            NRHS, A, LDA, XACT, LDA, B, LDA,
427     $                            ISEED, INFO )
428                     CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
429*
430                     SRNAMT = 'SPOTRS'
431                     CALL SPOTRS( UPLO, N, NRHS, AFAC, LDA, X, LDA,
432     $                            INFO )
433*
434*                 Check error code from SPOTRS.
435*
436                     IF( INFO.NE.0 )
437     $                  CALL ALAERH( PATH, 'SPOTRS', INFO, 0, UPLO, N,
438     $                               N, -1, -1, NRHS, IMAT, NFAIL,
439     $                               NERRS, NOUT )
440*
441                     CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
442                     CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
443     $                            LDA, RWORK, RESULT( 3 ) )
444*
445*+    TEST 4
446*                 Check solution from generated exact solution.
447*
448                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
449     $                            RESULT( 4 ) )
450*
451*+    TESTS 5, 6, and 7
452*                 Use iterative refinement to improve the solution.
453*
454                     SRNAMT = 'SPORFS'
455                     CALL SPORFS( UPLO, N, NRHS, A, LDA, AFAC, LDA, B,
456     $                            LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
457     $                            WORK, IWORK, INFO )
458*
459*                 Check error code from SPORFS.
460*
461                     IF( INFO.NE.0 )
462     $                  CALL ALAERH( PATH, 'SPORFS', INFO, 0, UPLO, N,
463     $                               N, -1, -1, NRHS, IMAT, NFAIL,
464     $                               NERRS, NOUT )
465*
466                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
467     $                            RESULT( 5 ) )
468                     CALL SPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
469     $                            XACT, LDA, RWORK, RWORK( NRHS+1 ),
470     $                            RESULT( 6 ) )
471*
472*                    Print information about the tests that did not pass
473*                    the threshold.
474*
475                     DO 70 K = 3, 7
476                        IF( RESULT( K ).GE.THRESH ) THEN
477                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
478     $                        CALL ALAHD( NOUT, PATH )
479                           WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
480     $                        IMAT, K, RESULT( K )
481                           NFAIL = NFAIL + 1
482                        END IF
483   70                CONTINUE
484                     NRUN = NRUN + 5
485   80             CONTINUE
486*
487*+    TEST 8
488*                 Get an estimate of RCOND = 1/CNDNUM.
489*
490                  ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
491                  SRNAMT = 'SPOCON'
492                  CALL SPOCON( UPLO, N, AFAC, LDA, ANORM, RCOND, WORK,
493     $                         IWORK, INFO )
494*
495*                 Check error code from SPOCON.
496*
497                  IF( INFO.NE.0 )
498     $               CALL ALAERH( PATH, 'SPOCON', INFO, 0, UPLO, N, N,
499     $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
500*
501                  RESULT( 8 ) = SGET06( RCOND, RCONDC )
502*
503*                 Print the test ratio if it is .GE. THRESH.
504*
505                  IF( RESULT( 8 ).GE.THRESH ) THEN
506                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
507     $                  CALL ALAHD( NOUT, PATH )
508                     WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 8,
509     $                  RESULT( 8 )
510                     NFAIL = NFAIL + 1
511                  END IF
512                  NRUN = NRUN + 1
513   90          CONTINUE
514  100       CONTINUE
515  110    CONTINUE
516  120 CONTINUE
517*
518*     Print a summary of the results.
519*
520      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
521*
522 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
523     $      I2, ', test ', I2, ', ratio =', G12.5 )
524 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
525     $      I2, ', test(', I2, ') =', G12.5 )
526 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
527     $      ', test(', I2, ') =', G12.5 )
528      RETURN
529*
530*     End of SCHKPO
531*
532      END
533