４４４５ - プログラム倉庫

Function seeky(s As Single, m As Single, n As Single, h As Single, ws, c, y, bigc, bigy, u, v) As Single
Dim bxs As Single
Dim bx1 As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim ux1 As Single
Dim wx1 As Single
Dim mx1 As Single
Dim nx1 As Single
Dim ux2 As Single
Dim wx2 As Single
Dim mx2 As Single
Dim nx2 As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim t2 As Single
Dim ps As Single
Dim p1 As Single
Dim p2 As Single
vs = -999
For j = -5 To 5
bxs = j
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
uxs = u(s, m, bxs)
wxs = seekw(uxs)
mxs = Int((wxs - ws(s - 1)) / h)
ps = 0
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = -5
If mxs < -5 Then mxs = 1
nxs = n - bxs
If nxs < -25 Then ps = 1
If nxs < -25 Then nxs = -25
If nxs > 25 Then ps = 1
If nxs > 25 Then nxs = 25
v1 = uxs + v(s - 1, mxs, nxs)
c2 = bigc(s - 1, mxs, nxs)
y2 = bigy(s - 1, mxs, nxs)
If c2 > c1 Then ps = 1
If y2 > y1 Then ps = 1
If ps = 1 Then v1 = -999
If v1 > vs Then ys = y1
If v1 > vs Then vs = v1
Next
seeky = ys
End Function

Function seekc(s As Single, m As Single, n As Single, h As Single, ws, c, y, bigc, bigy, u, v) As Single
Dim bxs As Single
Dim bx1 As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim ux1 As Single
Dim wx1 As Single
Dim mx1 As Single
Dim nx1 As Single
Dim ux2 As Single
Dim wx2 As Single
Dim mx2 As Single
Dim nx2 As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim t2 As Single
Dim ps As Single
Dim p1 As Single
Dim p2 As Single
vs = -999
For j = -5 To 5
bxs = j
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
uxs = u(s, m, bxs)
wxs = seekw(uxs)
mxs = Int((wxs - ws(s - 1)) / h)
ps = 0
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = -5
If mxs < -5 Then mxs = 1
nxs = n - bxs
If nxs < -25 Then ps = 1
If nxs < -25 Then nxs = -25
If nxs > 25 Then ps = 1
If nxs > 25 Then nxs = 25
v1 = uxs + v(s - 1, mxs, nxs)
c2 = bigc(s - 1, mxs, nxs)
y2 = bigy(s - 1, mxs, nxs)
If c2 > c1 Then ps = 1
If y2 > y1 Then ps = 1
If ps = 1 Then v1 = -999
If v1 > vs Then cs = c1
If v1 > vs Then vs = v1
Next
seekc = cs
End Function
Function seekw(wp As Single) As Single
Dim x1 As Single
Dim x2 As Single
Dim x3 As Single
Dim w1 As Single
Dim w2 As Single
Dim t As Single
Dim pp As Single
pp = 0
If wp < 2 * Log(0.1) Then pp = 1
If wp > 2 * Log(1) Then pp = 1
x1 = 0.3
x2 = 0.7
t = 0
If pp = 1 Then t = 1000
Do Until t > 100
w1 = 2 * Log(x1)
w2 = 2 * Log(x2)
x3 = x2 + (wp - w2) * (x2 - x1) / (w2 - w1)
x1 = x2
x2 = x3
If (wp - w2) ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
If pp = 1 Then x2 = -999
seekw = x2
End Function
Function seektr(s As Single, m As Single, n As Single, h As Single, ws, bs) As Single
Dim bb As Single
Dim s1 As Single
Dim pp As Single
Dim c1 As Single
Dim u1 As Single
bb = 0
For s1 = 1 To s
bb = bb + bs(s1)
Next
bb = bb + h * n
c1 = -bb / s
seektr = c1
End Function
Function seeknowork(s As Single, m As Single, n As Single, h As Single, ws, bs) As Single
Dim bb As Single
Dim s1 As Single
Dim pp As Single
Dim c1 As Single
Dim u1 As Single
bb = 0
For s1 = 1 To s
bb = bb + bs(s1)
Next
bb = bb + h * n
c1 = -bb / s
pp = 0
If c1 < 0.01 Then pp = 1
If c1 < 0.01 Then c1 = 0.01
u1 = Log(c1) + Log(1)
If u1 > 2 * Log(ws(s) + m * h) Then pp = 1
u1 = s * u1
If pp = 1 Then u1 = -999
seeknowork = u1
End Function
Function seekv(s As Single, m As Single, n As Single, h As Single, ws, c, y, bigc, bigy, u, v) As Single
Dim bxs As Single
Dim bx1 As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim ux1 As Single
Dim wx1 As Single
Dim mx1 As Single
Dim nx1 As Single
Dim ux2 As Single
Dim wx2 As Single
Dim mx2 As Single
Dim nx2 As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim t2 As Single
Dim ps As Single
Dim p1 As Single
Dim p2 As Single
vs = -999
For j = -5 To 5
bxs = j
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
uxs = u(s, m, bxs)
wxs = seekw(uxs)
mxs = Int((wxs - ws(s - 1)) / h)
ps = 0
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = -5
If mxs < -5 Then mxs = 1
nxs = n - bxs
If nxs < -25 Then ps = 1
If nxs < -25 Then nxs = -25
If nxs > 25 Then ps = 1
If nxs > 25 Then nxs = 25
v1 = uxs + v(s - 1, mxs, nxs)
c2 = bigc(s - 1, mxs, nxs)
y2 = bigy(s - 1, mxs, nxs)
If c2 > c1 Then ps = 1
If y2 > y1 Then ps = 1
If ps = 1 Then v1 = -999
If v1 > vs Then vs = v1
Next
seekv = vs
End Function
Private Sub Command1_Click()
Dim th(1 To 100) As Single
Dim s As Single
Dim m As Single
Dim n As Single
Dim tl As Single
Dim tr As Single
Dim bs(1 To 100) As Single
Dim ws(1 To 100) As Single
Dim u(1 To 99, -5 To 5, -5 To 5) As Single
Dim c(1 To 99, -5 To 5, -5 To 5) As Single
Dim y(1 To 99, -5 To 5, -5 To 5) As Single
Dim bigc(1 To 99, -5 To 5, -25 To 25) As Single
Dim bigy(1 To 99, -5 To 5, -25 To 25) As Single
Dim v(1 To 99, -5 To 5, -25 To 25) As Single
Dim nowork(1 To 99, -5 To 5, -25 To 25) 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
Open "c:/101.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3
s = a1
ws(s) = a2
bs(s) = a3
Loop
Close #2
Open "c:/102.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2, a3, a4, a5, a6
s = a1
m = a2
n = a3
u(s, m, n) = a4
c(s, m, n) = a5
y(s, m, n) = a6
Loop
Close #1
For s = 1 To 100
th(s) = 0.02 * s
Next
h = 10 ^ (-2)
For s = 1 To 99
For m = -5 To 5
For n = -25 To 25
nowork(s, m, n) = seeknowork(s, m, n, h, ws, bs)
Next
Next
Next
For s = 1 To 99
For m = -5 To 5
For n = -25 To 25
v(s, m, n) = -999
Next
Next
Next
s = 1
For m = -5 To 5
For n = -5 To 5
v(s, m, n) = u(s, m, n)
If nowork(s, m, n) > v(s, m, n) Then v(s, m, n) = nowork(s, m, n)
Next
Next
s = 1
For m = -5 To 5
For n = -5 To 5
bigc(s, m, n) = c(s, m, n)
bigy(s, m, n) = y(s, m, n)
Next
Next
For s = 2 To 99
For m = -5 To 5
For n = -25 To 25
v(s, m, n) = seekv(s, m, n, h, ws, c, y, bigc, bigy, u, v)
bigc(s, m, n) = seekc(s, m, n, h, ws, c, y, bigc, bigy, u, v)
bigy(s, m, n) = seeky(s, m, n, h, ws, c, y, bigc, bigy, u, v)
If nowork(s, m, n) > v(s, m, n) Then v(s, m, n) = nowork(s, m, n)
If nowork(s, m, n) > v(s, m, n) Then bigy(s, m, n) = 0
If nowork(s, m, n) > v(s, m, n) Then bigc(s, m, n) = seektr(s, m, n, h, ws, bs)
Next
Next
Debug.Print s, v(s, 0, 0)
Next
Open "c:/103.txt" For Output As #3
For s = 1 To 99
For m = -5 To 5
For n = -25 To 25
Write #3, s, m, n, v(s, m, n), bigc(s, m, n), bigy(s, m, n)
Next
Next
Next
Close #3
End Sub