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
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
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 )
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...
REAL function slamch(CMACH)
SLAMCH
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
REAL function slarnd(IDIST, ISEED)
SLARND
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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.
REAL function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
REAL function sasum(N, SX, INCX)
SASUM
REAL function snrm2(N, X, INCX)
SNRM2
subroutine sscal(N, SA, SX, INCX)
SSCAL