167 INTEGER nmax, nn, nout, nrhs
172 INTEGER iwork( * ), nval( * )
174 COMPLEX a( * ), afac( * ), ainv( * ), b( * ),
175 $ work( * ), x( * ), xact( * )
182 parameter ( one = 1.0e+0, zero = 0.0e+0 )
183 INTEGER ntypes, ntests
184 parameter ( ntypes = 10, ntests = 6 )
186 parameter ( nfact = 2 )
190 CHARACTER dist, fact, packit,
TYPE, uplo, xtype
192 INTEGER i, i1, i2, ifact, imat, in, info, ioff, iuplo,
193 $ izero, j, k, k1, kl, ku, lda, mode, n, nb,
194 $ nbmin, nerrs, nfail, nimat, npp, nrun, nt
195 REAL ainvnm, anorm, cndnum, rcond, rcondc
198 CHARACTER facts( nfact )
199 INTEGER iseed( 4 ), iseedy( 4 )
200 REAL result( ntests )
218 COMMON / infoc / infot, nunit, ok, lerr
219 COMMON / srnamc / srnamt
222 INTRINSIC cmplx, max, min
225 DATA iseedy / 1988, 1989, 1990, 1991 /
226 DATA facts /
'F',
'N' /
238 iseed( i ) = iseedy( i )
244 $
CALL cerrvx( path, nout )
265 DO 170 imat = 1, nimat
269 IF( .NOT.dotype( imat ) )
274 zerot = imat.GE.3 .AND. imat.LE.6
275 IF( zerot .AND. n.LT.imat-2 )
281 IF( iuplo.EQ.1 )
THEN
292 CALL clatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
296 CALL clatms( n, n, dist, iseed,
TYPE, rwork, mode,
297 $ cndnum, anorm, kl, ku, packit, a, lda, work,
303 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n, -1,
304 $ -1, -1, imat, nfail, nerrs, nout )
314 ELSE IF( imat.EQ.4 )
THEN
324 IF( iuplo.EQ.1 )
THEN
325 ioff = ( izero-1 )*izero / 2
326 DO 20 i = 1, izero - 1
336 DO 40 i = 1, izero - 1
347 IF( iuplo.EQ.1 )
THEN
377 IF( iuplo.EQ.1 )
THEN
380 CALL claipd( n, a, n, -1 )
383 DO 150 ifact = 1, nfact
387 fact = facts( ifact )
397 ELSE IF( ifact.EQ.1 )
THEN
401 anorm =
clanhp(
'1', uplo, n, a, rwork )
405 CALL ccopy( npp, a, 1, afac, 1 )
406 CALL chptrf( uplo, n, afac, iwork, info )
410 CALL ccopy( npp, afac, 1, ainv, 1 )
411 CALL chptri( uplo, n, ainv, iwork, work, info )
412 ainvnm =
clanhp(
'1', uplo, n, ainv, rwork )
416 IF( anorm.LE.zero .OR. ainvnm.LE.zero )
THEN
419 rcondc = ( one / anorm ) / ainvnm
426 CALL clarhs( path, xtype, uplo,
' ', n, n, kl, ku,
427 $ nrhs, a, lda, xact, lda, b, lda, iseed,
433 IF( ifact.EQ.2 )
THEN
434 CALL ccopy( npp, a, 1, afac, 1 )
435 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
440 CALL chpsv( uplo, n, nrhs, afac, iwork, x, lda,
449 IF( iwork( k ).LT.0 )
THEN
450 IF( iwork( k ).NE.-k )
THEN
454 ELSE IF( iwork( k ).NE.k )
THEN
463 CALL alaerh( path,
'CHPSV ', info, k, uplo, n,
464 $ n, -1, -1, nrhs, imat, nfail,
467 ELSE IF( info.NE.0 )
THEN
474 CALL chpt01( uplo, n, a, afac, iwork, ainv, lda,
475 $ rwork, result( 1 ) )
479 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
480 CALL cppt02( uplo, n, nrhs, a, x, lda, work, lda,
481 $ rwork, result( 2 ) )
485 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
493 IF( result( k ).GE.thresh )
THEN
494 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
495 $
CALL aladhd( nout, path )
496 WRITE( nout, fmt = 9999 )
'CHPSV ', uplo, n,
497 $ imat, k, result( k )
507 IF( ifact.EQ.2 .AND. npp.GT.0 )
508 $
CALL claset(
'Full', npp, 1, cmplx( zero ),
509 $ cmplx( zero ), afac, npp )
510 CALL claset(
'Full', n, nrhs, cmplx( zero ),
511 $ cmplx( zero ), x, lda )
517 CALL chpsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
518 $ lda, x, lda, rcond, rwork,
519 $ rwork( nrhs+1 ), work, rwork( 2*nrhs+1 ),
528 IF( iwork( k ).LT.0 )
THEN
529 IF( iwork( k ).NE.-k )
THEN
533 ELSE IF( iwork( k ).NE.k )
THEN
542 CALL alaerh( path,
'CHPSVX', info, k, fact // uplo,
543 $ n, n, -1, -1, nrhs, imat, nfail,
549 IF( ifact.GE.2 )
THEN
554 CALL chpt01( uplo, n, a, afac, iwork, ainv, lda,
555 $ rwork( 2*nrhs+1 ), result( 1 ) )
563 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
564 CALL cppt02( uplo, n, nrhs, a, x, lda, work, lda,
565 $ rwork( 2*nrhs+1 ), result( 2 ) )
569 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
574 CALL cppt05( uplo, n, nrhs, a, b, lda, x, lda,
575 $ xact, lda, rwork, rwork( nrhs+1 ),
584 result( 6 ) =
sget06( rcond, rcondc )
590 IF( result( k ).GE.thresh )
THEN
591 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
592 $
CALL aladhd( nout, path )
593 WRITE( nout, fmt = 9998 )
'CHPSVX', fact, uplo,
594 $ n, imat, k, result( k )
608 CALL alasvm( path, nout, nfail, nrun, nerrs )
610 9999
FORMAT( 1x, a,
', UPLO=''', a1,
''', N =', i5,
', type ', i2,
611 $
', test ', i2,
', ratio =', g12.5 )
612 9998
FORMAT( 1x, a,
', FACT=''', a1,
''', UPLO=''', a1,
''', N =', i5,
613 $
', type ', i2,
', test ', i2,
', ratio =', g12.5 )
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
subroutine clarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
CLARHS
subroutine claipd(N, A, INDA, VINDA)
CLAIPD
subroutine cppt05(UPLO, N, NRHS, AP, B, LDB, X, LDX, XACT, LDXACT, FERR, BERR, RESLTS)
CPPT05
subroutine chptrf(UPLO, N, AP, IPIV, INFO)
CHPTRF
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 cerrvx(PATH, NUNIT)
CERRVX
real function sget06(RCOND, RCONDC)
SGET06
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
subroutine chptri(UPLO, N, AP, IPIV, WORK, INFO)
CHPTRI
subroutine cppt02(UPLO, N, NRHS, A, X, LDX, B, LDB, RWORK, RESID)
CPPT02
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
subroutine aladhd(IOUNIT, PATH)
ALADHD
subroutine chpsvx(FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
CHPSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine chpsv(UPLO, N, NRHS, AP, IPIV, B, LDB, INFO)
CHPSV computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine clatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
CLATB4
real function clanhp(NORM, UPLO, N, AP, WORK)
CLANHP 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 supplied in packed form.
subroutine chpt01(UPLO, N, A, AFAC, IPIV, C, LDC, RWORK, RESID)
CHPT01
subroutine cget04(N, NRHS, X, LDX, XACT, LDXACT, RCOND, RESID)
CGET04