２部 - プログラム倉庫

Function wel(tl As Single, tr As Single, th) As Single
Dim x1 As Single
Dim c1 As Single
Dim s As Single
Dim w1 As Single
w1 = 0
For s = 1 To 100
x1 = 1 - lx(s, tl, tr, th)
c1 = cx(s, tl, tr, th)
w1 = w1 + u(c1, x1)
Next
wel = w1
End Function

Function trs(tl As Single, th) As Single
Dim tr1 As Single
Dim tr2 As Single
Dim tr3 As Single
Dim b1 As Single
Dim b2 As Single
Dim t1 As Single
tr1 = 0.1
tr2 = 0.2
b1 = bud(tl, tr1, th)
t1 = 0
Do Until t1 > 100
b2 = bud(tl, tr2, th)
tr3 = tr2 - b2 * (tr2 - tr1) / (b2 - b1)
b1 = b2
tr1 = tr2
tr2 = tr3
If b2 ^ 2 < 10 ^ (-5) Then t1 = 1000
t1 = t1 + 1
Loop
trs = tr2
End Function

Function tls(th) As Single
Dim n As Single
Dim tl As Single
Dim tr As Single
Dim maxw As Single
Dim ww As Single
maxw = -999
For n = 10 To 50
tl = 0.01 * n
tr = trs(tl, th)
ww = wel(tl, tr, th)
If ww > maxw Then tlp = tl
If ww > maxw Then maxw = ww
Next
tls = tlp
End Function
Function bud(tl As Single, tr As Single, th) As Single
Dim y1 As Single
Dim c1 As Single
Dim s As Single
Dim b1 As Single
b1 = 0
For s = 1 To 100
y1 = th(s) * lx(s, tl, tr, th)
c1 = cx(s, tl, tr, th)
b1 = b1 + y1 - c1
Next
bud = b1
End Function
Function con(s As Single, tl1 As Single, tl2 As Single, tr As Single, th) As Single
Dim l1 As Single
Dim tr1 As Single
Dim c1 As Single
Dim x1 As Single
Dim u1 As Single
Dim l2 As Single
Dim tr2 As Single
Dim c2 As Single
Dim x2 As Single
Dim u2 As Single
tr1 = tr
l1 = lx(s, tl1, tr1, rh)
If th(s) * l1 > 0.5 Then l1 = 0.5 / th(s)
c1 = (1 - tl1) * th(s) * l1 + tr1
x1 = 1 - l1
u1 = u(c1, x1)
tr2 = 0.5 * (1 - tl1) + tr - 0.5 * (1 - tl2)
l2 = lx(s, tl2, tr2, rh)
If th(s) * l2 < 0.5 Then l2 = 0.5 / th(s)
c2 = (1 - tl2) * th(s) * l2 + tr2
x2 = 1 - l2
u2 = u(c2, x2)
If u2 > u1 Then c1 = c2
con = c1
End Function
Function lab(s As Single, tl1 As Single, tl2 As Single, tr As Single, th) As Single
Dim l1 As Single
Dim tr1 As Single
Dim c1 As Single
Dim x1 As Single
Dim u1 As Single
Dim l2 As Single
Dim tr2 As Single
Dim c2 As Single
Dim x2 As Single
Dim u2 As Single
tr1 = tr
l1 = lx(s, tl1, tr1, th)
If th(s) * l1 > 0.5 Then l1 = 0.5 / th(s)
c1 = (1 - tl1) * th(s) * l1 + tr1
x1 = 1 - l1
u1 = u(c1, x1)
tr2 = 0.5 * (1 - tl1) + tr - 0.5 * (1 - tl2)
l2 = lx(s, tl2, tr2, th)
If th(s) * l2 < 0.5 Then l2 = 0.5 / th(s)
c2 = (1 - tl2) * th(s) * l2 + tr2
x2 = 1 - l2
u2 = u(c2, x2)
If u2 > u1 Then l1 = l2
lab = l1
End Function


Function lx(s As Single, tl As Single, tr As Single, th) As Single
Dim w1 As Single
Dim l1 As Single
w1 = (1 - tl) * th(s)
l1 = (w1 - tr) / (2 * w1)
If l1 < 0 Then l1 = 0
lx = l1
End Function

Function cx(s As Single, tl As Single, tr As Single, th) As Single
Dim w1 As Single
Dim l1 As Single
w1 = (1 - tl) * th(s)
l1 = lx(s, tl, tr, th)
cx = w1 * l1 + tr
End Function

Function u(c1 As Single, x1 As Single) As Single
Dim c2 As Single
Dim x2 As Single
Dim z As Single
c2 = c1
x2 = x1
z = 0
If c2 < 0 Then z = 100
If c2 = 0 Then z = 100
If x2 < 0 Then z = 100
If x2 = 0 Then z = 100
If x2 > 1 Then z = 100
If z = 100 Then c2 = 0.5
If z = 100 Then x2 = 0.5
u1 = Log(c2) + Log(x2)
If z > 50 Then u1 = -999
u = u1
End Function

Private Sub Command1_Click()
Dim s As Single
Dim th(1 To 100) As Single
Dim c(1 To 100) As Single
Dim y(1 To 100) As Single
Dim tl1 As Single
Dim tl2 As Single
Dim tr As Single
Dim h As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim m As Single
h = 0.01
For s = 1 To 100
th(s) = 0.02 * s
Next
tl1 = 0.38
tl2 = 0.38
tr = 0.15
For s = 1 To 100
Debug.Print lab(s, tl1, tl2, tr, th)
Next
End Sub