149 SUBROUTINE zqrt15( SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S,
150 $ rank, norma, normb, iseed, work, lwork )
158 INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
159 DOUBLE PRECISION NORMA, NORMB
163 DOUBLE PRECISION S( * )
164 COMPLEX*16 A( lda, * ), B( ldb, * ), WORK( lwork )
170 DOUBLE PRECISION ZERO, ONE, TWO, SVMIN
171 parameter ( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
173 COMPLEX*16 CZERO, CONE
174 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
175 $ cone = ( 1.0d+0, 0.0d+0 ) )
179 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
182 DOUBLE PRECISION DUMMY( 1 )
185 DOUBLE PRECISION DASUM, DLAMCH, DLARND, DZNRM2, ZLANGE
186 EXTERNAL dasum, dlamch, dlarnd, dznrm2, zlange
193 INTRINSIC abs, dcmplx, max, min
198 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) )
THEN
199 CALL xerbla(
'ZQRT15', 16 )
203 smlnum = dlamch(
'Safe minimum' )
204 bignum = one / smlnum
205 CALL dlabad( smlnum, bignum )
206 eps = dlamch(
'Epsilon' )
207 smlnum = ( smlnum / eps ) / eps
208 bignum = one / smlnum
212 IF( rksel.EQ.1 )
THEN
214 ELSE IF( rksel.EQ.2 )
THEN
216 DO 10 j = rank + 1, mn
220 CALL xerbla(
'ZQRT15', 2 )
230 temp = dlarnd( 1, iseed )
231 IF( temp.GT.svmin )
THEN
237 CALL dlaord(
'Decreasing', rank, s, 1 )
241 CALL zlarnv( 2, iseed, m, work )
242 CALL zdscal( m, one / dznrm2( m, work, 1 ), work, 1 )
243 CALL zlaset(
'Full', m, rank, czero, cone, a, lda )
244 CALL zlarf(
'Left', m, rank, work, 1, dcmplx( two ), a, lda,
251 CALL zlarnv( 2, iseed, rank*nrhs, work )
252 CALL zgemm(
'No transpose',
'No transpose', m, nrhs, rank,
253 $ cone, a, lda, work, rank, czero, b, ldb )
260 CALL zdscal( m, s( j ), a( 1, j ), 1 )
263 $
CALL zlaset(
'Full', m, n-rank, czero, czero,
264 $ a( 1, rank+1 ), lda )
265 CALL zlaror(
'Right',
'No initialization', m, n, a, lda, iseed,
277 CALL zlaset(
'Full', m, n, czero, czero, a, lda )
278 CALL zlaset(
'Full', m, nrhs, czero, czero, b, ldb )
284 IF( scale.NE.1 )
THEN
285 norma = zlange(
'Max', m, n, a, lda, dummy )
286 IF( norma.NE.zero )
THEN
287 IF( scale.EQ.2 )
THEN
291 CALL zlascl(
'General', 0, 0, norma, bignum, m, n, a,
293 CALL dlascl(
'General', 0, 0, norma, bignum, mn, 1, s,
295 CALL zlascl(
'General', 0, 0, norma, bignum, m, nrhs, b,
297 ELSE IF( scale.EQ.3 )
THEN
301 CALL zlascl(
'General', 0, 0, norma, smlnum, m, n, a,
303 CALL dlascl(
'General', 0, 0, norma, smlnum, mn, 1, s,
305 CALL zlascl(
'General', 0, 0, norma, smlnum, m, nrhs, b,
308 CALL xerbla(
'ZQRT15', 1 )
314 norma = dasum( mn, s, 1 )
315 normb = zlange(
'One-norm', m, nrhs, b, ldb, dummy )
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 zlaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
ZLAROR
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine zlarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
ZLARF applies an elementary reflector to a general rectangular matrix.
subroutine zgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
ZGEMM
subroutine dlaord(JOB, N, X, INCX)
DLAORD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zlarnv(IDIST, ISEED, N, X)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine zqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
ZQRT15