ｍｌ２ - プログラム倉庫

Function tls(th1, th2, y) As Single
Dim n As Single
Dim m As Single
Dim tl As Single
Dim tr As Single
Dim c(0 To 10) As Single
Dim maxw As Single
Dim maxtl As Single
Dim w1 As Single
maxw = -999
For n = 1 To 60
tl = 0.01 * n
tr = trs(tl, th1, th2, y)
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr
Next
w1 = wel(th1, th2, c, y)
If w1 > maxw Then maxtl = tl
If w1 > maxw Then maxw = w1
Next
tls = maxtl
End Function
Function trs(tl As Single, th1, th2, y) As Single
Dim m As Single
Dim tr1 As Single
Dim tr2 As Single
Dim tr3 As Single
Dim b1 As Single
Dim b2 As Single
Dim b3 As Single
Dim c(0 To 10) As Single
Dim t As Single
tr1 = 0.01
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr1
Next
b1 = bud(th1, th2, c, y)
tr2 = 0.5
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr2
Next
b2 = bud(th1, th2, c, y)
t = 0
Do Until t > 100
tr3 = (tr1 + tr2) / 2
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr3
Next
b3 = bud(th1, th2, c, y)
If b3 > 0 Then b1 = b3
If b3 > 0 Then tr1 = tr3
If b3 < 0 Then b2 = b3
If b3 < 0 Then tr2 = tr3
If b3 ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
trs = tr1
End Function
Function bud(th1, th2, c, y) As Single
Dim b1 As Single
Dim s1 As Single
Dim s2 As Single
Dim m As Single
b1 = 0
For s1 = 1 To 25
For s2 = 1 To 10
m = prefer(s1, s2, th1, th2, c, y)
b1 = b1 + y(m) - c(m)
Next
Next
bud = b1
End Function
Function wel(th1, th2, c, y) As Single
Dim w1 As Single
Dim s1 As Single
Dim s2 As Single
Dim m As Single
w1 = 0
For s1 = 1 To 25
For s2 = 1 To 10
m = prefer(s1, s2, th1, th2, c, y)
w1 = w1 + Log(c(m) + th2(s2)) + Log(1 - y(m) / th1(s1))
Next
Next
wel = w1
End Function

Function prefer(s1 As Single, s2 As Single, th1, th2, c, y) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim l1 As Single
maxu = -999
For m = 0 To 10
c1 = c(m) + th2(s2)
l1 = y(m) / th1(s1)
pp = 0
If l1 > 0.99 Then pp = 1
If l1 > 0.99 Then l1 = 0.5
If c1 < 0.01 Then pp = 1
If c1 < 0.01 Then c1 = 0.5
u1 = Log(c1) + Log(1 - l1)
If pp = 1 Then u1 = -999
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function

Private Sub Command1_Click()
Dim s1 As Single
Dim s2 As Single
Dim m As Single
Dim tl As Single
Dim tr As Single
Dim th1(1 To 25) As Single
Dim th2(1 To 10) As Single
Dim y(0 To 10) As Single
Dim c(0 To 10) As Single
For s1 = 1 To 25
th1(s1) = 0.08 * s1
Next
For s2 = 1 To 10
th2(s2) = 0.01 * s2
Next
For m = 0 To 10
y(m) = 0.1 * m
Next
tl = tls(th1, th2, y)
tr = trs(tl, th1, th2, y)
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr
Next
Debug.Print tl, tr
For m = 0 To 10
c(m) = (1 - tl) * y(m) + tr
Next
Open "c:/401.txt" For Output As #1
For m = 0 To 10
Write #1, m, y(m), c(m)
Next
Close #1
End Sub