４ ４ ４ - プログラム倉庫

Function stopv(s As Single, m As Single, n As Single, nowork, 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 = m
n1 = n
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) * (nowork(s, m3, n2) - nowork(s, m2, n2))
dn = (n1 - n2) * (nowork(s, m2, n3) - nowork(s, m2, n2))
If nowork(s, m2, n2) < -900 Then pp = 1
If nowork(s, m3, n2) < -900 Then pp = 1
If nowork(s, m2, n3) < -900 Then pp = 1
nv = nowork(s, m2, n2) + dm + dn
If pp = 1 Then nv = -999
v1 = nearv(s, m, n, v)
x = 0
If nv > v1 Then x = 1
If nv = v1 Then x = 1
stopv = x
End Function






Function seekstartu(th, bp As Single) As Single
Dim ls As Single
Dim cs As Single
Dim us As Single
Dim ys As Single
Dim ws As Single
Dim l1 As Single
Dim c1 As Single
Dim u1 As Single
Dim l2 As Single
Dim y2 As Single
Dim y1 As Single
Dim c2 As Single
Dim u2 As Single
Dim h As Single
Dim lp As Single
Dim t1 As Single
Dim t2 As Single
Dim e As Single
e = 10 ^ (-5)
h = 0.1
ls = 0.5
ys = th(100) * ls
cs = ys - bp
us = Log(cs) + Log(1 - ls)
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
l1 = ls + h
c1 = th(100) * l1 - bp
u1 = Log(c1) + Log(1 - l1)
l2 = ls - h
If l2 < 0.01 Then l2 = ls
c2 = th(100) * l2 - bp
u2 = Log(c2) + Log(1 - l2)
If u1 > us Then ls = l1
If u1 > us Then us = u1
If u2 > us Then ls = l2
If u2 > us Then us = u2
If (lp - ls) ^ 2 < e Then t1 = 1000
lp = ls
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
seekstartu = us
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
If pp = 1 Then u1 = -999
seeknowork = u1
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 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 startu(-10 To 10) 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 v(1 To 99, -5 To 5, -25 To 25) As Single
Dim gotob(1 To 99, -5 To 5, -25 To 25) As Single
Dim gotow(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 stopwork(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
Open "c:/103.txt" For Input As #3
Do Until EOF(3)
Input #3, a1, a2, a3, a4, a5, a6, a7
s = a1
m = a2
n = a3
v(s, m, n) = a4
gotow(s, m, n) = a5
gotob(s, m, n) = a6
stopwork(s, m, n) = a7
Loop
Close #3
For s = 1 To 100
th(s) = 0.02 * s
Next
h = 10 ^ (-2)
For n = -10 To 10
bp = bs(100) + n * h
startu(n) = seekstartu(th, bp)
Next
Dim u1 As Single
Dim opb(1 To 100) As Single
Dim opw(1 To 100) As Single
vs = -999
For n = -10 To 10
u1 = startu(n)
m = Int((seekw(u1) - ws(99)) / h)
If m > 5 Then m = 5
v1 = startu(n) + v(99, m, -n)
If v1 > vs Then ms = m
If v1 > vs Then ns = n
If v1 > vs Then vs = v1
Next
Debug.Print ns
Dim stoppoint As Single
opw(99) = ms
opb(99) = -ns
s = 99
Do Until s < 10
s = s - 1
opb(s) = gotob(s + 1, opw(s + 1), opb(s + 1))
opw(s) = gotow(s + 1, opw(s + 1), opb(s + 1))
If stopwork(s, opw(s), opb(s)) = 1 Then stoppoint = s
If stopwork(s, opw(s), opb(s)) = 1 Then s = -10
Loop
Debug.Print stoppoint
Dim bu(1 To 100) As Single
bu(100) = opb(100)
For s = stoppoint + 1 To 99
bu(s) = opb(s) - opb(s - 1)
Next
For s = stoppoint + 1 To 99
Debug.Print s, c(s, opw(s), bu(s)), y(s, opw(s), bu(s))
Next
bs(100) = bs(100) + ns * h
For s = stoppoint + 1 To 99
c1 = c(s, opw(s), bu(s))
y1 = y(s, opw(s), bu(s))
bs(s) = y1 - c1
ws(s) = seekw(Log(c1) + Log(1 - y1 / th(s + 1)))
Next
s = stoppoint
w1 = seeknowork(s, opw(s), opb(s), h, ws, bs)
b1 = seektr(s, opw(s), opb(s), h, ws, bs)
For s = 1 To stoppoint
ws(s) = seekw(w1)
bs(s) = b1
Next
For s = 1 To 100
Debug.Print s, ws(s), bs(s)
Next
Open "c:/101.txt" For Output As #1
For s = 1 To 100
Write #1, s, ws(s), bs(s)
Next
Close #1

End Sub