strsyl.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 914 行 · 第 1/3 页
F
914 行
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
140 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( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
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 150 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
150 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( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .FALSE., 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 160 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
160 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( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN(L2+1, N ) ), LDB )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .TRUE., .TRUE., 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 170 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
170 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
*
180 CONTINUE
190 CONTINUE
*
ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
*
* Solve A*X + ISGN*X*B' = scale*C.
*
* The (K,L)th block of X is determined starting from
* bottom-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
* M N
* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
* I=K+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 250 L = N, 1, -1
IF( L.GT.LNEXT )
$ GO TO 250
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 = M
DO 240 K = M, 1, -1
IF( K.GT.KNEXT )
$ GO TO 240
IF( K.EQ.1 ) THEN
K1 = K
K2 = K
ELSE
IF( A( K, K-1 ).NE.ZERO ) THEN
K1 = K - 1
K2 = K
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( M-K1, A( K1, MIN(K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), 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 200 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
200 CONTINUE
SCALE = SCALE*SCALOC
END IF
C( K1, L1 ) = X( 1, 1 )
*
ELSE IF( L1.EQ.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( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
*
SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
*
CALL SLALN2( .FALSE., 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 210 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
210 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( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
*
SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
$ C( MIN( K1+1, M ), L2 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
*
CALL SLALN2( .FALSE., 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 220 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
220 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( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
$ C( MIN( K2+1, M ), L1 ), 1 )
SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
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( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
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( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L1, MIN( L2+1, N ) ), LDB )
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( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
$ B( L2, MIN( L2+1, N ) ), LDB )
VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
*
CALL SLASY2( .FALSE., .TRUE., 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 230 J = 1, N
CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
230 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
*
240 CONTINUE
250 CONTINUE
*
END IF
*
RETURN
*
* End of STRSYL
*
END
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?