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
149 EXTERNAL lsame, slamch, slange
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' ) )
subroutine sgeqr2(M, N, A, LDA, TAU, WORK, INFO)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
subroutine xerbla(SRNAME, INFO)
XERBLA
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 sgelq2(M, N, A, LDA, TAU, WORK, INFO)
SGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm...
real function sqrt14(TRANS, M, N, NRHS, A, LDA, X, LDX, WORK, LWORK)
SQRT14
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.