160 SUBROUTINE cgetsls( TRANS, M, N, NRHS, A, LDA, B, LDB,
161 $ work, lwork, info )
170 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
173 COMPLEX A( lda, * ), B( ldb, * ), WORK( * )
181 parameter ( zero = 0.0e0, one = 1.0e0 )
183 parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
187 INTEGER I, IASCL, IBSCL, J, MINMN, MAXMN, BROW,
188 $ scllen, mnk, tszo, tszm, lwo, lwm, lw1, lw2,
189 $ wsizeo, wsizem, info2
190 REAL ANRM, BIGNUM, BNRM, SMLNUM
191 COMPLEX TQ( 5 ), WORKQ
197 EXTERNAL lsame, ilaenv,
slabad, slamch, clange
204 INTRINSIC REAL, MAX, MIN, INT
213 mnk = max( minmn, nrhs )
214 tran = lsame( trans,
'C' )
216 lquery = ( lwork.EQ.-1 .OR. lwork.EQ.-2 )
217 IF( .NOT.( lsame( trans,
'N' ) .OR.
218 $ lsame( trans,
'C' ) ) )
THEN
220 ELSE IF( m.LT.0 )
THEN
222 ELSE IF( n.LT.0 )
THEN
224 ELSE IF( nrhs.LT.0 )
THEN
226 ELSE IF( lda.LT.max( 1, m ) )
THEN
228 ELSE IF( ldb.LT.max( 1, m, n ) )
THEN
237 CALL cgeqr( m, n, a, lda, tq, -1, workq, -1, info2 )
238 tszo = int( tq( 1 ) )
240 CALL cgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
241 $ tszo, b, ldb, workq, -1, info2 )
242 lwo = max( lwo, int( workq ) )
243 CALL cgeqr( m, n, a, lda, tq, -2, workq, -2, info2 )
244 tszm = int( tq( 1 ) )
246 CALL cgemqr(
'L', trans, m, nrhs, n, a, lda, tq,
247 $ tszm, b, ldb, workq, -1, info2 )
248 lwm = max( lwm, int( workq ) )
252 CALL cgelq( m, n, a, lda, tq, -1, workq, -1, info2 )
253 tszo = int( tq( 1 ) )
255 CALL cgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
256 $ tszo, b, ldb, workq, -1, info2 )
257 lwo = max( lwo, int( workq ) )
258 CALL cgelq( m, n, a, lda, tq, -2, workq, -2, info2 )
259 tszm = int( tq( 1 ) )
261 CALL cgemlq(
'L', trans, n, nrhs, m, a, lda, tq,
262 $ tszo, b, ldb, workq, -1, info2 )
263 lwm = max( lwm, int( workq ) )
268 IF( ( lwork.LT.wsizem ).AND.( .NOT.lquery ) )
THEN
275 CALL xerbla(
'CGETSLS', -info )
276 work( 1 ) =
REAL( wsizeo )
280 IF( lwork.EQ.-1 ) work( 1 ) =
REAL( wsizeo )
281 IF( lwork.EQ.-2 ) work( 1 ) =
REAL( wsizem )
284 IF( lwork.LT.wsizeo )
THEN
294 IF( min( m, n, nrhs ).EQ.0 )
THEN
295 CALL claset(
'FULL', max( m, n ), nrhs, czero, czero,
302 smlnum = slamch(
'S' ) / slamch(
'P' )
303 bignum = one / smlnum
304 CALL slabad( smlnum, bignum )
308 anrm = clange(
'M', m, n, a, lda, work )
310 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
314 CALL clascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
316 ELSE IF( anrm.GT.bignum )
THEN
320 CALL clascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
322 ELSE IF( anrm.EQ.zero )
THEN
326 CALL claset(
'F', maxmn, nrhs, czero, czero, b, ldb )
334 bnrm = clange(
'M', brow, nrhs, b, ldb, work )
336 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
340 CALL clascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
343 ELSE IF( bnrm.GT.bignum )
THEN
347 CALL clascl(
'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
356 CALL cgeqr( m, n, a, lda, work( lw2+1 ), lw1,
357 $ work( 1 ), lw2, info )
358 IF ( .NOT.tran )
THEN
364 CALL cgemqr(
'L' ,
'C', m, nrhs, n, a, lda,
365 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
370 CALL ctrtrs(
'U',
'N',
'N', n, nrhs,
371 $ a, lda, b, ldb, info )
382 CALL ctrtrs(
'U',
'C',
'N', n, nrhs,
383 $ a, lda, b, ldb, info )
399 CALL cgemqr(
'L',
'N', m, nrhs, n, a, lda,
400 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
411 CALL cgelq( m, n, a, lda, work( lw2+1 ), lw1,
412 $ work( 1 ), lw2, info )
422 CALL ctrtrs(
'L',
'N',
'N', m, nrhs,
423 $ a, lda, b, ldb, info )
439 CALL cgemlq(
'L',
'C', n, nrhs, m, a, lda,
440 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
453 CALL cgemlq(
'L',
'N', n, nrhs, m, a, lda,
454 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
461 CALL ctrtrs(
'L',
'C',
'N', m, nrhs,
462 $ a, lda, b, ldb, info )
476 IF( iascl.EQ.1 )
THEN
477 CALL clascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
479 ELSE IF( iascl.EQ.2 )
THEN
480 CALL clascl(
'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
483 IF( ibscl.EQ.1 )
THEN
484 CALL clascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
486 ELSE IF( ibscl.EQ.2 )
THEN
487 CALL clascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
492 work( 1 ) =
REAL( tszo + lwo )
subroutine cgetsls(TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO)
subroutine cgemqr(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
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 cgelq(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
subroutine ctrtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
CTRTRS
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 cgemlq(SIDE, TRANS, M, N, K, A, LDA, T, TSIZE, C, LDC, WORK, LWORK, INFO)
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cgeqr(M, N, A, LDA, T, TSIZE, WORK, LWORK, INFO)
subroutine slabad(SMALL, LARGE)
SLABAD