せ００ - プログラム倉庫

Function fselect2(s1 As Single, s2 As Single, m2 As Single, th1, th2, cs, 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
Dim i As Single
Dim j As Single
Dim t1 As Single
Dim t2 As Single
maxu = -999
For i = 0 To 10
For j = -1 To 1
c1 = cs(i, j)
my = y1(i)
fy = y2(m2 + j)
u1 = u(s1, s2, th1, th2, c1, my, fy)
If pp = 1 Then u1 = -999
If u1 > maxu Then maxm = j
If u1 > maxu Then maxu = u1
Next
Next
fselect2 = maxm
End Function

Function mselect2(s1 As Single, s2 As Single, m2 As Single, th1, th2, cs, 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
Dim i As Single
Dim j As Single
Dim t1 As Single
Dim t2 As Single
maxu = -999
For i = 0 To 10
For j = -1 To 1
c1 = cs(i, j)
my = y1(i)
fy = y2(m2 + j)
u1 = u(s1, s2, th1, th2, c1, my, fy)
If pp = 1 Then u1 = -999
If u1 > maxu Then maxm = i
If u1 > maxu Then maxu = u1
Next
Next
mselect2 = 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 lx 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
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
maxu = -999
For m1 = 0 To 10
For m2 = 0 To 5
c1 = c(m1, m2)
my = y1(m1)
fy = y2(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 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
maxu = -999
For m1 = 0 To 10
For m2 = 0 To 5
c1 = c(m1, m2)
my = y1(m1)
fy = y2(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

Private Sub Command1_Click()
Dim m1 As Single
Dim m2 As Single
Dim s1 As Single
Dim s2 As Single
Dim cp1 As Single
Dim yp1 As Single
Dim yp2 As Single
Dim c(0 To 10, 0 To 5) As Single
Dim cs(-1 To 1, 0 To 5) As Single
Dim cs2(0 To 10, -1 To 1) As Single
Dim th1(1 To 10) As Single
Dim th2(1 To 10) As Single
Dim y1(0 To 10) As Single
Dim y2(0 To 5) As Single
Dim mgr(1 To 10, 1 To 10) As Single
Dim fgr(1 To 10, 1 To 10) As Single
Dim gu(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim gb(1 To 9, -1 To 1, -1 To 1, -1 To 1) As Single
Dim gu2(1 To 4, -1 To 1, -1 To 1, -1 To 1) As Single
Dim gb2(1 To 4, -1 To 1, -1 To 1, -1 To 1) As Single
Dim endu(-1 To 1, -1 To 1) As Single
Dim fastb(-1 To 1, -1 To 1) As Single
Dim endb(-1 To 1, -1 To 1) As Single
Dim fastu(-1 To 1, -1 To 1) As Single
Dim endu2(-1 To 1, -1 To 1) As Single
Dim fastb2(-1 To 1, -1 To 1) As Single
Dim endb2(-1 To 1, -1 To 1) As Single
Dim fastu2(-1 To 1, -1 To 1) As Single
Dim mgroup(0 To 10, 1 To 100) As Single
Dim fgroup(0 To 10, 1 To 100) As Single
Dim mgroup2(0 To 5, 1 To 100) As Single
Dim fgroup2(0 To 5, 1 To 100) As Single
Dim ngroup(0 To 10) As Single
Dim ngroup2(0 To 5) As Single
Dim v(0 To 9, -1 To 1, -1 To 1, -25 To 25) As Single
Dim v2(0 To 4, -1 To 1, -1 To 1, -25 To 25) As Single
Dim goton(0 To 9, -1 To 1, -1 To 1, -25 To 25) As Single
Dim gotoq(0 To 9, -1 To 1, -1 To 1, -25 To 25) As Single
Dim goton2(0 To 4, -1 To 1, -1 To 1, -25 To 25) As Single
Dim gotoq2(0 To 4, -1 To 1, -1 To 1, -25 To 25) As Single
Dim endv(-1 To 1, -1 To 1, -25 To 25) As Single
Dim endv2(-1 To 1, -1 To 1, -25 To 25) As Single
Dim endq(-1 To 1, -1 To 1, -25 To 25) As Single
Dim endq2(-1 To 1, -1 To 1, -25 To 25) As Single
Dim op(0 To 10) As Single
Dim oq(0 To 10) As Single
Dim op2(0 To 10) As Single
Dim oq2(0 To 10) As Single
Dim memory(1 To 10, 1 To 10) As Single
Dim i As Single
Dim j 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
Open "c:/lup3.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3
m1 = a1
m2 = a2
c(m1, m2) = a3
Loop
Close #2
For s = 1 To 10
th1(s) = 0.2 * s
th2(s) = 0.1 * s
Next
For m = 0 To 10
y1(m) = 0.1 * m
Next
For m = 0 To 5
y2(m) = 0.1 * m
Next
For m1 = 0 To 10
t2 = 0
h = 0.001
Do Until t2 > 5
For s1 = 1 To 10
For s2 = 1 To 10
mgr(s1, s2) = mprefer(s1, s2, th1, th2, c, y1, y2)
fgr(s1, s2) = fprefer(s1, s2, th1, th2, c, y1, y2)
Next
Next
For m2 = 0 To 5
n = 0
For s1 = 1 To 10
For s2 = 1 To 10
If fgr(s1, s2) = m2 Then n = n + 1
If fgr(s1, s2) = m2 Then mgroup2(m2, n) = s1
If fgr(s1, s2) = m2 Then fgroup2(m2, n) = s2
Next
Next
ngroup2(m2) = n
Next
For m2 = 1 To 4
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
For i = 0 To 10
For j = -1 To 1
cs2(i, j) = c(i, m2 + j)
Next
Next
cs2(m1, -1) = c(m1, m2 - 1) + n1 * h
cs2(m1, 0) = c(m1, m2) + n2 * h
cs2(m1, 1) = c(m1, m2 - 1) + n3 * h
nu = ngroup2(m2)
us = 0
bs = 0
For n = 1 To nu
s1 = mgroup2(m2, n)
s2 = fgroup2(m2, n)
i = mselect2(s1, s2, m2, th1, th2, cs2, y1, y2)
j = fselect2(s1, s2, m2, th1, th2, cs2, y1, y2)
cp1 = cs2(i, j)
yp1 = y1(i)
yp2 = y2(m2 + j)
u1 = u(s1, s2, th1, th2, cp1, yp1, yp2)
us = us + u1
bs = bs + yp1 + yp2 - cp1
Next
If vv = 1 Then us = -999
gu2(m2, n1, n2, n3) = us
gb2(m2, n1, n2, n3) = bs
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For i = 0 To 10
For j = 0 To 1
cs2(i, j) = c(i, j)
Next
Next
cs2(m1, 0) = c(m1, 0) + n1 * h
cs2(m1, 1) = c(m1, 1) + n2 * h
nu = ngroup2(0)
us = 0
bs = 0
For n = 1 To nu
s1 = mgroup2(0, n)
s2 = fgroup2(0, n)
maxu = -999
For i = 0 To 10
For j = 0 To 1
cp1 = cs2(i, j)
yp1 = y1(i)
yp2 = y2(j)
u1 = u(s1, s2, th1, th2, cp1, yp1, yp2)
If u1 > maxu Then maxi = i
If u1 > maxu Then maxj = j
If u1 > maxu Then maxu = u1
Next
Next
us = us + maxu
bs = bs + y1(maxi) + y2(maxj) - cs2(maxi, maxj)
Next
fastu2(n1, n2) = us
fastb2(n1, n2) = bs
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For i = 0 To 10
For j = 0 To 1
cs2(i, j) = c(i, j)
Next
Next
cs2(m1, 0) = c(m1, 4) + n1 * h
cs2(m1, 1) = c(m1, 5) + n2 * h
nu = ngroup(5)
us = 0
bs = 0
For n = 1 To nu
s1 = mgroup(5, n)
s2 = fgroup(5, n)
maxu = -999
For i = 0 To 10
For j = 0 To 1
cp1 = cs(i, j)
yp1 = y1(i)
yp2 = y2(4 + j)
u1 = u(s1, s2, th1, th2, cp1, yp1, yp2)
If u1 > maxu Then maxi = i
If u1 > maxu Then maxj = j
If u1 > maxu Then maxu = u1
Next
Next
us = us + maxu
bs = bs + y1(maxi) + y2(4 + maxj) - cs(maxi, maxj)
Next
endu2(n1, n2) = us
endb2(n1, n2) = bs
Next
Next

For n1 = -1 To 1
For n2 = -1 To 1
For q = -25 To 25
v2(0, n1, n2, q) = -999
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
q0 = fastb2(0, 0)
q1 = fastb2(n1, n2)
q = Int((q1 - q0) / h)
pp = 0
If q > 25 Then pp = 1
If q < -25 Then pp = 1
If pp = 1 Then q = 0
v2(0, n1, n2, q) = fastu2(n1, n2)
If pp = 1 Then v2(0, n1, n2, q) = -999
Next
Next
For m2 = 1 To 4
For n1 = -1 To 1
For n2 = -1 To 1
For q = -25 To 25
vs = -999
For nx = -1 To 1
u1 = gu2(m2, nx, n1, n2)
q0 = gb2(m2, 0, 0, 0)
q1 = gb2(m2, nx, n1, n2)
qq = Int((q1 - q0) / h)
qx = q - qq
pp = 0
If qx > 25 Then pp = 1
If qx < -25 Then pp = 1
If pp = 1 Then qx = 0
v1 = u1 + v2(m2 - 1, nx, n1, qx)
If pp = 1 Then v1 = -999
If v1 > vs Then nxs = nx
If v1 > vs Then qxs = qx
If v1 > vs Then vs = v1
Next
v2(m2, n1, n2, q) = vs
goton2(m2, n1, n2, q) = nxs
gotoq2(m2, n1, n2, q) = qxs
Next
Next
Next
Next
For n1 = -1 To 1
For n2 = -1 To 1
For q = -25 To 25
u1 = endu2(n1, n2)
q0 = endb2(0, 0)
q1 = endb2(n1, n2)
qq = Int((q1 - q0) / h)
qx = q - qq
pp = 0
If qx > 25 Then pp = 1
If qx < -25 Then pp = 1
If pp = 1 Then qx = 0
v1 = u1 + v2(4, n1, n2, qx)
If pp = 1 Then v1 = -999
endv2(n1, n2, q) = v1
endq2(n1, n2, q) = qx
Next
Next
Next
maxv = -999
For n1 = -1 To 1
For n2 = -1 To 1
For q = 0 To 25
If endv2(n1, n2, q) > maxv Then nx1 = n1
If endv2(n1, n2, q) > maxv Then nx2 = n2
If endv2(n1, n2, q) > maxv Then qx = q
If endv2(n1, n2, q) > maxv Then maxv = endv2(n1, n2, q)
Next
Next
Next
op2(4) = nx1
op2(5) = nx2
oq2(5) = qx
oq2(4) = endq2(op2(4), op2(5), oq2(5))
For j = 1 To 4
m2 = 4 - j
op2(m2) = goton2(m2 + 1, op2(m2 + 1), op2(m2 + 2), oq2(m2 + 1))
oq2(m2) = gotoq2(m2 + 1, op2(m2 + 1), op2(m2 + 2), oq2(m2 + 1))
Next
For m2 = 0 To 5
c(m1, m2) = c(m1, m2) + op2(m2) * h
Next
e = 0
For s1 = 1 To 10
For s2 = 1 To 10
mx1 = mprefer(s1, s2, th1, th2, c, y1, y2)
mx2 = fprefer(s1, s2, th1, th2, c, y1, y2)
e = e + (c(mx1, mx2) - memory(s1, s2)) ^ 2
memory(s1, s2) = c(mx1, mx2)
Next
Next
If e < 10 ^ (-7) Then h = h / 2
If h < 10 ^ (-4) Then t2 = 1000
t2 = t2 + 1
Debug.Print m1, t2, e, maxv
Loop
Next
For m2 = 0 To 5
Debug.Print c(0, m2), y2(m2)
Next
Open "c:/lup3.txt" For Output As #1
For m1 = 0 To 10
For m2 = 0 To 5
Write #1, m1, m2, c(m1, m2)
Next
Next
Close #1

End Sub