最適所得税の準備 - プログラム倉庫

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

Function tls(th) As Single
Dim maxw As Single
Dim tl As Single
Dim tr As Single
Dim tp As Single
Dim w1 As Single
Dim n As Single
maxw = -999
For n = 1 To 400
tl = 0.001 * n
tr = trs(th, tl)
w1 = wel(th, tl, tr)
If w1 > maxw Then tp = tl
If w1 > maxw Then maxw = w1
Next
tls = tp
End Function

Function trs(th, tl As Single) As Single
Dim tr1 As Single
Dim tr2 As Single
Dim tr3 As Single
Dim b1 As Single
Dim b2 As Single
Dim t As Single
tr1 = 0
tr2 = 0.1
t = 0
Do Until t > 100
b1 = bud(th, tl, tr1)
b2 = bud(th, tl, tr2)
tr3 = tr2 - b2 * (tr2 - tr1) / (b2 - b1)
tr1 = tr2
tr2 = tr3
If (tr1 - tr2) ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
trs = tr2
End Function
Function wel(th, tl As Single, tr As Single) As Single
Dim w1 As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
w1 = 0
For s = 1 To 100
ls = lx(s, th, tl, tr)
If ls < 0 Then ls = 0
cs = cx(s, th, tl, tr)
w1 = w1 + Log(cs) + Log(1 - ls)
Next
wel = w1
End Function
Function bud(th, tl As Single, tr As Single) As Single
Dim w1 As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
Dim ys As Single
ys = 0
cs = 0
For s = 1 To 100
ls = lx(s, th, tl, tr)
If ls < 0 Then ls = 0
ys = ys + th(s) * ls
cs = cs + cx(s, th, tl, tr)
Next
bud = ys - cs
End Function
Private Sub Command1_Click()
Dim th(1 To 100) As Single
Dim s As Single
Dim q As Single
Dim m As Single
Dim n As Single
Dim qx As Single
Dim mx As Single
Dim nx As Single
Dim h As Single
Dim tl As Single
Dim tr As Single
Dim ys(1 To 100) As Single
Dim cs(1 To 100) As Single
Dim u(1 To 100, -5 To 5, -5 To 5) As Single
Dim w(1 To 99, -5 To 5, -5 To 5) As Single
Dim v(1 To 100, -25 To 25, -5 To 5, -5 To 5) As Single
Dim c1 As Single
Dim y1 As Single
Dim c2 As Single
Dim y2 As Single
Dim l1 As Single
Dim u1 As Single
Dim z As Single
Dim z1 As Single
Dim z2 As Single
Dim vps As Single
Dim j As Single
Dim w1 As Single
For s = 1 To 100
th(s) = 0.02 * s
Next
tl = tls(th)
tr = trs(th, tl)
Debug.Print tl, tr
For s = 1 To 100
ys(s) = th(s) * lx(s, th, tl, tr)
cs(s) = cx(s, th, tl, tr)
Next
h = 0.001
For s = 1 To 100
For m = -5 To 5
For n = -5 To 5
c1 = cs(s) + h * m
y1 = ys(s) + h * n
l1 = y1 / th(s)
z = 0
If c1 < 0.01 Then z = 1
If c1 < 0.01 Then c1 = 1
If l1 < 0 Then z = 1
If l1 < 0 Then l1 = 0
If l1 > 0.99 Then z = 1
If l1 > 0.99 Then l1 = 0.99
u1 = Log(c1) + Log(1 - l1)
If z = 1 Then u1 = -999
u(s, m, n) = u1
Next
Next
Next
For s = 1 To 99
For m = -5 To 5
For n = -5 To 5
c1 = cs(s) + h * m
y1 = ys(s) + h * n
l1 = y1 / th(s + 1)
z = 0
If c1 < 0.01 Then z = 1
If c1 < 0.01 Then c1 = 1
If l1 < 0 Then z = 1
If l1 < 0 Then l1 = 0
If l1 > 0.99 Then z = 1
If l1 > 0.99 Then l1 = 0.99
u1 = Log(c1) + Log(1 - l1)
If z = 1 Then u1 = -999
w(s, m, n) = u1
Next
Next
Next
For s = 1 To 99
For q = -25 To 25
For m = -5 To 5
For n = -5 To 5
v(s, q, m, n) = -999
Next
Next
Next
Next
s = 1
For m = -5 To 5
For n = -5 To 5
q = m - n
v(s, q, m, n) = u(s, m, n)
Next
Next
For s = 2 To 99
For q = -25 To 25
For m = -5 To 5
For n = -5 To 5
u1 = u(s, m, n)
c1 = cs(s) + m * h
y1 = ys(s) + n * h
qx = q - m + n
z1 = 0
If qx > 25 Then z1 = 1
If qx > 25 Then qx = 25
If qx < -25 Then z1 = 1
If qx < -25 Then qx = -25
If u1 < -900 Then z1 = 1
vps = -999
For mx = -5 To 5
For nx = -5 To 5
v1 = v(s - 1, qx, mx, nx)
c2 = cs(s) + mx * h
y2 = ys(s) + nx * h
z2 = 0
If c2 > c1 Then z2 = 1
If y2 > y1 Then z2 = 1
w1 = w(s - 1, mx, nx)
If w1 > u1 Then z2 = 1
vp = u1 + v1
If z2 = 1 Then vp = -999
If vp > vps Then vps = vp
Next
Next
If z1 = 1 Then vps = -999
v(s, q, m, n) = vps
Next
Next
Next
Debug.Print s, v(s, 0, 0, 0)
Next
Open "c:/100.txt" For Output As #12
For s = 1 To 99
For q = -25 To 25
For m = -5 To 5
For n = -5 To 5
Write #12, s, q, m, n, v(s, q, m, n)
Next
Next
Next
Next
Close #12


End Sub