161 SUBROUTINE cdrvpo( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
162 $ a, afac, asav,
b, bsav,
x, xact, s, work,
172 INTEGER nmax, nn, nout, nrhs
178 REAL rwork( * ), s( * )
179 COMPLEX a( * ), afac( * ), asav( * ),
b( * ),
180 $ bsav( * ), work( * ),
x( * ), xact( * )
187 parameter( one = 1.0e+0, zero = 0.0e+0 )
189 parameter( ntypes = 9 )
191 parameter( ntests = 6 )
194 LOGICAL equil, nofact, prefac, zerot
195 CHARACTER dist, equed, fact, type, uplo, xtype
197 INTEGER i, iequed, ifact, imat, in, info, ioff, iuplo,
198 $ izero, k, k1, kl, ku, lda, mode, n, nb, nbmin,
199 $ nerrs, nfact, nfail, nimat, nrun, nt,
201 REAL ainvnm, amax, anorm, cndnum, rcond, rcondc,
202 $ roldc, scond, rpvgrw_svxx
205 CHARACTER equeds( 2 ), facts( 3 ), uplos( 2 )
206 INTEGER iseed( 4 ), iseedy( 4 )
207 REAL result( ntests ), berr( nrhs ),
208 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
227 COMMON / infoc / infot, nunit, ok, lerr
228 COMMON / srnamc / srnamt
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA uplos /
'U',
'L' /
236 DATA facts /
'F',
'N',
'E' /
237 DATA equeds /
'N',
'Y' /
243 path( 1: 1 ) =
'Complex precision'
249 iseed( i ) = iseedy( i )
255 $ CALL
cerrvx( path, nout )
275 DO 120 imat = 1, nimat
279 IF( .NOT.dotype( imat ) )
284 zerot = imat.GE.3 .AND. imat.LE.5
285 IF( zerot .AND. n.LT.imat-2 )
291 uplo = uplos( iuplo )
296 CALL
clatb4( path, imat, n, n, type, kl, ku, anorm, mode,
300 CALL
clatms( n, n, dist, iseed, type, rwork, mode,
301 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
307 CALL
alaerh( path,
'CLATMS', info, 0, uplo, n, n, -1,
308 $ -1, -1, imat, nfail, nerrs, nout )
318 ELSE IF( imat.EQ.4 )
THEN
323 ioff = ( izero-1 )*lda
327 IF( iuplo.EQ.1 )
THEN
328 DO 20 i = 1, izero - 1
338 DO 40 i = 1, izero - 1
353 CALL
claipd( n, a, lda+1, 0 )
357 CALL
clacpy( uplo, n, n, a, lda, asav, lda )
360 equed = equeds( iequed )
361 IF( iequed.EQ.1 )
THEN
367 DO 90 ifact = 1, nfact
368 fact = facts( ifact )
369 prefac =
lsame( fact,
'F' )
370 nofact =
lsame( fact,
'N' )
371 equil =
lsame( fact,
'E' )
378 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
385 CALL
clacpy( uplo, n, n, asav, lda, afac, lda )
386 IF( equil .OR. iequed.GT.1 )
THEN
391 CALL
cpoequ( n, afac, lda, s, scond, amax,
393 IF( info.EQ.0 .AND. n.GT.0 )
THEN
399 CALL
claqhe( uplo, n, afac, lda, s, scond,
412 anorm =
clanhe(
'1', uplo, n, afac, lda, rwork )
416 CALL
cpotrf( uplo, n, afac, lda, info )
420 CALL
clacpy( uplo, n, n, afac, lda, a, lda )
421 CALL
cpotri( uplo, n, a, lda, info )
425 ainvnm =
clanhe(
'1', uplo, n, a, lda, rwork )
426 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
429 rcondc = ( one / anorm ) / ainvnm
435 CALL
clacpy( uplo, n, n, asav, lda, a, lda )
440 CALL
clarhs( path, xtype, uplo,
' ', n, n, kl, ku,
441 $ nrhs, a, lda, xact, lda,
b, lda,
444 CALL
clacpy(
'Full', n, nrhs,
b, lda, bsav, lda )
453 CALL
clacpy( uplo, n, n, a, lda, afac, lda )
454 CALL
clacpy(
'Full', n, nrhs,
b, lda,
x, lda )
457 CALL
cposv( uplo, n, nrhs, afac, lda,
x, lda,
462 IF( info.NE.izero )
THEN
463 CALL
alaerh( path,
'CPOSV ', info, izero,
464 $ uplo, n, n, -1, -1, nrhs, imat,
465 $ nfail, nerrs, nout )
467 ELSE IF( info.NE.0 )
THEN
474 CALL
cpot01( uplo, n, a, lda, afac, lda, rwork,
479 CALL
clacpy(
'Full', n, nrhs,
b, lda, work,
481 CALL
cpot02( uplo, n, nrhs, a, lda,
x, lda,
482 $ work, lda, rwork, result( 2 ) )
486 CALL
cget04( n, nrhs,
x, lda, xact, lda, rcondc,
494 IF( result( k ).GE.thresh )
THEN
495 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
496 $ CALL
aladhd( nout, path )
497 WRITE( nout, fmt = 9999 )
'CPOSV ', uplo,
498 $ n, imat, k, result( k )
509 $ CALL
claset( uplo, n, n, cmplx( zero ),
510 $ cmplx( zero ), afac, lda )
511 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
512 $ cmplx( zero ),
x, lda )
513 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
518 CALL
claqhe( uplo, n, a, lda, s, scond, amax,
526 CALL
cposvx( fact, uplo, n, nrhs, a, lda, afac,
527 $ lda, equed, s,
b, lda,
x, lda, rcond,
528 $ rwork, rwork( nrhs+1 ), work,
529 $ rwork( 2*nrhs+1 ), info )
533 IF( info.NE.izero )
THEN
534 CALL
alaerh( path,
'CPOSVX', info, izero,
535 $ fact // uplo, n, n, -1, -1, nrhs,
536 $ imat, nfail, nerrs, nout )
541 IF( .NOT.prefac )
THEN
546 CALL
cpot01( uplo, n, a, lda, afac, lda,
547 $ rwork( 2*nrhs+1 ), result( 1 ) )
555 CALL
clacpy(
'Full', n, nrhs, bsav, lda, work,
557 CALL
cpot02( uplo, n, nrhs, asav, lda,
x, lda,
558 $ work, lda, rwork( 2*nrhs+1 ),
563 IF( nofact .OR. ( prefac .AND.
lsame( equed,
565 CALL
cget04( n, nrhs,
x, lda, xact, lda,
566 $ rcondc, result( 3 ) )
568 CALL
cget04( n, nrhs,
x, lda, xact, lda,
569 $ roldc, result( 3 ) )
575 CALL
cpot05( uplo, n, nrhs, asav, lda,
b, lda,
576 $
x, lda, xact, lda, rwork,
577 $ rwork( nrhs+1 ), result( 4 ) )
585 result( 6 ) =
sget06( rcond, rcondc )
591 IF( result( k ).GE.thresh )
THEN
592 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
593 $ CALL
aladhd( nout, path )
595 WRITE( nout, fmt = 9997 )
'CPOSVX', fact,
596 $ uplo, n, equed, imat, k, result( k )
598 WRITE( nout, fmt = 9998 )
'CPOSVX', fact,
599 $ uplo, n, imat, k, result( k )
610 CALL
clacpy(
'Full', n, n, asav, lda, a, lda )
611 CALL
clacpy(
'Full', n, nrhs, bsav, lda,
b, lda )
614 $ CALL
claset( uplo, n, n, cmplx( zero ),
615 $ cmplx( zero ), afac, lda )
616 CALL
claset(
'Full', n, nrhs, cmplx( zero ),
617 $ cmplx( zero ),
x, lda )
618 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
623 CALL
claqhe( uplo, n, a, lda, s, scond, amax,
632 CALL
cposvxx( fact, uplo, n, nrhs, a, lda, afac,
633 $ lda, equed, s,
b, lda,
x,
634 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
635 $ errbnds_n, errbnds_c, 0, zero, work,
636 $ rwork( 2*nrhs+1 ), info )
640 IF( info.EQ.n+1 ) goto 90
641 IF( info.NE.izero )
THEN
642 CALL
alaerh( path,
'CPOSVXX', info, izero,
643 $ fact // uplo, n, n, -1, -1, nrhs,
644 $ imat, nfail, nerrs, nout )
649 IF( .NOT.prefac )
THEN
654 CALL
cpot01( uplo, n, a, lda, afac, lda,
655 $ rwork( 2*nrhs+1 ), result( 1 ) )
663 CALL
clacpy(
'Full', n, nrhs, bsav, lda, work,
665 CALL
cpot02( uplo, n, nrhs, asav, lda,
x, lda,
666 $ work, lda, rwork( 2*nrhs+1 ),
671 IF( nofact .OR. ( prefac .AND.
lsame( equed,
673 CALL
cget04( n, nrhs,
x, lda, xact, lda,
674 $ rcondc, result( 3 ) )
676 CALL
cget04( n, nrhs,
x, lda, xact, lda,
677 $ roldc, result( 3 ) )
683 CALL
cpot05( uplo, n, nrhs, asav, lda,
b, lda,
684 $
x, lda, xact, lda, rwork,
685 $ rwork( nrhs+1 ), result( 4 ) )
693 result( 6 ) =
sget06( rcond, rcondc )
699 IF( result( k ).GE.thresh )
THEN
700 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
701 $ CALL
aladhd( nout, path )
703 WRITE( nout, fmt = 9997 )
'CPOSVXX', fact,
704 $ uplo, n, equed, imat, k, result( k )
706 WRITE( nout, fmt = 9998 )
'CPOSVXX', fact,
707 $ uplo, n, imat, k, result( k )
721 CALL
alasvm( path, nout, nfail, nrun, nerrs )
728 9999
FORMAT( 1
x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
729 $
', test(', i1,
')=', g12.5 )
730 9998
FORMAT( 1
x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
731 $
', type ', i1,
', test(', i1,
')=', g12.5 )
732 9997
FORMAT( 1
x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
733 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
') =',
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
LOGICAL function lsame(CA, CB)
LSAME
subroutine cposvx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CPOSVX computes the solution to system of linear equations A * X = B for PO matrices ...
subroutine cpot01(UPLO, N, A, LDA, AFAC, LDAFAC, RWORK, RESID)
CPOT01
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
REAL function clanhe(NORM, UPLO, N, A, LDA, WORK)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
subroutine cposvxx(FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO)
CPOSVXX computes the solution to system of linear equations A * X = B for PO matrices ...
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine cpot05(UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPOT05
REAL function sget06(RCOND, RCONDC)
SGET06
subroutine cdrvpo(DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, RWORK, NOUT)
CDRVPO
subroutine cpoequ(N, A, LDA, S, SCOND, AMAX, INFO)
CPOEQU
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine claqhe(UPLO, N, A, LDA, S, SCOND, AMAX, EQUED)
CLAQHE scales a Hermitian matrix.
subroutine cpotri(UPLO, N, A, LDA, INFO)
CPOTRI
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine cpot02(UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
CPOT02
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine cebchvxx(THRESH, PATH)
CEBCHVXX
subroutine cerrvx(PATH, NUNIT)
CERRVX
subroutine cpotrf(UPLO, N, A, LDA, INFO)
CPOTRF
subroutine cposv(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
CPOSV computes the solution to system of linear equations A * X = B for PO matrices ...
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04