06 男子新規裁定者 - プログラム倉庫

Private Sub Command1_Click()
Dim theta(1 To 2, 15 To 65) As Single
Dim m2(-3 To 99, 16 To 65) As Single
Dim f2(-3 To 99, 16 To 65) As Single
Dim de(1 To 2, 16 To 65) As Single
Dim mis(16 To 65, 1 To 50) As Single
Dim mos(16 To 65, 1 To 50) As Single
Dim mrate(-3 To 99, 16 To 65) As Single
Dim frate(-3 To 99, 16 To 65) As Single
Dim b(-1 To 10, 0 To 99) As Single
Dim c(-1 To 10, 0 To 99) As Single
Dim m(-5 To 99, 0 To 99) As Single
Dim f(-5 To 99, 0 To 99) As Single
Dim newm(-3 To 99, 60 To 65) As Single
Dim newf(-3 To 99, 60 To 65) As Single
Dim alpha(1 To 2, 15 To 64) As Single
Dim beta(1 To 2, 15 To 64) As Single
Dim phi(1 To 2, 15 To 64) As Single
Dim age As Single
Dim car As Single
Dim year As Single
Dim c1 As Single
Dim c2 As Single
Dim c3 As Single
Dim zero As Single
Dim syear As Single
Dim rate(-3 To 99) As Single
n = -1
s = 0
Open "c:/simple/data/死亡（男性）.txt" For Input As #1
Do Until EOF(1)
Input #1, x
b(n, s) = x
n = n + 1
If n > 10 Then s = s + 1
If n > 10 Then n = -1
Loop
Close #1
n = -1
s = 0
Open "c:/simple/data/死亡（女性）.txt" For Input As #11
Do Until EOF(11)
Input #11, x
c(n, s) = x
n = n + 1
If n > 10 Then s = s + 1
If n > 10 Then n = -1
Loop
Close #11
Open "c:/simple/gdata/厚生年金加入率.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3, a4
year = a1
age = a2
mrate(year, age) = a3
frate(year, age) = a4
Loop
Close #2
Open "c:/simple/data/脱退率.txt" For Input As #3
Do Until EOF(3)
Input #3, a1, a2, a3, a4, a5, a6, a7, a8, a9
age = a1
alpha(1, age) = a3
beta(1, age) = a4
phi(1, age) = a5
alpha(2, age) = a7
beta(2, age) = a8
phi(2, age) = a9
Loop
Close #3
Open "c:/simple/data/再加入率.txt" For Input As #4
Do Until EOF(4)
Input #4, a1, a2, a3
age = a1
theta(1, age) = a2
theta(2, age) = a3
Loop
Close #4
Open "c:/simple/gdata/将来推計人口.txt" For Input As #5
Do Until EOF(5)
Input #5, a1, a2, a3, a4
year = a1
age = a2
m(year, age) = a3
f(year, age) = a4
Loop
Close #5
Open "c:/simple/gdata/厚生年金被保険者.txt" For Input As #6
Do Until EOF(6)
Input #6, a1, a2, a3, a4
year = a1
age = a2
m2(year, age) = a3
f2(year, age) = a4
Loop
Close #6
Dim mktime(-3 To 99) As Single
Dim fktime(-3 To 99) As Single
Open "c:/simple/data/新規裁定年数.txt" For Input As #55
Do Until EOF(55)
Input #55, a1, a2, a3
year = a1
mktime(year) = a2
fktime(year) = a3
Loop
Close #55
For year = -3 To -1
mktime(year) = 60
fktime(year) = 60
Next
For syear = 49 To 99
zero = 1
mis(16, 1) = m2(syear - 49, 16)
For age = 17 To 64
year = syear + age - 65
c1 = 1 - alpha(1, age) - beta(1, age) - phi(1, age)
c2 = c1 * m2(year - 1, age - 1)
mis(age, 1) = (1 - theta(1, age)) * (m2(year, age) - c2)
If mis(age, 1) < 0 Then mis(age, 1) = 0
If zero < 0 Then mis(age, 1) = 0
c3 = 0
For car = 1 To 50
c3 = c3 + mos(age - 1, car)
Next
c5 = 0
If c3 = 0 Then c5 = 1
If c3 = 0 Then c3 = 1
c4 = (m2(year, age) - c2 - mis(age, 1)) / c3
If c5 = 1 Then c4 = 0
If c4 < 0 Then c4 = 0
For car = 2 To 50
mis(age, car) = c1 * mis(age - 1, car - 1) + c4 * mos(age - 1, car - 1)
Next
For car = 1 To 50
mos(age, car) = alpha(1, age) * mis(age - 1, car) + (1 - c4 - beta(1, age)) * mos(age - 1, car)
Next
z1 = 0
For car = 1 To 50
z1 = z1 + mis(age, car) + mos(age, car)
Next
zero = m(year, age) - z1
Next
z2 = 0
For car = 1 To 50
z2 = z2 + mis(64, car) + mos(64, car)
Next
z3 = 0
For car = 25 To 50
z3 = z3 + mis(64, car) + mos(64, car)
Next
rate(syear) = z3 / z2
Debug.Print syear, rate(syear)
Next
For year = -3 To 49
rate(year) = rate(49)
Next
For year = -3 To 99
For age = 60 To 65
newm(year, age) = 0
Next
Next
For year = -3 To 99
age = mktime(year)
If age = 0 Then rate(year) = 0
If age = 0 Then age = 65
newm(year, age) = rate(year) * m(year, age)
Next
Open "c:/simple/gdata/男子老齢年金新規裁定者.txt " For Output As #8
For year = -3 To 99
For age = 60 To 65
Write #8, year, age, newm(year, age)
Next
Next
Close #8
For year = -3 To 50
age = mktime(year)
If age = 0 Then age = 65
Debug.Print year, newm(year, age)
Next
End Sub