Home
Browse Files
  1       SUBROUTINE ZCHKTR( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
  2      $                   THRESH, TSTERR, NMAX, A, AINV, B, X, XACT,
  3      $                   WORK, RWORK, NOUT )
  4 *
  5 *  -- LAPACK test routine (version 3.1) --
  6 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
  7 *     November 2006
  8 *
  9 *     .. Scalar Arguments ..
 10       LOGICAL            TSTERR
 11       INTEGER            NMAX, NN, NNB, NNS, NOUT
 12       DOUBLE PRECISION   THRESH
 13 *     ..
 14 *     .. Array Arguments ..
 15       LOGICAL            DOTYPE( * )
 16       INTEGER            NBVAL( * ), NSVAL( * ), NVAL( * )
 17       DOUBLE PRECISION   RWORK( * )
 18       COMPLEX*16         A( * ), AINV( * ), B( * ), WORK( * ), X( * ),
 19      $                   XACT( * )
 20 *     ..
 21 *
 22 *  Purpose
 23 *  =======
 24 *
 25 *  ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS
 26 *
 27 *  Arguments
 28 *  =========
 29 *
 30 *  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
 31 *          The matrix types to be used for testing.  Matrices of type j
 32 *          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
 33 *          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
 34 *
 35 *  NN      (input) INTEGER
 36 *          The number of values of N contained in the vector NVAL.
 37 *
 38 *  NVAL    (input) INTEGER array, dimension (NN)
 39 *          The values of the matrix column dimension N.
 40 *
 41 *  NNB     (input) INTEGER
 42 *          The number of values of NB contained in the vector NBVAL.
 43 *
 44 *  NBVAL   (input) INTEGER array, dimension (NNB)
 45 *          The values of the blocksize NB.
 46 *
 47 *  NNS     (input) INTEGER
 48 *          The number of values of NRHS contained in the vector NSVAL.
 49 *
 50 *  NSVAL   (input) INTEGER array, dimension (NNS)
 51 *          The values of the number of right hand sides NRHS.
 52 *
 53 *  THRESH  (input) DOUBLE PRECISION
 54 *          The threshold value for the test ratios.  A result is
 55 *          included in the output file if RESULT >= THRESH.  To have
 56 *          every test ratio printed, use THRESH = 0.
 57 *
 58 *  TSTERR  (input) LOGICAL
 59 *          Flag that indicates whether error exits are to be tested.
 60 *
 61 *  NMAX    (input) INTEGER
 62 *          The leading dimension of the work arrays.
 63 *          NMAX >= the maximum value of N in NVAL.
 64 *
 65 *  A       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
 66 *
 67 *  AINV    (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
 68 *
 69 *  B       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
 70 *          where NSMAX is the largest entry in NSVAL.
 71 *
 72 *  X       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
 73 *
 74 *  XACT    (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
 75 *
 76 *  WORK    (workspace) COMPLEX*16 array, dimension
 77 *                      (NMAX*max(3,NSMAX))
 78 *
 79 *  RWORK   (workspace) DOUBLE PRECISION array, dimension
 80 *                      (max(NMAX,2*NSMAX))
 81 *
 82 *  NOUT    (input) INTEGER
 83 *          The unit number for output.
 84 *
 85 *  =====================================================================
 86 *
 87 *     .. Parameters ..
 88       INTEGER            NTYPE1, NTYPES
 89       PARAMETER          ( NTYPE1 = 10, NTYPES = 18 )
 90       INTEGER            NTESTS
 91       PARAMETER          ( NTESTS = 9 )
 92       INTEGER            NTRAN
 93       PARAMETER          ( NTRAN = 3 )
 94       DOUBLE PRECISION   ONE, ZERO
 95       PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
 96 *     ..
 97 *     .. Local Scalars ..
 98       CHARACTER          DIAG, NORM, TRANS, UPLO, XTYPE
 99       CHARACTER*3        PATH
100       INTEGER            I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
101      $                   IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
102       DOUBLE PRECISION   AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI,
103      $                   RCONDO, SCALE
104 *     ..
105 *     .. Local Arrays ..
106       CHARACTER          TRANSS( NTRAN ), UPLOS( 2 )
107       INTEGER            ISEED( 4 ), ISEEDY( 4 )
108       DOUBLE PRECISION   RESULT( NTESTS )
109 *     ..
110 *     .. External Functions ..
111       LOGICAL            LSAME
112       DOUBLE PRECISION   ZLANTR
113       EXTERNAL           LSAME, ZLANTR
114 *     ..
115 *     .. External Subroutines ..
116       EXTERNAL           ALAERH, ALAHD, ALASUM, XLAENV, ZCOPY, ZERRTR,
117      $                   ZGET04, ZLACPY, ZLARHS, ZLATRS, ZLATTR, ZTRCON,
118      $                   ZTRRFS, ZTRT01, ZTRT02, ZTRT03, ZTRT05, ZTRT06,
119      $                   ZTRTRI, ZTRTRS
120 *     ..
121 *     .. Scalars in Common ..
122       LOGICAL            LERR, OK
123       CHARACTER*32       SRNAMT
124       INTEGER            INFOT, IOUNIT
125 *     ..
126 *     .. Common blocks ..
127       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
128       COMMON             / SRNAMC / SRNAMT
129 *     ..
130 *     .. Intrinsic Functions ..
131       INTRINSIC          MAX
132 *     ..
133 *     .. Data statements ..
134       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
135       DATA               UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
136 *     ..
137 *     .. Executable Statements ..
138 *
139 *     Initialize constants and the random number seed.
140 *
141       PATH( 1: 1 ) = 'Zomplex precision'
142       PATH( 2: 3 ) = 'TR'
143       NRUN = 0
144       NFAIL = 0
145       NERRS = 0
146       DO 10 I = 1, 4
147          ISEED( I ) = ISEEDY( I )
148    10 CONTINUE
149 *
150 *     Test the error exits
151 *
152       IF( TSTERR )
153      $   CALL ZERRTR( PATH, NOUT )
154       INFOT = 0
155 *
156       DO 120 IN = 1, NN
157 *
158 *        Do for each value of N in NVAL
159 *
160          N = NVAL( IN )
161          LDA = MAX( 1, N )
162          XTYPE = 'N'
163 *
164          DO 80 IMAT = 1, NTYPE1
165 *
166 *           Do the tests only if DOTYPE( IMAT ) is true.
167 *
168             IF( .NOT.DOTYPE( IMAT ) )
169      $         GO TO 80
170 *
171             DO 70 IUPLO = 1, 2
172 *
173 *              Do first for UPLO = 'U', then for UPLO = 'L'
174 *
175                UPLO = UPLOS( IUPLO )
176 *
177 *              Call ZLATTR to generate a triangular test matrix.
178 *
179                SRNAMT = 'ZLATTR'
180                CALL ZLATTR( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
181      $                      A, LDA, X, WORK, RWORK, INFO )
182 *
183 *              Set IDIAG = 1 for non-unit matrices, 2 for unit.
184 *
185                IF( LSAME( DIAG, 'N' ) ) THEN
186                   IDIAG = 1
187                ELSE
188                   IDIAG = 2
189                END IF
190 *
191                DO 60 INB = 1, NNB
192 *
193 *                 Do for each blocksize in NBVAL
194 *
195                   NB = NBVAL( INB )
196                   CALL XLAENV( 1, NB )
197 *
198 *+    TEST 1
199 *                 Form the inverse of A.
200 *
201                   CALL ZLACPY( UPLO, N, N, A, LDA, AINV, LDA )
202                   SRNAMT = 'ZTRTRI'
203                   CALL ZTRTRI( UPLO, DIAG, N, AINV, LDA, INFO )
204 *
205 *                 Check error code from ZTRTRI.
206 *
207                   IF( INFO.NE.0 )
208      $               CALL ALAERH( PATH, 'ZTRTRI', INFO, 0, UPLO // DIAG,
209      $                            N, N, -1, -1, NB, IMAT, NFAIL, NERRS,
210      $                            NOUT )
211 *
212 *                 Compute the infinity-norm condition number of A.
213 *
214                   ANORM = ZLANTR( 'I', UPLO, DIAG, N, N, A, LDA, RWORK )
215                   AINVNM = ZLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA,
216      $                     RWORK )
217                   IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
218                      RCONDI = ONE
219                   ELSE
220                      RCONDI = ( ONE / ANORM ) / AINVNM
221                   END IF
222 *
223 *                 Compute the residual for the triangular matrix times
224 *                 its inverse.  Also compute the 1-norm condition number
225 *                 of A.
226 *
227                   CALL ZTRT01( UPLO, DIAG, N, A, LDA, AINV, LDA, RCONDO,
228      $                         RWORK, RESULT( 1 ) )
229 *                 Print the test ratio if it is .GE. THRESH.
230 *
231                   IF( RESULT( 1 ).GE.THRESH ) THEN
232                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
233      $                  CALL ALAHD( NOUT, PATH )
234                      WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, NB, IMAT,
235      $                  1, RESULT( 1 )
236                      NFAIL = NFAIL + 1
237                   END IF
238                   NRUN = NRUN + 1
239 *
240 *                 Skip remaining tests if not the first block size.
241 *
242                   IF( INB.NE.1 )
243      $               GO TO 60
244 *
245                   DO 40 IRHS = 1, NNS
246                      NRHS = NSVAL( IRHS )
247                      XTYPE = 'N'
248 *
249                      DO 30 ITRAN = 1, NTRAN
250 *
251 *                    Do for op(A) = A, A**T, or A**H.
252 *
253                         TRANS = TRANSS( ITRAN )
254                         IF( ITRAN.EQ.1 ) THEN
255                            NORM = 'O'
256                            RCONDC = RCONDO
257                         ELSE
258                            NORM = 'I'
259                            RCONDC = RCONDI
260                         END IF
261 *
262 *+    TEST 2
263 *                       Solve and compute residual for op(A)*x = b.
264 *
265                         SRNAMT = 'ZLARHS'
266                         CALL ZLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
267      $                               IDIAG, NRHS, A, LDA, XACT, LDA, B,
268      $                               LDA, ISEED, INFO )
269                         XTYPE = 'C'
270                         CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
271 *
272                         SRNAMT = 'ZTRTRS'
273                         CALL ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
274      $                               X, LDA, INFO )
275 *
276 *                       Check error code from ZTRTRS.
277 *
278                         IF( INFO.NE.0 )
279      $                     CALL ALAERH( PATH, 'ZTRTRS', INFO, 0,
280      $                                  UPLO // TRANS // DIAG, N, N, -1,
281      $                                  -1, NRHS, IMAT, NFAIL, NERRS,
282      $                                  NOUT )
283 *
284 *                       This line is needed on a Sun SPARCstation.
285 *
286                         IF( N.GT.0 )
287      $                     DUMMY = A( 1 )
288 *
289                         CALL ZTRT02( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
290      $                               X, LDA, B, LDA, WORK, RWORK,
291      $                               RESULT( 2 ) )
292 *
293 *+    TEST 3
294 *                       Check solution from generated exact solution.
295 *
296                         CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
297      $                               RESULT( 3 ) )
298 *
299 *+    TESTS 4, 5, and 6
300 *                       Use iterative refinement to improve the solution
301 *                       and compute error bounds.
302 *
303                         SRNAMT = 'ZTRRFS'
304                         CALL ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
305      $                               B, LDA, X, LDA, RWORK,
306      $                               RWORK( NRHS+1 ), WORK,
307      $                               RWORK( 2*NRHS+1 ), INFO )
308 *
309 *                       Check error code from ZTRRFS.
310 *
311                         IF( INFO.NE.0 )
312      $                     CALL ALAERH( PATH, 'ZTRRFS', INFO, 0,
313      $                                  UPLO // TRANS // DIAG, N, N, -1,
314      $                                  -1, NRHS, IMAT, NFAIL, NERRS,
315      $                                  NOUT )
316 *
317                         CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
318      $                               RESULT( 4 ) )
319                         CALL ZTRT05( UPLO, TRANS, DIAG, N, NRHS, A, LDA,
320      $                               B, LDA, X, LDA, XACT, LDA, RWORK,
321      $                               RWORK( NRHS+1 ), RESULT( 5 ) )
322 *
323 *                       Print information about the tests that did not
324 *                       pass the threshold.
325 *
326                         DO 20 K = 2, 6
327                            IF( RESULT( K ).GE.THRESH ) THEN
328                               IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
329      $                           CALL ALAHD( NOUT, PATH )
330                               WRITE( NOUT, FMT = 9998 )UPLO, TRANS,
331      $                           DIAG, N, NRHS, IMAT, K, RESULT( K )
332                               NFAIL = NFAIL + 1
333                            END IF
334    20                   CONTINUE
335                         NRUN = NRUN + 5
336    30                CONTINUE
337    40             CONTINUE
338 *
339 *+    TEST 7
340 *                       Get an estimate of RCOND = 1/CNDNUM.
341 *
342                   DO 50 ITRAN = 1, 2
343                      IF( ITRAN.EQ.1 ) THEN
344                         NORM = 'O'
345                         RCONDC = RCONDO
346                      ELSE
347                         NORM = 'I'
348                         RCONDC = RCONDI
349                      END IF
350                      SRNAMT = 'ZTRCON'
351                      CALL ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND,
352      $                            WORK, RWORK, INFO )
353 *
354 *                       Check error code from ZTRCON.
355 *
356                      IF( INFO.NE.0 )
357      $                  CALL ALAERH( PATH, 'ZTRCON', INFO, 0,
358      $                               NORM // UPLO // DIAG, N, N, -1, -1,
359      $                               -1, IMAT, NFAIL, NERRS, NOUT )
360 *
361                      CALL ZTRT06( RCOND, RCONDC, UPLO, DIAG, N, A, LDA,
362      $                            RWORK, RESULT( 7 ) )
363 *
364 *                    Print the test ratio if it is .GE. THRESH.
365 *
366                      IF( RESULT( 7 ).GE.THRESH ) THEN
367                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
368      $                     CALL ALAHD( NOUT, PATH )
369                         WRITE( NOUT, FMT = 9997 )NORM, UPLO, N, IMAT,
370      $                     7, RESULT( 7 )
371                         NFAIL = NFAIL + 1
372                      END IF
373                      NRUN = NRUN + 1
374    50             CONTINUE
375    60          CONTINUE
376    70       CONTINUE
377    80    CONTINUE
378 *
379 *        Use pathological test matrices to test ZLATRS.
380 *
381          DO 110 IMAT = NTYPE1 + 1, NTYPES
382 *
383 *           Do the tests only if DOTYPE( IMAT ) is true.
384 *
385             IF( .NOT.DOTYPE( IMAT ) )
386      $         GO TO 110
387 *
388             DO 100 IUPLO = 1, 2
389 *
390 *              Do first for UPLO = 'U', then for UPLO = 'L'
391 *
392                UPLO = UPLOS( IUPLO )
393                DO 90 ITRAN = 1, NTRAN
394 *
395 *                 Do for op(A) = A, A**T, and A**H.
396 *
397                   TRANS = TRANSS( ITRAN )
398 *
399 *                 Call ZLATTR to generate a triangular test matrix.
400 *
401                   SRNAMT = 'ZLATTR'
402                   CALL ZLATTR( IMAT, UPLO, TRANS, DIAG, ISEED, N, A,
403      $                         LDA, X, WORK, RWORK, INFO )
404 *
405 *+    TEST 8
406 *                 Solve the system op(A)*x = b.
407 *
408                   SRNAMT = 'ZLATRS'
409                   CALL ZCOPY( N, X, 1, B, 1 )
410                   CALL ZLATRS( UPLO, TRANS, DIAG, 'N', N, A, LDA, B,
411      $                         SCALE, RWORK, INFO )
412 *
413 *                 Check error code from ZLATRS.
414 *
415                   IF( INFO.NE.0 )
416      $               CALL ALAERH( PATH, 'ZLATRS', INFO, 0,
417      $                            UPLO // TRANS // DIAG // 'N', N, N,
418      $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
419 *
420                   CALL ZTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA, SCALE,
421      $                         RWORK, ONE, B, LDA, X, LDA, WORK,
422      $                         RESULT( 8 ) )
423 *
424 *+    TEST 9
425 *                 Solve op(A)*X = b again with NORMIN = 'Y'.
426 *
427                   CALL ZCOPY( N, X, 1, B( N+1 ), 1 )
428                   CALL ZLATRS( UPLO, TRANS, DIAG, 'Y', N, A, LDA,
429      $                         B( N+1 ), SCALE, RWORK, INFO )
430 *
431 *                 Check error code from ZLATRS.
432 *
433                   IF( INFO.NE.0 )
434      $               CALL ALAERH( PATH, 'ZLATRS', INFO, 0,
435      $                            UPLO // TRANS // DIAG // 'Y', N, N,
436      $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
437 *
438                   CALL ZTRT03( UPLO, TRANS, DIAG, N, 1, A, LDA, SCALE,
439      $                         RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
440      $                         RESULT( 9 ) )
441 *
442 *                 Print information about the tests that did not pass
443 *                 the threshold.
444 *
445                   IF( RESULT( 8 ).GE.THRESH ) THEN
446                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
447      $                  CALL ALAHD( NOUT, PATH )
448                      WRITE( NOUT, FMT = 9996 )'ZLATRS', UPLO, TRANS,
449      $                  DIAG, 'N', N, IMAT, 8, RESULT( 8 )
450                      NFAIL = NFAIL + 1
451                   END IF
452                   IF( RESULT( 9 ).GE.THRESH ) THEN
453                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
454      $                  CALL ALAHD( NOUT, PATH )
455                      WRITE( NOUT, FMT = 9996 )'ZLATRS', UPLO, TRANS,
456      $                  DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
457                      NFAIL = NFAIL + 1
458                   END IF
459                   NRUN = NRUN + 2
460    90          CONTINUE
461   100       CONTINUE
462   110    CONTINUE
463   120 CONTINUE
464 *
465 *     Print a summary of the results.
466 *
467       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
468 *
469  9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, ', NB=',
470      $      I4, ', type ', I2, ', test(', I2, ')= ', G12.5 )
471  9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
472      $      ''', N=', I5, ', NB=', I4, ', type ', I2, ',
473      $      test(', I2, ')= ', G12.5 )
474  9997 FORMAT( ' NORM=''', A1, ''', UPLO =''', A1, ''', N=', I5, ',',
475      $      11X, ' type ', I2, ', test(', I2, ')=', G12.5 )
476  9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
477      $      A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
478      $      G12.5 )
479       RETURN
480 *
481 *     End of ZCHKTR
482 *
483       END
Home