Private Sub Command1_Click() 'program D1R1 'Driver program for routine GAUSSJ N = 3 Dim A(3, 3), B(3), A1(3, 3), B1(3) '输入已知的方程组的系数矩阵 A(1, 1) = 2: A(1, 2) = 1: A(1, 3) = 2 A(2, 1) = 5: A(2, 2) = -1: A(2, 3) = 1 A(3, 1) = 1: A(3, 2) = -3: A(3, 3) = -4 '输入已知的方程组的右端向量B B(1) = 5 B(2) = 8 B(3) = -4 Print Print Tab(5); "已知的方程组的右端向量" Print Tab(14); Format$(B(1), "##.##") Print Tab(14); Format$(B(2), "##.##") Print Tab(14); Format$(B(3), "##.##") For I = 1 To N For J = 1 To 3 A1(I, J) = A(I, J) Next J Next I Call GAUSSJ(A(), N, B()) Print Print Tab(5); "计算出的方程组的解" Print Tab(14); Format$(B(1), "##.##") Print Tab(14); Format$(B(2), "##.##") Print Tab(14); Format$(B(3), "##.##") '将计算出的解B乘以系数矩阵,以验证计算结果正确 For L = 1 To N B1(L) = 0# For J = 1 To N B1(L) = B1(L) + A1(L, J) * B(J) Next J Next L Print Print Tab(5); "计算出的解乘以系数矩阵的结果" Print Tab(14); Format$(B1(1), "##.##") Print Tab(14); Format$(B1(2), "##.##") Print Tab(14); Format$(B1(3), "##.##") End Sub Sub GAUSSJ(A(), N, B()) Dim IPIV(50), INDXR(50), INDXC(50) For J = 1 To N IPIV(J) = 0 Next J For I = 1 To N BIG = 0# For J = 1 To N If IPIV(J) <> 1 Then For K = 1 To N If IPIV(K) = 0 Then If Abs(A(J, K)) >= BIG Then BIG = Abs(A(J, K)) IROW = J ICOL = K End If ElseIf IPIV(K) > 1 Then Print "Singular matrix" End If Next K End If Next J IPIV(ICOL) = IPIV(ICOL) + 1 If IROW <> ICOL Then For L = 1 To N DUM = A(IROW, L) A(IROW, L) = A(ICOL, L) A(ICOL, L) = DUM Next L DUM = B(IROW) B(IROW) = B(ICOL) B(ICOL) = DUM End If INDXR(I) = IROW INDXC(I) = ICOL If A(ICOL, ICOL) = 0# Then Print "Singular matrix." PIVINV = 1# / A(ICOL, ICOL) A(ICOL, ICOL) = 1# For L = 1 To N A(ICOL, L) = A(ICOL, L) * PIVINV Next L B(ICOL) = B(ICOL) * PIVINV For LL = 1 To N If LL <> ICOL Then DUM = A(LL, ICOL) A(LL, ICOL) = 0# For L = 1 To N A(LL, L) = A(LL, L) - A(ICOL, L) * DUM Next L B(LL) = B(LL) - B(ICOL) * DUM End If Next LL Next I For L = N To 1 Step -1 If INDXR(L) <> INDXC(L) Then For K = 1 To N DUM = A(K, INDXR(L)) A(K, INDXR(L)) = A(K, INDXC(L)) A(K, INDXC(L)) = DUM Next K End If Next L End Sub
Private Sub Command1_Click()
'program D1R1
'Driver program for routine GAUSSJ
N = 3
Dim A(3, 3), B(3), A1(3, 3), B1(3)
'输入已知的方程组的系数矩阵
A(1, 1) = 2: A(1, 2) = 1: A(1, 3) = 2
A(2, 1) = 5: A(2, 2) = -1: A(2, 3) = 1
A(3, 1) = 1: A(3, 2) = -3: A(3, 3) = -4
'输入已知的方程组的右端向量B
B(1) = 5
B(2) = 8
B(3) = -4
Print
Print Tab(5); "已知的方程组的右端向量"
Print Tab(14); Format$(B(1), "##.##")
Print Tab(14); Format$(B(2), "##.##")
Print Tab(14); Format$(B(3), "##.##")
For I = 1 To N
For J = 1 To 3
A1(I, J) = A(I, J)
Next J
Next I
Call GAUSSJ(A(), N, B())
Print
Print Tab(5); "计算出的方程组的解"
Print Tab(14); Format$(B(1), "##.##")
Print Tab(14); Format$(B(2), "##.##")
Print Tab(14); Format$(B(3), "##.##")
'将计算出的解B乘以系数矩阵,以验证计算结果正确
For L = 1 To N
B1(L) = 0#
For J = 1 To N
B1(L) = B1(L) + A1(L, J) * B(J)
Next J
Next L
Print
Print Tab(5); "计算出的解乘以系数矩阵的结果"
Print Tab(14); Format$(B1(1), "##.##")
Print Tab(14); Format$(B1(2), "##.##")
Print Tab(14); Format$(B1(3), "##.##")
End Sub
Sub GAUSSJ(A(), N, B())
Dim IPIV(50), INDXR(50), INDXC(50)
For J = 1 To N
IPIV(J) = 0
Next J
For I = 1 To N
BIG = 0#
For J = 1 To N
If IPIV(J) <> 1 Then
For K = 1 To N
If IPIV(K) = 0 Then
If Abs(A(J, K)) >= BIG Then
BIG = Abs(A(J, K))
IROW = J
ICOL = K
End If
ElseIf IPIV(K) > 1 Then
Print "Singular matrix"
End If
Next K
End If
Next J
IPIV(ICOL) = IPIV(ICOL) + 1
If IROW <> ICOL Then
For L = 1 To N
DUM = A(IROW, L)
A(IROW, L) = A(ICOL, L)
A(ICOL, L) = DUM
Next L
DUM = B(IROW)
B(IROW) = B(ICOL)
B(ICOL) = DUM
End If
INDXR(I) = IROW
INDXC(I) = ICOL
If A(ICOL, ICOL) = 0# Then Print "Singular matrix."
PIVINV = 1# / A(ICOL, ICOL)
A(ICOL, ICOL) = 1#
For L = 1 To N
A(ICOL, L) = A(ICOL, L) * PIVINV
Next L
B(ICOL) = B(ICOL) * PIVINV
For LL = 1 To N
If LL <> ICOL Then
DUM = A(LL, ICOL)
A(LL, ICOL) = 0#
For L = 1 To N
A(LL, L) = A(LL, L) - A(ICOL, L) * DUM
Next L
B(LL) = B(LL) - B(ICOL) * DUM
End If
Next LL
Next I
For L = N To 1 Step -1
If INDXR(L) <> INDXC(L) Then
For K = 1 To N
DUM = A(K, INDXR(L))
A(K, INDXR(L)) = A(K, INDXC(L))
A(K, INDXC(L)) = DUM
Next K
End If
Next L
End Sub