90 DOUBLE PRECISION FUNCTION dqrt12( M, N, A, LDA, S, WORK, LWORK )
98 INTEGER lda, lwork, m, n
101 DOUBLE PRECISION a( lda, * ), s( * ), work( lwork )
107 DOUBLE PRECISION zero, one
108 parameter( zero = 0.0d0, one = 1.0d0 )
111 INTEGER i, info, iscl, j, mn
112 DOUBLE PRECISION anrm, bignum, nrmsvl, smlnum
123 INTRINSIC dble, max, min
126 DOUBLE PRECISION dummy( 1 )
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(
'DQRT12', 7 )
146 nrmsvl =
dnrm2( mn, s, 1 )
150 CALL
dlaset(
'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
dlabad( smlnum, bignum )
165 anrm =
dlange(
'M', m, n, work, m, dummy )
167 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
171 CALL
dlascl(
'G', 0, 0, anrm, smlnum, m, n, work, m, info )
173 ELSE IF( anrm.GT.bignum )
THEN
177 CALL
dlascl(
'G', 0, 0, anrm, bignum, m, n, work, m, info )
181 IF( anrm.NE.zero )
THEN
185 CALL
dgebd2( 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
dbdsqr(
'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
dlascl(
'G', 0, 0, bignum, anrm, mn, 1,
195 $ work( m*n+1 ), mn, info )
197 IF( anrm.LT.smlnum )
THEN
198 CALL
dlascl(
'G', 0, 0, smlnum, anrm, mn, 1,
199 $ work( m*n+1 ), mn, info )
212 CALL
daxpy( mn, -one, s, 1, work( m*n+1 ), 1 )
214 $ (
dlamch(
'Epsilon' )*dble( max( m, n ) ) )