151
152
153
154
155
156
157 LOGICAL TSTERR
158 INTEGER NMAX, NN, NNS, NOUT
159 DOUBLE PRECISION THRESH
160
161
162 LOGICAL DOTYPE( * )
163 INTEGER NSVAL( * ), NVAL( * )
164 DOUBLE PRECISION RWORK( * )
165 COMPLEX*16 AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ),
166 $ XACT( * )
167
168
169
170
171
172 INTEGER NTYPE1, NTYPES
173 parameter( ntype1 = 10, ntypes = 18 )
174 INTEGER NTESTS
175 parameter( ntests = 9 )
176 INTEGER NTRAN
177 parameter( ntran = 3 )
178 DOUBLE PRECISION ONE, ZERO
179 parameter( one = 1.0d+0, zero = 0.0d+0 )
180
181
182 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
183 CHARACTER*3 PATH
184 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
185 $ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
186 DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
187 $ SCALE
188
189
190 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
191 INTEGER ISEED( 4 ), ISEEDY( 4 )
192 DOUBLE PRECISION RESULT( NTESTS )
193
194
195 LOGICAL LSAME
196 DOUBLE PRECISION ZLANTP
198
199
204
205
206 LOGICAL LERR, OK
207 CHARACTER*32 SRNAMT
208 INTEGER INFOT, IOUNIT
209
210
211 COMMON / infoc / infot, iounit, ok, lerr
212 COMMON / srnamc / srnamt
213
214
215 INTRINSIC max
216
217
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
220
221
222
223
224
225 path( 1: 1 ) = 'Zomplex precision'
226 path( 2: 3 ) = 'TP'
227 nrun = 0
228 nfail = 0
229 nerrs = 0
230 DO 10 i = 1, 4
231 iseed( i ) = iseedy( i )
232 10 CONTINUE
233
234
235
236 IF( tsterr )
237 $
CALL zerrtr( path, nout )
238 infot = 0
239
240 DO 110 in = 1, nn
241
242
243
244 n = nval( in )
245 lda = max( 1, n )
246 lap = lda*( lda+1 ) / 2
247 xtype = 'N'
248
249 DO 70 imat = 1, ntype1
250
251
252
253 IF( .NOT.dotype( imat ) )
254 $ GO TO 70
255
256 DO 60 iuplo = 1, 2
257
258
259
260 uplo = uplos( iuplo )
261
262
263
264 srnamt = 'ZLATTP'
265 CALL zlattp( imat, uplo,
'No transpose', diag, iseed, n,
266 $ ap, x, work, rwork, info )
267
268
269
270 IF(
lsame( diag,
'N' ) )
THEN
271 idiag = 1
272 ELSE
273 idiag = 2
274 END IF
275
276
277
278
279 IF( n.GT.0 )
280 $
CALL zcopy( lap, ap, 1, ainvp, 1 )
281 srnamt = 'ZTPTRI'
282 CALL ztptri( uplo, diag, n, ainvp, info )
283
284
285
286 IF( info.NE.0 )
287 $
CALL alaerh( path,
'ZTPTRI', info, 0, uplo // diag, n,
288 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
289
290
291
292 anorm =
zlantp(
'I', uplo, diag, n, ap, rwork )
293 ainvnm =
zlantp(
'I', uplo, diag, n, ainvp, rwork )
294 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
295 rcondi = one
296 ELSE
297 rcondi = ( one / anorm ) / ainvnm
298 END IF
299
300
301
302
303 CALL ztpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
304 $ result( 1 ) )
305
306
307
308 IF( result( 1 ).GE.thresh ) THEN
309 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
310 $
CALL alahd( nout, path )
311 WRITE( nout, fmt = 9999 )uplo, diag, n, imat, 1,
312 $ result( 1 )
313 nfail = nfail + 1
314 END IF
315 nrun = nrun + 1
316
317 DO 40 irhs = 1, nns
318 nrhs = nsval( irhs )
319 xtype = 'N'
320
321 DO 30 itran = 1, ntran
322
323
324
325 trans = transs( itran )
326 IF( itran.EQ.1 ) THEN
327 norm = 'O'
328 rcondc = rcondo
329 ELSE
330 norm = 'I'
331 rcondc = rcondi
332 END IF
333
334
335
336
337 srnamt = 'ZLARHS'
338 CALL zlarhs( path, xtype, uplo, trans, n, n, 0,
339 $ idiag, nrhs, ap, lap, xact, lda, b,
340 $ lda, iseed, info )
341 xtype = 'C'
342 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
343
344 srnamt = 'ZTPTRS'
345 CALL ztptrs( uplo, trans, diag, n, nrhs, ap, x,
346 $ lda, info )
347
348
349
350 IF( info.NE.0 )
351 $
CALL alaerh( path,
'ZTPTRS', info, 0,
352 $ uplo // trans // diag, n, n, -1,
353 $ -1, -1, imat, nfail, nerrs, nout )
354
355 CALL ztpt02( uplo, trans, diag, n, nrhs, ap, x,
356 $ lda, b, lda, work, rwork,
357 $ result( 2 ) )
358
359
360
361
362 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
363 $ result( 3 ) )
364
365
366
367
368
369 srnamt = 'ZTPRFS'
370 CALL ztprfs( uplo, trans, diag, n, nrhs, ap, b,
371 $ lda, x, lda, rwork, rwork( nrhs+1 ),
372 $ work, rwork( 2*nrhs+1 ), info )
373
374
375
376 IF( info.NE.0 )
377 $
CALL alaerh( path,
'ZTPRFS', info, 0,
378 $ uplo // trans // diag, n, n, -1,
379 $ -1, nrhs, imat, nfail, nerrs,
380 $ nout )
381
382 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
383 $ result( 4 ) )
384 CALL ztpt05( uplo, trans, diag, n, nrhs, ap, b,
385 $ lda, x, lda, xact, lda, rwork,
386 $ rwork( nrhs+1 ), result( 5 ) )
387
388
389
390
391 DO 20 k = 2, 6
392 IF( result( k ).GE.thresh ) THEN
393 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
394 $
CALL alahd( nout, path )
395 WRITE( nout, fmt = 9998 )uplo, trans, diag,
396 $ n, nrhs, imat, k, result( k )
397 nfail = nfail + 1
398 END IF
399 20 CONTINUE
400 nrun = nrun + 5
401 30 CONTINUE
402 40 CONTINUE
403
404
405
406
407 DO 50 itran = 1, 2
408 IF( itran.EQ.1 ) THEN
409 norm = 'O'
410 rcondc = rcondo
411 ELSE
412 norm = 'I'
413 rcondc = rcondi
414 END IF
415 srnamt = 'ZTPCON'
416 CALL ztpcon( norm, uplo, diag, n, ap, rcond, work,
417 $ rwork, info )
418
419
420
421 IF( info.NE.0 )
422 $
CALL alaerh( path,
'ZTPCON', info, 0,
423 $ norm // uplo // diag, n, n, -1, -1,
424 $ -1, imat, nfail, nerrs, nout )
425
426 CALL ztpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
427 $ result( 7 ) )
428
429
430
431 IF( result( 7 ).GE.thresh ) THEN
432 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
433 $
CALL alahd( nout, path )
434 WRITE( nout, fmt = 9997 ) 'ZTPCON', norm, uplo,
435 $ diag, n, imat, 7, result( 7 )
436 nfail = nfail + 1
437 END IF
438 nrun = nrun + 1
439 50 CONTINUE
440 60 CONTINUE
441 70 CONTINUE
442
443
444
445 DO 100 imat = ntype1 + 1, ntypes
446
447
448
449 IF( .NOT.dotype( imat ) )
450 $ GO TO 100
451
452 DO 90 iuplo = 1, 2
453
454
455
456 uplo = uplos( iuplo )
457 DO 80 itran = 1, ntran
458
459
460
461 trans = transs( itran )
462
463
464
465 srnamt = 'ZLATTP'
466 CALL zlattp( imat, uplo, trans, diag, iseed, n, ap, x,
467 $ work, rwork, info )
468
469
470
471
472 srnamt = 'ZLATPS'
473 CALL zcopy( n, x, 1, b, 1 )
474 CALL zlatps( uplo, trans, diag,
'N', n, ap, b, scale,
475 $ rwork, info )
476
477
478
479 IF( info.NE.0 )
480 $
CALL alaerh( path,
'ZLATPS', info, 0,
481 $ uplo // trans // diag // 'N', n, n,
482 $ -1, -1, -1, imat, nfail, nerrs, nout )
483
484 CALL ztpt03( uplo, trans, diag, n, 1, ap, scale,
485 $ rwork, one, b, lda, x, lda, work,
486 $ result( 8 ) )
487
488
489
490
491 CALL zcopy( n, x, 1, b( n+1 ), 1 )
492 CALL zlatps( uplo, trans, diag,
'Y', n, ap, b( n+1 ),
493 $ scale, rwork, info )
494
495
496
497 IF( info.NE.0 )
498 $
CALL alaerh( path,
'ZLATPS', info, 0,
499 $ uplo // trans // diag // 'Y', n, n,
500 $ -1, -1, -1, imat, nfail, nerrs, nout )
501
502 CALL ztpt03( uplo, trans, diag, n, 1, ap, scale,
503 $ rwork, one, b( n+1 ), lda, x, lda, work,
504 $ result( 9 ) )
505
506
507
508
509 IF( result( 8 ).GE.thresh ) THEN
510 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
511 $
CALL alahd( nout, path )
512 WRITE( nout, fmt = 9996 )'ZLATPS', uplo, trans,
513 $ diag, 'N', n, imat, 8, result( 8 )
514 nfail = nfail + 1
515 END IF
516 IF( result( 9 ).GE.thresh ) THEN
517 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
518 $
CALL alahd( nout, path )
519 WRITE( nout, fmt = 9996 )'ZLATPS', uplo, trans,
520 $ diag, 'Y', n, imat, 9, result( 9 )
521 nfail = nfail + 1
522 END IF
523 nrun = nrun + 2
524 80 CONTINUE
525 90 CONTINUE
526 100 CONTINUE
527 110 CONTINUE
528
529
530
531 CALL alasum( path, nout, nfail, nrun, nerrs )
532
533 9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5,
534 $ ', type ', i2, ', test(', i2, ')= ', g12.5 )
535 9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
536 $ ''', N=', i5, ''', NRHS=', i5, ', type ', i2, ', test(',
537 $ i2, ')= ', g12.5 )
538 9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''',',
539 $ i5, ', ... ), type ', i2, ', test(', i2, ')=', g12.5 )
540 9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
541 $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
542 $ g12.5 )
543 RETURN
544
545
546
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine alahd(iounit, path)
ALAHD
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zlantp(norm, uplo, diag, n, ap, work)
ZLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine zlatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
ZLATPS solves a triangular system of equations with the matrix held in packed storage.
logical function lsame(ca, cb)
LSAME
subroutine ztpcon(norm, uplo, diag, n, ap, rcond, work, rwork, info)
ZTPCON
subroutine ztprfs(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZTPRFS
subroutine ztptri(uplo, diag, n, ap, info)
ZTPTRI
subroutine ztptrs(uplo, trans, diag, n, nrhs, ap, b, ldb, info)
ZTPTRS
subroutine zerrtr(path, nunit)
ZERRTR
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
subroutine zlattp(imat, uplo, trans, diag, iseed, n, ap, b, work, rwork, info)
ZLATTP
subroutine ztpt01(uplo, diag, n, ap, ainvp, rcond, rwork, resid)
ZTPT01
subroutine ztpt02(uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, rwork, resid)
ZTPT02
subroutine ztpt03(uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
ZTPT03
subroutine ztpt05(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZTPT05
subroutine ztpt06(rcond, rcondc, uplo, diag, n, ap, rwork, rat)
ZTPT06