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
115 DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2
116 EXTERNAL dasum, dlamch, dlange, dnrm2
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 )
159 smlnum = dlamch(
'S' ) / dlamch(
'P' )
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 )
213 dqrt12 = dasum( mn, work( m*n+1 ), 1 ) /
214 $ ( dlamch(
'Epsilon' )*dble( max( m, n ) ) )
double precision function dqrt12(M, N, A, LDA, S, WORK, LWORK)
DQRT12
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
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 dgebd2(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO)
DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dbdsqr(UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
DBDSQR