準備 ｎ - プログラム倉庫

Function lx(s As Single, th, tl As Single, tr As Single) As Single
Dim ls As Single
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
lx = ls
End Function
Function cx(s As Single, th, tl As Single, tr As Single) As Single
Dim ls As Single
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
cx = (1 - tl) * th(s) * ls + tr
End Function

Function tls(th) As Single
Dim maxw As Single
Dim tl As Single
Dim tr As Single
Dim tp As Single
Dim w1 As Single
Dim n As Single
maxw = -999
For n = 1 To 400
tl = 0.001 * n
tr = trs(th, tl)
w1 = wel(th, tl, tr)
If w1 > maxw Then tp = tl
If w1 > maxw Then maxw = w1
Next
tls = tp
End Function

Function trs(th, tl As Single) As Single
Dim tr1 As Single
Dim tr2 As Single
Dim tr3 As Single
Dim b1 As Single
Dim b2 As Single
Dim t As Single
tr1 = 0
tr2 = 0.1
t = 0
Do Until t > 100
b1 = bud(th, tl, tr1)
b2 = bud(th, tl, tr2)
tr3 = tr2 - b2 * (tr2 - tr1) / (b2 - b1)
tr1 = tr2
tr2 = tr3
If (tr1 - tr2) ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
trs = tr2
End Function
Function wel(th, tl As Single, tr As Single) As Single
Dim w1 As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
w1 = 0
For s = 1 To 100
ls = lx(s, th, tl, tr)
If ls < 0 Then ls = 0
cs = cx(s, th, tl, tr)
w1 = w1 + Log(cs) + Log(1 - ls)
Next
wel = w1
End Function
Function bud(th, tl As Single, tr As Single) As Single
Dim w1 As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
Dim ys As Single
ys = 0
cs = 0
For s = 1 To 100
ls = lx(s, th, tl, tr)
If ls < 0 Then ls = 0
ys = ys + th(s) * ls
cs = cs + cx(s, th, tl, tr)
Next
bud = ys - cs
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 q As Single
Dim mx As Single
Dim nx As Single
Dim qx As Single
Dim tl As Single
Dim tr As Single
Dim cs(1 To 100) As Single
Dim ys(1 To 100) As Single
Dim u(1 To 100, -10 To 10, -10 To 10) As Single
Dim w(1 To 99, -10 To 10, -10 To 10) As Single
Dim v(1 To 100, -10 To 10, -10 To 10, -10 To 10) As Single
Dim h As Single
Dim c1 As Single
Dim y1 As Single
Dim don As Single

For s = 1 To 100
th(s) = 0.5 + 0.01 * s
Next
tl = tls(th)
tr = trs(th, tl)
For s = 1 To 100
cs(s) = cx(s, th, tl, tr)
ys(s) = th(s) * lx(s, th, tl, tr)
Next
h = 0.001
For s = 1 To 100
For m = -10 To 10
For n = -10 To 10
c1 = cs(s) + m * h
y1 = ys(s) + n * h
l1 = y1 / th(s)
don = 0
If l1 < 0 Then don = 1
If l1 < 0 Then l1 = 0
If l1 > 0.99 Then don = 1
If l1 > 0.99 Then l1 = 0.99
u1 = Log(c1) + Log(1 - l1)
u(s, m, n) = u1
If don = 1 Then u1 = -999
Next
Next
Debug.Print s
Next
For s = 1 To 99
For m = -10 To 10
For n = -10 To 10
c1 = cs(s) + m * h
y1 = ys(s) + n * h
l1 = y1 / th(s + 1)
don = 0
If l1 < 0 Then don = 1
If l1 < 0 Then l1 = 0
If l1 > 0.99 Then don = 1
If l1 > 0.99 Then l1 = 0.99
u1 = Log(c1) + Log(1 - l1)
w(s, m, n) = u1
If don = 1 Then u1 = -999
Next
Next
Debug.Print s
Next
For m = -10 To 10
For n = -10 To 10
u1 = u(1, m, n)
q = n - m
don = 0
If q > 10 Then don = 1
If q > 10 Then q = 10
If q < -10 Then don = 1
If q < -10 Then q = -10
If don = 1 Then u1 = -999
v(1, q, m, n) = u1
Next
Next
For s = 2 To 99
For q = -10 To 10
For m = -5 To 5
For n = -5 To 5
u1 = u(s, m, n)
qx = q - n + m
don = 0
If qx > 10 Then don = 1
If qx > 10 Then qx = 10
If qx < -10 Then don = 1
If qx < -10 Then qx = -10
vs = -999
For mx = -5 To 5
For nx = -5 To 5
v1 = v(s - 1, qx, mx, nx)
dondon = 0
If w(s - 1, mx, nx) > u1 Then dondon = 1
v2 = u1 + v1
If dondon = 1 Then v2 = -999
If v2 > vs Then vs = v2
Next
Next
If don = 1 Then vs = -999
v(s, q, m, n) = vs
Next
Next
Next
Debug.Print s, v(s, 0, 0, 0)
Next
End Sub