📄 dtgsy2.f
字号:
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 50 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
50 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
ALPHA = -RHS( 1 )
CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
$ 1 )
CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
$ 1 )
END IF
IF( J.LT.Q ) THEN
CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = D( IS, IS )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = -B( JS, JSP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = -E( JS, JSP1 )
*
Z( 1, 4 ) = -B( JSP1, JS )
Z( 2, 4 ) = -B( JSP1, JSP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 60 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
60 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
$ 1, C( 1, JS ), LDC )
CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
$ 1, F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = D( IS, ISP1 )
Z( 4, 2 ) = D( ISP1, ISP1 )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = -B( JS, JS )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 70 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
$ RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD,
$ RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
END IF
IF( J.LT.Q ) THEN
CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ E( JS, JE+1 ), LDB, F( IS, JE+1 ), LDC )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z * x = RHS
*
CALL DCOPY( LDZ*LDZ, ZERO, 0, Z, 1 )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 5, 1 ) = D( IS, IS )
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 5, 2 ) = D( IS, ISP1 )
Z( 6, 2 ) = D( ISP1, ISP1 )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( ISP1, IS )
Z( 7, 3 ) = D( IS, IS )
*
Z( 3, 4 ) = A( IS, ISP1 )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 7, 4 ) = D( IS, ISP1 )
Z( 8, 4 ) = D( ISP1, ISP1 )
*
Z( 1, 5 ) = -B( JS, JS )
Z( 3, 5 ) = -B( JS, JSP1 )
Z( 5, 5 ) = -E( JS, JS )
Z( 7, 5 ) = -E( JS, JSP1 )
*
Z( 2, 6 ) = -B( JS, JS )
Z( 4, 6 ) = -B( JS, JSP1 )
Z( 6, 6 ) = -E( JS, JS )
Z( 8, 6 ) = -E( JS, JSP1 )
*
Z( 1, 7 ) = -B( JSP1, JS )
Z( 3, 7 ) = -B( JSP1, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 2, 8 ) = -B( JSP1, JS )
Z( 4, 8 ) = -B( JSP1, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 80 JJ = 0, NB - 1
CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
K = K + MB
II = II + MB
80 CONTINUE
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 90 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 100 JJ = 0, NB - 1
CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
K = K + MB
II = II + MB
100 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
$ C( 1, JS ), LDC )
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
K = MB*NB + 1
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
$ MB, B( JS, JE+1 ), LDB, ONE,
$ C( IS, JE+1 ), LDC )
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
$ MB, E( JS, JE+1 ), LDE, ONE,
$ F( IS, JE+1 ), LDF )
END IF
*
END IF
*
110 CONTINUE
120 CONTINUE
ELSE
*
* Solve (I, J) - subsystem
* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J)
* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
*
SCALE = ONE
SCALOC = ONE
DO 200 I = 1, P
*
IS = IWORK( I )
ISP1 = IS + 1
IE = IWORK( I+1 ) - 1
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -