1*> \brief \b SCHKTP
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 SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
12*                          NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
13*                          IWORK, NOUT )
14*
15*       .. Scalar Arguments ..
16*       LOGICAL            TSTERR
17*       INTEGER            NMAX, NN, NNS, NOUT
18*       REAL               THRESH
19*       ..
20*       .. Array Arguments ..
21*       LOGICAL            DOTYPE( * )
22*       INTEGER            IWORK( * ), NSVAL( * ), NVAL( * )
23*       REAL               AINVP( * ), AP( * ), B( * ), RWORK( * ),
24*      $                   WORK( * ), X( * ), XACT( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS
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 column dimension N.
57*> \endverbatim
58*>
59*> \param[in] NNS
60*> \verbatim
61*>          NNS is INTEGER
62*>          The number of values of NRHS contained in the vector NSVAL.
63*> \endverbatim
64*>
65*> \param[in] NSVAL
66*> \verbatim
67*>          NSVAL is INTEGER array, dimension (NNS)
68*>          The values of the number of right hand sides NRHS.
69*> \endverbatim
70*>
71*> \param[in] THRESH
72*> \verbatim
73*>          THRESH is REAL
74*>          The threshold value for the test ratios.  A result is
75*>          included in the output file if RESULT >= THRESH.  To have
76*>          every test ratio printed, use THRESH = 0.
77*> \endverbatim
78*>
79*> \param[in] TSTERR
80*> \verbatim
81*>          TSTERR is LOGICAL
82*>          Flag that indicates whether error exits are to be tested.
83*> \endverbatim
84*>
85*> \param[in] NMAX
86*> \verbatim
87*>          NMAX is INTEGER
88*>          The leading dimension of the work arrays.  NMAX >= the
89*>          maximumm value of N in NVAL.
90*> \endverbatim
91*>
92*> \param[out] AP
93*> \verbatim
94*>          AP is REAL array, dimension
95*>                      (NMAX*(NMAX+1)/2)
96*> \endverbatim
97*>
98*> \param[out] AINVP
99*> \verbatim
100*>          AINVP is REAL array, dimension
101*>                      (NMAX*(NMAX+1)/2)
102*> \endverbatim
103*>
104*> \param[out] B
105*> \verbatim
106*>          B is REAL array, dimension (NMAX*NSMAX)
107*>          where NSMAX is the largest entry in NSVAL.
108*> \endverbatim
109*>
110*> \param[out] X
111*> \verbatim
112*>          X is REAL array, dimension (NMAX*NSMAX)
113*> \endverbatim
114*>
115*> \param[out] XACT
116*> \verbatim
117*>          XACT is REAL array, dimension (NMAX*NSMAX)
118*> \endverbatim
119*>
120*> \param[out] WORK
121*> \verbatim
122*>          WORK is REAL array, dimension
123*>                      (NMAX*max(3,NSMAX))
124*> \endverbatim
125*>
126*> \param[out] IWORK
127*> \verbatim
128*>          IWORK is INTEGER array, dimension (NMAX)
129*> \endverbatim
130*>
131*> \param[out] RWORK
132*> \verbatim
133*>          RWORK is REAL array, dimension
134*>                      (max(NMAX,2*NSMAX))
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*> \date November 2011
152*
153*> \ingroup single_lin
154*
155*  =====================================================================
156      SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
157     $                   NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
158     $                   IWORK, NOUT )
159*
160*  -- LAPACK test routine (version 3.4.0) --
161*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
162*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*     November 2011
164*
165*     .. Scalar Arguments ..
166      LOGICAL            TSTERR
167      INTEGER            NMAX, NN, NNS, NOUT
168      REAL               THRESH
169*     ..
170*     .. Array Arguments ..
171      LOGICAL            DOTYPE( * )
172      INTEGER            IWORK( * ), NSVAL( * ), NVAL( * )
173      REAL               AINVP( * ), AP( * ), B( * ), RWORK( * ),
174     $                   WORK( * ), X( * ), XACT( * )
175*     ..
176*
177*  =====================================================================
178*
179*     .. Parameters ..
180      INTEGER            NTYPE1, NTYPES
181      PARAMETER          ( NTYPE1 = 10, NTYPES = 18 )
182      INTEGER            NTESTS
183      PARAMETER          ( NTESTS = 9 )
184      INTEGER            NTRAN
185      PARAMETER          ( NTRAN = 3 )
186      REAL               ONE, ZERO
187      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
188*     ..
189*     .. Local Scalars ..
190      CHARACTER          DIAG, NORM, TRANS, UPLO, XTYPE
191      CHARACTER*3        PATH
192      INTEGER            I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
193     $                   K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
194      REAL               AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
195     $                   SCALE
196*     ..
197*     .. Local Arrays ..
198      CHARACTER          TRANSS( NTRAN ), UPLOS( 2 )
199      INTEGER            ISEED( 4 ), ISEEDY( 4 )
200      REAL               RESULT( NTESTS )
201*     ..
202*     .. External Functions ..
203      LOGICAL            LSAME
204      REAL               SLANTP
205      EXTERNAL           LSAME, SLANTP
206*     ..
207*     .. External Subroutines ..
208      EXTERNAL           ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04,
209     $                   SLACPY, SLARHS, SLATPS, SLATTP, STPCON, STPRFS,
210     $                   STPT01, STPT02, STPT03, STPT05, STPT06, STPTRI,
211     $                   STPTRS
212*     ..
213*     .. Scalars in Common ..
214      LOGICAL            LERR, OK
215      CHARACTER*32       SRNAMT
216      INTEGER            INFOT, IOUNIT
217*     ..
218*     .. Common blocks ..
219      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
220      COMMON             / SRNAMC / SRNAMT
221*     ..
222*     .. Intrinsic Functions ..
223      INTRINSIC          MAX
224*     ..
225*     .. Data statements ..
226      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
227      DATA               UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
228*     ..
229*     .. Executable Statements ..
230*
231*     Initialize constants and the random number seed.
232*
233      PATH( 1: 1 ) = 'Single precision'
234      PATH( 2: 3 ) = 'TP'
235      NRUN = 0
236      NFAIL = 0
237      NERRS = 0
238      DO 10 I = 1, 4
239         ISEED( I ) = ISEEDY( I )
240   10 CONTINUE
241*
242*     Test the error exits
243*
244      IF( TSTERR )
245     $   CALL SERRTR( PATH, NOUT )
246      INFOT = 0
247*
248      DO 110 IN = 1, NN
249*
250*        Do for each value of N in NVAL
251*
252         N = NVAL( IN )
253         LDA = MAX( 1, N )
254         LAP = LDA*( LDA+1 ) / 2
255         XTYPE = 'N'
256*
257         DO 70 IMAT = 1, NTYPE1
258*
259*           Do the tests only if DOTYPE( IMAT ) is true.
260*
261            IF( .NOT.DOTYPE( IMAT ) )
262     $         GO TO 70
263*
264            DO 60 IUPLO = 1, 2
265*
266*              Do first for UPLO = 'U', then for UPLO = 'L'
267*
268               UPLO = UPLOS( IUPLO )
269*
270*              Call SLATTP to generate a triangular test matrix.
271*
272               SRNAMT = 'SLATTP'
273               CALL SLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
274     $                      AP, X, WORK, INFO )
275*
276*              Set IDIAG = 1 for non-unit matrices, 2 for unit.
277*
278               IF( LSAME( DIAG, 'N' ) ) THEN
279                  IDIAG = 1
280               ELSE
281                  IDIAG = 2
282               END IF
283*
284*+    TEST 1
285*              Form the inverse of A.
286*
287               IF( N.GT.0 )
288     $            CALL SCOPY( LAP, AP, 1, AINVP, 1 )
289               SRNAMT = 'STPTRI'
290               CALL STPTRI( UPLO, DIAG, N, AINVP, INFO )
291*
292*              Check error code from STPTRI.
293*
294               IF( INFO.NE.0 )
295     $            CALL ALAERH( PATH, 'STPTRI', INFO, 0, UPLO // DIAG, N,
296     $                         N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
297*
298*              Compute the infinity-norm condition number of A.
299*
300               ANORM = SLANTP( 'I', UPLO, DIAG, N, AP, RWORK )
301               AINVNM = SLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK )
302               IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
303                  RCONDI = ONE
304               ELSE
305                  RCONDI = ( ONE / ANORM ) / AINVNM
306               END IF
307*
308*              Compute the residual for the triangular matrix times its
309*              inverse.  Also compute the 1-norm condition number of A.
310*
311               CALL STPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK,
312     $                      RESULT( 1 ) )
313*
314*              Print the test ratio if it is .GE. THRESH.
315*
316               IF( RESULT( 1 ).GE.THRESH ) THEN
317                  IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
318     $               CALL ALAHD( NOUT, PATH )
319                  WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1,
320     $               RESULT( 1 )
321                  NFAIL = NFAIL + 1
322               END IF
323               NRUN = NRUN + 1
324*
325               DO 40 IRHS = 1, NNS
326                  NRHS = NSVAL( IRHS )
327                  XTYPE = 'N'
328*
329                  DO 30 ITRAN = 1, NTRAN
330*
331*                 Do for op(A) = A, A**T, or A**H.
332*
333                     TRANS = TRANSS( ITRAN )
334                     IF( ITRAN.EQ.1 ) THEN
335                        NORM = 'O'
336                        RCONDC = RCONDO
337                     ELSE
338                        NORM = 'I'
339                        RCONDC = RCONDI
340                     END IF
341*
342*+    TEST 2
343*                 Solve and compute residual for op(A)*x = b.
344*
345                     SRNAMT = 'SLARHS'
346                     CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
347     $                            IDIAG, NRHS, AP, LAP, XACT, LDA, B,
348     $                            LDA, ISEED, INFO )
349                     XTYPE = 'C'
350                     CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
351*
352                     SRNAMT = 'STPTRS'
353                     CALL STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X,
354     $                            LDA, INFO )
355*
356*                 Check error code from STPTRS.
357*
358                     IF( INFO.NE.0 )
359     $                  CALL ALAERH( PATH, 'STPTRS', INFO, 0,
360     $                               UPLO // TRANS // DIAG, N, N, -1,
361     $                               -1, -1, IMAT, NFAIL, NERRS, NOUT )
362*
363                     CALL STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X,
364     $                            LDA, B, LDA, WORK, RESULT( 2 ) )
365*
366*+    TEST 3
367*                 Check solution from generated exact solution.
368*
369                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
370     $                            RESULT( 3 ) )
371*
372*+    TESTS 4, 5, and 6
373*                 Use iterative refinement to improve the solution and
374*                 compute error bounds.
375*
376                     SRNAMT = 'STPRFS'
377                     CALL STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B,
378     $                            LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
379     $                            WORK, IWORK, INFO )
380*
381*                 Check error code from STPRFS.
382*
383                     IF( INFO.NE.0 )
384     $                  CALL ALAERH( PATH, 'STPRFS', INFO, 0,
385     $                               UPLO // TRANS // DIAG, N, N, -1,
386     $                               -1, NRHS, IMAT, NFAIL, NERRS,
387     $                               NOUT )
388*
389                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
390     $                            RESULT( 4 ) )
391                     CALL STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B,
392     $                            LDA, X, LDA, XACT, LDA, RWORK,
393     $                            RWORK( NRHS+1 ), RESULT( 5 ) )
394*
395*                    Print information about the tests that did not pass
396*                    the threshold.
397*
398                     DO 20 K = 2, 6
399                        IF( RESULT( K ).GE.THRESH ) THEN
400                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
401     $                        CALL ALAHD( NOUT, PATH )
402                           WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG,
403     $                        N, NRHS, IMAT, K, RESULT( K )
404                           NFAIL = NFAIL + 1
405                        END IF
406   20                CONTINUE
407                     NRUN = NRUN + 5
408   30             CONTINUE
409   40          CONTINUE
410*
411*+    TEST 7
412*                 Get an estimate of RCOND = 1/CNDNUM.
413*
414               DO 50 ITRAN = 1, 2
415                  IF( ITRAN.EQ.1 ) THEN
416                     NORM = 'O'
417                     RCONDC = RCONDO
418                  ELSE
419                     NORM = 'I'
420                     RCONDC = RCONDI
421                  END IF
422*
423                  SRNAMT = 'STPCON'
424                  CALL STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK,
425     $                         IWORK, INFO )
426*
427*                 Check error code from STPCON.
428*
429                  IF( INFO.NE.0 )
430     $               CALL ALAERH( PATH, 'STPCON', INFO, 0,
431     $                            NORM // UPLO // DIAG, N, N, -1, -1,
432     $                            -1, IMAT, NFAIL, NERRS, NOUT )
433*
434                  CALL STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK,
435     $                         RESULT( 7 ) )
436*
437*                 Print the test ratio if it is .GE. THRESH.
438*
439                  IF( RESULT( 7 ).GE.THRESH ) THEN
440                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
441     $                  CALL ALAHD( NOUT, PATH )
442                     WRITE( NOUT, FMT = 9997 ) 'STPCON', NORM, UPLO,
443     $                  DIAG, N, IMAT, 7, RESULT( 7 )
444                     NFAIL = NFAIL + 1
445                  END IF
446                  NRUN = NRUN + 1
447   50          CONTINUE
448   60       CONTINUE
449   70    CONTINUE
450*
451*        Use pathological test matrices to test SLATPS.
452*
453         DO 100 IMAT = NTYPE1 + 1, NTYPES
454*
455*           Do the tests only if DOTYPE( IMAT ) is true.
456*
457            IF( .NOT.DOTYPE( IMAT ) )
458     $         GO TO 100
459*
460            DO 90 IUPLO = 1, 2
461*
462*              Do first for UPLO = 'U', then for UPLO = 'L'
463*
464               UPLO = UPLOS( IUPLO )
465               DO 80 ITRAN = 1, NTRAN
466*
467*                 Do for op(A) = A, A**T, or A**H.
468*
469                  TRANS = TRANSS( ITRAN )
470*
471*                 Call SLATTP to generate a triangular test matrix.
472*
473                  SRNAMT = 'SLATTP'
474                  CALL SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X,
475     $                         WORK, INFO )
476*
477*+    TEST 8
478*                 Solve the system op(A)*x = b.
479*
480                  SRNAMT = 'SLATPS'
481                  CALL SCOPY( N, X, 1, B, 1 )
482                  CALL SLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE,
483     $                         RWORK, INFO )
484*
485*                 Check error code from SLATPS.
486*
487                  IF( INFO.NE.0 )
488     $               CALL ALAERH( PATH, 'SLATPS', INFO, 0,
489     $                            UPLO // TRANS // DIAG // 'N', N, N,
490     $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
491*
492                  CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
493     $                         RWORK, ONE, B, LDA, X, LDA, WORK,
494     $                         RESULT( 8 ) )
495*
496*+    TEST 9
497*                 Solve op(A)*x = b again with NORMIN = 'Y'.
498*
499                  CALL SCOPY( N, X, 1, B( N+1 ), 1 )
500                  CALL SLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ),
501     $                         SCALE, RWORK, INFO )
502*
503*                 Check error code from SLATPS.
504*
505                  IF( INFO.NE.0 )
506     $               CALL ALAERH( PATH, 'SLATPS', INFO, 0,
507     $                            UPLO // TRANS // DIAG // 'Y', N, N,
508     $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
509*
510                  CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
511     $                         RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
512     $                         RESULT( 9 ) )
513*
514*                 Print information about the tests that did not pass
515*                 the threshold.
516*
517                  IF( RESULT( 8 ).GE.THRESH ) THEN
518                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
519     $                  CALL ALAHD( NOUT, PATH )
520                     WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS,
521     $                  DIAG, 'N', N, IMAT, 8, RESULT( 8 )
522                     NFAIL = NFAIL + 1
523                  END IF
524                  IF( RESULT( 9 ).GE.THRESH ) THEN
525                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
526     $                  CALL ALAHD( NOUT, PATH )
527                     WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS,
528     $                  DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
529                     NFAIL = NFAIL + 1
530                  END IF
531                  NRUN = NRUN + 2
532   80          CONTINUE
533   90       CONTINUE
534  100    CONTINUE
535  110 CONTINUE
536*
537*     Print a summary of the results.
538*
539      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
540*
541 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5,
542     $      ', type ', I2, ', test(', I2, ')= ', G12.5 )
543 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
544     $      ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(',
545     $      I2, ')= ', G12.5 )
546 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
547     $      I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 )
548 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
549     $      A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
550     $      G12.5 )
551      RETURN
552*
553*     End of SCHKTP
554*
555      END
556