step1 11 - プログラム倉庫

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 we As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
we = 0
For s = 1 To 100
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
cs = (1 - tl) * th(s) * ls + tr
we = we + Log(cs) + Log(1 - ls)
Next
wel = we
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 = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
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 100) As Single
Dim s As Single
Dim tl As Single
Dim tr As Single
For s = 1 To 100
th(s) = 0.02 * s
Next
tl = tls(th)
tr = trs(th, tl)
Debug.Print tl, tr

End Sub