97 INTEGER knt, lmax, nin
107 DOUBLE PRECISION zero, one
108 parameter ( zero = 0.0d0, one = 1.0d0 )
110 parameter ( ldt = 10, lwork = 2*ldt*ldt )
113 INTEGER i, ifst, ifst1, ifst2, ifstsv, ilst, ilst1,
114 $ ilst2, ilstsv, info1, info2, j, loc, n
115 DOUBLE PRECISION eps, res
118 DOUBLE PRECISION q( ldt, ldt ), result( 2 ), t1( ldt, ldt ),
119 $ t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
144 READ( nin, fmt = * )n, ifst, ilst
149 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
151 CALL dlacpy(
'F', n, n, tmp, ldt, t1, ldt )
152 CALL dlacpy(
'F', n, n, tmp, ldt, t2, ldt )
163 CALL dlaset(
'Full', n, n, zero, one, q, ldt )
164 CALL dtrexc(
'N', n, t1, ldt, q, ldt, ifst1, ilst1, work, info1 )
167 IF( i.EQ.j .AND. q( i, j ).NE.one )
168 $ res = res + one / eps
169 IF( i.NE.j .AND. q( i, j ).NE.zero )
170 $ res = res + one / eps
176 CALL dlaset(
'Full', n, n, zero, one, q, ldt )
177 CALL dtrexc(
'V', n, t2, ldt, q, ldt, ifst2, ilst2, work, info2 )
183 IF( t1( i, j ).NE.t2( i, j ) )
184 $ res = res + one / eps
188 $ res = res + one / eps
190 $ res = res + one / eps
192 $ res = res + one / eps
196 IF( info2.NE.0 )
THEN
197 ninfo( info2 ) = ninfo( info2 ) + 1
199 IF( abs( ifst2-ifstsv ).GT.1 )
200 $ res = res + one / eps
201 IF( abs( ilst2-ilstsv ).GT.1 )
202 $ res = res + one / eps
207 CALL dhst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
209 res = res + result( 1 ) + result( 2 )
215 IF( t2( loc+1, loc ).NE.zero )
THEN
219 IF( t2( loc, loc+1 ).EQ.zero .OR. t2( loc, loc ).NE.
220 $ t2( loc+1, loc+1 ) .OR. sign( one, t2( loc, loc+1 ) ).EQ.
221 $ sign( one, t2( loc+1, loc ) ) )res = res + one / eps
223 IF( t2( i, loc ).NE.zero )
224 $ res = res + one / res
225 IF( t2( i, loc+1 ).NE.zero )
226 $ res = res + one / res
234 IF( t2( i, loc ).NE.zero )
235 $ res = res + one / res
241 IF( res.GT.rmax )
THEN
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
double precision function dlamch(CMACH)
DLAMCH
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dtrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
DTREXC