stop - プログラム倉庫

Function seekgotow(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 vs As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim c2 As Single
Dim y2 As Single
Dim c1 As Single
Dim y1 As Single
vs = -999
For j = -5 To 5
bxs = j
uxs = u(s, m, bxs)
wxs = seekw(uxs)
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
ps = 0
If wxs < -900 Then ps = 1
If wxs < -900 Then wxs = ws(s - 1)
mxs = Int((wxs - ws(s - 1)) / h)
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = 1
If mxs < -5 Then mxs = -5
nxs = n - bxs
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 bxp = mxs
If v1 > vs Then vs = v1
Next
seekgotow = bxp
End Function

Function seekgotob(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 vs As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim c2 As Single
Dim y2 As Single
Dim c1 As Single
Dim y1 As Single
vs = -999
For j = -5 To 5
bxs = j
uxs = u(s, m, bxs)
wxs = seekw(uxs)
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
ps = 0
If wxs < -900 Then ps = 1
If wxs < -900 Then wxs = ws(s - 1)
mxs = Int((wxs - ws(s - 1)) / h)
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = 1
If mxs < -5 Then mxs = -5
nxs = n - bxs
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 bxp = nxs
If v1 > vs Then vs = v1
Next
seekgotob = bxp
End Function
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 vs As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim c2 As Single
Dim y2 As Single
Dim c1 As Single
Dim y1 As Single
vs = -999
For j = -5 To 5
bxs = j
uxs = u(s, m, bxs)
wxs = seekw(uxs)
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
ps = 0
If wxs < -900 Then ps = 1
If wxs < -900 Then wxs = ws(s - 1)
mxs = Int((wxs - ws(s - 1)) / h)
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = 1
If mxs < -5 Then mxs = -5
nxs = n - bxs
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 bxp = bxs
If v1 > vs Then vs = v1
Next
seeky = y(s, m, bxp)
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 vs As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim c2 As Single
Dim y2 As Single
Dim c1 As Single
Dim y1 As Single

vs = -999
For j = -5 To 5
bxs = j
uxs = u(s, m, bxs)
wxs = seekw(uxs)
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
ps = 0
If wxs < -900 Then ps = 1
If wxs < -900 Then wxs = ws(s - 1)
mxs = Int((wxs - ws(s - 1)) / h)
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = 1
If mxs < -5 Then mxs = -5
nxs = n - bxs
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 bxp = bxs
If v1 > vs Then vs = v1
Next
seekc = c(s, m, bxp)
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 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 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 vs As Single
Dim bx2 As Single
Dim uxs As Single
Dim wxs As Single
Dim mxs As Single
Dim nxs As Single
Dim j As Single
Dim t1 As Single
Dim bxp As Single
Dim c2 As Single
Dim y2 As Single
Dim c1 As Single
Dim y1 As Single
vs = -999
For j = -5 To 5
bxs = j
uxs = u(s, m, bxs)
wxs = seekw(uxs)
c1 = c(s, m, bxs)
y1 = y(s, m, bxs)
ps = 0
If wxs < -900 Then ps = 1
If wxs < -900 Then wxs = ws(s - 1)
mxs = Int((wxs - ws(s - 1)) / h)
If mxs > 5 Then mxs = 5
If mxs < -5 Then ps = 1
If mxs < -5 Then mxs = -5
nxs = n - bxs
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
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 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 gotow(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 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 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
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)
bigc(s, m, n) = c(s, m, n)
bigy(s, m, n) = y(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)
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, 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 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)
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
For s = 2 To 99
For m = -5 To 5
For n = -25 To 25
gotow(s, m, n) = seekgotow(s, m, n, h, ws, c, y, bigc, bigy, u, v)
gotob(s, m, n) = seekgotob(s, m, n, h, ws, c, y, bigc, bigy, u, v)
Next
Next
Next
For s = 2 To 99
For m = -5 To 5
For n = -25 To 25
stopwork(s, m, n) = 0
Next
Next
Next
For s = 2 To 99
For m = -5 To 5
For n = -25 To 25
If nowork(s, m, n) > v(s, m, n) Then stopwork(s, m, n) = 1
If nowork(s, m, n) = v(s, m, n) Then stopwork(s, m, n) = 1
Next
Next
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), gotow(s, m, n), gotob(s, m, n), stopwork(s, m, n)
Next
Next
Next
Close #3
End Sub