160 SUBROUTINE cgetsls( TRANS, M, N, NRHS, A, LDA, B, LDB,
161 $ WORK, LWORK, INFO )
169 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
172 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
180 parameter( zero = 0.0e0, one = 1.0e0 )
182 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
186 INTEGER I, IASCL, IBSCL, J, MAXMN, BROW,
187 $ scllen, tszo, tszm, lwo, lwm, lw1, lw2,
188 $ wsizeo, wsizem, info2
189 REAL ANRM, BIGNUM, BNRM, SMLNUM, DUM( 1 )
190 COMPLEX TQ( 5 ), WORKQ( 1 )
195 EXTERNAL lsame,
slabad, slamch, clange
202 INTRINSIC real, max, min, int
210 tran = lsame( trans,
'C' )
212 lquery = ( lwork.EQ.-1 .OR. lwork.EQ.-2 )
213 IF( .NOT.( lsame( trans,
'N' ) .OR.
214 $ lsame( trans,
'C' ) ) )
THEN
216 ELSE IF( m.LT.0 )
THEN
218 ELSE IF( n.LT.0 )
THEN
220 ELSE IF( nrhs.LT.0 )
THEN
222 ELSE IF( lda.LT.max( 1, m ) )
THEN
224 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
233 CALL cgeqr( m, n, a, lda, tq, -1, workq, -1, info2 )
234 tszo = int( tq( 1 ) )
235 lwo = int( workq( 1 ) )
236 CALL cgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
237 $ tszo, b, ldb, workq, -1, info2 )
238 lwo = max( lwo, int( workq( 1 ) ) )
239 CALL cgeqr( m, n, a, lda, tq, -2, workq, -2, info2 )
240 tszm = int( tq( 1 ) )
241 lwm = int( workq( 1 ) )
242 CALL cgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
243 $ tszm, b, ldb, workq, -1, info2 )
244 lwm = max( lwm, int( workq( 1 ) ) )
248 CALL cgelq( m, n, a, lda, tq, -1, workq, -1, info2 )
249 tszo = int( tq( 1 ) )
250 lwo = int( workq( 1 ) )
251 CALL cgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
252 $ tszo, b, ldb, workq, -1, info2 )
253 lwo = max( lwo, int( workq( 1 ) ) )
254 CALL cgelq( m, n, a, lda, tq, -2, workq, -2, info2 )
255 tszm = int( tq( 1 ) )
256 lwm = int( workq( 1 ) )
257 CALL cgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
258 $ tszm, b, ldb, workq, -1, info2 )
259 lwm = max( lwm, int( workq( 1 ) ) )
264 IF( ( lwork.LT.wsizem ).AND.( .NOT.lquery ) )
THEN
268 work( 1 ) = real( wsizeo )
273 CALL xerbla(
'CGETSLS', -info )
277 IF( lwork.EQ.-2 ) work( 1 ) = real( wsizem )
280 IF( lwork.LT.wsizeo )
THEN
290 IF( min( m, n, nrhs ).EQ.0 )
THEN
291 CALL claset(
'FULL', max( m, n ), nrhs, czero, czero,
298 smlnum = slamch(
'S' ) / slamch(
'P' )
299 bignum = one / smlnum
300 CALL slabad( smlnum, bignum )
304 anrm = clange(
'M', m, n, a, lda, dum )
306 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
310 CALL clascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
312 ELSE IF( anrm.GT.bignum )
THEN
316 CALL clascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
318 ELSE IF( anrm.EQ.zero )
THEN
322 CALL claset(
'F', maxmn, nrhs, czero, czero, b, ldb )
330 bnrm = clange(
'M', brow, nrhs, b, ldb, dum )
332 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
336 CALL clascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
339 ELSE IF( bnrm.GT.bignum )
THEN
343 CALL clascl(
'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
352 CALL cgeqr( m, n, a, lda, work( lw2+1 ), lw1,
353 $ work( 1 ), lw2, info )
354 IF ( .NOT.tran )
THEN
360 CALL cgemqr(
'L' ,
'C', m, nrhs, n, a, lda,
361 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
366 CALL ctrtrs(
'U',
'N',
'N', n, nrhs,
367 $ a, lda, b, ldb, info )
378 CALL ctrtrs(
'U',
'C',
'N', n, nrhs,
379 $ a, lda, b, ldb, info )
395 CALL cgemqr(
'L',
'N', m, nrhs, n, a, lda,
396 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
407 CALL cgelq( m, n, a, lda, work( lw2+1 ), lw1,
408 $ work( 1 ), lw2, info )
418 CALL ctrtrs(
'L',
'N',
'N', m, nrhs,
419 $ a, lda, b, ldb, info )
435 CALL cgemlq(
'L',
'C', n, nrhs, m, a, lda,
436 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
449 CALL cgemlq(
'L',
'N', n, nrhs, m, a, lda,
450 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
457 CALL ctrtrs(
'L',
'C',
'N', m, nrhs,
458 $ a, lda, b, ldb, info )
472 IF( iascl.EQ.1 )
THEN
473 CALL clascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
475 ELSE IF( iascl.EQ.2 )
THEN
476 CALL clascl(
'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
479 IF( ibscl.EQ.1 )
THEN
480 CALL clascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
482 ELSE IF( ibscl.EQ.2 )
THEN
483 CALL clascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
488 work( 1 ) = real( tszo + lwo )
subroutine cgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
CGELQ
subroutine cgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
CGEMLQ
subroutine cgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
CGEMQR
subroutine cgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
CGEQR
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
CGETSLS
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 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 ctrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
CTRTRS