155 SUBROUTINE ztrsyl( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
163 CHARACTER TRANA, TRANB
164 INTEGER INFO, ISGN, LDA, , LDC, M, N
165 DOUBLE PRECISION SCALE
168 COMPLEX*16 A( LDA, * ), B( LDB, * ), C( , * )
175 parameter( one = 1.0d+0 )
178 LOGICAL NOTRNA, NOTRNB
180 DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
182 COMPLEX*16 A11, SUML, SUMR, VEC, X11
185 DOUBLE PRECISION DUM( 1 )
189 DOUBLE PRECISION DLAMCH, ZLANGE
190 COMPLEX*16 ZDOTC, ZDOTU, ZLADIV
191 EXTERNAL lsame, dlamch, zlange, zdotc, zdotu, zladiv
197 INTRINSIC abs, dble, dcmplx, dconjg, dimag,
max,
min
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(
'ZTRSYL', -info )
232 IF( m.EQ.0 .OR. n.EQ.0 )
238 smlnum = dlamch(
'S' )
239 bignum = one / smlnum
240 CALL dlabad( smlnum, bignum )
241 smlnum = smlnum*dble( m*n ) / eps
242 bignum = one / smlnum
243 smin =
max( smlnum, eps*zlange(
'M', m, m, a, lda, dum ),
244 $ eps*zlange(
'M', n, n, b, ldb, dum ) )
247 IF( notrna .AND. notrnb )
THEN
264 suml = zdotu( m-k, a( k,
min( k+1, m ) ), lda,
265 $ c(
min( k+1, m ), l ), 1 )
266 sumr = zdotu( 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( dble( a11 ) ) + abs( dimag( a11 ) )
272 IF( da11.LE.smin )
THEN
277 db = abs( dble( vec ) ) + abs( dimag( vec ) )
278 IF( da11.LT.one .AND. db.GT.one )
THEN
279 IF( db.GT.bignum*da11 )
282 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
284 IF( scaloc.NE.one )
THEN
286 CALL zdscal( m, scaloc, c( 1, j ), 1 )
295 ELSE IF( .NOT.notrna .AND. notrnb )
THEN
313 sumr = zdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 )
314 vec = c( k, l ) - ( suml+sgn*sumr )
317 a11 = dconjg( a( k, k ) ) + sgn*b( l, l )
318 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
319 IF( da11.LE.smin )
THEN
324 db = abs( dble( vec ) ) + abs( dimag( vec ) )
325 IF( da11.LT.one .AND. db.GT.one )
THEN
326 IF( db.GT.bignum*da11 )
330 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
332 IF( scaloc.NE.one )
THEN
334 CALL zdscal( m, scaloc, c( 1, j ), 1 )
335 40 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
50 CONTINUE
60 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A**H*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* upper-right corner column by column by
*
* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1
* R(K,L) = SUM [A**H(I,K)*X(I,L)] +
* I=1
* N
* ISGN*SUM [X(K,J)*B**H(L,J)].
* J=L+1
*
DO 90 L = N, 1, -1
DO 80 K = 1, M
*
SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = DCONJG( A( K, K )+SGN*B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 70 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
80 CONTINUE
90 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
* I=K+1 J=L+1
*
DO 120 L = N, 1, -1
DO 110 K = M, 1, -1
*
SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
$ C( MIN( K+1, M ), L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = A( K, K ) + SGN*DCONJG( B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
110 CONTINUE
120 CONTINUE
*
END IF
*
RETURN
*
* End of ZTRSYL
*
END
CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
50 CONTINUE
60 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A**H*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* upper-right corner column by column by
*
* A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1
* R(K,L) = SUM [A**H(I,K)*X(I,L)] +
* I=1
* N
* ISGN*SUM [X(K,J)*B**H(L,J)].
* J=L+1
*
DO 90 L = N, 1, -1
DO 80 K = 1, M
*
SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = DCONJG( A( K, K )+SGN*B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 70 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
80 CONTINUE
90 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B**H = C.
*
* The (K,L)th block of X is determined starting from
* bottom-left corner column by column by
*
* A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
*
* Where
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
* I=K+1 J=L+1
*
DO 120 L = N, 1, -1
DO 110 K = M, 1, -1
*
SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA,
$ C( MIN( K+1, M ), L ), 1 )
SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC,
$ B( L, MIN( L+1, N ) ), LDB )
VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) )
*
SCALOC = ONE
A11 = A( K, K ) + SGN*DCONJG( B( L, L ) )
DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
*
X11 = ZLADIV( VEC*DCMPLX( SCALOC ), A11 )
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K, L ) = X11
*
110 CONTINUE
120 CONTINUE
*
END IF
*
RETURN
*
* End of ZTRSYL
*
END
CONTINUE
343 ELSE IF( .NOT.notrna .AND. .NOT.notrnb )
THEN
363 suml = zdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 )
364 sumr = zdotc( n-l, c( k,
min( l+1, n ) ), ldc,
365 $ b( l,
min( l+1, n ) ), ldb )
366 vec = c( k, l ) - ( suml+sgn*dconjg( sumr ) )
369 a11 = dconjg( a( k, k )+sgn*b( l, l ) )
370 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
371 IF( da11.LE.smin )
THEN
376 db = abs( dble( vec ) ) + abs( dimag( vec ) )
377 IF( da11.LT.one .AND. db.GT.one )
THEN
378 IF( db.GT.bignum*da11 )
382 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
384 IF( scaloc.NE.one )
THEN
386 CALL zdscal( m, scaloc, c( 1, j ), 1 )
395 ELSE IF( notrna .AND. .NOT.notrnb )
THEN
412 suml = zdotu( m-k, a( k,
min( k+1, m ) ), lda,
413 $ c(
min( k+1, m ), l ), 1 )
414 sumr = zdotc( n-l, c( k,
min( l+1, n ) ), ldc,
415 $ b( l,
min( l+1, n ) ), ldb )
416 vec = c( k, l ) - ( suml+sgn*dconjg( sumr ) )
419 a11 = a( k, k ) + sgn*dconjg( b( l, l ) )
420 da11 = abs( dble( a11 ) ) + abs( dimag( a11 ) )
421 IF( da11.LE.smin )
THEN
426 db = abs( dble( vec ) ) + abs( dimag( vec ) )
427 IF( da11.LT.one .AND. db.GT.one )
THEN
428 IF( db.GT.bignum*da11 )
432 x11 = zladiv( vec*dcmplx( scaloc ), a11 )
434 IF( scaloc.NE.one )
THEN
436 CALL zdscal( m, scaloc, c( 1, j ), 1 )