180 SUBROUTINE sgglse( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
189 INTEGER info, lda, ldb, lwork, m, n, p
192 REAL a( lda, * ),
b( ldb, * ), c( * ), d( * ),
200 parameter( one = 1.0e+0 )
204 INTEGER lopt, lwkmin, lwkopt, mn, nb, nb1, nb2, nb3,
216 INTRINSIC int, max, min
224 lquery = ( lwork.EQ.-1 )
227 ELSE IF( n.LT.0 )
THEN
229 ELSE IF( p.LT.0 .OR. p.GT.n .OR. p.LT.n-m )
THEN
231 ELSE IF( lda.LT.max( 1, m ) )
THEN
233 ELSE IF( ldb.LT.max( 1, p ) )
THEN
244 nb1 =
ilaenv( 1,
'SGEQRF',
' ', m, n, -1, -1 )
245 nb2 =
ilaenv( 1,
'SGERQF',
' ', m, n, -1, -1 )
246 nb3 =
ilaenv( 1,
'SORMQR',
' ', m, n, p, -1 )
247 nb4 =
ilaenv( 1,
'SORMRQ',
' ', m, n, p, -1 )
248 nb = max( nb1, nb2, nb3, nb4 )
250 lwkopt = p + mn + max( m, n )*nb
254 IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN
260 CALL
xerbla(
'SGGLSE', -info )
262 ELSE IF( lquery )
THEN
280 CALL
sggrqf( p, m, n,
b, ldb, work, a, lda, work( p+1 ),
281 $ work( p+mn+1 ), lwork-p-mn, info )
282 lopt = work( p+mn+1 )
287 CALL
sormqr(
'Left',
'Transpose', m, 1, mn, a, lda, work( p+1 ),
288 $ c, max( 1, m ), work( p+mn+1 ), lwork-p-mn, info )
289 lopt = max( lopt, int( work( p+mn+1 ) ) )
294 CALL
strtrs(
'Upper',
'No transpose',
'Non-unit', p, 1,
295 $
b( 1, n-p+1 ), ldb, d, p, info )
304 CALL
scopy( p, d, 1, x( n-p+1 ), 1 )
308 CALL
sgemv(
'No transpose', n-p, p, -one, a( 1, n-p+1 ), lda,
315 CALL
strtrs(
'Upper',
'No transpose',
'Non-unit', n-p, 1,
316 $ a, lda, c, n-p, info )
325 CALL
scopy( n-p, c, 1, x, 1 )
333 $ CALL
sgemv(
'No transpose', nr, n-m, -one, a( n-p+1, m+1 ),
334 $ lda, d( nr+1 ), 1, one, c( n-p+1 ), 1 )
339 CALL
strmv(
'Upper',
'No transpose',
'Non unit', nr,
340 $ a( n-p+1, n-p+1 ), lda, d, 1 )
341 CALL
saxpy( nr, -one, d, 1, c( n-p+1 ), 1 )
346 CALL
sormrq(
'Left',
'Transpose', n, 1, p,
b, ldb, work( 1 ), x,
347 $ n, work( p+mn+1 ), lwork-p-mn, info )
348 work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ) ) )
subroutine sormqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMQR
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine strmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
STRMV
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
subroutine sormrq(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
SORMRQ
subroutine sgglse(M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO)
SGGLSE solves overdetermined or underdetermined systems for OTHER matrices
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
subroutine strtrs(UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO)
STRTRS
subroutine sggrqf(M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO)
SGGRQF
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)