最適所得税４ - プログラム倉庫

Function seekl(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
seekl = ls
End Function
Function seekc(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
seekc = th(s) * ls - bp
End Function

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
Dim cs As Single
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
cs = (1 - tl) * th(s) * ls + tr
cx = cs
End Function

Function pathb(s As Single, mx As Single, nx As Single, w, u, v) As Single
Dim bs As Single
Dim us As Single
Dim vs As Single
Dim b1 As Single
Dim u1 As Single
Dim v1 As Single
Dim b2 As Single
Dim u2 As Single
Dim v2 As Single
Dim w0 As Single
Dim w1 As Single
Dim w2 As Single
Dim ww As Single
Dim h As Single
Dim vps As Single
Dim ws As Single
bp = 700
h = 3
w0 = w(s - 1, 0)
dw = Log(0.51) - Log(0.5)
bs = 0
us = nearu(s, mx, bs, u)
ws = (us - w0) / dw
vs = nearv(s - 1, ws, nx - bs, v)
vps = us + vs
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
b1 = bs + h
u1 = nearu(s, mx, b1, u)
w1 = (u1 - w0) / dw
v1 = nearv(s - 1, w1, nx - b1, v)
vp1 = u1 + v1
b2 = bs - h
u2 = nearu(s, mx, b2, u)
w2 = (u2 - w0) / dw
v2 = nearv(s - 1, w2, nx - b2, v)
vp2 = u2 + v2
If vp1 > vps Then bs = b1
If vp1 > vps Then vps = vp1
If vp2 > vps Then bs = b2
If vp2 > vps Then vps = vp2
If (bp - bs) ^ 2 < 10 ^ (-5) Then t1 = 1000
bp = bs
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
pathb = nx - bs
End Function

Function pathw(s As Single, mx As Single, nx As Single, w, u, v) As Single
Dim bs As Single
Dim us As Single
Dim vs As Single
Dim b1 As Single
Dim u1 As Single
Dim v1 As Single
Dim b2 As Single
Dim u2 As Single
Dim v2 As Single
Dim w0 As Single
Dim w1 As Single
Dim w2 As Single
Dim ww As Single
Dim h As Single
Dim vps As Single
Dim ws As Single
bp = 700
h = 3
w0 = w(s - 1, 0)
dw = Log(0.51) - Log(0.5)
bs = 0
us = nearu(s, mx, bs, u)
ws = (us - w0) / dw
vs = nearv(s - 1, ws, nx - bs, v)
vps = us + vs
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
b1 = bs + h
u1 = nearu(s, mx, b1, u)
w1 = (u1 - w0) / dw
v1 = nearv(s - 1, w1, nx - b1, v)
vp1 = u1 + v1
b2 = bs - h
u2 = nearu(s, mx, b2, u)
w2 = (u2 - w0) / dw
v2 = nearv(s - 1, w2, nx - b2, v)
vp2 = u2 + v2
If vp1 > vps Then bs = b1
If vp1 > vps Then vps = vp1
If vp2 > vps Then bs = b2
If vp2 > vps Then vps = vp2
If (bp - bs) ^ 2 < 10 ^ (-5) Then t1 = 1000
bp = bs
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
pathw = (us - w0) / dw
End Function



Function fastw(fastu, w, v) As Single
Dim bs As Single
Dim us As Single
Dim vs As Single
Dim b1 As Single
Dim u1 As Single
Dim v1 As Single
Dim b2 As Single
Dim u2 As Single
Dim v2 As Single
Dim w0 As Single
Dim w1 As Single
Dim w2 As Single
Dim ww As Single
Dim h As Single
Dim vps As Single
bp = 700
h = 3
w0 = w(9, 0)
dw = (Log(0.51) - Log(0.5))
bs = 0
us = nearfast(bs, fastu)
w1 = (us - w0) / dw
vs = nearv(9, w1, -bs, v)
vps = us + vs
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
b1 = bs + h
u1 = nearfast(b1, fastu)
w1 = (u1 - w0) / dw
v1 = nearv(9, w1, -b1, v)
vp1 = u1 + v1
b2 = bs - h
u2 = nearfast(b2, fastu)
w2 = (u2 - w0) / dw
v2 = nearv(9, w2, -b2, v)
vp2 = u2 + v2
If vp1 > vps Then bs = b1
If vp1 > vps Then vps = vp1
If vp2 > vps Then bs = b2
If vp2 > vps Then vps = vp2
If (bp - bs) ^ 2 < 10 ^ (-5) Then t1 = 1000
bp = bs
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
us = nearfast(bs, fastu)
ws = (us - w0) / dw
fastw = ws
End Function
Function fastb(fastu, w, v) As Single
Dim bs As Single
Dim us As Single
Dim vs As Single
Dim b1 As Single
Dim u1 As Single
Dim v1 As Single
Dim b2 As Single
Dim u2 As Single
Dim v2 As Single
Dim w0 As Single
Dim w1 As Single
Dim w2 As Single
Dim ww As Single
Dim h As Single
Dim vps As Single
bp = 700
h = 3
w0 = w(9, 0)
dw = (Log(0.51) - Log(0.5))
bs = 0
us = nearfast(bs, fastu)
w1 = (us - w0) / dw
vs = nearv(9, w1, -bs, v)
vps = us + vs
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
b1 = bs + h
u1 = nearfast(b1, fastu)
w1 = (u1 - w0) / dw
v1 = nearv(9, w1, -b1, v)
vp1 = u1 + v1
b2 = bs - h
u2 = nearfast(b2, fastu)
w2 = (u2 - w0) / dw
v2 = nearv(9, w2, -b2, v)
vp2 = u2 + v2
If vp1 > vps Then bs = b1
If vp1 > vps Then vps = vp1
If vp2 > vps Then bs = b2
If vp2 > vps Then vps = vp2
If (bp - bs) ^ 2 < 10 ^ (-5) Then t1 = 1000
bp = bs
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
fastb = -bs
End Function



Function checku(s As Single, th, 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)
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)
l2 = ls - h
If l2 < 0.01 Then l2 = ls
c2 = th(s) * l2 - bp
If c2 < 0.01 Then l2 = ls
c2 = th(10) * l2 - bp
y2 = th(s) * l2
u2 = Log(c2) + Log(1 - l2)
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
checku = us
End Function
Function nearfast(nx As Single, fastu) As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim dn As Single
n1 = nx
pp = 0
If n1 > 9 Then pp = -999
If n1 > 9 Then n1 = 9
If n1 < -9 Then pp = -999
If n1 < -9 Then n1 = -9
n2 = Int(n1)
n3 = n2 + 1
dn = (n1 - n2) * (fastu(n3) - fastu(n2))
nearfast = fastu(n2) + dn + pp
End Function
Function fastv(fastu, w, v) As Single
Dim bs As Single
Dim us As Single
Dim vs As Single
Dim b1 As Single
Dim u1 As Single
Dim v1 As Single
Dim b2 As Single
Dim u2 As Single
Dim v2 As Single
Dim w0 As Single
Dim w1 As Single
Dim w2 As Single
Dim ww As Single
Dim h As Single
Dim vps As Single
bp = 700
h = 3
w0 = w(9, 0)
dw = Log(0.51) - Log(0.5)
bs = 0
us = nearfast(bs, fastu)
w1 = (us - w0) / dw
vs = nearv(9, w1, -bs, v)
vps = us + vs
t2 = 0
Do Until t2 > 10
t1 = 0
Do Until t1 > 100
b1 = bs + h
u1 = nearfast(b1, fastu)
w1 = (u1 - w0) / dw
v1 = nearv(9, w1, -b1, v)
vp1 = u1 + v1
b2 = bs - h
u2 = nearfast(b2, fastu)
w2 = (u2 - w0) / dw
v2 = nearv(9, w2, -b2, v)
vp2 = u2 + v2
If vp1 > vps Then bs = b1
If vp1 > vps Then vps = vp1
If vp2 > vps Then bs = b2
If vp2 > vps Then vps = vp2
If (bp - bs) ^ 2 < 10 ^ (-5) Then t1 = 1000
bp = bs
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
fastv = vps
End Function


Function seekv(s As Single, mx As Single, nx As Single, w, u, v) As Single
Dim bs As Single
Dim us As Single
Dim vs As Single
Dim b1 As Single
Dim u1 As Single
Dim v1 As Single
Dim b2 As Single
Dim u2 As Single
Dim v2 As Single
Dim w0 As Single
Dim w1 As Single
Dim w2 As Single
Dim ws As Single
Dim ww As Single
Dim h As Single
Dim vps As Single
bp = 700
h = 3
dw = Log(0.51) - Log(0.5)
w0 = w(s - 1, 0)
bs = nx
us = nearu(s, mx, bs, u)
ws = (us - w0) / dw
vs = nearv(s - 1, ws, nx - bs, v)
vps = us + vs
t2 = 0
Do Until t2 > 5
t1 = 0
Do Until t1 > 100
b1 = bs + h
u1 = nearu(s, mx, b1, u)
w1 = (u1 - w0) / dw
v1 = nearv(s - 1, w1, nx - b1, v)
vp1 = u1 + v1
b2 = bs - h
u2 = nearu(s, mx, b2, u)
w2 = (u2 - w0) / dw
v2 = nearv(s - 1, w2, nx - b2, v)
vp2 = u2 + v2
If vp1 > vps Then bs = b1
If vp1 > vps Then vps = vp1
If vp2 > vps Then bs = b2
If vp2 > vps Then vps = vp2
If (bp - bs) ^ 2 < 10 ^ (-5) Then t1 = 1000
bp = bs
t1 = t1 + 1
Loop
h = h / 2
t2 = t2 + 1
Loop
seekv = vps
End Function

Function nearv(s As Single, mx As Single, nx As Single, v) 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 nv As Single
pp = 0
m1 = mx
n1 = nx
If m1 < -9 Then pp = 1
If m1 < -9 Then m1 = -9
If m1 > 9 Then pp = 1
If m1 > 9 Then m1 = 9
If n1 < -9 Then pp = 1
If n1 < -9 Then n1 = 9
If n1 > 9 Then pp = 1
If n1 > 9 Then n1 = 9
m2 = Int(m1)
m3 = m2 + 1
n2 = Int(n1)
n3 = n2 + 1
dm = (m1 - m2) * (v(s, m3, n2) - v(s, m2, n2))
dn = (n1 - n2) * (v(s, m2, n3) - v(s, m2, n2))
nv = v(s, m2, n2) + dm + dn
If pp = 1 Then nv = -999
nearv = nv
End Function


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 < -10 Then pp = 1
If m1 < -10 Then m1 = -10
If m1 > 9 Then pp = 1
If m1 > 9 Then m1 = 9
If n1 < -10 Then pp = 1
If n1 < -10 Then n1 = -10
If n1 > 9 Then pp = 1
If n1 > 9 Then n1 = 9
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





Function tls(th) As Single
Dim n As Single
Dim tl As Single
Dim tr As Single
Dim wmax As Single
Dim tp As Single
Dim w1 As Single
wmax = -999
For n = 1 To 400
tl = 0.001 * n
tr = trs(th, tl)
w1 = wel(th, tl, tr)
If w1 > wmax Then tp = tl
If w1 > wmax Then wmax = 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
b1 = b2
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
w1 = 0
For s = 1 To 10
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
If ls < 0 Then ls = 0
cs = (1 - tl) * th(s) * ls + tr
w1 = w1 + Log(cs) + Log(1 - ls)
Next
wel = w1
End Function
Function bud(th, tl As Single, tr As Single) As Single
ys = 0
cs = 0
For s = 1 To 10
ls = ((1 - tl) * th(s) - tr) / (2 * (1 - tl) * th(s))
ys = ys + th(s) * ls
cs = cs + (1 - tl) * th(s) * ls + tr
Next
bud = ys - cs
End Function
Private Sub Command1_Click()
Dim th(1 To 10) As Single
Dim s As Single
Dim ls As Single
Dim tl As Single
Dim tr As Single
Dim bx(1 To 10) As Single
Dim wx(1 To 9) As Single
Dim b(1 To 10, -10 To 10) As Single
Dim w(1 To 9, -10 To 10) As Single
Dim u(1 To 9, -10 To 10, -10 To 10) As Single
Dim v(1 To 9, -10 To 10, -10 To 10) As Single
Dim fastu(-10 To 10) As Single
Dim m As Single
Dim n As Single
For s = 1 To 10
th(s) = 0.5 + 0.1 * s
Next
tl = tls(th)
tr = trs(th, tl)
For s = 1 To 9
bx(s) = th(s) * lx(s, th, tl, tr) - cx(s, th, tl, tr)
l1 = th(s) * lx(s, th, tl, tr) / th(s + 1)
wx(s) = Log(cx(s + 1, th, tl, tr)) + Log(1 - l1)
Next
bx(s) = th(s) * lx(s, th, tl, tr) - cx(s, th, tl, tr)
For s = 1 To 10
For n = -10 To 10
b(s, n) = bx(s) + 0.01 * n
Next
Next
dw = Log(0.51) - Log(0.5)
For s = 1 To 9
For m = -10 To 10
w(s, m) = wx(s) + m * dw
Next
Next
For s = 1 To 9
For m = -10 To 10
For n = -10 To 10
u(s, m, n) = seeku(s, th, w(s, m), b(s, n))
Next
Next
Next
s = 1
For m = -10 To 10
For n = -10 To 10
v(s, m, n) = u(s, m, n)
Next
Next
For s = 2 To 9
For m = -10 To 10
For n = -10 To 10
v(s, m, n) = seekv(s, m, n, w, u, v)
Next
Next
Next
For n = -10 To 10
fastu(n) = checku(10, th, b(10, n))
Next
Dim opb(1 To 9) As Single
Dim opw(1 To 9) As Single
Dim dp(1 To 10) As Single
Dim dq(1 To 10) As Single
opw(9) = fastw(fastu, w, v)
opb(9) = fastb(fastu, w, v)
For n = 1 To 8
s = 10 - n
opb(s - 1) = pathb(s, opw(s), opb(s), w, u, v)
opw(s - 1) = pathw(s, opw(s), opb(s), w, u, v)
Next
dp(1) = opb(1)
For s = 2 To 9
dp(s) = opb(s) - opb(s - 1)
Next
For s = 1 To 9
dp(s) = 0.01 * dp(s) + bx(s)
dq(s) = w(s, 0) + dw * opw(s)
Debug.Print s, dp(s)
Next
For s = 1 To 9
Debug.Print s, seekc(s, th, dq(s), dp(s)), seekl(s, th, dq(s), dp(s))
Next


End Sub