prog25 - プログラム倉庫

Function seekp(n As Single, ms As Single, pc As Single, k, cx, lx, px, cost) As Single
Dim um As Single
Dim s As Single
Dim k1 As Single
Dim r1 As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim pxs As Single
Dim pp As Single
Dim i1 As Single
Dim h As Single
Dim beta As Single
Dim a As Single
Dim cos As Single
beta = 0.95
a = 0.33
h = k(50) / 50
k1 = k(n) + k(n) ^ a * lx(n) ^ (1 - a) - cx(n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
cos = cost(n2) + (n1 - n2) * (cost(n3) - cost(n2))
r1 = cos * a * k1 ^ (a - 1) * lx(n) ^ (1 - a)
c1 = cx(n2) + (n1 - n2) * (cx(n3) - cx(n2))
pxs = px(n2) + (n1 - n2) * (px(n3) - px(n2))
pp = pxs / pc
i1 = (1 + r1) * pp - 1
um = (beta * i1) / (c1 * pp)
seekp = um * ms
End Function


Private Sub Command1_Click()
Dim n As Single
Dim h As Single
Dim a As Single
Dim beta As Single
Dim k(1 To 100) As Single
Dim cx(1 To 100) As Single
Dim lx(1 To 100) As Single
Dim lp(1 To 100) As Single
Dim cp(1 To 100) As Single
Dim cost(1 To 100) As Single
Dim ks As Single
Dim r1 As Single
Dim c1 As Single
Dim l1 As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim e As Single
Dim t As Single
Dim w1 As Single
Dim phi As Single
Dim ls As Single
Dim cos As Single
phi = 0.9
For n = 1 To 100
cost(n) = phi
Next
beta = 0.95
a = 0.33
ls = (phi * (1 - a)) / (phi * (1 - a) + 1)
For n = 1 To 100
Next
ks = ls * ((1 / beta - 1) / (a * phi)) ^ (1 / (a - 1))
h = 2 * ks / 100
For n = 1 To 100
k(n) = n * h
lx(n) = ls
Next
For n = 1 To 100
cx(n) = k(n) ^ a * lx(n) ^ (1 - a)
Next
t = 0
Do Until t > 100
For n = 10 To 90
k1 = k(n) + k(n) ^ a * lx(n) ^ (1 - a) - cx(n)
n1 = k1 / h
n2 = Int(n1)
n3 = n2 + 1
c1 = cx(n2) + (n1 - n2) * (cx(n3) - cx(n2))
l1 = lx(n2) + (n1 - n2) * (lx(n3) - lx(n2))
cos = cost(n2) + (n1 - n2) * (cost(n3) - cost(n2))
r1 = cos * a * k1 ^ (a - 1) * l1 ^ (1 - a)
cp(n) = c1 / (beta * (1 + r1))
w1 = cost(n) * (1 - a) * k(n) ^ a * lx(n) ^ (-a)
lp(n) = 1 - cx(n) / w1
Next
e = 0
For n = 10 To 90
e = e + (cx(n) - cp(n)) ^ 2 + (lx(n) - lp(n)) ^ 2
Next
For n = 10 To 90
cx(n) = cp(n)
lx(n) = lp(n)
Next
If e < 10 ^ (-5) Then t = 1000
Debug.Print t, e
t = t + 1
Loop
Dim ms As Single
Dim p1 As Single
Dim p2 As Single
Dim p3 As Single
Dim px(1 To 100) As Single
Dim ps(1 To 100) As Single
Dim z1 As Single
Dim z2 As Single
Dim t2 As Single
Dim t1 As Single
For n = 1 To 100
px(n) = 1
Next
ms = 50
t1 = 0
Do Until t1 > 1000
For n = 10 To 90
p1 = 0.9 * px(n)
p2 = 1.1 * px(n)
z1 = seekp(n, ms, p1, k, cx, lx, px, cost) - p1
t = 0
Do Until t > 100
z2 = seekp(n, ms, p2, k, cx, lx, px, cost) - p2
p3 = p2 - z2 * (p2 - p1) / (z2 - z1)
p1 = p2
p2 = p3
z1 = z2
If (z2) ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
ps(n) = p2
Next
e = 0
For n = 10 To 90
e = e + (px(n) - ps(n)) ^ 2
Next
If e < 10 ^ (-5) Then t1 = 10000
For n = 10 To 90
px(n) = ps(n)
Next
Debug.Print t1, e
t1 = t1 + 1
Loop
End Sub