求取對稱矩陣特徵值和特徵向量的Jacobi過關法

特徵值和特徵向量是指對於矩陣A有，Av=lv，v爲特徵向量，l爲特徵值。就是求解一個高次方程：det(A-lI)=0

代碼如下：

unit Matrix;

interface

uses
  Math, Windows, SysUtils, Variants, Classes;

Type

TSingleExtendedArray =array of extended;

TDoubleExtendedArray=array of array of extended;

TDoubleLongintArray=array of array of longint;

procedure CalculateEigenVV(var EigenLambda: TSingleExtendedArray; var EigenVector: TDoubleExtendedArray; C: TDoubleLongintArray; N: longint; eps: extended);

implementation

procedure CalculateEigenVV(var EigenLambda: TSingleExtendedArray; var EigenVector: TDoubleExtendedArray; C: TDoubleLongintArray; N: longint; eps: extended);
var
  i, j, fi, fj, p, q, TL, k: longint;
  Change: boolean;
  x, y, cn, sn, Omega, fm, Acurrency: Extended;
  Ja: TDoubleExtendedArray;
begin
  setlength(Ja, N, N);
  setlength(EigenVector, N, N);
  setlength(EigenLambda, N);

  for i := 0 to N - 1 do begin
    EigenVector[i, i] := 1.0; EigenLambda[i] := 0;
    for j := 0 to N - 1 do
      if i <> j then EigenVector[i, j] := 0;
  end;

  Acurrency := 0;
  for i := 0 to N - 1 do
    for j := 0 to N - 1 do begin
      Ja[i, j] := C[i, j];
      Acurrency := Acurrency + Ja[i, j] * Ja[i, j];
    end;
  Acurrency := sqrt(2 * Acurrency);
  Change := true;
  repeat
    if not Change then Acurrency := Acurrency * 0.5;
    Change := false;
    for p := 0 to N - 1 do begin
      for q := p + 1 to N - 1 do
        if Abs(Ja[p, q]) > Acurrency then begin
          x := -Ja[p, q]; y := (Ja[q, q] - Ja[p, p]) / 2;
          if (x <> 0) or (y <> 0) then Omega := x / sqrt(x * x + y * y) else Omega := 1;
          if (y < 0.0) then Omega := -Omega;
          sn := 1.0 + sqrt(1.0 - Omega * Omega);
          sn := Omega / sqrt(2.0 * sn);
          cn := sqrt(1.0 - sn * sn);

          fm := Ja[p, p];
          Ja[p, p] := fm * cn * cn + Ja[q, q] * sn * sn + Ja[p, q] * Omega;
          Ja[q, q] := fm * sn * sn + Ja[q, q] * cn * cn - Ja[p, q] * Omega;
          Ja[p, q] := 0; Ja[q, p] := 0;

          for i := 0 to N - 1 do
            if (i <> p) and (i <> q) then begin
              fm := Ja[p, i];
              Ja[p, i] := fm * cn + Ja[q, i] * sn;
              Ja[q, i] := -fm * sn + Ja[q, i] * cn;
            end;

          for i := 0 to N - 1 do
            if (i <> p) and (i <> q) then begin
              fm := Ja[i, p];
              Ja[i, p] := fm * cn + Ja[i, q] * sn;
              Ja[i, q] := -fm * sn + Ja[i, q] * cn;
            end;

          for i := 0 to N - 1 do begin
            fm := EigenVector[p, i];
            EigenVector[p, i] := fm * cn + EigenVector[q, i] * sn;
            EigenVector[q, i] := -fm * sn + EigenVector[q, i] * cn;
          end;

          for i := 0 to N - 1 do
            EigenLambda[i] := Ja[i, i];

          Change := true; break;
        end;
      if Change then break;
    end;
  until Acurrency <= eps;

  setlength(Ja, 0);
end;

end.