けいろ - プログラム倉庫

Function checknowork(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
checknowork = u1
End Function
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
u1 = s * u1
If pp = 1 Then u1 = -999
seeknowork = u1
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 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
s = a1
m = a2
n = a3
v(s, m, n) = a4
gotow(s, m, n) = a5
gotob(s, m, n) = a6
Loop
Close #3
For s = 1 To 100
th(s) = 0.02 * s
Next
h = 10 ^ (-3)
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 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
Debug.Print n, m
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
opb(100) = ns
Debug.Print opb(100)
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))
Debug.Print s, opw(s), opb(s)
If opb(s) > 200 Then startpoint = s
If opb(s) > 200 Then s = -10
Loop
Debug.Print startpoint
End Sub