最適線形３ - プログラム倉庫

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
b1 = b2
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
w1 = 0
For s = 1 To 10
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
cs = (1 - tl) * th(s) * ls + tr
w1 = w1 + Log(cs) + Log(1 - ls)
Next
wel = w1
End Function
Function bud(th, tl As Single, tr As Single) As Single
ys = 0
cs = 0
For s = 1 To 10
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
ys = ys + th(s) * ls
cs = cs + (1 - tl) * th(s) * ls + tr
Next
bud = ys - cs
End Function
Private Sub Command1_Click()
Dim th(1 To 10) As Single
Dim s As Single
Dim ls As Single
Dim tl As Single
Dim tr As Single
Dim w(0 To 40) As Single
tl = 0.3
tr = 0
For s = 1 To 10
th(s) = 1 + 0.1 * s
Next
For n = 1 To 40
tl = 0.01 * n
tr = trs(th, tl)
w(n) = wel(th, tl, tr)
Next
maxw = -999
For n = 1 To 40
If w(n) > maxw Then nx = n
If w(n) > maxw Then maxw = w(n)
Next
Debug.Print nx
End Sub