📄 d9r10.frm
字号:
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4815
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4815
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 375
Left = 3120
TabIndex = 0
Top = 2640
Width = 1215
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
'PROGRAM D9R10
'Driver for routine SIMPLX
'Incorporates examples discussed in text
N = 4
M = 4
NP = 5
MP = 6
M1 = 2
M2 = 1
M3 = 1
NM1M2 = N + M1 + M2
Dim A(6, 5), IZROV(4), IPOSV(4), ANUM(5), TXT(7), ALPHA(5)
TXT(1) = "x1": TXT(2) = "x2": TXT(3) = "x3": TXT(4) = "x4"
TXT(5) = "y1": TXT(6) = "y2": TXT(7) = "y3"
A(1, 1) = 0#: A(1, 2) = 1#: A(1, 3) = 1#: A(1, 4) = 3#: A(1, 5) = -0.5
A(2, 1) = 740#: A(2, 2) = -1#: A(2, 3) = 0: A(2, 4) = -2#: A(2, 5) = 0#
A(3, 1) = 0#: A(3, 2) = 0#: A(3, 3) = -2#: A(3, 4) = 0#: A(3, 5) = 7#
A(4, 1) = 0.5: A(4, 2) = 0#: A(4, 3) = -1: A(4, 4) = 1#: A(4, 5) = -2#
A(5, 1) = 9#: A(5, 2) = -1#: A(5, 3) = -1#: A(5, 4) = -1#: A(5, 5) = -1#
A(6, 1) = 0#: A(6, 2) = 0#: A(6, 3) = 0#: A(6, 4) = 0#: A(6, 5) = 0#
Call SIMPLX(A(), M, N, MP, NP, M1, M2, M3, ICASE, IZROV(), IPOSV())
If ICASE = 1 Then
Print Tab(5); "'Unbounded objective function"
ElseIf ICASE = -1 Then
Print Tab(5); "No solutions satisfy constraints given"
Else
JJ = 1
For I = 1 To N
If IZROV(I) <= N + M1 + M2 Then
ALPHA(JJ) = TXT(IZROV(I))
JJ = JJ + 1
End If
Next I
JMax = JJ - 1
Print
For JJ = 1 To JMax
Print Tab(11 + JJ * 10); Format$(ALPHA(JJ), "##.##");
Next JJ
For I = 1 To M + 1
If I > 1 Then
ALPHA(1) = TXT(IPOSV(I - 1))
Else
ALPHA(1) = " "
End If
ANUM(1) = A(I, 1)
JJ = 2
For J = 2 To N + 1
If IZROV(J - 1) <= (N + M1 + M2) Then
ANUM(JJ) = A(I, J)
JJ = JJ + 1
End If
Next
JMax = JJ - 1
Print Tab(3); Format$(ALPHA(1), "##.##");
For JJ = 1 To JMax
Print Tab(JJ * 10); Format$(ANUM(JJ), "##.#0");
Next JJ
Next
End If
End Sub
Sub SIMPLX(A(), M, N, MP, NP, M1, M2, M3, ICASE, IZROV(), IPOSV())
EPS = 0.000001
Dim L1(100), L2(100), L3(100)
If M <> M1 + M2 + M3 Then
Print " Bad input constraint counts"
Exit Sub
End If
NL1 = N
For K = 1 To N
L1(K) = K
IZROV(K) = K
Next K
NL2 = M
For I = 1 To M
If A(I + 1, 1) < 0# Then
Print " Bad input tableau."
Exit Sub
End If
L2(I) = I
IPOSV(I) = N + I
Next I
For I = 1 To M2
L3(I) = 1
Next I
IR = 0
If M2 + M3 = 0 Then GoTo 3
IR = 1
For K = 1 To N + 1
Q1 = 0#
For I = M1 + 1 To M
Q1 = Q1 + A(I + 1, K)
Next I
A(M + 2, K) = -Q1
Next K
Do
Call SIMP1(A(), MP, NP, M + 1, L1(), NL1, 0, KP, BMAX)
If BMAX <= EPS And A(M + 2, 1) < -EPS Then
ICASE = -1
Erase L3, L2, L1
Exit Sub
ElseIf BMAX <= EPS And A(M + 2, 1) <= EPS Then
M12 = M1 + M2 + 1
If M12 <= M Then
For IP = M12 To M
If IPOSV(IP) = IP + N Then
Call SIMP1(A(), MP, NP, IP, L1(), NL1, 1, KP, BMAX)
If BMAX > 0# Then GoTo 1
End If
Next IP
End If
IR = 0
M12 = M12 - 1
If M1 + 1 > M12 Then Exit Do
For I = M1 + 1 To M12
If L3(I - M1) = 1 Then
For K = 1 To N + 1
A(I + 1, K) = -A(I + 1, K)
Next K
End If
Next I
Exit Do
End If
Call SIMP2(A(), M, N, MP, NP, L2(), NL2, IP, KP, Q1)
If IP = 0 Then
ICASE = -1
Erase L3, L2, L1
Exit Sub
End If
1 Call SIMP3(A(), MP, NP, M + 1, N, IP, KP)
If IPOSV(IP) >= N + M1 + M2 + 1 Then
For K = 1 To NL1
If L1(K) = KP Then Exit For
Next K
NL1 = NL1 - 1
For IQ = K To NL1
L1(IQ) = L1(IQ + 1)
Next IQ
Else
If IPOSV(IP) < N + M1 + 1 Then GoTo 2
KH = IPOSV(IP) - M1 - N
If L3(KH) = 0 Then GoTo 2
L3(KH) = 0
End If
A(M + 2, KP + 1) = A(M + 2, KP + 1) + 1#
For I = 1 To M + 2
A(I, KP + 1) = -A(I, KP + 1)
Next I
2 IQ = IZROV(KP)
IZROV(KP) = IPOSV(IP)
IPOSV(IP) = IQ
Loop While IR <> 0
3 Call SIMP1(A(), MP, NP, 0, L1(), NL1, 0, KP, BMAX)
If BMAX <= 0# Then
ICASE = 0
Erase L3, L2, L1
Exit Sub
End If
Call SIMP2(A(), M, N, MP, NP, L2(), NL2, IP, KP, Q1)
If IP = 0 Then
ICASE = 1
Erase L3, L2, L1
Exit Sub
End If
Call SIMP3(A(), MP, NP, M, N, IP, KP)
GoTo 2
End Sub
Sub SIMP1(A(), MP, NP, MM, LL(), NLL, IABF, KP, BMAX)
KP = LL(1)
BMAX = A(MM + 1, KP + 1)
For K = 2 To NLL
If IABF = 0 Then
TEST = A(MM + 1, LL(K) + 1) - BMAX
Else
TEST = Abs(A(MM + 1, LL(K) + 1)) - Abs(BMAX)
End If
If TEST > 0# Then
BMAX = A(MM + 1, LL(K) + 1)
KP = LL(K)
End If
Next K
End Sub
Sub SIMP2(A(), M, N, MP, NP, L2(), NL2, IP, KP, Q1)
EPS = 0.000001
IP = 0
FLAG = 0
For I = 1 To NL2
If A(L2(I) + 1, KP + 1) < -EPS Then FLAG = 1
If FLAG = 1 Then Exit For
Next I
If FLAG = 0 Then Exit Sub
Q1 = -A(L2(I) + 1, 1) / A(L2(I) + 1, KP + 1)
IP = L2(I)
For I = I + 1 To NL2
II = L2(I)
If A(II + 1, KP + 1) < -EPS Then
Q = -A(II + 1, 1) / A(II + 1, KP + 1)
If Q < Q1 Then
IP = II
Q1 = Q
ElseIf Q = Q1 Then
For K = 1 To N
QP = -A(IP + 1, K + 1) / A(IP + 1, KP + 1)
Q0 = -A(II + 1, K + 1) / A(II + 1, KP + 1)
If Q0 <> QP Then Exit For
Next K
If Q0 < QP Then IP = II
End If
End If
Next I
End Sub
Sub SIMP3(A(), MP, NP, I1, K1, IP, KP)
PIV = 1# / A(IP + 1, KP + 1)
For II = 1 To I1 + 1
If II - 1 <> IP Then
A(II, KP + 1) = A(II, KP + 1) * PIV
For KK = 1 To K1 + 1
If KK - 1 <> KP Then
A(II, KK) = A(II, KK) - A(IP + 1, KK) * A(II, KP + 1)
End If
Next KK
End If
Next II
For KK = 1 To K1 + 1
If KK - 1 <> KP Then A(IP + 1, KK) = -A(IP + 1, KK) * PIV
Next KK
A(IP + 1, KP + 1) = PIV
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -