150 SUBROUTINE zchktp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
151 $ nmax, ap, ainvp, b, x, xact, work, rwork,
161 INTEGER NMAX, NN, NNS, NOUT
162 DOUBLE PRECISION THRESH
166 INTEGER NSVAL( * ), NVAL( * )
167 DOUBLE PRECISION RWORK( * )
168 COMPLEX*16 AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ),
175 INTEGER NTYPE1, NTYPES
176 parameter ( ntype1 = 10, ntypes = 18 )
178 parameter ( ntests = 9 )
180 parameter ( ntran = 3 )
181 DOUBLE PRECISION ONE, ZERO
182 parameter ( one = 1.0d+0, zero = 0.0d+0 )
185 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
187 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
188 $ k, lap, lda, n, nerrs, nfail, nrhs, nrun
189 DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
193 CHARACTER TRANSS( ntran ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 DOUBLE PRECISION RESULT( ntests )
199 DOUBLE PRECISION ZLANTP
200 EXTERNAL lsame, zlantp
211 INTEGER INFOT, IOUNIT
214 COMMON / infoc / infot, iounit, ok, lerr
215 COMMON / srnamc / srnamt
221 DATA iseedy / 1988, 1989, 1990, 1991 /
222 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
228 path( 1: 1 ) =
'Zomplex precision'
234 iseed( i ) = iseedy( i )
240 $
CALL zerrtr( path, nout )
249 lap = lda*( lda+1 ) / 2
252 DO 70 imat = 1, ntype1
256 IF( .NOT.dotype( imat ) )
263 uplo = uplos( iuplo )
268 CALL zlattp( imat, uplo,
'No transpose', diag, iseed, n,
269 $ ap, x, work, rwork, info )
273 IF( lsame( diag,
'N' ) )
THEN
283 $
CALL zcopy( lap, ap, 1, ainvp, 1 )
285 CALL ztptri( uplo, diag, n, ainvp, info )
290 $
CALL alaerh( path,
'ZTPTRI', info, 0, uplo // diag, n,
291 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
295 anorm = zlantp(
'I', uplo, diag, n, ap, rwork )
296 ainvnm = zlantp(
'I', uplo, diag, n, ainvp, rwork )
297 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
300 rcondi = ( one / anorm ) / ainvnm
306 CALL ztpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
311 IF( result( 1 ).GE.thresh )
THEN
312 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
313 $
CALL alahd( nout, path )
314 WRITE( nout, fmt = 9999 )uplo, diag, n, imat, 1,
324 DO 30 itran = 1, ntran
328 trans = transs( itran )
329 IF( itran.EQ.1 )
THEN
341 CALL zlarhs( path, xtype, uplo, trans, n, n, 0,
342 $ idiag, nrhs, ap, lap, xact, lda, b,
345 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
348 CALL ztptrs( uplo, trans, diag, n, nrhs, ap, x,
354 $
CALL alaerh( path,
'ZTPTRS', info, 0,
355 $ uplo // trans // diag, n, n, -1,
356 $ -1, -1, imat, nfail, nerrs, nout )
358 CALL ztpt02( uplo, trans, diag, n, nrhs, ap, x,
359 $ lda, b, lda, work, rwork,
365 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
373 CALL ztprfs( uplo, trans, diag, n, nrhs, ap, b,
374 $ lda, x, lda, rwork, rwork( nrhs+1 ),
375 $ work, rwork( 2*nrhs+1 ), info )
380 $
CALL alaerh( path,
'ZTPRFS', info, 0,
381 $ uplo // trans // diag, n, n, -1,
382 $ -1, nrhs, imat, nfail, nerrs,
385 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
387 CALL ztpt05( uplo, trans, diag, n, nrhs, ap, b,
388 $ lda, x, lda, xact, lda, rwork,
389 $ rwork( nrhs+1 ), result( 5 ) )
395 IF( result( k ).GE.thresh )
THEN
396 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
397 $
CALL alahd( nout, path )
398 WRITE( nout, fmt = 9998 )uplo, trans, diag,
399 $ n, nrhs, imat, k, result( k )
411 IF( itran.EQ.1 )
THEN
419 CALL ztpcon( norm, uplo, diag, n, ap, rcond, work,
425 $
CALL alaerh( path,
'ZTPCON', info, 0,
426 $ norm // uplo // diag, n, n, -1, -1,
427 $ -1, imat, nfail, nerrs, nout )
429 CALL ztpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
434 IF( result( 7 ).GE.thresh )
THEN
435 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
436 $
CALL alahd( nout, path )
437 WRITE( nout, fmt = 9997 )
'ZTPCON', norm, uplo,
438 $ diag, n, imat, 7, result( 7 )
448 DO 100 imat = ntype1 + 1, ntypes
452 IF( .NOT.dotype( imat ) )
459 uplo = uplos( iuplo )
460 DO 80 itran = 1, ntran
464 trans = transs( itran )
469 CALL zlattp( imat, uplo, trans, diag, iseed, n, ap, x,
470 $ work, rwork, info )
476 CALL zcopy( n, x, 1, b, 1 )
477 CALL zlatps( uplo, trans, diag,
'N', n, ap, b, scale,
483 $
CALL alaerh( path,
'ZLATPS', info, 0,
484 $ uplo // trans // diag //
'N', n, n,
485 $ -1, -1, -1, imat, nfail, nerrs, nout )
487 CALL ztpt03( uplo, trans, diag, n, 1, ap, scale,
488 $ rwork, one, b, lda, x, lda, work,
494 CALL zcopy( n, x, 1, b( n+1 ), 1 )
495 CALL zlatps( uplo, trans, diag,
'Y', n, ap, b( n+1 ),
496 $ scale, rwork, info )
501 $
CALL alaerh( path,
'ZLATPS', info, 0,
502 $ uplo // trans // diag //
'Y', n, n,
503 $ -1, -1, -1, imat, nfail, nerrs, nout )
505 CALL ztpt03( uplo, trans, diag, n, 1, ap, scale,
506 $ rwork, one, b( n+1 ), lda, x, lda, work,
512 IF( result( 8 ).GE.thresh )
THEN
513 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
514 $
CALL alahd( nout, path )
515 WRITE( nout, fmt = 9996 )
'ZLATPS', uplo, trans,
516 $ diag,
'N', n, imat, 8, result( 8 )
519 IF( result( 9 ).GE.thresh )
THEN
520 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
521 $
CALL alahd( nout, path )
522 WRITE( nout, fmt = 9996 )
'ZLATPS', uplo, trans,
523 $ diag,
'Y', n, imat, 9, result( 9 )
534 CALL alasum( path, nout, nfail, nrun, nerrs )
536 9999
FORMAT(
' UPLO=''', a1,
''', DIAG=''', a1,
''', N=', i5,
537 $
', type ', i2,
', test(', i2,
')= ', g12.5 )
538 9998
FORMAT(
' UPLO=''', a1,
''', TRANS=''', a1,
''', DIAG=''', a1,
539 $
''', N=', i5,
''', NRHS=', i5,
', type ', i2,
', test(',
541 9997
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''',',
542 $ i5,
', ... ), type ', i2,
', test(', i2,
')=', g12.5 )
543 9996
FORMAT( 1x, a,
'( ''', a1,
''', ''', a1,
''', ''', a1,
''', ''',
544 $ a1,
''',', i5,
', ... ), type ', i2,
', test(', i2,
')=',
subroutine ztpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO)
ZTPCON
subroutine alahd(IOUNIT, PATH)
ALAHD
subroutine ztptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
ZTPTRS
subroutine zerrtr(PATH, NUNIT)
ZERRTR
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine zget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
ZGET04
subroutine ztprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZTPRFS
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine ztpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RWORK, RESID)
ZTPT02
subroutine ztpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
ZTPT05
subroutine ztptri(UPLO, DIAG, N, AP, INFO)
ZTPTRI
subroutine zlarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
ZLARHS
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zlattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, RWORK, INFO)
ZLATTP
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.
subroutine zchktp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, NOUT)
ZCHKTP
subroutine ztpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
ZTPT03
subroutine ztpt01(UPLO, DIAG, N, AP, AINVP, RCOND, RWORK, RESID)
ZTPT01
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine ztpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, RAT)
ZTPT06