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 sqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
SQRT15
subroutine sgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
SGEMM
subroutine slaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
SLAROR
subroutine xerbla(SRNAME, INFO)
XERBLA
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 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 slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine slaord(JOB, N, X, INCX)
SLAORD
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine slarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
SLARF applies an elementary reflector to a general rectangular matrix.