plo - プログラム倉庫

Function mlx(s1 As Single, s2 As Single, tk As Single, tl As Single, tr As Single, th1, th2) As Single
Dim w1 As Single
Dim w2 As Single
w1 = (1 - tk) * th1(s1)
w2 = (1 - tl) * th2(s2)
l1 = 1 - (w1 + w2 + tr) / (3 * w1)
l2 = 1 - (w1 + w2 + tr) / (3 * w2)
If l2 < 0 Then l1 = 1 - (w1 + tr) / (2 * w1)
If l1 < 0 Then l1 = 0
mlx = l1
End Function
Function flx(s1 As Single, s2 As Single, tk As Single, tl As Single, tr As Single, th1, th2) As Single
Dim w1 As Single
Dim w2 As Single
w1 = (1 - tk) * th1(s1)
w2 = (1 - tl) * th2(s2)
l1 = 1 - (w1 + w2 + tr) / (3 * w1)
l2 = 1 - (w1 + w2 + tr) / (3 * w2)
If l1 < 0 Then l2 = 1 - (w2 + tr) / (2 * w2)
If l2 < 0 Then l2 = 0
flx = l2
End Function

Function cx(s1 As Single, s2 As Single, tk As Single, tl As Single, tr As Single, th1, th2) As Single
Dim w1 As Single
Dim w2 As Single
w1 = (1 - tk) * th1(s1)
w2 = (1 - tl) * th2(s2)
l1 = mlx(s1, s2, tk, tl, tr, th1, th2)
l2 = flx(s1, s2, tk, tl, tr, th1, th2)
cx = w1 * l1 + w2 * l2 + tr
End Function


Function u(c1 As Single, l1 As Single, l2 As Single) As Single
u = Log(c1) + Log(1 - l1) + Log(1 - l2)
End Function
Function tls(th1, th2) As Single
Dim n As Single
Dim m1 As Single
Dim m2 As Single
Dim tl As Single
Dim tk As Single
Dim tr As Single
Dim c(0 To 10, 0 To 10) As Single
Dim maxw As Single
Dim maxtk As Single
Dim w1 As Single
maxw = -999
For m = 1 To 50
For n = 1 To 50
tk = 0.01 * m
tl = 0.01 * n
tr = trs(tk, tl, th1, th2)
w1 = wel(tk, tl, tr, th1, th2)
If w1 > maxw Then maxtl = tl
If w1 > maxw Then maxw = w1
Next
Next
tls = maxtl
End Function
Function tks(th1, th2) As Single
Dim n As Single
Dim m1 As Single
Dim m2 As Single
Dim tl As Single
Dim tk As Single
Dim tr As Single
Dim c(0 To 10, 0 To 10) As Single
Dim maxw As Single
Dim maxtk As Single
Dim w1 As Single
maxw = -999
For m = 1 To 50
For n = 1 To 50
tk = 0.01 * m
tl = 0.01 * n
tr = trs(tk, tl, th1, th2)
w1 = wel(tk, tl, tr, th1, th2)
If w1 > maxw Then maxtk = tk
If w1 > maxw Then maxw = w1
Next
Next
tks = maxtk
End Function


Function trs(tk As Single, tl As Single, th1, th2) 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 t As Single
tr1 = 0.01
b1 = bud(tk, tl, tr1, th1, th2)
tr2 = 0.5
b2 = bud(tk, tl, tr2, th1, th2)
t = 0
Do Until t > 100
tr3 = (tr1 + tr2) / 2
b3 = bud(tk, tl, tr3, th1, th2)
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(tk As Single, tl As Single, tr As Single, th1, th2) As Single
Dim b1 As Single
Dim s As Single
Dim s1 As Single
Dim s2 As Single
b1 = 0
For s1 = 1 To 10
For s2 = 1 To 10
l1 = mlx(s1, s2, tk, tl, tr, th1, th2)
l2 = flx(s1, s2, tk, tl, tr, th1, th2)
c1 = cx(s1, s2, tk, tl, tr, th1, th2)
b1 = b1 + th1(s1) * l1 + th2(s2) * l2 - c1
Next
Next
bud = b1
End Function
Function wel(tk As Single, tl As Single, tr As Single, th1, th2) As Single
Dim w1 As Single
Dim l2 As Single
Dim l1 As Single
Dim c1 As Single
Dim s1 As Single
Dim s2 As Single
w1 = 0
For s1 = 1 To 10
For s2 = 1 To 10
l1 = mlx(s1, s2, tk, tl, tr, th1, th2)
l2 = flx(s1, s2, tk, tl, tr, th1, th2)
c1 = cx(s1, s2, tk, tl, tr, th1, th2)
w1 = w1 + u(c1, l1, l2)
Next
Next
wel = w1
End Function

Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim th1(1 To 10) As Single
Dim th2(1 To 10) As Single
Dim y1(0 To 10) As Single
Dim y2(0 To 10) As Single
Dim c(0 To 10, 0 To 10) As Single
Dim tl As Single
Dim tk As Single
Dim tr As Single
Dim s1 As Single
For s = 1 To 10
th1(s) = 0.2 * s
th2(s) = 0.1 * s
Next
tl = tls(th1, th2)
tk = tks(th1, th2)
tr = trs(tk, tl, th1, th2)
Debug.Print tk, tl, tr
Open "c:/lupin.txt" For Output As #1
For m1 = 0 To 10
For m2 = 0 To 10
Write #1, m1, m2, c(m1, m2)
Next
Next
Close #1
End Sub