148 SUBROUTINE dqrt15( 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
158 DOUBLE PRECISION NORMA, NORMB
162 DOUBLE PRECISION A( lda, * ), B( ldb, * ), S( * ), WORK( lwork )
168 DOUBLE PRECISION ZERO, ONE, TWO, SVMIN
169 parameter ( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
174 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
177 DOUBLE PRECISION DUMMY( 1 )
180 DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLARND, DNRM2
181 EXTERNAL dasum, dlamch, dlange, dlarnd, dnrm2
188 INTRINSIC abs, max, min
193 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) )
THEN
194 CALL xerbla(
'DQRT15', 16 )
198 smlnum = dlamch(
'Safe minimum' )
199 bignum = one / smlnum
200 eps = dlamch(
'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(
'DQRT15', 2 )
224 temp = dlarnd( 1, iseed )
225 IF( temp.GT.svmin )
THEN
231 CALL dlaord(
'Decreasing', rank, s, 1 )
235 CALL dlarnv( 2, iseed, m, work )
236 CALL dscal( m, one / dnrm2( m, work, 1 ), work, 1 )
237 CALL dlaset(
'Full', m, rank, zero, one, a, lda )
238 CALL dlarf(
'Left', m, rank, work, 1, two, a, lda,
245 CALL dlarnv( 2, iseed, rank*nrhs, work )
246 CALL dgemm(
'No transpose',
'No transpose', m, nrhs, rank, one,
247 $ a, lda, work, rank, zero, b, ldb )
254 CALL dscal( m, s( j ), a( 1, j ), 1 )
257 $
CALL dlaset(
'Full', m, n-rank, zero, zero, a( 1, rank+1 ),
259 CALL dlaror(
'Right',
'No initialization', m, n, a, lda, iseed,
271 CALL dlaset(
'Full', m, n, zero, zero, a, lda )
272 CALL dlaset(
'Full', m, nrhs, zero, zero, b, ldb )
278 IF( scale.NE.1 )
THEN
279 norma = dlange(
'Max', m, n, a, lda, dummy )
280 IF( norma.NE.zero )
THEN
281 IF( scale.EQ.2 )
THEN
285 CALL dlascl(
'General', 0, 0, norma, bignum, m, n, a,
287 CALL dlascl(
'General', 0, 0, norma, bignum, mn, 1, s,
289 CALL dlascl(
'General', 0, 0, norma, bignum, m, nrhs, b,
291 ELSE IF( scale.EQ.3 )
THEN
295 CALL dlascl(
'General', 0, 0, norma, smlnum, m, n, a,
297 CALL dlascl(
'General', 0, 0, norma, smlnum, mn, 1, s,
299 CALL dlascl(
'General', 0, 0, norma, smlnum, m, nrhs, b,
302 CALL xerbla(
'DQRT15', 1 )
308 norma = dasum( mn, s, 1 )
309 normb = dlange(
'One-norm', m, nrhs, b, ldb, dummy )
subroutine dlarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
DLARF applies an elementary reflector to a general rectangular matrix.
subroutine dlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine dlaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
DLAROR
subroutine dlarnv(IDIST, ISEED, N, X)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine dlaord(JOB, N, X, INCX)
DLAORD
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
DGEMM
subroutine dqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
DQRT15
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL