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 ) ) )
double precision function dqrt12(M, N, A, LDA, S, WORK, LWORK)
DQRT12
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
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
double precision function dlamch(CMACH)
DLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
double precision function dnrm2(N, X, INCX)
DNRM2
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...
double precision function dasum(N, DX, INCX)
DASUM
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 dbdsqr(UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO)
DBDSQR