162
163
164
165
166
167
168 CHARACTER TRANS
169 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
170
171
172 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
173
174
175
176
177
178
179 REAL ZERO, ONE
180 parameter( zero = 0.0e0, one = 1.0e0 )
181 COMPLEX CZERO
182 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
183
184
185 LOGICAL LQUERY, TRAN
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 )
191
192
193 LOGICAL LSAME
194 REAL SLAMCH, CLANGE
196
197
200
201
202 INTRINSIC real, max, min, int
203
204
205
206
207
208 info = 0
209 maxmn = max( m, n )
210 tran =
lsame( trans,
'C' )
211
212 lquery = ( lwork.EQ.-1 .OR. lwork.EQ.-2 )
213 IF( .NOT.(
lsame( trans,
'N' ) .OR.
214 $
lsame( trans,
'C' ) ) )
THEN
215 info = -1
216 ELSE IF( m.LT.0 ) THEN
217 info = -2
218 ELSE IF( n.LT.0 ) THEN
219 info = -3
220 ELSE IF( nrhs.LT.0 ) THEN
221 info = -4
222 ELSE IF( lda.LT.max( 1, m ) ) THEN
223 info = -6
224 ELSE IF( ldb.LT.max( 1, m, n ) ) THEN
225 info = -8
226 END IF
227
228 IF( info.EQ.0 ) THEN
229
230
231
232 IF( m.GE.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 ) ) )
245 wsizeo = tszo + lwo
246 wsizem = tszm + lwm
247 ELSE
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 ) ) )
260 wsizeo = tszo + lwo
261 wsizem = tszm + lwm
262 END IF
263
264 IF( ( lwork.LT.wsizem ).AND.( .NOT.lquery ) ) THEN
265 info = -10
266 END IF
267
268 work( 1 ) = real( wsizeo )
269
270 END IF
271
272 IF( info.NE.0 ) THEN
273 CALL xerbla(
'CGETSLS', -info )
274 RETURN
275 END IF
276 IF( lquery ) THEN
277 IF( lwork.EQ.-2 ) work( 1 ) = real( wsizem )
278 RETURN
279 END IF
280 IF( lwork.LT.wsizeo ) THEN
281 lw1 = tszm
282 lw2 = lwm
283 ELSE
284 lw1 = tszo
285 lw2 = lwo
286 END IF
287
288
289
290 IF( min( m, n, nrhs ).EQ.0 ) THEN
291 CALL claset(
'FULL', max( m, n ), nrhs, czero, czero,
292 $ b, ldb )
293 RETURN
294 END IF
295
296
297
299 bignum = one / smlnum
300 CALL slabad( smlnum, bignum )
301
302
303
304 anrm =
clange(
'M', m, n, a, lda, dum )
305 iascl = 0
306 IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
307
308
309
310 CALL clascl(
'G', 0, 0, anrm, smlnum, m, n, a, lda, info )
311 iascl = 1
312 ELSE IF( anrm.GT.bignum ) THEN
313
314
315
316 CALL clascl(
'G', 0, 0, anrm, bignum, m, n, a, lda, info )
317 iascl = 2
318 ELSE IF( anrm.EQ.zero ) THEN
319
320
321
322 CALL claset(
'F', maxmn, nrhs, czero, czero, b, ldb )
323 GO TO 50
324 END IF
325
326 brow = m
327 IF ( tran ) THEN
328 brow = n
329 END IF
330 bnrm =
clange(
'M', brow, nrhs, b, ldb, dum )
331 ibscl = 0
332 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum ) THEN
333
334
335
336 CALL clascl(
'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb,
337 $ info )
338 ibscl = 1
339 ELSE IF( bnrm.GT.bignum ) THEN
340
341
342
343 CALL clascl(
'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,
344 $ info )
345 ibscl = 2
346 END IF
347
348 IF ( m.GE.n ) THEN
349
350
351
352 CALL cgeqr( m, n, a, lda, work( lw2+1 ), lw1,
353 $ work( 1 ), lw2, info )
354 IF ( .NOT.tran ) THEN
355
356
357
358
359
360 CALL cgemqr(
'L' ,
'C', m, nrhs, n, a, lda,
361 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
362 $ info )
363
364
365
366 CALL ctrtrs(
'U',
'N',
'N', n, nrhs,
367 $ a, lda, b, ldb, info )
368 IF( info.GT.0 ) THEN
369 RETURN
370 END IF
371 scllen = n
372 ELSE
373
374
375
376
377
378 CALL ctrtrs(
'U',
'C',
'N', n, nrhs,
379 $ a, lda, b, ldb, info )
380
381 IF( info.GT.0 ) THEN
382 RETURN
383 END IF
384
385
386
387 DO 20 j = 1, nrhs
388 DO 10 i = n + 1, m
389 b( i, j ) = czero
390 10 CONTINUE
391 20 CONTINUE
392
393
394
395 CALL cgemqr(
'L',
'N', m, nrhs, n, a, lda,
396 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
397 $ info )
398
399 scllen = m
400
401 END IF
402
403 ELSE
404
405
406
407 CALL cgelq( m, n, a, lda, work( lw2+1 ), lw1,
408 $ work( 1 ), lw2, info )
409
410
411
412 IF( .NOT.tran ) THEN
413
414
415
416
417
418 CALL ctrtrs(
'L',
'N',
'N', m, nrhs,
419 $ a, lda, b, ldb, info )
420
421 IF( info.GT.0 ) THEN
422 RETURN
423 END IF
424
425
426
427 DO 40 j = 1, nrhs
428 DO 30 i = m + 1, n
429 b( i, j ) = czero
430 30 CONTINUE
431 40 CONTINUE
432
433
434
435 CALL cgemlq(
'L',
'C', n, nrhs, m, a, lda,
436 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
437 $ info )
438
439
440
441 scllen = n
442
443 ELSE
444
445
446
447
448
449 CALL cgemlq(
'L',
'N', n, nrhs, m, a, lda,
450 $ work( lw2+1 ), lw1, b, ldb, work( 1 ), lw2,
451 $ info )
452
453
454
455
456
457 CALL ctrtrs(
'L',
'C',
'N', m, nrhs,
458 $ a, lda, b, ldb, info )
459
460 IF( info.GT.0 ) THEN
461 RETURN
462 END IF
463
464 scllen = m
465
466 END IF
467
468 END IF
469
470
471
472 IF( iascl.EQ.1 ) THEN
473 CALL clascl(
'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,
474 $ info )
475 ELSE IF( iascl.EQ.2 ) THEN
476 CALL clascl(
'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,
477 $ info )
478 END IF
479 IF( ibscl.EQ.1 ) THEN
480 CALL clascl(
'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,
481 $ info )
482 ELSE IF( ibscl.EQ.2 ) THEN
483 CALL clascl(
'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,
484 $ info )
485 END IF
486
487 50 CONTINUE
488 work( 1 ) = real( tszo + lwo )
489 RETURN
490
491
492
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
logical function lsame(CA, CB)
LSAME
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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
real function slamch(CMACH)
SLAMCH