159 SUBROUTINE cdrvpo( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
160 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK,
169 INTEGER NMAX, NN, NOUT, NRHS
175 REAL RWORK( * ), S( * )
176 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
177 $ bsav( * ), work( * ), x( * ), xact( * )
184 PARAMETER ( ONE = 1.0e+0, zero = 0.0e+0 )
186 parameter( ntypes = 9 )
188 parameter( ntests = 6 )
191 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
192 CHARACTER DIST, EQUED, FACT,
TYPE, UPLO, XTYPE
194 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
195 $ izero, k, k1, kl, ku, lda, mode, n, nb, nbmin,
196 $ nerrs, nfact, nfail, nimat, nrun, nt,
198 REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
199 $ ROLDC, SCOND, RPVGRW_SVXX
202 CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 REAL RESULT( NTESTS ), BERR( NRHS ),
205 $ errbnds_n( nrhs, 3 ), errbnds_c( nrhs, 3 )
210 EXTERNAL lsame, clanhe, sget06
224 COMMON / infoc / infot, nunit, ok, lerr
225 COMMON / srnamc / srnamt
231 DATA iseedy / 1988, 1989, 1990, 1991 /
232 DATA uplos /
'U',
'L' /
233 DATA facts /
'F',
'N',
'E' /
234 DATA equeds /
'N',
'Y' /
240 path( 1: 1 ) =
'Complex precision'
246 iseed( i ) = iseedy( i )
252 $
CALL cerrvx( path, nout )
272 DO 120 imat = 1, nimat
276 IF( .NOT.dotype( imat ) )
281 zerot = imat.GE.3 .AND. imat.LE.5
282 IF( zerot .AND. n.LT.imat-2 )
288 uplo = uplos( iuplo )
293 CALL clatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
297 CALL clatms( n, n, dist, iseed,
TYPE, rwork, mode,
298 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
304 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n, -1,
305 $ -1, -1, imat, nfail, nerrs, nout )
315 ELSE IF( imat.EQ.4 )
THEN
320 ioff = ( izero-1 )*lda
324 IF( iuplo.EQ.1 )
THEN
325 DO 20 i = 1, izero - 1
335 DO 40 i = 1, izero - 1
350 CALL claipd( n, a, lda+1, 0 )
354 CALL clacpy( uplo, n, n, a, lda, asav, lda )
357 equed = equeds( iequed )
358 IF( iequed.EQ.1 )
THEN
364 DO 90 ifact = 1, nfact
365 fact = facts( ifact )
366 prefac = lsame( fact,
'F' )
367 nofact = lsame( fact,
'N' )
368 equil = lsame( fact,
'E' )
375 ELSE IF( .NOT.lsame( fact,
'N' ) )
THEN
382 CALL clacpy( uplo, n, n, asav, lda, afac, lda )
383 IF( equil .OR. iequed.GT.1 )
THEN
388 CALL cpoequ( n, afac, lda, s, scond, amax,
390 IF( info.EQ.0 .AND. n.GT.0 )
THEN
396 CALL claqhe( uplo, n, afac, lda, s, scond,
409 anorm = clanhe(
'1', uplo, n, afac, lda, rwork )
413 CALL cpotrf( uplo, n, afac, lda, info )
417 CALL clacpy( uplo, n, n, afac, lda, a, lda )
418 CALL cpotri( uplo, n, a, lda, info )
422 ainvnm = clanhe(
'1', uplo, n, a, lda, rwork )
423 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
426 rcondc = ( one / anorm ) / ainvnm
432 CALL clacpy( uplo, n, n, asav, lda, a, lda )
437 CALL clarhs( path, xtype, uplo,
' ', n, n, kl, ku,
438 $ nrhs, a, lda, xact, lda, b, lda,
441 CALL clacpy(
'Full', n, nrhs, b, lda, bsav, lda )
450 CALL clacpy( uplo, n, n, a, lda, afac, lda )
451 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
454 CALL cposv( uplo, n, nrhs, afac, lda, x, lda,
459 IF( info.NE.izero )
THEN
460 CALL alaerh( path,
'CPOSV ', info, izero,
461 $ uplo, n, n, -1, -1, nrhs, imat,
462 $ nfail, nerrs, nout )
464 ELSE IF( info.NE.0 )
THEN
471 CALL cpot01( uplo, n, a, lda, afac, lda, rwork,
476 CALL clacpy(
'Full', n, nrhs, b, lda, work,
478 CALL cpot02( uplo, n, nrhs, a, lda, x, lda,
479 $ work, lda, rwork, result( 2 ) )
483 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
491 IF( result( k ).GE.thresh )
THEN
492 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
493 $
CALL aladhd( nout, path )
494 WRITE( nout, fmt = 9999 )
'CPOSV ', uplo,
495 $ n, imat, k, result( k )
506 $
CALL claset( uplo, n, n, cmplx( zero ),
507 $ cmplx( zero ), afac, lda )
508 CALL claset(
'Full', n, nrhs, cmplx( zero ),
509 $ cmplx( zero ), x, lda )
510 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
515 CALL claqhe( uplo, n, a, lda, s, scond, amax,
523 CALL cposvx( fact, uplo, n, nrhs, a, lda, afac,
524 $ lda, equed, s, b, lda, x, lda, rcond,
525 $ rwork, rwork( nrhs+1 ), work,
526 $ rwork( 2*nrhs+1 ), info )
530 IF( info.NE.izero )
THEN
531 CALL alaerh( path,
'CPOSVX', info, izero,
532 $ fact // uplo, n, n, -1, -1, nrhs,
533 $ imat, nfail, nerrs, nout )
538 IF( .NOT.prefac )
THEN
543 CALL cpot01( uplo, n, a, lda, afac, lda,
544 $ rwork( 2*nrhs+1 ), result( 1 ) )
552 CALL clacpy(
'Full', n, nrhs, bsav, lda, work,
554 CALL cpot02( uplo, n, nrhs, asav, lda, x, lda,
555 $ work, lda, rwork( 2*nrhs+1 ),
560 IF( nofact .OR. ( prefac .AND. lsame( equed,
562 CALL cget04( n, nrhs, x, lda, xact, lda,
563 $ rcondc, result( 3 ) )
565 CALL cget04( n, nrhs, x, lda, xact, lda,
566 $ roldc, result( 3 ) )
572 CALL cpot05( uplo, n, nrhs, asav, lda, b, lda,
573 $ x, lda, xact, lda, rwork,
574 $ rwork( nrhs+1 ), result( 4 ) )
582 result( 6 ) = sget06( rcond, rcondc )
588 IF( result( k ).GE.thresh )
THEN
589 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
590 $
CALL aladhd( nout, path )
592 WRITE( nout, fmt = 9997 )
'CPOSVX', fact,
593 $ uplo, n, equed, imat, k, result( k )
595 WRITE( nout, fmt = 9998 )
'CPOSVX', fact,
596 $ uplo, n, imat, k, result( k )
607 CALL clacpy(
'Full', n, n, asav, lda, a, lda )
608 CALL clacpy(
'Full', n, nrhs, bsav, lda, b, lda )
611 $
CALL claset( uplo, n, n, cmplx( zero ),
612 $ cmplx( zero ), afac, lda )
613 CALL claset(
'Full', n, nrhs, cmplx( zero ),
614 $ cmplx( zero ), x, lda )
615 IF( iequed.GT.1 .AND. n.GT.0 )
THEN
620 CALL claqhe( uplo, n, a, lda, s, scond, amax,
629 CALL cposvxx( fact, uplo, n, nrhs, a, lda, afac,
630 $ lda, equed, s, b, lda, x,
631 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
632 $ errbnds_n, errbnds_c, 0, zero, work,
633 $ rwork( 2*nrhs+1 ), info )
637 IF( info.EQ.n+1 )
GOTO 90
638 IF( info.NE.izero )
THEN
639 CALL alaerh( path,
'CPOSVXX', info, izero,
640 $ fact // uplo, n, n, -1, -1, nrhs,
641 $ imat, nfail, nerrs, nout )
646 IF( .NOT.prefac )
THEN
651 CALL cpot01( uplo, n, a, lda, afac, lda,
652 $ rwork( 2*nrhs+1 ), result( 1 ) )
660 CALL clacpy(
'Full', n, nrhs, bsav, lda, work,
662 CALL cpot02( uplo, n, nrhs, asav, lda, x, lda,
663 $ work, lda, rwork( 2*nrhs+1 ),
668 IF( nofact .OR. ( prefac .AND. lsame( equed,
670 CALL cget04( n, nrhs, x, lda, xact, lda,
671 $ rcondc, result( 3 ) )
673 CALL cget04( n, nrhs, x, lda, xact, lda,
674 $ roldc, result( 3 ) )
680 CALL cpot05( uplo, n, nrhs, asav, lda, b, lda,
681 $ x, lda, xact, lda, rwork,
682 $ rwork( nrhs+1 ), result( 4 ) )
690 result( 6 ) = sget06( rcond, rcondc )
696 IF( result( k ).GE.thresh )
THEN
697 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
698 $
CALL aladhd( nout, path )
700 WRITE( nout, fmt = 9997 )
'CPOSVXX', fact,
701 $ uplo, n, equed, imat, k, result( k )
703 WRITE( nout, fmt = 9998 )
'CPOSVXX', fact,
704 $ uplo, n, imat, k, result( k )
718 CALL alasvm( path, nout, nfail, nrun, nerrs )
725 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i1,
726 $
', test(', i1,
')=', g12.5 )
727 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
728 $
', type ', i1,
', test(', i1,
')=', g12.5 )
729 9997
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N=', i5,
730 $
', EQUED=''', a1,
''', type ', i1,
', test(', i1,
') =',
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine aladhd(iounit, path)
ALADHD
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine cdrvpo(dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
CDRVPO
subroutine cebchvxx(thresh, path)
CEBCHVXX
subroutine cerrvx(path, nunit)
CERRVX
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
subroutine claipd(n, a, inda, vinda)
CLAIPD
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
subroutine cpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
CPOT01
subroutine cpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPOT02
subroutine cpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPOT05
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
subroutine claqhe(uplo, n, a, lda, s, scond, amax, equed)
CLAQHE scales a Hermitian matrix.
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 cpoequ(n, a, lda, s, scond, amax, info)
CPOEQU
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 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 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 cpotrf(uplo, n, a, lda, info)
CPOTRF
subroutine cpotri(uplo, n, a, lda, info)
CPOTRI