116 REAL FUNCTION sqrt14( TRANS, M, N, NRHS, A, LDA, X,
126 INTEGER lda, ldx, lwork, m, n, nrhs
129 REAL a( lda, * ), work( lwork ),
x( ldx, * )
136 parameter( zero = 0.0e0, one = 1.0e0 )
140 INTEGER i, info,
j, ldwork
155 INTRINSIC abs, max, min, real
160 IF(
lsame( trans,
'N' ) )
THEN
163 IF( lwork.LT.( m+nrhs )*( n+2 ) )
THEN
164 CALL
xerbla(
'SQRT14', 10 )
166 ELSE IF( n.LE.0 .OR. nrhs.LE.0 )
THEN
169 ELSE IF(
lsame( trans,
'T' ) )
THEN
172 IF( lwork.LT.( n+nrhs )*( m+2 ) )
THEN
173 CALL
xerbla(
'SQRT14', 10 )
175 ELSE IF( m.LE.0 .OR. nrhs.LE.0 )
THEN
179 CALL
xerbla(
'SQRT14', 1 )
185 CALL
slacpy(
'All', m, n, a, lda, work, ldwork )
186 anrm =
slange(
'M', m, n, work, ldwork, rwork )
188 $ CALL
slascl(
'G', 0, 0, anrm, one, m, n, work, ldwork, info )
196 CALL
slacpy(
'All', m, nrhs,
x, ldx, work( n*ldwork+1 ),
198 xnrm =
slange(
'M', m, nrhs, work( n*ldwork+1 ), ldwork,
201 $ CALL
slascl(
'G', 0, 0, xnrm, one, m, nrhs,
202 $ work( n*ldwork+1 ), ldwork, info )
203 anrm =
slange(
'One-norm', m, n+nrhs, work, ldwork, rwork )
207 CALL
sgeqr2( m, n+nrhs, work, ldwork,
208 $ work( ldwork*( n+nrhs )+1 ),
209 $ work( ldwork*( n+nrhs )+min( m, n+nrhs )+1 ),
216 DO 20
j = n + 1, n + nrhs
217 DO 10 i = n + 1, min( m,
j )
218 err = max( err, abs( work( i+(
j-1 )*m ) ) )
228 work( m+
j+( i-1 )*ldwork ) =
x( i,
j )
232 xnrm =
slange(
'M', nrhs, n, work( m+1 ), ldwork, rwork )
234 $ CALL
slascl(
'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
239 CALL
sgelq2( ldwork, n, work, ldwork, work( ldwork*n+1 ),
240 $ work( ldwork*( n+1 )+1 ), info )
248 err = max( err, abs( work( i+(
j-1 )*ldwork ) ) )
254 sqrt14 = err / (
REAL( MAX( M, N, NRHS ) )*
slamch(
'Epsilon' ) )
LOGICAL function lsame(CA, CB)
LSAME
REAL function slamch(CMACH)
SLAMCH
subroutine xerbla(SRNAME, INFO)
XERBLA
REAL function sqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
SQRT14
subroutine slascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
REAL function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sgelq2(M, N, A, LDA, TAU, WORK, INFO)
SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sgeqr2(M, N, A, LDA, TAU, WORK, INFO)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...