90 REAL FUNCTION sqrt12( M, N, A, LDA, S, WORK, LWORK )
98 INTEGER lda, lwork, m, n
101 REAL a( lda, * ), s( * ), work( lwork )
108 parameter( zero = 0.0e0, one = 1.0e0 )
111 INTEGER i, info, iscl,
j, mn
112 REAL anrm, bignum, nrmsvl, smlnum
123 INTRINSIC max, min, real
134 IF( lwork.LT.max( m*n+4*min( m, n )+max( m, n ),
135 $ m*n+2*min( m, n )+4*n) )
THEN
136 CALL
xerbla(
'SQRT12', 7 )
146 nrmsvl =
snrm2( mn, s, 1 )
150 CALL
slaset(
'Full', m, n, zero, zero, work, m )
152 DO 10 i = 1, min(
j, m )
153 work( (
j-1 )*m+i ) = a( i,
j )
160 bignum = one / smlnum
161 CALL
slabad( smlnum, bignum )
165 anrm =
slange(
'M', m, n, work, m, dummy )
167 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
171 CALL
slascl(
'G', 0, 0, anrm, smlnum, m, n, work, m, info )
173 ELSE IF( anrm.GT.bignum )
THEN
177 CALL
slascl(
'G', 0, 0, anrm, bignum, m, n, work, m, info )
181 IF( anrm.NE.zero )
THEN
185 CALL
sgebd2( m, n, work, m, work( m*n+1 ), work( m*n+mn+1 ),
186 $ work( m*n+2*mn+1 ), work( m*n+3*mn+1 ),
187 $ work( m*n+4*mn+1 ), info )
188 CALL
sbdsqr(
'Upper', mn, 0, 0, 0, work( m*n+1 ),
189 $ work( m*n+mn+1 ), dummy, mn, dummy, 1, dummy, mn,
190 $ work( m*n+2*mn+1 ), info )
193 IF( anrm.GT.bignum )
THEN
194 CALL
slascl(
'G', 0, 0, bignum, anrm, mn, 1,
195 $ work( m*n+1 ), mn, info )
197 IF( anrm.LT.smlnum )
THEN
198 CALL
slascl(
'G', 0, 0, smlnum, anrm, mn, 1,
199 $ work( m*n+1 ), mn, info )
212 CALL
saxpy( mn, -one, s, 1, work( m*n+1 ), 1 )
214 $ (
slamch(
'Epsilon' )*
REAL( MAX( M, N ) ) )
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...
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 ...
real function sasum(N, SX, INCX)
SASUM
subroutine sbdsqr(UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
SBDSQR
subroutine xerbla(SRNAME, INFO)
XERBLA
real function sqrt12(M, N, A, LDA, S, WORK, LWORK)
SQRT12
subroutine sgebd2(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO)
SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
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.
real function slamch(CMACH)
SLAMCH
real function snrm2(N, X, INCX)
SNRM2
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD