lk - プログラム倉庫

Function seekendu(th, c1 As Single, c2 As Single, y1 As Single, y2 As Single) As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim l1 As Single
Dim l2 As Single
Dim l3 As Single
Dim pp As Single
Dim us As Single
Dim cp As Single
l1 = y1 / th(100)
pp = 0
cp = c1
If cp < 0.001 Then pp = 1
If l1 > 0.99 Then pp = 1
If pp = 1 Then l1 = 0.5
If pp = 1 Then cp = 0.5
u1 = Log(cp) + Log(1 - l1)
If pp = 1 Then u1 = -999
pp = 0
cp = c2
l2 = y2 / th(100)
If cp < 0.001 Then pp = 1
If l2 > 0.99 Then pp = 1
If pp = 1 Then l2 = 0.5
If pp = 1 Then cp = 0.5
u2 = Log(cp) + Log(1 - l2)
If pp = 1 Then u2 = -999
us = -999
If u1 > us Then us = u1
If u2 > us Then us = u2
seekendu = us
End Function

Function seekfastu(th, c1 As Single, c2 As Single, y1 As Single, y2 As Single) As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim l1 As Single
Dim l2 As Single
Dim l3 As Single
Dim pp As Single
Dim us As Single
Dim cp As Single
l1 = y1 / th(1)
pp = 0
cp = c1
If cp < 0.001 Then pp = 1
If l1 > 0.99 Then pp = 1
If pp = 1 Then l1 = 0.5
If pp = 1 Then cp = 0.5
u1 = Log(cp) + Log(1 - l1)
If pp = 1 Then u1 = -999
pp = 0
cp = c2
l2 = y2 / th(1)
If cp < 0.001 Then pp = 1
If l2 > 0.99 Then pp = 1
If pp = 1 Then l2 = 0.5
If pp = 1 Then cp = 0.5
u2 = Log(cp) + Log(1 - l2)
If pp = 1 Then u2 = -999
us = -999
If u1 > us Then us = u1
If u2 > us Then us = u2
seekfastu = us
End Function


Function seeku(s As Single, th, c1 As Single, c2 As Single, c3 As Single, y1 As Single, y2 As Single, y3 As Single) As Single
Dim u1 As Single
Dim u2 As Single
Dim u3 As Single
Dim l1 As Single
Dim l2 As Single
Dim l3 As Single
Dim pp As Single
Dim us As Single
Dim cp As Single
l1 = y1 / th(s)
pp = 0
cp = c1
If cp < 0.001 Then pp = 1
If l1 > 0.99 Then pp = 1
If pp = 1 Then l1 = 0.5
If pp = 1 Then cp = 0.5
u1 = Log(cp) + Log(1 - l1)
If pp = 1 Then u1 = -999
pp = 0
cp = c2
If cp < 0.001 Then pp = 1
If l2 > 0.99 Then pp = 1
If pp = 1 Then l2 = 0.5
If pp = 1 Then cp = 0.5
l2 = y2 / th(s)
u2 = Log(cp) + Log(1 - l2)
If pp = 1 Then u2 = -999
l3 = y3 / th(s)
pp = 0
cp = c3
If cp < 0.001 Then pp = 1
If l3 > 0.99 Then pp = 1
If pp = 1 Then l3 = 0.5
If pp = 1 Then c3 = 0.5
u3 = Log(cp) + Log(1 - l3)
If pp = 1 Then u3 = -999
us = -999
If u1 > us Then us = u1
If u2 > us Then us = u2
If u3 > us Then us = u3
seeku = us
End Function




Private Sub Command1_Click()
Dim s As Single
Dim th(1 To 100) As Single
Dim c(1 To 100) As Single
Dim y(1 To 100) As Single
Dim u(2 To 99, -1 To 1, -1 To 1, -1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim fastu(-1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim endu(-1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim endv(-1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim v(1 To 99, -1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim gotoc(1 To 99, -1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim gotoy(1 To 99, -1 To 1, -1 To 1, -1 To 1, -1 To 1) As Single
Dim n1 As Single
Dim n2 As Single
Dim n3 As Single
Dim m1 As Single
Dim m2 As Single
Dim m3 As Single
Dim h 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
Dim opc(1 To 100) As Single
Dim opy(1 To 100) As Single
For s = 1 To 100
th(s) = 0.02 * s
Next
For s = 1 To 100
c(s) = th(s) / 2
y(s) = th(s) / 2
Next
h = 0.001
t = 0
Do Until t > 100
For s = 2 To 99
For m1 = -1 To 1
For m2 = -1 To 1
For m3 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
For n3 = -1 To 1
c1 = c(s - 1) + m1 * h
c2 = c(s) + m2 * h
c3 = c(s + 1) + m3 * h
y1 = y(s - 1) + n1 * h
y2 = y(s) + n2 * h
y3 = y(s + 1) + n3 * h
u(s, m1, m2, m3, n1, n2, n3) = seeku(s, th, c1, c2, c3, y1, y2, y3)
Next
Next
Next
Next
Next
Next
Next
For m1 = -1 To 1
For m2 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
c1 = c(1) + m1 * h
c2 = c(2) + m2 * h
y1 = y(1) + n1 * h
y2 = y(2) + n2 * h
fastu(m1, m2, n1, n2) = seekfastu(th, c1, c2, y1, y2)
Next
Next
Next
Next
For m1 = -1 To 1
For m2 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
c1 = c(99) + m1 * h
c2 = c(100) + m2 * h
y1 = y(99) + n1 * h
y2 = y(100) + n2 * h
endu(m1, m2, n1, n2) = seekendu(th, c1, c2, y1, y2)
Next
Next
Next
Next
s = 1
For m1 = -1 To 1
For m2 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
v(s, m1, m2, n1, n2) = fastu(m1, m2, n1, n2)
Next
Next
Next
Next
For s = 2 To 99
For m1 = -1 To 1
For m2 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
vs = -999
For mx = -1 To 1
For nx = -1 To 1
u1 = u(s, mx, m1, m2, nx, n1, n2)
v1 = u1 + v(s - 1, mx, m1, nx, n1)
If v1 > vs Then mxs = mx
If v1 > vs Then nxs = nx
If v1 > vs Then vs = v1
Next
Next
gotoc(s, m1, m2, n1, n2) = mxs
gotoy(s, m1, m2, n1, n2) = nxs
v(s, m1, m2, n1, n2) = vs
Next
Next
Next
Next
Next
For m1 = -1 To 1
For m2 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
endv(m1, m2, n1, n2) = endu(m1, m2, n1, n2) + v(99, m1, m2, n1, n2)
Next
Next
Next
Next
vs = -999
For m1 = -1 To 1
For m2 = -1 To 1
For n1 = -1 To 1
For n2 = -1 To 1
If endv(m1, m2, n1, n2) > vs Then mx1 = m1
If endv(m1, m2, n1, n2) > vs Then mx2 = m2
If endv(m1, m2, n1, n2) > vs Then nx1 = n1
If endv(m1, m2, n1, n2) > vs Then nx2 = n2
If endv(m1, m2, n1, n2) > vs Then vs = endv(m1, m2, n1, n2)
Next
Next
Next
Next
Debug.Print vs
opc(99) = mx1
opc(100) = mx2
opy(99) = nx1
opy(100) = nx2
For j = 1 To 98
s = 100 - j
opc(s - 1) = gotoc(s, opc(s), opc(s + 1), opy(s), opy(s + 1))
opy(s - 1) = gotoy(s, opc(s), opc(s + 1), opy(s), opy(s + 1))
Next
e = 0
For s = 1 To 100
e = e + opc(s) ^ 2 + opy(s) ^ 2
Next
Debug.Print t, e
For s = 1 To 100
c(s) = c(s) + opc(s) * h
y(s) = y(s) + opy(s) * h
Next
t = t + 1
Loop


End Sub