89 SUBROUTINE dget36( RMAX, LMAX, NINFO, KNT, NIN )
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 dtrexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
DTREXC
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dget36(RMAX, LMAX, NINFO, KNT, NIN)
DGET36
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 dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...