89 SUBROUTINE sget36( RMAX, LMAX, NINFO, KNT, NIN )
97 INTEGER knt, lmax, nin
108 parameter( zero = 0.0e0, one = 1.0e0 )
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
118 REAL 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
slacpy(
'F', n, n, tmp, ldt, t1, ldt )
152 CALL
slacpy(
'F', n, n, tmp, ldt, t2, ldt )
163 CALL
slaset(
'Full', n, n, zero, one, q, ldt )
164 CALL
strexc(
'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
slaset(
'Full', n, n, zero, one, q, ldt )
177 CALL
strexc(
'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
shst01( 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 slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine sget36(RMAX, LMAX, NINFO, KNT, NIN)
SGET36
subroutine shst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
SHST01
subroutine strexc(COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO)
STREXC
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j