ppp - プログラム倉庫

Function bud(th, c, y) As Single
Dim s As Single
Dim w1 As Single
Dim theta As Single
Dim c1 As Single
Dim y1 As Single
b1 = 0
For s = 1 To 10
m = prefer(s, th, c, y)
theta = th(s)
c1 = c(m)
y1 = y(m)
b1 = b1 + y1 - c1
Next
bud = b1
End Function
Function wel(th, c, y) As Single
Dim s As Single
Dim w1 As Single
Dim theta As Single
Dim c1 As Single
Dim y1 As Single
w1 = 0
For s = 1 To 10
m = prefer(s, th, c, y)
theta = th(s)
c1 = c(m)
y1 = y(m)
w1 = w1 + u(theta, c1, y1)
Next
wel = w1
End Function

Function prefer(s As Single, th, c, y) As Single
Dim m As Single
Dim u1 As Single
Dim maxu As Single
Dim maxm As Single
Dim theta As Single
Dim c1 As Single
Dim y1 As Single
maxu = -999
theta = th(s)
For m = 1 To 2
c1 = c(m)
y1 = y(m)
u1 = u(theta, c1, y1)
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function
Function u(theta As Single, c1 As Single, y1 As Single) As Single
Dim pp As Single
Dim u1 As Single
Dim c2 As Single
Dim l2 As Single
pp = 0
c2 = c1
l2 = y1 / theta
If c2 < 0 Then pp = 1
If c2 = 0 Then pp = 1
If l2 > 0.99 Then pp = 1
If pp = 1 Then c2 = 0.5
If pp = 1 Then l2 = 0.5
u1 = Log(c2) + Log(1 - l2)
If pp = 1 Then u1 = -999
u = u1
End Function
Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim q As Single

Dim th(1 To 10) 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 cp(1 To 2, 1 To 9) As Single
Dim yp(1 To 2, 1 To 9) As Single
Dim h As Single
Dim i As Single
Dim j As Single
For s = 1 To 10
th(s) = 0.2 * s
Next
ys(1) = 0
cs(1) = 0.01
cs(2) = 0.44
ys(2) = 0.5
For m = 1 To 2
c(m) = cs(m)
y(m) = ys(m)
Next
h = 0.1
t = 0
Do Until t > 100
i = -1
j = -1
For q = 1 To 9
cp(2, q) = cs(2) + h * i
yp(2, q) = ys(2) + h * j
j = j + 1
If j = 2 Then i = i + 1
If j = 2 Then j = -1
Next
ws = -999
For q = 1 To 9
c(1) = cs(1)
y(1) = ys(1)
c(2) = cp(2, q)
y(2) = yp(2, q)
w1 = wel(th, c, y)
b1 = bud(th, c, y)
If b1 < 0 Then w1 = -999
If w1 > ws Then qs = q
If w1 > ws Then ws = w1
Next
cs(2) = cp(2, qs)
ys(2) = yp(2, qs)
If (qs - 5) ^ 2 < 10 ^ (-2) Then h = h / 2
If h < 10 ^ (-4) Then t = 1000
Debug.Print t, qs, ws
t = t + 1
Loop

End Sub