97 DOUBLE PRECISION FUNCTION zqrt12( M, N, A, LDA, S, WORK, LWORK,
106 INTEGER LDA, LWORK, M, N
109 DOUBLE PRECISION RWORK( * ), S( * )
110 COMPLEX*16 A( lda, * ), WORK( lwork )
116 DOUBLE PRECISION ZERO, ONE
117 parameter( zero = 0.0d0, one = 1.0d0 )
120 INTEGER I, INFO, ISCL, J, MN
121 DOUBLE PRECISION ANRM, BIGNUM, NRMSVL, SMLNUM
124 DOUBLE PRECISION DUMMY( 1 )
127 DOUBLE PRECISION DASUM, DLAMCH, DNRM2, ZLANGE
128 EXTERNAL dasum, dlamch, dnrm2, zlange
135 INTRINSIC dble, dcmplx, max, min
143 IF( lwork.LT.m*n+2*min( m, n )+max( m, n ) )
THEN
144 CALL
xerbla(
'ZQRT12', 7 )
154 nrmsvl = dnrm2( mn, s, 1 )
158 CALL
zlaset(
'Full', m, n, dcmplx( zero ), dcmplx( zero ), work,
161 DO 10 i = 1, min( j, m )
162 work( ( j-1 )*m+i ) = a( i, j )
168 smlnum = dlamch(
'S' ) / dlamch(
'P' )
169 bignum = one / smlnum
170 CALL
dlabad( smlnum, bignum )
174 anrm = zlange(
'M', m, n, work, m, dummy )
176 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
180 CALL
zlascl(
'G', 0, 0, anrm, smlnum, m, n, work, m, info )
182 ELSE IF( anrm.GT.bignum )
THEN
186 CALL
zlascl(
'G', 0, 0, anrm, bignum, m, n, work, m, info )
190 IF( anrm.NE.zero )
THEN
194 CALL
zgebd2( m, n, work, m, rwork( 1 ), rwork( mn+1 ),
195 $ work( m*n+1 ), work( m*n+mn+1 ),
196 $ work( m*n+2*mn+1 ), info )
197 CALL
dbdsqr(
'Upper', mn, 0, 0, 0, rwork( 1 ), rwork( mn+1 ),
198 $ dummy, mn, dummy, 1, dummy, mn, rwork( 2*mn+1 ),
202 IF( anrm.GT.bignum )
THEN
203 CALL
dlascl(
'G', 0, 0, bignum, anrm, mn, 1, rwork( 1 ),
206 IF( anrm.LT.smlnum )
THEN
207 CALL
dlascl(
'G', 0, 0, smlnum, anrm, mn, 1, rwork( 1 ),
221 CALL
daxpy( mn, -one, s, 1, rwork( 1 ), 1 )
222 zqrt12 = dasum( mn, rwork( 1 ), 1 ) /
223 $ ( dlamch(
'Epsilon' )*dble( max( m, n ) ) )
225 $ zqrt12 = zqrt12 / nrmsvl
subroutine xerbla(SRNAME, INFO)
XERBLA
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 dlabad(SMALL, LARGE)
DLABAD
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zgebd2(M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO)
ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dbdsqr(UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
DBDSQR