yokof - プログラム倉庫

Function survey(s1 As Single, cp As Single, yp1 As Single, yp2 As Single, th1, th2, c, y1, y2) As Single
Dim m1 As Single
Dim m2 As Single
Dim maxu As Single
Dim maxm As Single
Dim maxn As Single
Dim u1 As Single
Dim my As Single
Dim fy As Single
Dim ch As Single
Dim c1 As Single
ch = 0
For m1 = 1 To 10
For m2 = 1 To 10
c1 = c(m1, m2)
my = y1(m1, m2)
fy = y2(m1, m2)
u1 = u(m1, m2, th1, th2, c1, my, fy)
u2 = u(m1, m2, th1, th2, cp, yp1, yp2)
If m1 = s1 Then u2 = -999
If u2 > u1 Then ch = 1
Next
Next
survey = ch
End Function
Function check(s1 As Single, s2 As Single, th1, th2, c, y1, y2) As Single
Dim m As Single
Dim maxu As Single
Dim maxm As Single
Dim maxn As Single
Dim u1 As Single
Dim my As Single
Dim fy As Single
Dim c1 As Single
maxu = -999
For m1 = 1 To 10
For m2 = 1 To 10
c1 = c(m1, m2)
my = y1(m1, m2)
fy = y2(m1, m2)
u1 = u(s1, s2, th1, th2, c1, my, fy)
If m2 = s1 Then u1 = -999
If u1 > maxu Then maxu = u1
Next
Next
check = maxu
End Function

Function mprefer(s1 As Single, s2 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 my As Single
Dim fy As Single
maxm = s1
c1 = c(s1, s2)
my = y1(s1, s2)
fy = y2(s1, s2)
maxu = u(s1, s2, th1, th2, c1, my, fy)
For m1 = 1 To 10
For m2 = 1 To 10
c1 = c(m1, m2)
my = y1(m1, m2)
fy = y2(m1, m2)
u1 = u(s1, s2, th1, th2, c1, my, fy)
If u1 > maxu Then maxm = m1
If u1 > maxu Then maxu = u1
Next
Next
mprefer = maxm
End Function
Function fprefer(s1 As Single, s2 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 my As Single
Dim fy As Single
maxm = s2
c1 = c(s1, s2)
my = y1(s1, s2)
fy = y2(s1, s2)
maxu = u(s1, s2, th1, th2, c1, my, fy)
For m1 = 1 To 10
For m2 = 1 To 10
c1 = c(m1, m2)
my = y1(m1, m2)
fy = y2(m1, m2)
u1 = u(s1, s2, th1, th2, c1, my, fy)
If u1 > maxu Then maxm = m2
If u1 > maxu Then maxu = u1
Next
Next
fprefer = maxm
End Function


Function u(s1 As Single, s2 As Single, th1, th2, cp As Single, yp1 As Single, yp2 As Single) As Single
Dim l1 As Single
Dim l2 As Single
Dim cx As Single
Dim px As Single
l1 = yp1 / th1(s1)
l2 = yp2 / th2(s2)
cx = cp
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 s1 As Single
Dim s2 As Single
Dim c(1 To 10, 1 To 10) As Single
Dim y1(1 To 10, 1 To 10) As Single
Dim y2(1 To 10, 1 To 10) As Single
Dim th1(1 To 10) As Single
Dim th2(1 To 10) As Single
Dim gu(1 To 10, -1 To 1, -1 To 1, -1 To 1) As Single
Dim w(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim rw(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim v(1 To 9, -1 To 1, -1 To 1, -1 To 1, -10 To 10) As Single
Dim gotoc(1 To 9, -1 To 1, -1 To 1, -1 To 1, -10 To 10) As Single
Dim gotoy1(1 To 9, -1 To 1, -1 To 1, -1 To 1, -10 To 10) As Single
Dim gotoy2(1 To 9, -1 To 1, -1 To 1, -1 To 1, -10 To 10) As Single
Dim gotoq(1 To 9, -1 To 1, -1 To 1, -1 To 1, -10 To 10) As Single
Dim endv(-1 To 1, -1 To 1, -1 To 1) As Single
Dim endc(-1 To 1, -1 To 1, -1 To 1) As Single
Dim endy1(-1 To 1, -1 To 1, -1 To 1) As Single
Dim endy2(-1 To 1, -1 To 1, -1 To 1) As Single
Dim ch(1 To 10) As Single
Dim op1(1 To 10) As Single
Dim op2(1 To 10) As Single
Dim op3(1 To 10) As Single
Dim opq(1 To 10) As Single
Dim che(1 To 10) As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim cp As Single
Dim yp1 As Single
Dim yp2 As Single
Open "c:/lupin3.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2, a3, a4, a5
s1 = a1
s2 = a2
c(s1, s2) = a3
y1(s1, s2) = a4
y2(s1, s2) = a5
Loop
Close #1
For s = 1 To 10
th1(s) = 0.2 * s
th2(s) = 0.1 * s
Next
For s1 = 1 To 10
h = 0.001
t1 = 0
Do Until t1 > 100
For s2 = 1 To 10
che(s2) = check(s1, s2, th1, th2, c, y1, y2)
Next
For s2 = 1 To 10
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
cp = c(s1, s2) + n1 * h
yp1 = y1(s1, s2) + n2 * h
yp2 = y2(s1, s2) + n3 * h
u1 = u(s1, s2, th1, th2, cp, yp1, yp2)
If che(s2) > u1 Then u1 = -999
gu(s2, n1, n2, n3) = u1
If survey(s1, cp, yp1, yp2, th1, th2, c, y1, y2) = 1 Then u1 = -999
gu(s2, n1, n2, n3) = u1
Next
Next
Next
Next
For s2 = 1 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
cp = c(s1, s2) + n1 * h
yp1 = y1(s1, s2) + n2 * h
yp2 = y2(s1, s2) + n3 * h
w(s2, n1, n2, n3) = u(s1, s2 + 1, th1, th2, cp, yp1, yp2)
Next
Next
Next
Next
For s2 = 1 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
cp = c(s1, s2 + 1) + n1 * h
yp1 = y1(s1, s2 + 1) + n2 * h
yp2 = y2(s1, s2 + 1) + n3 * h
rw(s2, n1, n2, n3) = u(s1, s2, th1, th2, cp, yp1, yp2)
Next
Next
Next
Next
s2 = 1
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
For q = -10 To 10
v(s2, n1, n2, n3, q) = -999
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
q = n2 + n3 - n1
v(s2, n1, n2, n3, q) = gu(s2, n1, n2, n3)
Next
Next
Next
For s2 = 2 To 9
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
u1 = gu(s2, n1, n2, n3)
For q = -10 To 10
qx = q + n1 - n2 - n3
pp = 0
If qx > 10 Then pp = 1
If qx < -10 Then pp = 1
If pp = 1 Then qx = 0
vs = -999
For m1 = -1 To 1
For m2 = -1 To 1
For m3 = -1 To 1
v1 = u1 + v(s2 - 1, m1, m2, m3, qx)
w1 = w(s2 - 1, m1, m2, m3)
u2 = gu(s2 - 1, m1, m2, m3)
w2 = rw(s2 - 1, n1, n2, n3)
If w1 > u1 Then v1 = -999
If w2 > u2 Then v1 = -999
If v1 > vs Then mx1 = m1
If v1 > vs Then mx2 = m2
If v1 > vs Then mx3 = m3
If v1 > vs Then vs = v1
Next
Next
Next
If pp = 1 Then vs = -999
gotoc(s2, n1, n2, n3, q) = mx1
gotoy1(s2, n1, n2, n3, q) = mx2
gotoy2(s2, n1, n2, n3, q) = mx3
gotoq(s2, n1, n2, n3, q) = qx
v(s2, n1, n2, n3, q) = vs
Next
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
u1 = gu(10, n1, n2, n3)
qx = n1 - n2 - n3
vs = -999
For m1 = -1 To 1
For m2 = -1 To 1
For m3 = -1 To 1
v1 = u1 + v(9, m1, m2, m3, qx)
w1 = w(9, m1, m2, m3)
If w1 > u1 Then v1 = -999
If v1 > vs Then mx1 = m1
If v1 > vs Then mx2 = m2
If v1 > vs Then mx3 = m3
If v1 > vs Then vs = v1
Next
Next
Next
endc(n1, n2, n3) = mx1
endy1(n1, n2, n3) = mx2
endy2(n1, n2, n3) = mx3
endv(n1, n2, n3) = vs
Next
Next
Next
vs = -999
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
If endv(n1, n2, n3) > vs Then nx1 = n1
If endv(n1, n2, n3) > vs Then nx2 = n2
If endv(n1, n2, n3) > vs Then nx3 = n3
If endv(n1, n2, n3) > vs Then vs = endv(n1, n2, n3)
Next
Next
Next
op1(10) = nx1
op2(10) = nx2
op3(10) = nx3
op1(9) = endc(op1(10), op2(10), op3(10))
op2(9) = endy1(op1(10), op2(10), op3(10))
op3(9) = endy2(op1(10), op2(10), op3(10))
opq(9) = op1(10) - op2(10) - op3(10)
For sx = 1 To 8
s2 = 9 - sx
op1(s2) = gotoc(s2 + 1, op1(s2 + 1), op2(s2 + 1), op3(s2 + 1), opq(s2 + 1))
op2(s2) = gotoy1(s2 + 1, op1(s2 + 1), op2(s2 + 1), op3(s2 + 1), opq(s2 + 1))
op3(s2) = gotoy2(s2 + 1, op1(s2 + 1), op2(s2 + 1), op3(s2 + 1), opq(s2 + 1))
opq(s2) = gotoq(s2 + 1, op1(s2 + 1), op2(s2 + 1), op3(s2 + 1), opq(s2 + 1))
Next
e = 0
For s2 = 1 To 10
e = e + op1(s2) ^ 2 + op2(s2) ^ 2 + op3(s2) ^ 2
Next
For s2 = 1 To 10
c(s1, s2) = c(s1, s2) + op1(s2) * h
y1(s1, s2) = y1(s1, s2) + op2(s2) * h
y2(s1, s2) = y2(s1, s2) + op3(s2) * h
Next
Debug.Print s1, t1, e, vs
If e < 1 Then h = h / 2
If h < 10 ^ (-4) Then t1 = 1000
t1 = t1 + 1
Loop
Next
Open "c:/lupin3.txt" For Output As #3
For m1 = 1 To 10
For m2 = 1 To 10
Write #3, m1, m2, c(m1, m2), y1(m1, m2), y2(m1, m2)
Next
Next
Close #3
End Sub