86 SUBROUTINE zget36( RMAX, LMAX, NINFO, KNT, NIN )
94 INTEGER knt, lmax, nin, ninfo
101 DOUBLE PRECISION zero, one
102 parameter( zero = 0.0d+0, one = 1.0d+0 )
103 COMPLEX*16 czero, cone
104 parameter( czero = ( 0.0d+0, 0.0d+0 ),
105 $ cone = ( 1.0d+0, 0.0d+0 ) )
107 parameter( ldt = 10, lwork = 2*ldt*ldt )
110 INTEGER i, ifst, ilst, info1, info2,
j, n
111 DOUBLE PRECISION eps, res
115 DOUBLE PRECISION result( 2 ), rwork( ldt )
116 COMPLEX*16 diag( ldt ), q( ldt, ldt ), t1( ldt, ldt ),
117 $ t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
137 READ( nin, fmt = * )n, ifst, ilst
142 READ( nin, fmt = * )( tmp( i,
j ),
j = 1, n )
144 CALL
zlacpy(
'F', n, n, tmp, ldt, t1, ldt )
145 CALL
zlacpy(
'F', n, n, tmp, ldt, t2, ldt )
150 CALL
zlaset(
'Full', n, n, czero, cone, q, ldt )
151 CALL
ztrexc(
'N', n, t1, ldt, q, ldt, ifst, ilst, info1 )
154 IF( i.EQ.
j .AND. q( i,
j ).NE.cone )
155 $ res = res + one / eps
156 IF( i.NE.
j .AND. q( i,
j ).NE.czero )
157 $ res = res + one / eps
163 CALL
zlaset(
'Full', n, n, czero, cone, q, ldt )
164 CALL
ztrexc(
'V', n, t2, ldt, q, ldt, ifst, ilst, info2 )
170 IF( t1( i,
j ).NE.t2( i,
j ) )
171 $ res = res + one / eps
174 IF( info1.NE.0 .OR. info2.NE.0 )
177 $ res = res + one / eps
181 CALL
zcopy( n, tmp, ldt+1, diag, 1 )
182 IF( ifst.LT.ilst )
THEN
183 DO 70 i = ifst + 1, ilst
185 diag( i ) = diag( i-1 )
188 ELSE IF( ifst.GT.ilst )
THEN
189 DO 80 i = ifst - 1, ilst, -1
191 diag( i+1 ) = diag( i )
196 IF( t2( i, i ).NE.diag( i ) )
197 $ res = res + one / eps
202 CALL
zhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
204 res = res + result( 1 ) + result( 2 )
210 IF( t2( i,
j ).NE.czero )
211 $ res = res + one / eps
214 IF( res.GT.rmax )
THEN
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zget36(RMAX, LMAX, NINFO, KNT, NIN)
ZGET36
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ztrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO)
ZTREXC
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
ZHST01