３３３３ - プログラム倉庫

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, 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
j = 3
bxs = 0
uxs = nearu(s, m, bxs, u)
wxs = seekw(uxs)
ps = 0
If wxs < -900 Then ps = 1
If wxs < -900 Then wxs = ws(s - 1)
mxs = (wxs - ws(s - 1)) / h
nxs = n - bxs
vxs = uxs + nearv(s - 1, mxs, nxs, v)
If ps = 1 Then vxs = -999
bxp = 888
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
bx1 = bxs + j
ux1 = nearu(s, m, bx1, u)
wx1 = seekw(ux1)
p1 = 0
If wx1 < -900 Then p1 = 1
If wx1 < -900 Then wx1 = ws(s - 1)
mx1 = (wx1 - ws(s - 1)) / h
nx1 = n - bx1
vx1 = ux1 + nearv(s - 1, mx1, nx1, v)
If p1 = 1 Then vx1 = -999
bx2 = bxs - j
ux2 = nearu(s, m, bx2, u)
wx2 = seekw(ux2)
p2 = 0
If wx2 < -900 Then p2 = 1
If wx2 < -900 Then wx2 = ws(s - 1)
mx2 = (wx2 - ws(s - 1)) / h
nx2 = n - bx2
vx2 = ux2 + nearv(s - 1, mx2, nx2, v)
If p2 = 1 Then vx2 = -999
If vx1 > vxs Then bxs = bx1
If vx1 > vxs Then vxs = vx1
If vx2 > vxs Then bxs = bx2
If vx2 > vxs Then vxs = vx2
If (bxp - bxs) ^ 2 < 10 ^ (-9) Then t1 = 1000
bxp = bxs
t1 = t1 + 1
Loop
t2 = t2 + 1
j = j / 2
Loop
seekv = vxs
End Function
Function nearu(s As Single, m As Single, n As Single, u) As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim pp As Single
Dim dn As Single
Dim nu As Single
pp = 0
n1 = n
If n1 < -5 Then pp = 1
If n1 < -5 Then n1 = -5
If n1 > 4 Then pp = 1
If n1 > 4 Then n1 = 4
n2 = Int(n1)
n3 = n2 + 1
dn = (n1 - n2) * (u(s, m, n3) - u(s, m, n2))
If u(s, m, n2) < -900 Then pp = 1
If u(s, m, n3) < -900 Then pp = 1
nu = u(s, m, n2) + dn
If pp = 1 Then nu = -999
nearu = nu
End Function

Function nearv(s As Single, mx As Single, nx As Single, v) As Single
Dim m1 As Single
Dim m2 As Single
Dim m3 As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim pp As Single
Dim dm As Single
Dim dn As Single
Dim nv As Single
pp = 0
m1 = mx
n1 = nx
If m1 < -5 Then pp = 1
If m1 < -5 Then m1 = -4
If m1 > 4 Then pp = 1
If m1 > 4 Then m1 = 4
If n1 < -25 Then pp = 1
If n1 < -25 Then n1 = 9
If n1 > 24 Then pp = 1
If n1 > 24 Then n1 = 9
m2 = Int(m1)
m3 = m2 + 1
n2 = Int(n1)
n3 = n2 + 1
dm = (m1 - m2) * (v(s, m3, n2) - v(s, m2, n2))
dn = (n1 - n2) * (v(s, m2, n3) - v(s, m2, n2))
If v(s, m2, n2) < -900 Then pp = 1
If v(s, m3, n2) < -900 Then pp = 1
If v(s, m2, n3) < -900 Then pp = 1
nv = v(s, m2, n2) + dm + dn
If pp = 1 Then nv = -999
nearv = nv
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
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 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
s = a1
m = a2
n = a3
u(s, m, n) = a4
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
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, u, v)
If nowork(s, m, n) > v(s, m, n) Then v(s, m, n) = nowork(s, m, n)
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)
Next
Next
Next
Close #3
End Sub