149 SUBROUTINE cqrt15( 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
164 COMPLEX A( lda, * ), B( ldb, * ), WORK( lwork )
170 REAL ZERO, ONE, TWO, SVMIN
171 parameter ( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
174 parameter ( czero = ( 0.0e+0, 0.0e+0 ),
175 $ cone = ( 1.0e+0, 0.0e+0 ) )
179 REAL BIGNUM, EPS, SMLNUM, TEMP
185 REAL CLANGE, SASUM, SCNRM2, SLAMCH, SLARND
186 EXTERNAL clange, sasum, scnrm2, slamch, slarnd
193 INTRINSIC abs, cmplx, max, min
198 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) )
THEN
199 CALL xerbla(
'CQRT15', 16 )
203 smlnum = slamch(
'Safe minimum' )
204 bignum = one / smlnum
205 CALL slabad( smlnum, bignum )
206 eps = slamch(
'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(
'CQRT15', 2 )
230 temp = slarnd( 1, iseed )
231 IF( temp.GT.svmin )
THEN
237 CALL slaord(
'Decreasing', rank, s, 1 )
241 CALL clarnv( 2, iseed, m, work )
242 CALL csscal( m, one / scnrm2( m, work, 1 ), work, 1 )
243 CALL claset(
'Full', m, rank, czero, cone, a, lda )
244 CALL clarf(
'Left', m, rank, work, 1, cmplx( two ), a, lda,
251 CALL clarnv( 2, iseed, rank*nrhs, work )
252 CALL cgemm(
'No transpose',
'No transpose', m, nrhs, rank,
253 $ cone, a, lda, work, rank, czero, b, ldb )
260 CALL csscal( m, s( j ), a( 1, j ), 1 )
263 $
CALL claset(
'Full', m, n-rank, czero, czero,
264 $ a( 1, rank+1 ), lda )
265 CALL claror(
'Right',
'No initialization', m, n, a, lda, iseed,
277 CALL claset(
'Full', m, n, czero, czero, a, lda )
278 CALL claset(
'Full', m, nrhs, czero, czero, b, ldb )
284 IF( scale.NE.1 )
THEN
285 norma = clange(
'Max', m, n, a, lda, dummy )
286 IF( norma.NE.zero )
THEN
287 IF( scale.EQ.2 )
THEN
291 CALL clascl(
'General', 0, 0, norma, bignum, m, n, a,
293 CALL slascl(
'General', 0, 0, norma, bignum, mn, 1, s,
295 CALL clascl(
'General', 0, 0, norma, bignum, m, nrhs, b,
297 ELSE IF( scale.EQ.3 )
THEN
301 CALL clascl(
'General', 0, 0, norma, smlnum, m, n, a,
303 CALL slascl(
'General', 0, 0, norma, smlnum, mn, 1, s,
305 CALL clascl(
'General', 0, 0, norma, smlnum, m, nrhs, b,
308 CALL xerbla(
'CQRT15', 1 )
314 norma = sasum( mn, s, 1 )
315 normb = clange(
'One-norm', m, nrhs, b, ldb, dummy )
subroutine cqrt15(SCALE, RKSEL, M, N, NRHS, A, LDA, B, LDB, S, RANK, NORMA, NORMB, ISEED, WORK, LWORK)
CQRT15
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine claror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
CLAROR
subroutine clarnv(IDIST, ISEED, N, X)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine clascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
subroutine xerbla(SRNAME, INFO)
XERBLA
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 slabad(SMALL, LARGE)
SLABAD
subroutine slaord(JOB, N, X, INCX)
SLAORD
subroutine clarf(SIDE, M, N, V, INCV, TAU, C, LDC, WORK)
CLARF applies an elementary reflector to a general rectangular matrix.
subroutine cgemm(TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC)
CGEMM
subroutine csscal(N, SA, CX, INCX)
CSSCAL