148 SUBROUTINE sqrt15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
149 $ rank, norma, normb, iseed, work, lwork )
157 INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
162 REAL A( lda, * ), B( ldb, * ), S( * ), WORK( lwork )
168 REAL ZERO, ONE, TWO, SVMIN
169 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
174 REAL BIGNUM, EPS, SMLNUM, TEMP
180 REAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
181 EXTERNAL sasum, slamch, slange, slarnd, snrm2
188 INTRINSIC abs, max, min
193 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) )
THEN
194 CALL
xerbla(
'SQRT15', 16 )
198 smlnum = slamch(
'Safe minimum' )
199 bignum = one / smlnum
200 eps = slamch(
'Epsilon' )
201 smlnum = ( smlnum / eps ) / eps
202 bignum = one / smlnum
206 IF( rksel.EQ.1 )
THEN
208 ELSE IF( rksel.EQ.2 )
THEN
210 DO 10 j = rank + 1, mn
214 CALL
xerbla(
'SQRT15', 2 )
224 temp = slarnd( 1, iseed )
225 IF( temp.GT.svmin )
THEN
231 CALL
slaord(
'Decreasing', rank, s, 1 )
235 CALL
slarnv( 2, iseed, m, work )
236 CALL
sscal( m, one / snrm2( m, work, 1 ), work, 1 )
237 CALL
slaset(
'Full', m, rank, zero, one, a, lda )
238 CALL
slarf(
'Left', m, rank, work, 1, two, a, lda,
245 CALL
slarnv( 2, iseed, rank*nrhs, work )
246 CALL
sgemm(
'No transpose',
'No transpose', m, nrhs, rank, one,
247 $ a, lda, work, rank, zero, b, ldb )
254 CALL
sscal( m, s( j ), a( 1, j ), 1 )
257 $ CALL
slaset(
'Full', m, n-rank, zero, zero, a( 1, rank+1 ),
259 CALL
slaror(
'Right',
'No initialization', m, n, a, lda, iseed,
271 CALL
slaset(
'Full', m, n, zero, zero, a, lda )
272 CALL
slaset(
'Full', m, nrhs, zero, zero, b, ldb )
278 IF( scale.NE.1 )
THEN
279 norma = slange(
'Max', m, n, a, lda, dummy )
280 IF( norma.NE.zero )
THEN
281 IF( scale.EQ.2 )
THEN
285 CALL
slascl(
'General', 0, 0, norma, bignum, m, n, a,
287 CALL
slascl(
'General', 0, 0, norma, bignum, mn, 1, s,
289 CALL
slascl(
'General', 0, 0, norma, bignum, m, nrhs, b,
291 ELSE IF( scale.EQ.3 )
THEN
295 CALL
slascl(
'General', 0, 0, norma, smlnum, m, n, a,
297 CALL
slascl(
'General', 0, 0, norma, smlnum, mn, 1, s,
299 CALL
slascl(
'General', 0, 0, norma, smlnum, m, nrhs, b,
302 CALL
xerbla(
'SQRT15', 1 )
308 norma = sasum( mn, s, 1 )
309 normb = slange(
'One-norm', m, nrhs, b, ldb, dummy )
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine slarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
SLARF applies an elementary reflector to a general rectangular matrix.
subroutine slaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
SLAROR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
SQRT15
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 sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine slaord(JOB, N, X, INCX)
SLAORD
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine sscal(N, SA, SX, INCX)
SSCAL