効用関数の近似 - プログラム倉庫

Function nearu(s As Single, mx As Single, nx As Single, u) As Single
Dim m1 As Single
Dim m2 As Single
Dim m3 As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim pp As Single
Dim dm As Single
Dim dn As Single
Dim nu As Single
pp = 0
m1 = mx
n1 = nx
If m1 < 1 Then pp = 1
If m1 < 1 Then m1 = 1
If m1 > 99 Then pp = 1
If m1 > 99 Then m1 = 99
If n1 < -19 Then pp = 1
If n1 < -19 Then n1 = -19
If n1 > 19 Then pp = 1
If n1 > 19 Then n1 = 19
m2 = Int(m1)
m3 = m2 + 1
n2 = Int(n1)
n3 = n2 + 1
dm = (m1 - m2) * (u(s, m3, n2) - u(s, m2, n2))
dn = (n1 - n2) * (u(s, m2, n3) - u(s, m2, n2))
nu = u(s, m2, n2) + dm + dn
If pp = 1 Then nu = -999
nearu = nu
End Function


Function seeku(s As Single, th, wp As Single, bp As Single) As Single
Dim ls As Single
Dim cs As Single
Dim us As Single
Dim ys As Single
Dim ws As Single
Dim l1 As Single
Dim c1 As Single
Dim u1 As Single
Dim l2 As Single
Dim y2 As Single
Dim y1 As Single
Dim c2 As Single
Dim u2 As Single
Dim h As Single
Dim lp As Single
Dim t1 As Single
Dim t2 As Single
Dim e As Single
e = 10 ^ (-5)
h = 0.1
ls = (bp + 0.1) / th(s)
ys = th(s) * ls
cs = ys - bp
us = Log(cs) + Log(1 - ls)
ws = Log(cs) + Log(1 - ys / th(s + 1))
If ws > wp Then us = -999
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
l1 = ls + h
If l1 > 0.99 Then l1 = ls
c1 = th(s) * l1 - bp
y1 = th(s) * l1
u1 = Log(c1) + Log(1 - l1)
w1 = Log(c1) + Log(1 - y1 / th(s + 1))
If w1 > wp Then u1 = -999
l2 = ls - h
If l2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
If c2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
y2 = th(s) * l2
u2 = Log(c2) + Log(1 - l2)
w2 = Log(c2) + Log(1 - y2 / th(s + 1))
If w2 > wp Then u2 = -999
If u1 > us Then ls = l1
If u1 > us Then us = u1
If u2 > us Then ls = l2
If u2 > us Then us = u2
If (lp - ls) ^ 2 < e Then t1 = 1000
lp = ls
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
seeku = us
End Function
Private Sub Command1_Click()
Dim u(1 To 9, 1 To 100, -20 To 20) As Single
Dim b(-100 To 100) As Single
Dim w(1 To 100) As Single
Dim m As Single
Dim n As Single
Dim w0 As Single
Dim th(1 To 10) As Single
Dim s As Single
For s = 1 To 10
th(s) = 1 + 0.01 * s
Next
For m = -20 To 20
b(m) = 0.01 * m
Next
w1 = Log(0.4) + Log(0.4)
ww = (Log(0.7) + Log(0.7) - w1) / 100
For n = 1 To 100
w(n) = w1 + ww * n
Next
For s = 1 To 9
For m = 1 To 100
For n = -20 To 20
u(s, m, n) = seeku(s, th, w(m), b(n))
Next
Next
Debug.Print s
Next
Debug.Print nearu(5, 20, 10, u)
End Sub