ねあｒ - プログラム倉庫

Function nearprefer(s As Single, gr, th1, th2, c, y1, y2) 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
Dim yp1 As Single
Dim yp2 As Single
maxu = -999
For m = 1 To 100
c1 = c(m)
yp1 = y1(m)
yp2 = y2(m)
u1 = u(s, th1, th2, c1, yp1, yp2)
If gr(m) = 1 Then u1 = -999
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
nearprefer = maxm
End Function

Function prefer(s As Single, th1, th2, c, y1, y2) 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
Dim yp1 As Single
Dim yp2 As Single
maxm = s
c1 = c(s)
yp1 = y1(s)
yp2 = y2(s)
maxu = u(s, th1, th2, c1, yp1, yp2)
For m = 1 To 100
c1 = c(m)
yp1 = y1(m)
yp2 = y2(m)
u1 = u(s, th1, th2, c1, yp1, yp2)
If u1 > maxu Then maxm = m
If u1 > maxu Then maxu = u1
Next
prefer = maxm
End Function


Function u(s As Single, th1, th2, c1 As Single, y1 As Single, y2 As Single) As Single
Dim lx As Single
Dim cx As Single
Dim px As Single
l1 = y1 / th1(s)
l2 = y2 / th2(s)
cx = c1
px = 0
If cx < 0.01 Then px = 1
If l1 > 0.99 Then px = 1
If l2 > 0.99 Then px = 1
If l1 < 0 Then px = 1
If l2 < 0 Then px = 1
If px = 1 Then cx = 0.5
If px = 1 Then l1 = 0.5
If px = 1 Then l2 = 0.5
ux = Log(cx) + Log(1 - l1) + Log(1 - l2)
If px = 1 Then ux = -999
u = ux
End Function


Private Sub Command1_Click()
Dim s As Single
Dim m As Single
Dim th1(1 To 100) As Single
Dim th2(1 To 100) As Single
Dim y1(0 To 100) As Single
Dim y2(0 To 100) As Single
Dim c(0 To 100) As Single
Dim tl As Single
Dim tk As Single
Dim tr As Single
Dim s1 As Single
Dim c1 As Single
Dim w1 As Single
Dim w2 As Single
Dim rank(1 To 100) As Single
Dim r As Single
s1 = 1
s2 = 1
For s = 1 To 100
th1(s) = 0.2 * s1
th2(s) = 0.1 * s2
s1 = s1 + 1
If s1 = 11 Then s2 = s2 + 1
If s1 = 11 Then s1 = 1
Next
Open "c:/f1.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3, a4
s = a1
c(s) = a2
y1(s) = a3
y2(s) = a4
Loop
Close #2
For r = 1 To 100
minc = 999
For s = 1 To 100
c1 = c(s)
For j = 1 To r - 1
If rank(j) = s Then c1 = 1000
Next
If c1 < minc Then m = s
If c1 < minc Then minc = c1
Next
rank(r) = m
Next
For r = 1 To 100
Debug.Print r, rank(r)
Next


End Sub