148 SUBROUTINE cchktp( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
149 $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
158 INTEGER NMAX, NN, NNS, NOUT
163 INTEGER NSVAL( * ), NVAL( * )
165 COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ),
172 INTEGER NTYPE1, NTYPES
173 PARAMETER ( NTYPE1 = 10, ntypes = 18 )
175 parameter( ntests = 9 )
177 parameter( ntran = 3 )
179 parameter( one = 1.0e+0, zero = 0.0e+0 )
182 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
184 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
185 $ k, lap, lda, n, nerrs, nfail, nrhs, nrun
186 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
190 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
191 INTEGER ISEED( 4 ), ISEEDY( 4 )
192 REAL RESULT( NTESTS )
197 EXTERNAL lsame, clantp
208 INTEGER INFOT, IOUNIT
211 COMMON / infoc / infot, iounit, ok, lerr
212 COMMON / srnamc / srnamt
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos /
'U',
'L' / , transs /
'N',
'T',
'C' /
225 path( 1: 1 ) =
'Complex precision'
231 iseed( i ) = iseedy( i )
237 $
CALL cerrtr( path, nout )
246 lap = lda*( lda+1 ) / 2
249 DO 70 imat = 1, ntype1
253 IF( .NOT.dotype( imat ) )
260 uplo = uplos( iuplo )
265 CALL clattp( imat, uplo,
'No transpose', diag, iseed, n,
266 $ ap, x, work, rwork, info )
270 IF( lsame( diag,
'N' ) )
THEN
280 $
CALL ccopy( lap, ap, 1, ainvp, 1 )
282 CALL ctptri( uplo, diag, n, ainvp, info )
287 $
CALL alaerh( path,
'CTPTRI', info, 0, uplo // diag, n,
288 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
292 anorm = clantp(
'I', uplo, diag, n, ap, rwork )
293 ainvnm = clantp(
'I', uplo, diag, n, ainvp, rwork )
294 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
297 rcondi = ( one / anorm ) / ainvnm
303 CALL ctpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
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,
321 DO 30 itran = 1, ntran
325 trans = transs( itran )
326 IF( itran.EQ.1 )
THEN
338 CALL clarhs( path, xtype, uplo, trans, n, n, 0,
339 $ idiag, nrhs, ap, lap, xact, lda, b,
342 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
345 CALL ctptrs( uplo, trans, diag, n, nrhs, ap, x,
351 $
CALL alaerh( path,
'CTPTRS', info, 0,
352 $ uplo // trans // diag, n, n, -1,
353 $ -1, -1, imat, nfail, nerrs, nout )
355 CALL ctpt02( uplo, trans, diag, n, nrhs, ap, x,
356 $ lda, b, lda, work, rwork,
362 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
370 CALL ctprfs( uplo, trans, diag, n, nrhs, ap, b,
371 $ lda, x, lda, rwork, rwork( nrhs+1 ),
372 $ work, rwork( 2*nrhs+1 ), info )
377 $
CALL alaerh( path,
'CTPRFS', info, 0,
378 $ uplo // trans // diag, n, n, -1,
379 $ -1, nrhs, imat, nfail, nerrs,
382 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
384 CALL ctpt05( uplo, trans, diag, n, nrhs, ap, b,
385 $ lda, x, lda, xact, lda, rwork,
386 $ rwork( nrhs+1 ), result( 5 ) )
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 )
408 IF( itran.EQ.1 )
THEN
416 CALL ctpcon( norm, uplo, diag, n, ap, rcond, work,
422 $
CALL alaerh( path,
'CTPCON', info, 0,
423 $ norm // uplo // diag, n, n, -1, -1,
424 $ -1, imat, nfail, nerrs, nout )
426 CALL ctpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
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 )
'CTPCON', norm, uplo,
435 $ diag, n, imat, 7, result( 7 )
445 DO 100 imat = ntype1 + 1, ntypes
449 IF( .NOT.dotype( imat ) )
456 uplo = uplos( iuplo )
457 DO 80 itran = 1, ntran
461 trans = transs( itran )
466 CALL clattp( imat, uplo, trans, diag, iseed, n, ap, x,
467 $ work, rwork, info )
473 CALL ccopy( n, x, 1, b, 1 )
474 CALL clatps( uplo, trans, diag,
'N', n, ap, b, scale,
480 $
CALL alaerh( path,
'CLATPS', info, 0,
481 $ uplo // trans // diag //
'N', n, n,
482 $ -1, -1, -1, imat, nfail, nerrs, nout )
484 CALL ctpt03( uplo, trans, diag, n, 1, ap, scale,
485 $ rwork, one, b, lda, x, lda, work,
491 CALL ccopy( n, x, 1, b( n+1 ), 1 )
492 CALL clatps( uplo, trans, diag,
'Y', n, ap, b( n+1 ),
493 $ scale, rwork, info )
498 $
CALL alaerh( path,
'CLATPS', info, 0,
499 $ uplo // trans // diag //
'Y', n, n,
500 $ -1, -1, -1, imat, nfail, nerrs, nout )
502 CALL ctpt03( uplo, trans, diag, n, 1, ap, scale,
503 $ rwork, one, b( n+1 ), lda, x, lda, work,
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 )
'CLATPS', uplo, trans,
513 $ diag,
'N', n, imat, 8, result( 8 )
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 )
'CLATPS', uplo, trans,
520 $ diag,
'Y', n, imat, 9, result( 9 )
531 CALL alasum( path, nout, nfail, nrun, nerrs )
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(',
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,
')=',