'===== Bairstow法(VBA)を用いたN次方程式の解 ============ ' ' (1) パラメータを格納するシート名を"Bairstow"とする ' (2) 格納するパラメータは,次数(セルB1),誤差(セルD1) '    係数 (セルB2, C2, D2, ・・・) ' (3) 結果は,4行目以降に格納する ' A列:解の番号,B列:実数部,C列:虚数部 '========================================================= Private NMAX As Integer Private A() As Double Private EPS As Double Private pnt As Integer Private Sub dspRoot(R, I) '解の設定 A4〜Cn pnt = pnt + 1 With Worksheets("Bairstow") .Cells(pnt + 3, 1) = pnt ' 解の番号 .Cells(pnt + 3, 2) = R ' 実数部 .Cells(pnt + 3, 3) = I ' 虚数部 End With End Sub Private Sub eqRoot(p, q) '二次方程式の解 X^2+pX+q=0 d = p * p - 4 * q ' 判別式 If d < 0 Then ' 複素数解 F = Sqr(-d): R1 = -p * 0.5: R2 = R1 I1 = F * 0.5: I2 = -F * 0.5 Else ' 実数解 F = Sqr(d): R1 = (-p + F) * 0.5: R2 = (-p - F) * 0.5 I1 = 0: I2 = 0 End If dspRoot R1, I1: dspRoot R2, I2 End Sub Private Sub bairstow(p, q, A, n) ' 2次式の積に変換 ReDim B(n + 1), C(n + 1): p = 1#: q = 1# Do B(0) = A(0): B(1) = A(1) - p * B(0) '商の係数行列 For k = 2 To n B(k) = A(k) - p * B(k - 1) - q * B(k - 2) Next C(0) = B(0): C(1) = B(1) - p * C(0) For k = 2 To n C(k) = B(k) - p * C(k - 1) - q * C(k - 2) Next e = C(n - 2) * C(n - 2) - C(n - 3) * (C(n - 1) - B(n - 1)) dp = (B(n - 1) * C(n - 2) - B(n) * C(n - 3)) / e dq = (B(n) * C(n - 2) - B(n - 1) * (C(n - 1) - B(n - 1))) / e p = p + dp: q = q + dq: Loop While Abs(dp) > EPS And Abs(dq) > EPS For I = 0 To n - 2 A(I) = B(I) Next End Sub Sub データ設定() ' シート名を"Bairstow"とする With Worksheets("Bairstow") '次数(セルB1),誤差(セルD1) NMAX = Val(.Cells(1, 2)): EPS = Val(.Cells(1, 4)): ReDim A(NMAX) For I = 0 To NMAX ' 係数 (セルB2, C2, D2, ・・・) A(I) = Val(.Cells(2, I + 2)) Next I = 4 ' 結果設定領域をクリア While .Cells(I, 1) <> "" And .Cells(I, 2) <> "" And .Cells(I, 3) <> "" .Cells(I, 1) = "": .Cells(I, 2) = "": .Cells(I, 3) = "": I = I + 1 Wend pnt = 0 '結果設定用カウンタ0セット End With End Sub Sub ボタン1_Click() データ設定 n = NMAX While n >= 3 '3次式以上のとき,2次式の積に変換して解を求める bairstow p, q, A, n: eqRoot p, q: n = n - 2 Wend If n = 1 Then '残りが1次式のとき,実数-A(1)/A(0) dspRoot -A(1) / A(0), 0 ElseIf n = 2 Then '残りが2次式のとき2次方程式の解の公式 eqRoot A(1), A(2) End If End Sub