strsyl.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 914 行 · 第 1/3 页
F
914 行
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L2 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .FALSE., .FALSE., ISGN, 2, 2,
$ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
$ 2, SCALOC, X, 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 50 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
50 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
60 CONTINUE
*
70 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
*
* Solve A' *X + ISGN*X*B = scale*C.
*
* The (K,L)th block of X is determined starting from
* upper-left corner column by column by
*
* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
*
* Where
* K-1 L-1
* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
* I=1 J=1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = 1
DO 130 L = 1, N
IF( L.LT.LNEXT )
$ GO TO 130
IF( L.EQ.N ) THEN
L1 = L
L2 = L
ELSE
IF( B( L+1, L ).NE.ZERO ) THEN
L1 = L
L2 = L + 1
LNEXT = L + 2
ELSE
L1 = L
L2 = L
LNEXT = L + 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = 1
DO 120 K = 1, M
IF( K.LT.KNEXT )
$ GO TO 120
IF( K.EQ.M ) THEN
K1 = K
K2 = K
ELSE
IF( A( K+1, K ).NE.ZERO ) THEN
K1 = K
K2 = K + 1
KNEXT = K + 2
ELSE
K1 = K
K2 = K
KNEXT = K + 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 80 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
80 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
$ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 90 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K2, L1 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
$ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
$ ZERO, X, 2, SCALOC, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 100 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
100 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 2, 1 )
*
ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
$ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
$ 2, XNORM, IERR )
IF( IERR.NE.0 )
$ INFO = 1
*
IF( SCALOC.NE.ONE ) THEN
DO 110 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
110 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
C( K1, L2 ) = X( 1, 2 )
C( K2, L1 ) = X( 2, 1 )
C( K2, L2 ) = X( 2, 2 )
END IF
*
120 CONTINUE
130 CONTINUE
*
ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A'*X + ISGN*X*B' = scale*C.
*
* The (K,L)th block of X is determined starting from
* top-right corner column by column by
*
* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
*
* Where
* K-1 N
* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
* I=1 J=L+1
*
* Start column loop (index = L)
* L1 (L2): column index of the first (last) row of X(K,L)
*
LNEXT = N
DO 190 L = N, 1, -1
IF( L.GT.LNEXT )
$ GO TO 190
IF( L.EQ.1 ) THEN
L1 = L
L2 = L
ELSE
IF( B( L, L-1 ).NE.ZERO ) THEN
L1 = L - 1
L2 = L
LNEXT = L - 2
ELSE
L1 = L
L2 = L
LNEXT = L - 1
END IF
END IF
*
* Start row loop (index = K)
* K1 (K2): row index of the first (last) row of X(K,L)
*
KNEXT = 1
DO 180 K = 1, M
IF( K.LT.KNEXT )
$ GO TO 180
IF( K.EQ.M ) THEN
K1 = K
K2 = K
ELSE
IF( A( K+1, K ).NE.ZERO ) THEN
K1 = K
K2 = K + 1
KNEXT = K + 2
ELSE
K1 = K
K2 = K
KNEXT = K + 1
END IF
END IF
*
IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
$ B( L1, MIN( L1+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
SCALOC = ONE
*
A11 = A( K1, K1 ) + SGN*B( L1, L1 )
DA11 = ABS( A11 )
IF( DA11.LE.SMIN ) THEN
A11 = SMIN
DA11 = SMIN
INFO = 1
END IF
DB = ABS( VEC( 1, 1 ) )
IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
IF( DB.GT.BIGNUM*DA11 )
$ SCALOC = ONE / DB
END IF
X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
*
IF( SCALOC.NE.ONE ) THEN
DO 140 J = 1, N
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?