150 SUBROUTINE cchktp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
151 $ nmax, ap, ainvp, b, x, xact, work, rwork,
161 INTEGER NMAX, NN, NNS, NOUT
166 INTEGER NSVAL( * ), NVAL( * )
168 COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ),
175 INTEGER NTYPE1, NTYPES
176 parameter( ntype1 = 10, ntypes = 18 )
178 parameter( ntests = 9 )
180 parameter( ntran = 3 )
182 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
193 CHARACTER TRANSS( ntran ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 REAL RESULT( ntests )
200 EXTERNAL lsame, clantp
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 ) =
'Complex precision'
234 iseed( i ) = iseedy( i )
240 $ CALL
cerrtr( 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
clattp( imat, uplo,
'No transpose', diag, iseed, n,
269 $ ap, x, work, rwork, info )
273 IF( lsame( diag,
'N' ) )
THEN
283 $ CALL
ccopy( lap, ap, 1, ainvp, 1 )
285 CALL
ctptri( uplo, diag, n, ainvp, info )
290 $ CALL
alaerh( path,
'CTPTRI', info, 0, uplo // diag, n,
291 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
295 anorm = clantp(
'I', uplo, diag, n, ap, rwork )
296 ainvnm = clantp(
'I', uplo, diag, n, ainvp, rwork )
297 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
300 rcondi = ( one / anorm ) / ainvnm
306 CALL
ctpt01( 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
clarhs( path, xtype, uplo, trans, n, n, 0,
342 $ idiag, nrhs, ap, lap, xact, lda, b,
345 CALL
clacpy(
'Full', n, nrhs, b, lda, x, lda )
348 CALL
ctptrs( uplo, trans, diag, n, nrhs, ap, x,
354 $ CALL
alaerh( path,
'CTPTRS', info, 0,
355 $ uplo // trans // diag, n, n, -1,
356 $ -1, -1, imat, nfail, nerrs, nout )
358 CALL
ctpt02( uplo, trans, diag, n, nrhs, ap, x,
359 $ lda, b, lda, work, rwork,
365 CALL
cget04( n, nrhs, x, lda, xact, lda, rcondc,
373 CALL
ctprfs( 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,
'CTPRFS', info, 0,
381 $ uplo // trans // diag, n, n, -1,
382 $ -1, nrhs, imat, nfail, nerrs,
385 CALL
cget04( n, nrhs, x, lda, xact, lda, rcondc,
387 CALL
ctpt05( 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
ctpcon( norm, uplo, diag, n, ap, rcond, work,
425 $ CALL
alaerh( path,
'CTPCON', info, 0,
426 $ norm // uplo // diag, n, n, -1, -1,
427 $ -1, imat, nfail, nerrs, nout )
429 CALL
ctpt06( 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 )
'CTPCON', 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
clattp( imat, uplo, trans, diag, iseed, n, ap, x,
470 $ work, rwork, info )
476 CALL
ccopy( n, x, 1, b, 1 )
477 CALL
clatps( uplo, trans, diag,
'N', n, ap, b, scale,
483 $ CALL
alaerh( path,
'CLATPS', info, 0,
484 $ uplo // trans // diag //
'N', n, n,
485 $ -1, -1, -1, imat, nfail, nerrs, nout )
487 CALL
ctpt03( uplo, trans, diag, n, 1, ap, scale,
488 $ rwork, one, b, lda, x, lda, work,
494 CALL
ccopy( n, x, 1, b( n+1 ), 1 )
495 CALL
clatps( uplo, trans, diag,
'Y', n, ap, b( n+1 ),
496 $ scale, rwork, info )
501 $ CALL
alaerh( path,
'CLATPS', info, 0,
502 $ uplo // trans // diag //
'Y', n, n,
503 $ -1, -1, -1, imat, nfail, nerrs, nout )
505 CALL
ctpt03( 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 )
'CLATPS', 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 )
'CLATPS', 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 alahd(IOUNIT, PATH)
ALAHD
subroutine ctptri(UPLO, DIAG, N, AP, INFO)
CTPTRI
subroutine clatps(UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO)
CLATPS solves a triangular system of equations with the matrix held in packed storage.
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine cerrtr(PATH, NUNIT)
CERRTR
subroutine ctprfs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
CTPRFS
subroutine ctpt02(UPLO, TRANS, DIAG, N, NRHS, AP, X, LDX, B, LDB, WORK, RWORK, RESID)
CTPT02
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine clattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, B, WORK, RWORK, INFO)
CLATTP
subroutine ctpcon(NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO)
CTPCON
subroutine ctpt01(UPLO, DIAG, N, AP, AINVP, RCOND, RWORK, RESID)
CTPT01
subroutine ctpt06(RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, RAT)
CTPT06
subroutine ctptrs(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO)
CTPTRS
subroutine ctpt03(UPLO, TRANS, DIAG, N, NRHS, AP, SCALE, CNORM, TSCAL, X, LDX, B, LDB, WORK, RESID)
CTPT03
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine ctpt05(UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CTPT05
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04
subroutine cchktp(DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, NOUT)
CCHKTP