157 SUBROUTINE ztrsyl( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
166 CHARACTER TRANA, TRANB
167 INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
168 DOUBLE PRECISION SCALE
171 COMPLEX*16 A( lda, * ), B( ldb, * ), C( ldc, * )
178 parameter ( one = 1.0d+0 )
181 LOGICAL NOTRNA, NOTRNB
183 DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
185 COMPLEX*16 A11, SUML, SUMR, VEC, X11
188 DOUBLE PRECISION DUM( 1 )
192 DOUBLE PRECISION DLAMCH, ZLANGE
193 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
194 EXTERNAL lsame, dlamch, zlange, zdotc, zdotu, zladiv
200 INTRINSIC abs, dble, dcmplx, dconjg, dimag, max, min
206 notrna = lsame( trana,
'N' )
207 notrnb = lsame( tranb,
'N' )
210 IF( .NOT.notrna .AND. .NOT.lsame( trana,
'C' ) )
THEN
212 ELSE IF( .NOT.notrnb .AND. .NOT.lsame( tranb,
'C' ) )
THEN
214 ELSE IF( isgn.NE.1 .AND. isgn.NE.-1 )
THEN
216 ELSE IF( m.LT.0 )
THEN
218 ELSE IF( n.LT.0 )
THEN
220 ELSE IF( lda.LT.max( 1, m ) )
THEN
222 ELSE IF( ldb.LT.max( 1, n ) )
THEN
224 ELSE IF( ldc.LT.max( 1, m ) )
THEN
228 CALL xerbla(
'ZTRSYL', -info )
235 IF( m.EQ.0 .OR. n.EQ.0 )
241 smlnum = dlamch(
'S' )
242 bignum = one / smlnum
243 CALL dlabad( smlnum, bignum )
244 smlnum = smlnum*dble( m*n ) / eps
245 bignum = one / smlnum
246 smin = max( smlnum, eps*zlange(
'M', m, m, a, lda, dum ),
247 $ eps*zlange(
'M', n, n, b, ldb, dum ) )
250 IF( notrna .AND. notrnb )
THEN
267 suml = zdotu( m-k, a( k, min( k+1, m ) ), lda,
268 $ c( min( k+1, m ), l ), 1 )
269 sumr = zdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
270 vec = c( k, l ) - ( suml+sgn*sumr )
273 a11 = a( k, k ) + sgn*b( l, l )
274 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
275 IF( da11.LE.smin )
THEN
280 db = abs( dble( vec ) ) + abs( dimag( vec ) )
281 IF( da11.LT.one .AND. db.GT.one )
THEN
282 IF( db.GT.bignum*da11 )
285 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
287 IF( scaloc.NE.one )
THEN
289 CALL zdscal( m, scaloc, c( 1, j ), 1 )
298 ELSE IF( .NOT.notrna .AND. notrnb )
THEN
315 suml = zdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
316 sumr = zdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
317 vec = c( k, l ) - ( suml+sgn*sumr )
320 a11 = dconjg( a( k, k ) ) + sgn*b( l, l )
321 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
322 IF( da11.LE.smin )
THEN
327 db = abs( dble( vec ) ) + abs( dimag( vec ) )
328 IF( da11.LT.one .AND. db.GT.one )
THEN
329 IF( db.GT.bignum*da11 )
333 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
335 IF( scaloc.NE.one )
THEN
337 CALL zdscal( m, scaloc, c( 1, j ), 1 )
346 ELSE IF( .NOT.notrna .AND. .NOT.notrnb )
THEN
366 suml = zdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
367 sumr = zdotc( n-l, c( k, min( l+1, n ) ), ldc,
368 $ b( l, min( l+1, n ) ), ldb )
369 vec = c( k, l ) - ( suml+sgn*dconjg( sumr ) )
372 a11 = dconjg( a( k, k )+sgn*b( l, l ) )
373 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
374 IF( da11.LE.smin )
THEN
379 db = abs( dble( vec ) ) + abs( dimag( vec ) )
380 IF( da11.LT.one .AND. db.GT.one )
THEN
381 IF( db.GT.bignum*da11 )
385 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
387 IF( scaloc.NE.one )
THEN
389 CALL zdscal( m, scaloc, c( 1, j ), 1 )
398 ELSE IF( notrna .AND. .NOT.notrnb )
THEN
415 suml = zdotu( m-k, a( k, min( k+1, m ) ), lda,
416 $ c( min( k+1, m ), l ), 1 )
417 sumr = zdotc( n-l, c( k, min( l+1, n ) ), ldc,
418 $ b( l, min( l+1, n ) ), ldb )
419 vec = c( k, l ) - ( suml+sgn*dconjg( sumr ) )
422 a11 = a( k, k ) + sgn*dconjg( b( l, l ) )
423 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
424 IF( da11.LE.smin )
THEN
429 db = abs( dble( vec ) ) + abs( dimag( vec ) )
430 IF( da11.LT.one .AND. db.GT.one )
THEN
431 IF( db.GT.bignum*da11 )
435 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
437 IF( scaloc.NE.one )
THEN
439 CALL zdscal( m, scaloc, c( 1, j ), 1 )
subroutine ztrsyl(TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO)
ZTRSYL
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL