149 SUBROUTINE cqrt15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
150 $ rank, norma, normb, iseed, work, lwork )
158 INTEGER lda, ldb, lwork, m, n, nrhs, rank, rksel, scale
164 COMPLEX a( lda, * ),
b( ldb, * ), work( lwork )
170 REAL zero, one, two, svmin
171 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
174 parameter( czero = ( 0.0e+0, 0.0e+0 ),
175 $ cone = ( 1.0e+0, 0.0e+0 ) )
179 REAL bignum, eps, smlnum, temp
193 INTRINSIC abs, cmplx, max, min
198 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) )
THEN
199 CALL
xerbla(
'CQRT15', 16 )
203 smlnum =
slamch(
'Safe minimum' )
204 bignum = one / smlnum
205 CALL
slabad( smlnum, bignum )
207 smlnum = ( smlnum / eps ) / eps
208 bignum = one / smlnum
212 IF( rksel.EQ.1 )
THEN
214 ELSE IF( rksel.EQ.2 )
THEN
216 DO 10
j = rank + 1, mn
220 CALL
xerbla(
'CQRT15', 2 )
231 IF( temp.GT.svmin )
THEN
237 CALL
slaord(
'Decreasing', rank, s, 1 )
241 CALL
clarnv( 2, iseed, m, work )
243 CALL
claset(
'Full', m, rank, czero, cone, a, lda )
244 CALL
clarf(
'Left', m, rank, work, 1, cmplx( two ), a, lda,
251 CALL
clarnv( 2, iseed, rank*nrhs, work )
252 CALL
cgemm(
'No transpose',
'No transpose', m, nrhs, rank,
253 $ cone, a, lda, work, rank, czero,
b, ldb )
260 CALL
csscal( m, s(
j ), a( 1,
j ), 1 )
263 $ CALL
claset(
'Full', m, n-rank, czero, czero,
264 $ a( 1, rank+1 ), lda )
265 CALL
claror(
'Right',
'No initialization', m, n, a, lda, iseed,
277 CALL
claset(
'Full', m, n, czero, czero, a, lda )
278 CALL
claset(
'Full', m, nrhs, czero, czero,
b, ldb )
284 IF( scale.NE.1 )
THEN
285 norma =
clange(
'Max', m, n, a, lda, dummy )
286 IF( norma.NE.zero )
THEN
287 IF( scale.EQ.2 )
THEN
291 CALL
clascl(
'General', 0, 0, norma, bignum, m, n, a,
293 CALL
slascl(
'General', 0, 0, norma, bignum, mn, 1, s,
295 CALL
clascl(
'General', 0, 0, norma, bignum, m, nrhs,
b,
297 ELSE IF( scale.EQ.3 )
THEN
301 CALL
clascl(
'General', 0, 0, norma, smlnum, m, n, a,
303 CALL
slascl(
'General', 0, 0, norma, smlnum, mn, 1, s,
305 CALL
clascl(
'General', 0, 0, norma, smlnum, m, nrhs,
b,
308 CALL
xerbla(
'CQRT15', 1 )
314 norma =
sasum( mn, s, 1 )
315 normb =
clange(
'One-norm', m, nrhs,
b, ldb, dummy )
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...
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
real function sasum(N, SX, INCX)
SASUM
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine claror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
CLAROR
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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.
real function scnrm2(N, X, INCX)
SCNRM2
real function slarnd(IDIST, ISEED)
SLARND
real function slamch(CMACH)
SLAMCH
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine slaord(JOB, N, X, INCX)
SLAORD
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine cqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
CQRT15
subroutine clarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
CLARF applies an elementary reflector to a general rectangular matrix.