ぷろ２ - プログラム倉庫

Function seekb(m As Single, th, gr, c1 As Single, c2 As Single, c3 As Single, y1 As Single, y2 As Single, y3 As Single) As Single
Dim s As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim us As Single
Dim sumb As Single
sumb = 0
For s = 1 To 100
us = -999
If gr(s) = m Then u1 = Log(c1) + Log(1 - y1 / th(s))
If gr(s) = m Then u2 = Log(c2) + Log(1 - y2 / th(s))
If gr(s) = m Then u3 = Log(c3) + Log(1 - y3 / th(s))
If u1 > us Then bs = y1 - c1
If u1 > us Then us = u1
If u2 > us Then bs = y2 - c2
If u2 > us Then us = u2
If u3 > us Then bs = y3 - c3
If u3 > us Then us = u3
If gr(s) = m Then sumb = sumb + bs
Next
seekb = sumb
End Function
Function seeku(m As Single, th, gr, c1 As Single, c2 As Single, c3 As Single, y1 As Single, y2 As Single, y3 As Single) As Single
Dim s As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim us As Single
Dim sumu As Single
sumu = 0
For s = 1 To 100
us = -999
If gr(s) = m Then u1 = Log(c1) + Log(1 - y1 / th(s))
If gr(s) = m Then u2 = Log(c2) + Log(1 - y2 / th(s))
If gr(s) = m Then u3 = Log(c3) + Log(1 - y3 / th(s))
If u1 > us Then us = u1
If u2 > us Then us = u2
If u3 > us Then us = u3
If gr(s) = m Then sumu = sumu + us
Next
seeku = sumu
End Function


Function prefer(s As Single, th, c, y) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim u1 As Single
Dim c1 As Single
Dim l1 As Single
maxu = -999
For m = 0 To 10
c1 = c(m)
l1 = y(m) / th(s)
pp = 0
If l1 > 0.99 Then pp = 1
If l1 > 0.99 Then l1 = 0.5
If c1 < 0.01 Then pp = 1
If c1 < 0.01 Then c1 = 0.5
u1 = Log(c1) + Log(1 - l1)
If pp = 1 Then u1 = -999
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function
Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim th(1 To 100) As Single
Dim gr(1 To 100) As Single
Dim y(0 To 10) As Single
Dim c(0 To 10) As Single
Dim u(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim b(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim h As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim c1 As Single
Dim c2 As Single
Dim c3 As Single
Dim y1 As Single
Dim y2 As Single
Dim y3 As Single
For s = 1 To 100
th(s) = 0.02 * s
Next
Open "c:/m1.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2, a3
m = a1
y(m) = a2
c(m) = a3
Loop
Close #1
For s = 1 To 100
m = prefer(s, th, c, y)
gr(s) = m
Next
For s = 1 To 100
Debug.Print s, gr(s)
Next
h = 0.01
For m = 1 To 9
y1 = y(m - 1)
y2 = y(m)
y3 = y(m + 1)
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
c1 = c(m - 1) + n1 * h
c2 = c(m) + n2 * h
c3 = c(m + 1) + n3 * h
u(m, n1, n2, n3) = seeku(m, th, gr, c1, c2, c3, y1, y2, y3)
b(m, n1, n2, n3) = seekb(m, th, gr, c1, c2, c3, y1, y2, y3)
Next
Next
Next
Debug.Print m, b(m, 0, 0, 0)
Next
Open "c:/m2.txt" For Output As #2
For m = 1 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
Write #2, m, n1, n2, n3, u(m, n1, n2, n3), b(m, n1, n2, n3)
Next
Next
Next
Next
Close #2
End Sub