| |
近似曲線を求めるプログラムをもらったのですが、
求める近似曲線が元の曲線よりも必ず高い値になってほしいのです。
どこに手を加えればいいのかがまったくわかりません。
助言よろしくお願いします。
Sub square_least()
Dim Obs(256) As Single '離散点
Dim cons(10), dcon(10) As Single '関数パラメータ
Dim Fobje, xx, Rtmp As Single
Dim Lmat(10, 10), Rmat(10) As Single
Dim l As Single
Dim chk As Single
' 対数近時 f(x)=a*ln(x)+b
cons(1) = 100#
cons(2) = 1#
Nfunc = 2 ' 未知係数の個数
For l = 1 To 256
If (Cells(l, 1) = "") Then
Exit For
End If
Sheets("sheet1").Select
For j = 1 To 256
'chk = Cells(3, j)
If (Cells(l, j) = "") Then ' データ数のチェック
Ndata = j - 1
Exit For
End If
Obs(j) = Cells(l, j)
Next j
For itr = 1 To 20
'目的関数の作成
Fobje = 0#
For i = 1 To Ndata
xx = i
Fobje = Fobje + (Obs(i) - func(cons, xx)) ^ 2
Next i
'右辺の作成
For j = 1 To Nfunc
Rmat(j) = 0#
Rtmp = 0#
For i = 1 To Ndata
xx = i
Rtmp = Rtmp + dev_f(j, cons, xx) * (Obs(i) - func(cons, xx))
Next i
Rmat(j) = Rtmp
Next j
'左辺の作成
For j = 1 To 10
For i = 1 To 10
Lmat(i, j) = 0#
Next i
Next j
For i = 1 To Nfunc
For j = 1 To Nfunc
For k = 1 To Ndata
xx = k
Lmat(i, j) = Lmat(i, j) + dev_f(i, cons, xx) * dev_f(j, cons, xx)
f2 = dev_f(i, cons, xx)
Next k
Next j
Next i
Call gauss(Lmat, Rmat, dcon, Nfunc, 10)
bcoef = 0.5
For i = 1 To Nfunc
cons(i) = cons(i) + bcoef * dcon(i)
Next i
Sheets("sheet1").Select
Next itr
For i = 1 To Ndata
Sheets("sheet3").Select
Cells(l, i) = cons(1) * Log(i) + cons(2)
Sheets("sheet1").Select
Next i
Next l
End Sub
|
|
初心者
- 07/11/5(月) 20:19 -
