new - プログラム倉庫

Private Sub Command1_Click()
Dim a As Single
Dim beta As Single
Dim phi As Single
Dim sig As Single
Dim barm As Single
Dim t2 As Single
Dim t1 As Single
Dim t3 As Single
Dim t4 As Single
Dim t5 As Single
Dim k(1 To 100) As Single
Dim cx(-5 To 5, 1 To 10, 1 To 100) As Single
Dim cp(-5 To 5, 1 To 10, 1 To 100) As Single
Dim lx(-5 To 5, 1 To 10, 1 To 100) As Single
Dim lp(-5 To 5, 1 To 10, 1 To 100) As Single
Dim px(-5 To 5, 1 To 10, 1 To 100) As Single
Dim ps(-5 To 5, 1 To 10, 1 To 100) As Single
Dim gotos(-5 To 5, 1 To 10, 1 To 100, 1 To 10) As Single
Dim maki(-5 To 5, 1 To 10, 1 To 100, 1 To 10) As Single
Dim v(0 To 2, -5 To 5, 1 To 10, 1 To 100) As Single
Dim vs(0 To 2, -5 To 5, 1 To 10, 1 To 100) As Single
Dim wedge(-5 To 5) As Single
Dim th(1 To 10) As Single
Dim ls As Single
Dim ks As Single
Dim s As Single
Dim m As Single
Dim n As Single
Dim q As Single
Dim m1 As Single
Dim h As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim s1 As Single
Dim s2 As Single
Dim s3 As Single
Dim q1 As Single
Dim q2 As Single
Dim q3 As Single
Dim r1 As Single
Dim c1 As Single
Dim l1 As Single
Dim y1 As Single
Dim i1 As Single
Dim ds As Single
Dim dn As Single
Dim dq As Single
Dim e As Single
Dim uc As Single
Dim um As Single
Dim mc As Single
Dim p1 As Single
Dim p2 As Single
Dim p3 As Single
Dim z1 As Single
Dim z2 As Single
Dim pxs As Single
Dim pp As Single
Dim pr1 As Single
Dim pr2 As Single
Dim pr3 As Single
Dim ys As Single
Dim vv1 As Single
Dim vv2 As Single
Dim vv0 As Single
Dim price(-5 To 5, 1 To 10, 1 To 100) As Single
Open "c:/pro131.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3, a4, a5, a6
s = a1
m = a2
n = a3
lx(s, m, n) = a4
cx(s, m, n) = a5
px(s, m, n) = a6
Loop
Close #2
phi = 0.9
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
For m1 = 1 To 10
gotos(s, m, n, m1) = s
Next
Next
Next
Next
For m = 1 To 10
th(m) = 1 + 0.01 * m
Next
For s = -5 To 5
sig = 1 / (1 - phi)
px1 = 1 + 0.01 * s
px2 = ((1 - 0.1 * px1 ^ (1 - sig)) / 0.9) ^ (1 / (1 - sig))
wedge(s) = phi * px2
Next
beta = 0.95
a = 0.33
ls = ((1 - a) * phi) / ((1 - a) * phi + 1)
ks = ls * ((1 / beta - 1) / (a * phi)) ^ (1 / (a - 1))
h = 2 * ks / 100
For n = 1 To 100
k(n) = n * h
Next
t5 = 0
Do Until t5 > 100
t1 = 0
Do Until t1 > 100
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
uc = 0
k1 = k(n) + th(m) * k(n) ^ a * lx(s, m, n) ^ (1 - a) - cx(s, m, n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
For m1 = 1 To 10
s1 = gotos(s, m, n, m1)
s2 = Int(s1)
s3 = s2 + 1
If s3 > 5 Then s3 = 5
ds = (s1 - s2) * (cx(s3, m1, n2) - cx(s2, m1, n2))
dn = (n1 - n2) * (cx(s2, m1, n3) - cx(s2, m1, n2))
c1 = cx(s2, m1, n2) + ds + dn
ds = (s1 - s2) * (lx(s3, m1, n2) - lx(s2, m1, n2))
dn = (n1 - n2) * (lx(s2, m1, n3) - lx(s2, m1, n2))
l1 = lx(s2, m1, n2) + ds + dn
mc = wedge(s2) + (s1 - s2) * (wedge(s3) - wedge(s2))
r1 = mc * th(m1) * a * k1 ^ (a - 1) * l1 ^ (1 - a)
uc = uc + (beta * (1 + r1)) / c1
Next
uc = uc / 10
cp(s, m, n) = 1 / uc
w1 = wedge(s) * th(m) * (1 - a) * k(n) ^ a * lx(s, m, n) ^ (-a)
lp(s, m, n) = 1 - cp(s, m, n) / w1
Next
Next
Next
e = 0
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
e = e + (cx(s, m, n) - cp(s, m, n)) ^ 2 + (lx(s, m, n) - lp(s, m, n)) ^ 2
Next
Next
Next
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
cx(s, m, n) = cp(s, m, n)
lx(s, m, n) = lp(s, m, n)
Next
Next
Next
If e < 10 ^ (-5) Then t1 = 1000
Debug.Print 81, t1, e
t1 = t1 + 1
Loop
barm = 20
t2 = 0
Do Until t2 > 100
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
p1 = 0.9 * px(s, m, n)
p2 = 1.1 * px(s, m, n)
k1 = k(n) + th(m) * k(n) ^ a * lx(s, m, n) ^ (1 - a) - cx(s, m, n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
um = 0
For m1 = 1 To 10
s1 = gotos(s, m, n, m1)
s2 = Int(s1)
s3 = s2 + 1
If s3 > 5 Then s3 = 5
ds = (s1 - s2) * (cx(s3, m1, n2) - cx(s2, m1, n2))
dn = (n1 - n2) * (cx(s2, m1, n3) - cx(s2, m1, n2))
c1 = cx(s2, m1, n2) + ds + dn
ds = (s1 - s2) * (lx(s3, m1, n2) - lx(s2, m1, n2))
dn = (n1 - n2) * (lx(s2, m1, n3) - lx(s2, m1, n2))
l1 = lx(s2, m1, n2) + ds + dn
ds = (s1 - s2) * (px(s3, m1, n2) - px(s2, m1, n2))
dn = (n1 - n2) * (px(s2, m1, n3) - px(s2, m1, n2))
pxs = px(s2, m1, n2) + ds + dn
mc = wedge(s2) + (s1 - s2) * (wedge(s3) - wedge(s2))
r1 = mc * th(m1) * a * k1 ^ (a - 1) * l1 ^ (1 - a)
pp = pxs / p1
i1 = (1 + r1) * pp - 1
um = um + (beta * i1) / (c1 * pp)
Next
um = 0.1 * um
z1 = um * barm - p1
t3 = 0
Do Until t3 > 100
k1 = k(n) + th(m) * k(n) ^ a * lx(s, m, n) ^ (1 - a) - cx(s, m, n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
um = 0
For m1 = 1 To 10
s1 = gotos(s, m, n, m1)
s2 = Int(s1)
s3 = s2 + 1
If s3 > 5 Then s3 = 5
ds = (s1 - s2) * (cx(s3, m1, n2) - cx(s2, m1, n2))
dn = (n1 - n2) * (cx(s2, m1, n3) - cx(s2, m1, n2))
c1 = cx(s2, m1, n2) + ds + dn
ds = (s1 - s2) * (lx(s3, m1, n2) - lx(s2, m1, n2))
dn = (n1 - n2) * (lx(s2, m1, n3) - lx(s2, m1, n2))
l1 = lx(s2, m1, n2) + ds + dn
ds = (s1 - s2) * (px(s3, m1, n2) - px(s2, m1, n2))
dn = (n1 - n2) * (px(s2, m1, n3) - px(s2, m1, n2))
pxs = px(s2, m1, n2) + ds + dn
mc = wedge(s2) + (s1 - s2) * (wedge(s3) - wedge(s2))
r1 = th(m1) * mc * a * k1 ^ (a - 1) * l1 ^ (1 - a)
pp = pxs / p2
i1 = (1 + r1) * pp - 1
um = um + (beta * i1) / (c1 * pp)
Next
um = 0.1 * um
z2 = um * barm - p2
p3 = p2 - z2 * (p2 - p1) / (z2 - z1)
p1 = p2
p2 = p3
z1 = z2
If (z2) ^ 2 < 10 ^ (-5) Then t3 = 10000
t3 = t3 + 1
Loop
ps(s, m, n) = p2
Next
Next
Next
e = 0
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
e = e + (px(s, m, n) - ps(s, m, n)) ^ 2
Next
Next
Next
If e < 10 ^ (-5) Then t2 = 1000
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
px(s, m, n) = ps(s, m, n)
Next
Next
Next
Debug.Print 82, t2, e
t2 = t2 + 1
Loop
Dim pi As Single
Dim pipi As Single
Dim pipipi As Single
Dim r(0 To 2, -5 To 5, 1 To 10, 1 To 100) As Single
Dim dv(0 To 2) As Single
Dim dr(0 To 2) As Single
Dim rank As Single
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
ys = th(m) * k(n) ^ a * lx(s, m, n) ^ (1 - a)
pi = px(s, m, n) * ys - wedge(s) * px(s, m, n) * ys
pipi = (phi - wedge(s)) * (ys / (phi - 1))
pipipi = (mr + wedge(s) * ys) / (px(s, m, n) * (phi - 1))
r(2, s, m, n) = pipipi / 2
r(1, s, m, n) = pipi - 2 * px(s, m, n) * r(2, s, m, n)
r(0, s, m, n) = pi - r(1, s, m, n) * px(s, m, n) - r(2, s, m, n) * px(s, m, n) ^ 2
Next
Next
Next
t4 = 0
Do Until t4 > 100
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
k1 = k(n) + th(m) * k(n) ^ a * lx(s, m, n) ^ (1 - a) - cx(s, m, n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
vv0 = 0
vv1 = 0
vv2 = 0
For m1 = 1 To 10
s1 = gotos(s, m, n, m1)
s2 = Int(s1)
s3 = s2 + 1
If s3 > 5 Then s3 = 5
ds = (s1 - s2) * (lx(s3, m1, n2) - lx(s2, m1, n2))
dn = (n1 - n2) * (lx(s2, m1, n3) - lx(s2, m1, n2))
l1 = lx(s2, m1, n2) + ds + dn
ds = (s1 - s2) * (px(s3, m1, n2) - px(s2, m1, n2))
dn = (n1 - n2) * (px(s2, m1, n3) - px(s2, m1, n2))
pxs = px(s2, m1, n2) + ds + dn
mc = wedge(s2) + (s1 - s2) * (wedge(s3) - wedge(s2))
r1 = th(m1) * mc * a * k1 ^ (a - 1) * l1 ^ (1 - a)
pp = pxs / px(s, m, n)
i1 = (1 + r1) * pp - 1
For rank = 0 To 2
ds = (s1 - s2) * (v(rank, s3, m1, n2) - v(rank, s2, m1, n2))
dn = (n1 - n2) * (v(rank, s2, m1, n3) - v(rank, s2, m1, n2))
dv(rank) = v(rank, s2, m1, n2) + ds + dn
Next
For rank = 0 To 2
ds = (s1 - s2) * (r(rank, s3, m1, n2) - r(rank, s2, m1, n2))
dn = (n1 - n2) * (r(rank, s2, m1, n3) - r(rank, s2, m1, n2))
dr(rank) = r(rank, s2, m1, n2) + ds + dn
Next
vv0 = vv0 + (dr(0) + 0.8 * dv(0)) / (1 + i1)
vv1 = vv1 + (dr(1) + 0.8 * dv(1)) / (1 + i1)
vv2 = vv2 + (dr(2) + 0.8 * dv(2)) / (1 + i1)
Next
vs(0, s, m, n) = vv0 / 10
vs(1, s, m, n) = vv1 / 10
vs(2, s, m, n) = vv2 / 10
Next
Next
Next
e = 0
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
For q = 0 To 2
e = e + (v(q, s, m, n) - vs(q, s, m, n)) ^ 2
Next
Next
Next
Next
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
For q = 0 To 2
v(q, s, m, n) = vs(q, s, m, n)
Next
Next
Next
Next
If e < 10 ^ (-5) Then t4 = 1000
Debug.Print 83, t4, e
t4 = t4 + 1
Loop
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
price(s, m, n) = -v(1, s, m, n) / (2 * v(2, s, m, n))
If price(s, m, n) > 1.05 * px(s, m, n) Then price(s, m, n) = 1.05 * px(s, m, n)
If price(s, m, n) < 0.95 * px(s, m, n) Then price(s, m, n) = 0.95 * px(s, m, n)
Next
Next
Next
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
p2 = price(s, m, n)
p1 = (1 + 0.01 * s) * px(s, m, n)
p3 = (0.8 * p1 ^ (1 - sig) + 0.2 * p2 ^ (1 - sig)) ^ (1 / (1 - sig))
k1 = k(n) + th(m) * k(n) ^ a * lx(s, m, n) ^ (1 - a) - cx(s, m, n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
For m1 = 1 To 10
s1 = gotos(s, m, n, m1)
s1 = gotos(s, m, n, m1)
s2 = Int(s1)
s3 = s2 + 1
If s3 > 5 Then s3 = 5
ds = (s1 - s2) * (px(s3, m1, n2) - px(s2, m1, n2))
dn = (n1 - n2) * (px(s2, m1, n3) - px(s2, m1, n2))
pxs = px(s2, m1, n2) + ds + dn
gt = 100 * (p3 / pxs - 1)
If gt > 5 Then gt = 5
If gt < -5 Then gt = -5
maki(s, m, n, m1) = gt
Next
Next
Next
Next
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
For m1 = 1 To 10
gotos(s, m, n, m1) = maki(s, m, n, m1)
Next
Next
Next
Next
Dim checkc(-5 To 5, 1 To 10, 1 To 100) As Single
Dim checkl(-5 To 5, 1 To 10, 1 To 100) As Single
Dim checkp(-5 To 5, 1 To 10, 1 To 100) As Single
e = 0
For s = -5 To 5
For m = 1 To 10
For n = 10 To 90
e = e + (checkc(s, m, n) - cx(s, m, n)) ^ 2 + (checkl(s, m, n) - lx(s, m, n)) ^ 2 + (checkp(s, m, n) - px(s, m, n)) ^ 2
Next
Next
Next
For s = -5 To 5
For n = 10 To 90
For m = 1 To 10
checkc(s, m, n) = cx(s, m, n)
checkl(s, m, n) = lx(s, m, n)
checkp(s, m, n) = px(s, m, n)
Next
Next
Next
If e < 10 ^ (-4) Then t5 = 1000
Debug.Print t5, e
t5 = t5 + 1
Loop
Open "c:/pro131.txt" For Output As #1
For s = -5 To 5
For m = 1 To 10
For n = 1 To 100
Write #1, s, m, n, lx(s, m, n), cx(s, m, n), px(s, m, n)
Next
Next
Next
Close #1
End Sub