ｐ３ - プログラム倉庫

Private Sub Command1_Click()
Dim s As Single
Dim n1 As Single
Dim n2 As Single
Dim c1 As Single
Dim y1 As Single
Dim l1 As Single
Dim u1 As Single
Dim h As Single
Dim th(1 To 100) As Single
Dim c(1 To 100) As Single
Dim y(1 To 100) As Single
Dim u(1 To 100, -1 To 1, -1 To 1) As Single
Dim w(1 To 99, -1 To 1, -1 To 1) As Single
Dim v(1 To 99, -1 To 1, -1 To 1, -25 To 25) As Single
Dim gotoc(1 To 99, -1 To 1, -1 To 1, -25 To 25) As Single
Dim gotoy(1 To 99, -1 To 1, -1 To 1, -25 To 25) As Single
Dim gotoq(1 To 99, -1 To 1, -1 To 1, -25 To 25) As Single
Dim endc(-1 To 1, -1 To 1) As Single
Dim endy(-1 To 1, -1 To 1) As Single
Dim endq(-1 To 1, -1 To 1) As Single
Dim endv(-1 To 1, -1 To 1) As Single
Dim pp As Single
Dim q As Single
Dim qx As Single
h = 0.01
For s = 1 To 100
th(s) = 0.02 * s
Next
Open "c:/201.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2
s = a1
th(s) = a2
Loop
Close #1
Open "c:/202.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3
s = a1
c(s) = a2
y(s) = a3
Loop
Close #2
t = 0
Do Until t > 200
For s = 1 To 100
For n1 = -1 To 1
For n2 = -1 To 1
c1 = c(s) + n1 * h
y1 = y(s) + n2 * h
l1 = y1 / th(s)
pp = 0
If c1 < 0.001 Then pp = 1
If l1 > 0.99 Then pp = 1
If l1 < 0 Then pp = 1
If pp = 1 Then c1 = 0.5
If pp = 1 Then l1 = 0.5
u1 = Log(c1) + Log(1 - l1)
If pp = 1 Then u1 = -999
u(s, n1, n2) = u1
Next
Next
Next
For s = 1 To 99
For n1 = -1 To 1
For n2 = -1 To 1
c1 = c(s) + n1 * h
y1 = y(s) + n2 * h
l1 = y1 / th(s + 1)
pp = 0
If c1 < 0.001 Then pp = 1
If l1 > 0.99 Then pp = 1
If l1 < 0 Then pp = 1
If pp = 1 Then c1 = 0.5
If pp = 1 Then l1 = 0.5
u1 = Log(c1) + Log(1 - l1)
If pp = 1 Then u1 = -999
w(s, n1, n2) = u1
Next
Next
Next
For s = 1 To 99
For n1 = -1 To 1
For n2 = -1 To 1
For q = -25 To 25
v(s, n1, n2, q) = -999
Next
Next
Next
Next
s = 1
For n1 = -1 To 1
For n2 = -1 To 1
q = n2 - n1
v(s, n1, n2, q) = u(s, n1, n2)
Next
Next
For s = 2 To 99
For n1 = -1 To 1
For n2 = -1 To 1
For q = -25 To 25
qx = q + n1 - n2
pp = 0
If qx > 25 Then pp = 1
If qx < -25 Then pp = 1
If qx > 25 Then qx = 0
If qx < -25 Then qx = 0
vs = -999
For nx1 = -1 To 1
For nx2 = -1 To 1
v1 = u(s, n1, n2) + v(s - 1, nx1, nx2, qx)
If w(s - 1, nx1, nx2) > u(s, n1, n2) Then v1 = -999
If v1 > vs Then ns1 = nx1
If v1 > vs Then ns2 = nx2
If v1 > vs Then qxs = qx
If v1 > vs Then vs = v1
Next
Next
If pp = 1 Then vs = -999
v(s, n1, n2, q) = vs
gotoc(s, n1, n2, q) = ns1
gotoy(s, n1, n2, q) = ns2
gotoq(s, n1, n2, q) = qxs
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
qx = n1 - n2
vs = -999
For nx1 = -1 To 1
For nx2 = -1 To 1
v1 = u(100, n1, n2) + v(99, nx1, nx2, qx)
If w(99, nx1, nx2) > u(100, n1, n2) Then v1 = -999
If v1 > vs Then ns1 = nx1
If v1 > vs Then ns2 = nx2
If v1 > vs Then qxs = qx
If v1 > vs Then vs = v1
Next
Next
endc(n1, n2) = ns1
endy(n1, n2) = ns2
endq(n1, n2) = qxs
endv(n1, n2) = vs
Next
Next
vs = -999
For n1 = -1 To 1
For n2 = -1 To 1
If endv(n1, n2) > vs Then nx1 = n1
If endv(n1, n2) > vs Then nx2 = n2
If endv(n1, n2) > vs Then vs = endv(n1, n2)
Next
Next
Dim opc(1 To 100) As Single
Dim opy(1 To 100) As Single
Dim opq(1 To 100) As Single
Dim e As Single
opc(100) = nx1
opy(100) = nx2
opq(100) = 0
opc(99) = endc(opc(100), opy(100))
opy(99) = endy(opc(100), opy(100))
opq(99) = endq(opc(100), opy(100))
For j = 1 To 98
s = 99 - j
opc(s) = gotoc(s + 1, opc(s + 1), opy(s + 1), opq(s + 1))
opy(s) = gotoy(s + 1, opc(s + 1), opy(s + 1), opq(s + 1))
opq(s) = gotoq(s + 1, opc(s + 1), opy(s + 1), opq(s + 1))
Next
e = 0
For s = 1 To 100
e = e + opc(s) ^ 2 + opy(s) ^ 2
Next
If e < 2 Then h = h / 2
If h < 10 ^ (-5) Then t = 1000
Debug.Print t, h, e, endv(0, 0)
For s = 1 To 100
c(s) = c(s) + opc(s) * h
y(s) = y(s) + opy(s) * h
Next
t = t + 1
Loop
For s = 1 To 99
y1 = y(s + 1) - y(s)
c1 = c(s + 1) - c(s)
If y1 > 0 Then Debug.Print y(s), 1 - c1 / y1
Next
End Sub