横 - プログラム倉庫

Function mcheck(s2 As Single, th1, th2, n As Single, c, y1, y2, x, h As Single) As Single
Dim ch As Single
Dim s1 As Single
Dim c1 As Single
Dim x1 As Single
Dim x2 As Single
Dim u1 As Single
ch = 0
For s1 = 1 To 9
c1 = c(s1, s2) + x(s1, s2, 1, n) * h
x1 = y1(s1, s2) + x(s1, s2, 2, n) * h
x2 = y2(s1, s2) + x(s1, s2, 3, n) * h
u1 = u(s1, s2, th1, th2, c1, x1, x2)
c1 = c(s1 + 1, s2) + x(s1 + 1, s2, 1, n) * h
x1 = y1(s1 + 1, s2) + x(s1 + 1, s2, 2, n) * h
x2 = y2(s1 + 1, s2) + x(s1 + 1, s2, 3, n) * h
u2 = u(s1, s2, th1, th2, c1, x1, x2)
If u2 > u1 Then ch = ch + 10
Next
mcheck = ch
End Function
Function mcount(s2 As Single, n As Single, x) As Single
Dim sum1 As Single
Dim s1 As Single
sum1 = 0
For s1 = 1 To 10
sum1 = sum1 + x(s1, s2, 1, n) - x(s1, s2, 2, n) - x(s1, s2, 3, n)
Next
mcount = sum1
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
Private Sub Command1_Click()
Dim s2 As Single
Dim m As Single
Dim th1(1 To 100) As Single
Dim th2(1 To 100) As Single
Dim y1(1 To 10, 1 To 10) As Single
Dim y2(1 To 10, 1 To 10) As Single
Dim c(1 To 10, 1 To 10) As Single
Dim x(1 To 10, 1 To 10, 1 To 3, 0 To 10) As Single
Dim mgu(1 To 10, 0 To 10) As Single
Dim mv(1 To 10, 0 To 10) As Single
Dim gotom(1 To 10, 0 To 10) As Single
Dim s1 As Single
Dim rank As Single
Dim s As Single
Dim r1 As Single
Dim x1 As Single
Dim c1 As Single
Dim x2 As Single
Dim t2 As Single
Dim n As Single
Dim h As Single
Dim mop(1 To 10) As Single
Dim vs As Single
For s = 1 To 10
th1(s) = 0.2 * s
th2(s) = 0.1 * s
Next
Open "c:/lupin.txt" For Input As #2
Do Until EOF(2)
Input #2, a1, a2, a3, a4, a5
s1 = a1
s2 = a2
c(s1, s2) = a3
y1(s1, s2) = a4
y2(s1, s2) = a5
Loop
Close #2
t3 = 0
Do Until t3 > 10
For s2 = 1 To 10
For n = 1 To 10
t2 = 0
Do Until t2 > 100
t1 = 0
Do Until t1 > 100
For s1 = 1 To 10
For rank = 1 To 3
Randomize
r1 = Rnd()
x1 = 0
If r1 > 0.7 Then x1 = 1
If r1 < 0.3 Then x1 = -1
x(s1, s2, rank, n) = x1
Next
Next
If mcount(s2, n, x) = 0 Then t1 = 1000
t1 = t1 + 1
Loop
h = 0.001
ch = mcheck(s2, th1, th2, n, c, y1, y2, x, h)
If ch < 10 Then t2 = 1000
t2 = t2 + 1
Loop
Next
Next
For s2 = 1 To 10
For n = 0 To 10
u1 = 0
For s1 = 1 To 10
c1 = c(s1, s2) + x(s1, s2, 1, n) * h
x1 = y1(s1, s2) + x(s1, s2, 2, n) * h
x2 = y2(s1, s2) + x(s1, s2, 3, n) * h
u1 = u1 + u(s1, s2, th1, th2, c1, x1, x2)
Next
mgu(s2, n) = u1
Next
Next
s2 = 1
For n = 0 To 10
mv(s2, n) = mgu(s2, n)
Next
For s2 = 2 To 10
For n = 0 To 10
vs = -999
For p = 0 To 10
de = 0
For s1 = 1 To 10
c1 = c(s1, s2) + x(s1, s2, 1, n) * h
x1 = y1(s1, s2) + x(s1, s2, 2, n) * h
x2 = y2(s1, s2) + x(s1, s2, 3, n) * h
u1 = u(s1, s2, th1, th2, c1, x1, x2)
For n2 = 1 To 10
c1 = c(n2, s2 - 1) + x(n2, s2 - 1, 1, p) * h
x1 = y1(n2, s2 - 1) + x(n2, s2 - 1, 2, p) * h
x2 = y2(n2, s2 - 1) + x(n2, s2 - 1, 3, p) * h
u2 = u(s1, s2, th1, th2, c1, x1, x2)
If u2 > u1 Then de = de + 10
Next
Next
v1 = mgu(s2, n) + mv(s2 - 1, p)
If de > 5 Then v1 = -999
If v1 > vs Then nx = p
If v1 > vs Then vs = v1
Next
mv(s2, n) = vs
gotom(s2, n) = nx
Next
Next
s2 = 10
maxv = -999
For n = 0 To 10
If mv(s2, n) > maxv Then nx = n
If mv(s2, n) > maxv Then maxv = mv(s2, n)
Next
mop(10) = nx
For j = 1 To 9
s2 = 11 - j
mop(s2 - 1) = gotom(s2, mop(s2))
Next
For s1 = 1 To 10
For s2 = 1 To 10
c(s1, s2) = c(s1, s2) + x(s1, s2, 1, mop(s2)) * h
y1(s1, s2) = y1(s1, s2) + x(s1, s2, 2, mop(s2)) * h
y2(s1, s2) = y2(s1, s2) + x(s1, s2, 3, mop(s2)) * h
Next
Next
e = 0
For s2 = 1 To 10
e = e + mop(s2) ^ 2
Next
Debug.Print t3, e, maxv
t3 = t3 + 1
Loop
For s1 = 1 To 10
For s2 = 1 To 10
Debug.Print c(s1, s2), y1(s1, s2), y2(s1, s2)
Next
Next

End Sub