xxx] - プログラム倉庫

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 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 asky(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
asky = y(s, m, bxp)
End Function
Function askc(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
askc = c(s, m, bxp)
End Function
Function askv(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
askv = vs
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 seeky(s As Single, th, wp As Single, 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 = (bp + 0.01) / th(s)
If ls < 0.01 Then ls = 0.01
ys = th(s) * ls
cs = ys - bp
us = Log(cs) + Log(1 - ls)
ws = Log(cs) + Log(1 - ys / th(s + 1))
If ws > wp Then us = -999
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
l1 = ls + h
If l1 > 0.99 Then l1 = ls
c1 = th(s) * l1 - bp
y1 = th(s) * l1
u1 = Log(c1) + Log(1 - l1)
w1 = Log(c1) + Log(1 - y1 / th(s + 1))
If w1 > wp Then u1 = -999
l2 = ls - h
If l2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
If c2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
y2 = th(s) * l2
u2 = Log(c2) + Log(1 - l2)
w2 = Log(c2) + Log(1 - y2 / th(s + 1))
If w2 > wp Then u2 = -999
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
seeky = th(s) * ls
End Function
Function seekc(s As Single, th, wp As Single, 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 = (bp + 0.01) / th(s)
If ls < 0.01 Then ls = 0.01
ys = th(s) * ls
cs = ys - bp
us = Log(cs) + Log(1 - ls)
ws = Log(cs) + Log(1 - ys / th(s + 1))
If ws > wp Then us = -999
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
l1 = ls + h
If l1 > 0.99 Then l1 = ls
c1 = th(s) * l1 - bp
y1 = th(s) * l1
u1 = Log(c1) + Log(1 - l1)
w1 = Log(c1) + Log(1 - y1 / th(s + 1))
If w1 > wp Then u1 = -999
l2 = ls - h
If l2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
If c2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
y2 = th(s) * l2
u2 = Log(c2) + Log(1 - l2)
w2 = Log(c2) + Log(1 - y2 / th(s + 1))
If w2 > wp Then u2 = -999
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
seekc = th(s) * ls - bp
End Function
Function seeku(s As Single, th, wp As Single, 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 = (bp + 0.01) / th(s)
If ls < 0.01 Then ls = 0.01
ys = th(s) * ls
cs = ys - bp
us = Log(cs) + Log(1 - ls)
ws = Log(cs) + Log(1 - ys / th(s + 1))
If ws > wp Then us = -999
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
l1 = ls + h
If l1 > 0.99 Then l1 = ls
c1 = th(s) * l1 - bp
y1 = th(s) * l1
u1 = Log(c1) + Log(1 - l1)
w1 = Log(c1) + Log(1 - y1 / th(s + 1))
If w1 > wp Then u1 = -999
l2 = ls - h
If l2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
If c2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
y2 = th(s) * l2
u2 = Log(c2) + Log(1 - l2)
w2 = Log(c2) + Log(1 - y2 / th(s + 1))
If w2 > wp Then u2 = -999
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
seeku = us
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
ps = 0
If wp < 2 * Log(0.1) Then ps = 1
x1 = 0.3
x2 = 0.7
t = 0
If ps > 0 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 ps = 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 startu(-5 To 5) 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 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 v(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 w1 As Single
Dim wp As Single
Dim bp As Single
Dim h 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
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 = -5 To 5
wp = 2 * Log(ws(s) + h * m)
bp = bs(s) + h * n
u(s, m, n) = seeku(s, th, wp, bp)
c(s, m, n) = seekc(s, th, wp, bp)
y(s, m, n) = seeky(s, th, wp, bp)
Next
Next
Next
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
Debug.Print s
For s = 2 To 99
For m = -5 To 5
For n = -25 To 25
v(s, m, n) = askv(s, m, n, h, ws, c, y, bigc, bigy, u, v)
bigc(s, m, n) = askc(s, m, n, h, ws, c, y, bigc, bigy, u, v)
bigy(s, m, n) = asky(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
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
For n = -5 To 5
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 = -5 To 5
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 vs
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
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
b1 = seektr(s, opw(s), opb(s), h, ws, bs)
w1 = Log(b1) + Log(1)
For s = 1 To stoppoint
ws(s) = seekw(w1)
bs(s) = -b1
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