155 SUBROUTINE ctrsyl( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
163 CHARACTER TRANA, TRANB
164 INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
168 COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * )
175 parameter( one = 1.0e+0 )
178 LOGICAL NOTRNA, NOTRNB
180 REAL BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
182 COMPLEX A11, SUML, SUMR, VEC, X11
190 COMPLEX CDOTC, CDOTU, CLADIV
191 EXTERNAL lsame, clange, slamch, cdotc, cdotu, cladiv
197 INTRINSIC abs, aimag, cmplx, conjg, max, min, real
203 notrna = lsame( trana,
'N' )
204 notrnb = lsame( tranb,
'N' )
207 IF( .NOT.notrna .AND. .NOT.lsame( trana,
'C' ) )
THEN
209 ELSE IF( .NOT.notrnb .AND. .NOT.lsame( tranb,
'C' ) )
THEN
211 ELSE IF( isgn.NE.1 .AND. isgn.NE.-1 )
THEN
213 ELSE IF( m.LT.0 )
THEN
215 ELSE IF( n.LT.0 )
THEN
217 ELSE IF( lda.LT.max( 1, m ) )
THEN
219 ELSE IF( ldb.LT.max( 1, n ) )
THEN
221 ELSE IF( ldc.LT.max( 1, m ) )
THEN
225 CALL xerbla(
'CTRSYL', -info )
232 IF( m.EQ.0 .OR. n.EQ.0 )
238 smlnum = slamch(
'S' )
239 bignum = one / smlnum
240 CALL slabad( smlnum, bignum )
241 smlnum = smlnum*real( m*n ) / eps
242 bignum = one / smlnum
243 smin = max( smlnum, eps*clange(
'M', m, m, a, lda, dum ),
244 $ eps*clange(
'M', n, n, b, ldb, dum ) )
247 IF( notrna .AND. notrnb )
THEN
264 suml = cdotu( m-k, a( k, min( k+1, m ) ), lda,
265 $ c( min( k+1, m ), l ), 1 )
266 sumr = cdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
267 vec = c( k, l ) - ( suml+sgn*sumr )
270 a11 = a( k, k ) + sgn*b( l, l )
271 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
272 IF( da11.LE.smin )
THEN
277 db = abs( real( vec ) ) + abs( aimag( vec ) )
278 IF( da11.LT.one .AND. db.GT.one )
THEN
279 IF( db.GT.bignum*da11 )
282 x11 = cladiv( vec*cmplx( scaloc ), a11 )
284 IF( scaloc.NE.one )
THEN
286 CALL csscal( m, scaloc, c( 1, j ), 1 )
295 ELSE IF( .NOT.notrna .AND. notrnb )
THEN
312 suml = cdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
313 sumr = cdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
314 vec = c( k, l ) - ( suml+sgn*sumr )
317 a11 = conjg( a( k, k ) ) + sgn*b( l, l )
318 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
319 IF( da11.LE.smin )
THEN
324 db = abs( real( vec ) ) + abs( aimag( vec ) )
325 IF( da11.LT.one .AND. db.GT.one )
THEN
326 IF( db.GT.bignum*da11 )
330 x11 = cladiv( vec*cmplx( scaloc ), a11 )
332 IF( scaloc.NE.one )
THEN
334 CALL csscal( m, scaloc, c( 1, j ), 1 )
343 ELSE IF( .NOT.notrna .AND. .NOT.notrnb )
THEN
363 suml = cdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
364 sumr = cdotc( n-l, c( k, min( l+1, n ) ), ldc,
365 $ b( l, min( l+1, n ) ), ldb )
366 vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
369 a11 = conjg( a( k, k )+sgn*b( l, l ) )
370 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
371 IF( da11.LE.smin )
THEN
376 db = abs( real( vec ) ) + abs( aimag( vec ) )
377 IF( da11.LT.one .AND. db.GT.one )
THEN
378 IF( db.GT.bignum*da11 )
382 x11 = cladiv( vec*cmplx( scaloc ), a11 )
384 IF( scaloc.NE.one )
THEN
386 CALL csscal( m, scaloc, c( 1, j ), 1 )
395 ELSE IF( notrna .AND. .NOT.notrnb )
THEN
412 suml = cdotu( m-k, a( k, min( k+1, m ) ), lda,
413 $ c( min( k+1, m ), l ), 1 )
414 sumr = cdotc( n-l, c( k, min( l+1, n ) ), ldc,
415 $ b( l, min( l+1, n ) ), ldb )
416 vec = c( k, l ) - ( suml+sgn*conjg( sumr ) )
419 a11 = a( k, k ) + sgn*conjg( b( l, l ) )
420 da11 = abs( real( a11 ) ) + abs( aimag( a11 ) )
421 IF( da11.LE.smin )
THEN
426 db = abs( real( vec ) ) + abs( aimag( vec ) )
427 IF( da11.LT.one .AND. db.GT.one )
THEN
428 IF( db.GT.bignum*da11 )
432 x11 = cladiv( vec*cmplx( scaloc ), a11 )
434 IF( scaloc.NE.one )
THEN
436 CALL csscal( m, scaloc, c( 1, j ), 1 )
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine ctrsyl(TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO)
CTRSYL