146 SUBROUTINE sqrt15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
147 $ RANK, NORMA, NORMB, ISEED, WORK, LWORK )
154 INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
159 REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
165 REAL ZERO, ONE, TWO, SVMIN
166 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
171 REAL BIGNUM, EPS, SMLNUM, TEMP
177 REAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
178 EXTERNAL sasum, slamch, slange, slarnd, snrm2
185 INTRINSIC abs, max, min
190 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) )
THEN
191 CALL xerbla(
'SQRT15', 16 )
195 smlnum = slamch(
'Safe minimum' )
196 bignum = one / smlnum
197 eps = slamch(
'Epsilon' )
198 smlnum = ( smlnum / eps ) / eps
199 bignum = one / smlnum
203 IF( rksel.EQ.1 )
THEN
205 ELSE IF( rksel.EQ.2 )
THEN
207 DO 10 j = rank + 1, mn
211 CALL xerbla(
'SQRT15', 2 )
221 temp = slarnd( 1, iseed )
222 IF( temp.GT.svmin )
THEN
228 CALL slaord(
'Decreasing', rank, s, 1 )
232 CALL slarnv( 2, iseed, m, work )
233 CALL sscal( m, one / snrm2( m, work, 1 ), work, 1 )
234 CALL slaset(
'Full', m, rank, zero, one, a, lda )
235 CALL slarf(
'Left', m, rank, work, 1, two, a, lda,
242 CALL slarnv( 2, iseed, rank*nrhs, work )
243 CALL sgemm(
'No transpose',
'No transpose', m, nrhs, rank, one,
244 $ a, lda, work, rank, zero, b, ldb )
251 CALL sscal( m, s( j ), a( 1, j ), 1 )
254 $
CALL slaset(
'Full', m, n-rank, zero, zero, a( 1, rank+1 ),
256 CALL slaror(
'Right',
'No initialization', m, n, a, lda, iseed,
268 CALL slaset(
'Full', m, n, zero, zero, a, lda )
269 CALL slaset(
'Full', m, nrhs, zero, zero, b, ldb )
275 IF( scale.NE.1 )
THEN
276 norma = slange(
'Max', m, n, a, lda, dummy )
277 IF( norma.NE.zero )
THEN
278 IF( scale.EQ.2 )
THEN
282 CALL slascl(
'General', 0, 0, norma, bignum, m, n, a,
284 CALL slascl(
'General', 0, 0, norma, bignum, mn, 1, s,
286 CALL slascl(
'General', 0, 0, norma, bignum, m, nrhs, b,
288 ELSE IF( scale.EQ.3 )
THEN
292 CALL slascl(
'General', 0, 0, norma, smlnum, m, n, a,
294 CALL slascl(
'General', 0, 0, norma, smlnum, mn, 1, s,
296 CALL slascl(
'General', 0, 0, norma, smlnum, m, nrhs, b,
299 CALL xerbla(
'SQRT15', 1 )
305 norma = sasum( mn, s, 1 )
306 normb = slange(
'One-norm', m, nrhs, b, ldb, dummy )
subroutine xerbla(srname, info)
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
subroutine slarf(side, m, n, v, incv, tau, c, ldc, work)
SLARF applies an elementary reflector to a general rectangular matrix.
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
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 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 sscal(n, sa, sx, incx)
SSCAL
subroutine slaord(job, n, x, incx)
SLAORD
subroutine slaror(side, init, m, n, a, lda, iseed, x, info)
SLAROR
subroutine sqrt15(scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
SQRT15