AR1 - プログラム倉庫

Function seektheta(p As Single, sig As Single) As Single
Dim x As Single
Dim z1 As Single
Dim y1 As Single
Dim y2 As Single
Dim y3 As Single
Dim g1 As Single
Dim g2 As Single
y1 = -3 * sig
y2 = 3 * sig
g1 = thetag(y1, sig)
t = 0
Do Until t > 100
g2 = thetag(y2, sig)
y3 = y2 + (p - g2) * (y2 - y1) / (g2 - g1)
y1 = y2
y2 = y3
g1 = g2
If (g2 - p) ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
seektheta = y2
End Function
Function thetag(y As Single, sig As Single) As Single
Dim n As Single
Dim h As Single
Dim z As Single
Dim x As Single
h = sig / 1000
z = Int(y / h)
z1 = 0
For n = -5000 To z
x = h * n
z1 = z1 + h * thetaf(x, sig)
Next
thetag = z1
End Function
Function thetaf(x As Single, sig As Single) As Single
Dim pi As Single
Dim x1 As Single
Dim x2 As Single
pi = 3.1415
x1 = Sqr(2 * pi) * sig
x2 = Exp(-x ^ 2 / (2 * sig ^ 2))
thetaf = x2 / x1
End Function
Private Sub Command1_Click()
Dim sig As Single
Dim p As Single
Dim n As Single
Dim th(1 To 10) As Single
Dim lnth(1 To 10) As Single
Dim lngototh(1 To 10, 1 To 10) As Single
Dim egototh(1 To 10, 1 To 10) As Single
Dim gototh(1 To 10, 1 To 10) As Single
Dim mu As Single
Dim e(1 To 10) As Single
mu = 0.95
sig = 0.008
For m = 1 To 10
th(m) = 0.98 + 0.004 * m
lnth(m) = Log(th(m))
Next
For s = 1 To 10
p = -0.05 + 0.1 * s
e(s) = seektheta(p, sig)
Next
For m = 1 To 10
For s = 1 To 10
lngototh(m, s) = mu * lnth(m) + e(s)
Next
Next
For m = 1 To 10
For s = 1 To 10
egototh(m, s) = Exp(lngototh(m, s))
Next
Next
For m = 1 To 10
For s = 1 To 10
gototh(m, s) = (egototh(m, s) - 0.98) / 0.004
Debug.Print m, s, gototh(m, s)
Next
Next
Open "c:/pro140.txt" For Output As #1
For m = 1 To 10
For s = 1 To 10
Write #1, m, s, gototh(m, s)
Next
Next
Close #1
End Sub