97 REAL FUNCTION cqrt12( M, N, A, LDA, S, WORK, LWORK,
106 INTEGER LDA, LWORK, M, N
109 REAL RWORK( * ), S( * )
110 COMPLEX A( lda, * ), WORK( lwork )
117 parameter( zero = 0.0e0, one = 1.0e0 )
120 INTEGER I, INFO, ISCL, J, MN
121 REAL ANRM, BIGNUM, NRMSVL, SMLNUM
127 REAL CLANGE, SASUM, SLAMCH, SNRM2
128 EXTERNAL clange, sasum, slamch, snrm2
135 INTRINSIC cmplx, max, min, real
143 IF( lwork.LT.m*n+2*min( m, n )+max( m, n ) )
THEN
144 CALL
xerbla(
'CQRT12', 7 )
154 nrmsvl = snrm2( mn, s, 1 )
158 CALL
claset(
'Full', m, n, cmplx( zero ), cmplx( zero ), work, m )
160 DO 10 i = 1, min( j, m )
161 work( ( j-1 )*m+i ) = a( i, j )
167 smlnum = slamch(
'S' ) / slamch(
'P' )
168 bignum = one / smlnum
169 CALL
slabad( smlnum, bignum )
173 anrm = clange(
'M', m, n, work, m, dummy )
175 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
179 CALL
clascl(
'G', 0, 0, anrm, smlnum, m, n, work, m, info )
181 ELSE IF( anrm.GT.bignum )
THEN
185 CALL
clascl(
'G', 0, 0, anrm, bignum, m, n, work, m, info )
189 IF( anrm.NE.zero )
THEN
193 CALL
cgebd2( m, n, work, m, rwork( 1 ), rwork( mn+1 ),
194 $ work( m*n+1 ), work( m*n+mn+1 ),
195 $ work( m*n+2*mn+1 ), info )
196 CALL
sbdsqr(
'Upper', mn, 0, 0, 0, rwork( 1 ), rwork( mn+1 ),
197 $ dummy, mn, dummy, 1, dummy, mn, rwork( 2*mn+1 ),
201 IF( anrm.GT.bignum )
THEN
202 CALL
slascl(
'G', 0, 0, bignum, anrm, mn, 1, rwork( 1 ),
205 IF( anrm.LT.smlnum )
THEN
206 CALL
slascl(
'G', 0, 0, smlnum, anrm, mn, 1, rwork( 1 ),
220 CALL
saxpy( mn, -one, s, 1, rwork( 1 ), 1 )
221 cqrt12 = sasum( mn, rwork( 1 ), 1 ) /
222 $ ( slamch(
'Epsilon' )*
REAL( MAX( M, N ) ) )
224 $ cqrt12 = cqrt12 / nrmsvl
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cgebd2(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO)
CGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine sbdsqr(UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
SBDSQR
subroutine xerbla(SRNAME, INFO)
XERBLA
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.
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine slabad(SMALL, LARGE)
SLABAD