117 SUBROUTINE dort01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID )
126 INTEGER ldu, lwork, m, n
127 DOUBLE PRECISION resid
130 DOUBLE PRECISION u( ldu, * ), work( * )
136 DOUBLE PRECISION zero, one
137 parameter( zero = 0.0d+0, one = 1.0d+0 )
141 INTEGER i,
j, k, ldwork, mnmin
142 DOUBLE PRECISION eps, tmp
153 INTRINSIC abs, dble, max, min
161 IF( m.LE.0 .OR. n.LE.0 )
164 eps =
dlamch(
'Precision' )
165 IF( m.LT.n .OR. ( m.EQ.n .AND.
lsame( rowcol,
'R' ) ) )
THEN
174 IF( ( mnmin+1 )*mnmin.LE.lwork )
THEN
179 IF( ldwork.GT.0 )
THEN
183 CALL
dlaset(
'Upper', mnmin, mnmin, zero, one, work, ldwork )
184 CALL
dsyrk(
'Upper', transu, mnmin, k, -one, u, ldu, one, work,
189 resid =
dlansy(
'1',
'Upper', mnmin, work, ldwork,
190 $ work( ldwork*mnmin+1 ) )
191 resid = ( resid / dble( k ) ) / eps
192 ELSE IF( transu.EQ.
'T' )
THEN
203 tmp = tmp -
ddot( m, u( 1, i ), 1, u( 1,
j ), 1 )
204 resid = max( resid, abs( tmp ) )
207 resid = ( resid / dble( m ) ) / eps
219 tmp = tmp -
ddot( n, u(
j, 1 ), ldu, u( i, 1 ), ldu )
220 resid = max( resid, abs( tmp ) )
223 resid = ( resid / dble( n ) ) / eps
logical function lsame(CA, CB)
LSAME
double precision function ddot(N, DX, INCX, DY, INCY)
DDOT
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
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 dort01(ROWCOL, M, N, U, LDU, WORK, LWORK, RESID)
DORT01