136 SUBROUTINE zpst01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM,
137 $ piv, rwork, resid, rank )
145 DOUBLE PRECISION resid
146 INTEGER lda, ldafac, ldperm, n, rank
150 COMPLEX*16 a( lda, * ), afac( ldafac, * ),
152 DOUBLE PRECISION rwork( * )
159 DOUBLE PRECISION zero, one
160 parameter( zero = 0.0d+0, one = 1.0d+0 )
162 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
166 DOUBLE PRECISION anorm, eps, tr
179 INTRINSIC dble, dconjg, dimag
193 anorm =
zlanhe(
'1', uplo, n, a, lda, rwork )
194 IF( anorm.LE.zero )
THEN
203 IF( dimag( afac(
j,
j ) ).NE.zero )
THEN
211 IF(
lsame( uplo,
'U' ) )
THEN
214 DO 120
j = rank + 1, n
215 DO 110 i = rank + 1,
j
225 tr =
zdotc( k, afac( 1, k ), 1, afac( 1, k ), 1 )
230 CALL
ztrmv(
'Upper',
'Conjugate',
'Non-unit', k-1, afac,
231 $ ldafac, afac( 1, k ), 1 )
240 DO 150
j = rank + 1, n
252 $ CALL
zher(
'Lower', n-k, one, afac( k+1, k ), 1,
253 $ afac( k+1, k+1 ), ldafac )
258 CALL
zscal( n-k+1, tc, afac( k, k ), 1 )
265 IF(
lsame( uplo,
'U' ) )
THEN
269 IF( piv( i ).LE.piv(
j ) )
THEN
271 perm( piv( i ), piv(
j ) ) = afac( i,
j )
273 perm( piv( i ), piv(
j ) ) = dconjg( afac(
j, i ) )
284 IF( piv( i ).GE.piv(
j ) )
THEN
286 perm( piv( i ), piv(
j ) ) = afac( i,
j )
288 perm( piv( i ), piv(
j ) ) = dconjg( afac(
j, i ) )
298 IF(
lsame( uplo,
'U' ) )
THEN
301 perm( i,
j ) = perm( i,
j ) - a( i,
j )
303 perm(
j,
j ) = perm(
j,
j ) - dble( a(
j,
j ) )
307 perm(
j,
j ) = perm(
j,
j ) - dble( a(
j,
j ) )
309 perm( i,
j ) = perm( i,
j ) - a( i,
j )
317 resid =
zlanhe(
'1', uplo, n, perm, ldafac, rwork )
319 resid = ( ( resid / dble( n ) ) / anorm ) / eps
complex *16 function zdotc(N, ZX, INCX, ZY, INCY)
ZDOTC
double precision function zlanhe(NORM, UPLO, N, A, LDA, WORK)
ZLANHE 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.
logical function lsame(CA, CB)
LSAME
subroutine ztrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
ZTRMV
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zpst01(UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, PIV, RWORK, RESID, RANK)
ZPST01
subroutine zher(UPLO, N, ALPHA, X, INCX, A, LDA)
ZHER
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL