つおｍ - プログラム倉庫

Private Sub Command1_Click()
Dim th(1 To 300) As Single
Dim s As Single
Dim m As Single
Dim n As Single
Dim mx As Single
Dim nx As Single
Dim q As Single
Dim c1 As Single
Dim y1 As Single
Dim c2 As Single
Dim y2 As Single
Dim cs(1 To 300) As Single
Dim ys(1 To 300) As Single
Dim u(1 To 299, -1 To 1, -1 To 1) As Single
Dim w(1 To 299, -1 To 1, -1 To 1) As Single
Dim gotoc(1 To 299, -1 To 1, -1 To 1, -10 To 10) As Single
Dim gotoy(1 To 299, -1 To 1, -1 To 1, -10 To 10) As Single
Dim v(1 To 299, -1 To 1, -1 To 1, -10 To 10) As Single
Dim opc(1 To 300) As Single
Dim opy(1 To 300) As Single
Dim opq(1 To 300) As Single
Dim w1 As Single
Dim wp As Single
Dim bp As Single
Dim h As Single
Dim bb As Single
Dim s1 As Single
Dim time As Single
Open "c:/p1.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2
s = a1
th(s) = a2
Loop
Close #1
Open "c:/p2.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3
s = a1
cs(s) = a2
ys(s) = a3
Loop
Close #2
h = 10 ^ (-2)
time = 1
Do Until time > 100
For s = 1 To 299
For m = -1 To 1
For n = -1 To 1
c1 = cs(s) + m * h
y1 = ys(s) + n * h
l1 = y1 / th(s)
pp = 0
If l1 < 0 Then pp = 1
If l1 < 0 Then l1 = 0
If l1 > 0.99 Then pp = 1
If l1 > 0.99 Then l1 = 0.99
If c1 < 0.01 Then pp = 1
If c1 < 0.01 Then c1 = 0.01
u(s, m, n) = -1 / c1 - 1 / (1 - l1)
If pp = 1 Then u(s, m, n) = -9999
Next
Next
Next
For s = 1 To 299
For m = -1 To 1
For n = -1 To 1
c1 = cs(s) + m * h
y1 = ys(s) + n * h
l1 = y1 / th(s + 1)
pp = 0
If l1 < 0 Then pp = 1
If l1 < 0 Then l1 = 0
If l1 > 0.99 Then pp = 1
If l1 > 0.99 Then l1 = 0.99
If c1 < 0.01 Then pp = 1
If c1 < 0.01 Then c1 = 0.01
w(s, m, n) = -1 / c1 - 1 / (1 - l1)
If pp = 1 Then w(s, m, n) = -9999
Next
Next
Next
For s = 1 To 299
For m = -1 To 1
For n = -1 To 1
For q = -10 To 10
v(s, m, n, q) = -9999
Next
Next
Next
Next
s = 1
For m = -1 To 1
For n = -1 To 1
q = n - m
v(s, m, n, q) = u(s, m, n)
Next
Next
For s = 2 To 299
For m = -1 To 1
For n = -1 To 1
For q = -10 To 10
u1 = u(s, m, n)
c1 = cs(s) + m * h
y1 = ys(s) + n * h
qx = q + m - n
t = 0
If qx > 10 Then t = 1000
If qx < -10 Then t = 1000
vs = -9999
Do Until t > 10
For mx = -1 To 1
For nx = -1 To 1
pp = 0
w1 = w(s - 1, mx, nx)
If w1 > u1 Then pp = 1
c2 = cs(s - 1) + mx * h
y2 = ys(s - 1) + nx * h
If c2 > c1 Then pp = 1
If y2 > y1 Then pp = 1
If v(s - 1, mx, nx, qx) < -9000 Then pp = 1
v1 = u1 + v(s - 1, mx, nx, qx)
If pp = 1 Then v1 = -9999
If v1 > vs Then mxs = mx
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
Next
t = 1000
Loop
gotoc(s, m, n, q) = mxs
gotoy(s, m, n, q) = nxs
v(s, m, n, q) = vs
Next
Next
Next
Next
s = 300
vs = -9999
For m = -1 To 1
For n = -1 To 1
c1 = cs(s) + m * h
y1 = ys(s) + n * h
u1 = -1 / c1 - 1 / (1 - y1 / th(s))
qx = m - n
For mx = -1 To 1
For nx = -1 To 1
pp = 0
w1 = w(s - 1, mx, nx)
If w1 > u1 Then pp = 1
c2 = cs(s - 1) + mx * h
y2 = ys(s - 1) + nx * h
If c2 > c1 Then pp = 1
If y2 > y1 Then pp = 1
If v(s - 1, mx, nx, qx) < -9000 Then pp = 1
v1 = u1 + v(s - 1, mx, nx, qx)
If pp = 1 Then v1 = -9999
If v1 > vs Then ms = m
If v1 > vs Then ns = n
If v1 > vs Then mxs = mx
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
Next
Next
Next
opc(300) = ms
opy(300) = ns
opc(299) = mxs
opy(299) = nxs
opq(299) = ms - ns
For t = 1 To 298
s = 299 - t
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) = opq(s + 1) + opc(s + 1) - opy(s + 1)
Next
For s = 1 To 300
cs(s) = cs(s) + opc(s) * h
ys(s) = ys(s) + opy(s) * h
Next
e = 0
For s = 1 To 300
e = e + opc(s) ^ 2 + opy(s) ^ 2
Next
If e < 2 Then h = h / 2
If h < 10 ^ (-5) Then time = 10000
Debug.Print time, e, h, vs
time = time + 1
Loop
Dim rate(1 To 300) As Single
For s = 1 To 299
y1 = ys(s + 1) - ys(s)
c1 = cs(s + 1) - cs(s)
pp = 0
If y1 < 10 ^ (-5) Then pp = 1
If y1 < 10 ^ (-5) Then y1 = 1
R = 100 * (1 - c1 / y1)
If pp = 1 Then R = 0
rate(s) = R
Next
Open "c:/p3.txt" For Output As #1
For s = 1 To 299
Write #1, ys(s), rate(s)
Next
Close #1

End Sub