し - プログラム倉庫

Function wel(sel, th, c, y) As Single
Dim s As Single
Dim s1 As Single
w1 = 0
For s = 1 To 100
s1 = sel(s)
w1 = w1 + Log(c(s1)) + Log(1 - y(s1) / th(s))
Next
wel = w1
End Function

Function prefer(s As Single, th, c, y) As Single
Dim maxu As Single
Dim ws As Single
Dim x As Single
Dim s1 As Single
maxu = -999
For s1 = 1 To 2
pp = 0
c1 = c(s1)
If c1 < 0 Then pp = 1
If c1 = 0 Then pp = 1
l1 = y(s1) / th(s)
If l1 < 0 Then pp = 1
If l1 > 0.99 Then pp = 1
If pp = 1 Then c1 = 0.1
If pp = 1 Then l1 = 0.1
u1 = Log(c1) + Log(1 - l1)
If pp = 1 Then u1 = -999
If u1 > maxu Then x = s1
If u1 > maxu Then maxu = u1
Next
prefer = x
End Function
Function bud(sel, th, c, y) As Single
Dim s As Single
Dim s1 As Single
For s = 1 To 100
s1 = sel(s)
b1 = b1 + y(s1) - c(s1)
Next
bud = b1
End Function

Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim n As Single
Dim th(1 To 100) As Single
Dim cs(1 To 2) As Single
Dim ys(1 To 2) As Single
Dim c(1 To 2) As Single
Dim y(1 To 2) As Single
Dim sel(1 To 100) As Single
Dim maxw As Single
For s = 1 To 100
th(s) = 0.02 * s
Next
cs(1) = 0.03
ys(1) = 0
cs(2) = 0.3
ys(2) = 0.5
c(1) = cs(1)
y(1) = ys(1)

h = 0.2
Do Until t2 > 10
t1 = 0
h = h / 2
Do Until t1 > 100
maxw = -999
For i = -1 To 1
For j = -1 To 1
c(2) = cs(2) + h * i
y(2) = ys(2) + h * j
For s = 1 To 100
sel(s) = prefer(s, th, c, y)
Next
b1 = bud(sel, th, c, y)
w1 = wel(sel, th, c, y)
If b1 < 0 Then w1 = -999
If w1 > maxw Then opi = i
If w1 > maxw Then opj = j
If w1 > maxw Then maxw = w1
Next
Next
e = opi ^ 2 + opj ^ 2
If e < 0.01 Then t1 = 1000
cs(2) = cs(2) + opi * h
ys(2) = ys(2) + opj * h
c(2) = cs(2)
y(2) = ys(2)
For s = 1 To 100
sel(s) = prefer(s, th, c, y)
Next
Debug.Print t2, t1, wel(sel, th, c, y)
t1 = t1 + 1
Loop
t2 = t2 + 1
Loop

End Sub