实对称矩阵的特征值与特征向量求解

chlh_jd

求非奇异实数矩阵A特征值与特征向量常用的求解方法有: 幂法，反幂法，QR迭代法， Givens变换收缩法，Jocobi法，同步求解法。

幂法用来求第一个特征值和特征向量，后面将给出第一次计算范例（详细步骤可在百度文库找到）。幂法收敛速度通常比较慢，如果提高计算速度就要损失精度，当前后两次迭代得到的特征值较为接近时，收敛很慢，因此还衍生出了加入瑞利（Rayleigh）商加速法、原位平移法等。幂法+收缩法就可以求全部特征值和特征向量，主要步骤为：
1.对矩阵A第一次求出特征值λ1和第1个特征向量x1;
2. 然后用0代替λ1所在行，将矩阵降阶，再次使用幂法，就可以得到第2个特征值λ2与特征向量x2 ;
3.依次类推，最终得到所有的特征值λ。
4. 对并列矩阵[ (λiI-A)^t | I ] 采用高斯消元法转为上三角矩阵，左阵0向量或相邻向量线性相关的向量对应的右阵向量即为特征向量，依次代入所有特征值求出所有特征向量。

2. ;;;---------------------------------------幂法-----------------------------------;;;
   
3. (defun PowerEigen  (mat eps / v0 f0 vk f1)
   
4.   ;; 求矩阵第一特征值与特征向量求解
   
5.   ;; Get First EigenValue and it's EigenVector
   
6.   ;; mat 为方阵 ; eps 为精度、该精度不宜太小否收敛很慢, 宜为1e-6~1e-8
   
7.   ;; by GSLS(SS) 2012-12-24
   
8.   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.))) -->(4. (0.5 1.0 0.5)) 即4为其中一个特征值，该特征值对应的特征向量为(0.5 1.0 0.5)
   
9.   ;; (setq a '((7. 3. -2.) (3. 4. 1.) (-2. -1. 3.))) --> (9.27492 (1.0 0.493399 -0.39736))
   
10.   ;; (setq a '((4. 1. 0.) (1. 0. -1.) (1. 1. -4.))) --> (4.20303 (1.0 0.20303 0.146657))
    
11.   ;; (setq a '((1. 1. 0.5) (1. 1. 0.25) (0.5 0.25 2.))) --> (2.53652587 (0.74822116 0.64966115 1.0))
    
12.   ;; (PowerEigen a 1e-9)
    
13.   (setq v0 (mapcar (function (lambda (x) 1.0)) (car mat))
    
14. f0 1.0
    
15. vk (mxv mat v0)
    
16. f1 (apply (function max) (mapcar (function abs) vk))
    
17. vk (pt* vk (1/ f1)))
    
18.   (while
    
19.     (not
    
20.       (and
    
21. (<= (abs (- f1 f0)) eps)
    
22. (<=
    
23.    ((lambda (x)
    
24.       (sqrt (apply (function +) (mapcar (function *) x x))))
    
25.      (pt- vk v0))
    
26.    eps)))
    
27.      (setq v0 vk
    
28.     f0 f1
    
29.     vk (mxv mat v0)
    
30.     f1 (apply (function max) (mapcar (function abs) vk))
    
31.     vk (pt* vk (1/ f1))))
    
32.   (cons f1 vk))
    
33. ;;
    
34. (defun Power->EV (mat eps / m  v  v1 eig res)
    
35.   ;; Get all EigenValues
    
36.   ;; by GSLS(SS) 2013-1-3
    
37.   ;; (PowerEigenValues a)
    
38.   (while (cadr mat)
    
39.     (setq eig (powereigen mat eps)
    
40.    res (cons eig res))
    
41.     (if res
    
42.       (setq v (car mat)
    
43.      v1 (cdar res)
    
44.      v1 (pt* v1 (1/ (car v1)))
    
45.      m (vtxv v1 v)
    
46.      mat ([-] mat m)
    
47.      mat (mapcar (function cdr) (cdr mat))
    
48.       ))     
    
49.     )
    
50.   (reverse (mapcar (function car) (cons (car mat) res)))
    
51.   )
    

;;;---------------------------------------幂法-----------------------------------;;;<br /> (defun PowerEigen  (mat eps / v0 f0 vk f1)<br />   ;; 求矩阵第一特征值与特征向量求解<br />   ;; Get First EigenValue and it's EigenVector<br />   ;; mat 为方阵 ; eps 为精度、该精度不宜太小否收敛很慢, 宜为1e-6~1e-8<br />   ;; by GSLS(SS) 2012-12-24<br />   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.))) -->(4. (0.5 1.0 0.5)) 即4为其中一个特征值，该特征值对应的特征向量为(0.5 1.0 0.5)<br />   ;; (setq a '((7. 3. -2.) (3. 4. 1.) (-2. -1. 3.))) --> (9.27492 (1.0 0.493399 -0.39736))<br />   ;; (setq a '((4. 1. 0.) (1. 0. -1.) (1. 1. -4.))) --> (4.20303 (1.0 0.20303 0.146657))<br />   ;; (setq a '((1. 1. 0.5) (1. 1. 0.25) (0.5 0.25 2.))) --> (2.53652587 (0.74822116 0.64966115 1.0))<br />   ;; (PowerEigen a 1e-9)<br />   (setq v0 (mapcar (function (lambda (x) 1.0)) (car mat))<br /> f0 1.0<br /> vk (mxv mat v0)<br /> f1 (apply (function max) (mapcar (function abs) vk))<br /> vk (pt* vk (1/ f1)))<br />   (while<br />     (not<br />       (and<br /> (<= (abs (- f1 f0)) eps)<br /> (<=<br />    ((lambda (x)<br />       (sqrt (apply (function +) (mapcar (function *) x x))))<br />      (pt- vk v0))<br />    eps)))<br />      (setq v0 vk<br />     f0 f1<br />     vk (mxv mat v0)<br />     f1 (apply (function max) (mapcar (function abs) vk))<br />     vk (pt* vk (1/ f1))))<br />   (cons f1 vk))<br /> ;; <br /> (defun Power->EV (mat eps / m  v  v1 eig res)<br />   ;; Get all EigenValues<br />   ;; by GSLS(SS) 2013-1-3<br />   ;; (PowerEigenValues a)<br />   (while (cadr mat)<br />     (setq eig (powereigen mat eps)<br />    res (cons eig res))<br />     (if res<br />       (setq v (car mat)<br />      v1 (cdar res)<br />      v1 (pt* v1 (1/ (car v1)))<br />      m (vtxv v1 v)<br />      mat ([-] mat m)<br />      mat (mapcar (function cdr) (cdr mat))<br />       ))     <br />     )<br />   (reverse (mapcar (function car) (cons (car mat) res)))<br />   )<br />

反幂法用来求最小特征值和特征向量，其迭代过程与幂法雷同。


QR迭代法是20世纪60年代产生的一种求中小规模的矩阵的特征值与特征向量的方法，先求得准确的矩阵模，将该模与叠代中间矩阵的主迹（脚标相同的元素积）做比较，如果在容差范围内，则停止迭代，否则进行下一步迭代。QR法的主要步骤：
R——矩阵A的上三角矩阵，A=QR
将A做Householder(镜像变换，由著名的数值分析专家Householder在1958年为讨论矩阵特征值问题而提出来的，在Grandyang的百度空间有详细的公式和算法说明http://hi.baidu.com/grandyang/item/e024400bf3c879ce915718e2）变换，得到Q1和R1，
新矩阵A1=R1Q1,如果A1的主迹等于|A|，停止迭代，否则继续
-----（镜像变换）---->Q2、R2
A2=R2Q2,如果A2的主迹等于|A|，停止迭代，否则继续
-----（镜像变换）---->Q3、R3
A3=R3Q3 ....
...
Ak=RkQk
...
An=RnQn
QR法经过N次迭代总能得到收敛，收敛速度依赖于相邻特征值的比值，为了加速收敛可以引入原点平移法，此时迭代公式改为Ak-sk*I=RkQk+sk*I , sk为位移量。求得的所有特征值后，采用幂法的第4步求特征向量。
QR法可以把求解精度设得很高，如1e-10，所需增加的计算量并不是太多（一个5x5方阵，计算精度由1e-8提高到1e-10其迭代次数也仅是由24次提高到28次），当然由于VLISP自身的计算精度并不是很高（如乘*、除/、幂expt等函数），精度也不适合设得太高，建议采用1e-10。值得一提的是QR法同时还可以用来求超秩矩阵（超定线性方程组的系数）的特征值。

2. ;;;----------------------------------Householder变换------------------------------;;;
   
3. (defun householder  (mat / imat i m n d a b u hk q)
   
4.   ;; Use Householder transformation to Get QR matrix for QR-decomposition
   
5.   ;; (householder mat)
   
6.   ;; (setq mat '((2. 3.) (1. 2.) (5. 7.)))
   
7.   ;; (setq mat '((1. 2. -3.) (1. 3. 10.) (1. -1. 6.)))
   
8.   (setq i    0
   
9. n    (length (car mat))
   
10. m    (length mat)
    
11. imat ([i] m)
    
12. q    imat)
    
13.   (while (< i n)
    
14.     (setq d (mapcar (function (lambda (x) (nth i x))) mat))
    
15.     (repeat i
    
16.       (setq d (cdr d)))
    
17.     (setq a (* (sign (car d))
    
18.         (sqrt (apply (function +)
    
19.        (mapcar (function (lambda (x)
    
20.       (* x x)))
    
21.         d))))
    
22.    b (* a (+ a (car d)))
    
23.    d (cons (+ (car d) a)
    
24.     (cdr d)))
    
25.     (repeat i
    
26.       (setq d (cons 0. d)))
    
27.     (setq u (vtxv d d))
    
28.     (if (not(zerop b))      
    
29.       (setq u ([k*] (1/ b) u)))
    
30.     (setq hk ([-] imat u)
    
31.    q  ([*] q hk)
    
32.    mat ([*] hk mat)
    
33.    i (1+ i)))
    
34.   (list q mat))
    
35. ;;;------------------------------------QR分解迭代---------------------------------;;;
    
36. ;;
    
37. (defun QR->EV  (mat eps / d i b t1)
    
38.   ;; QR-decomposition
    
39.   ;; by GSLS(SS) 2013-1-2
    
40.   (setq t1 (getvar "millisecs")
    
41. d  (gc:determ mat)
    
42. i  0);_Set the maximum number of iterations to prevent stack overflow
    
43.   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))
    
44.     (setq b   (householder mat)
    
45.    mat ([*] (cadr b) (car b))
    
46.    i   (1+ i)))
    
47.   (princ (strcat "\nQR-decomposition of iterations is : "
    
48.    (rtos i 2)
    
49.    " times ."))
    
50.   (princ (strcat "\nTotel time of QR-decomposition : "
    
51.    (rtos (- (getvar "millisecs") t1) 2 0)
    
52.    " m.s."))
    
53.   mat)

;;;----------------------------------Householder变换------------------------------;;;<br /> (defun householder  (mat / imat i m n d a b u hk q)<br />   ;; Use Householder transformation to Get QR matrix for QR-decomposition<br />   ;; (householder mat)<br />   ;; (setq mat '((2. 3.) (1. 2.) (5. 7.)))<br />   ;; (setq mat '((1. 2. -3.) (1. 3. 10.) (1. -1. 6.)))<br />   (setq i    0<br /> n    (length (car mat))<br /> m    (length mat)<br /> imat ([i] m)<br /> q    imat)<br />   (while (< i n)<br />     (setq d (mapcar (function (lambda (x) (nth i x))) mat))<br />     (repeat i<br />       (setq d (cdr d)))<br />     (setq a (* (sign (car d))<br />         (sqrt (apply (function +)<br />        (mapcar (function (lambda (x)<br />       (* x x)))<br />         d))))<br />    b (* a (+ a (car d)))<br />    d (cons (+ (car d) a)<br />     (cdr d)))<br />     (repeat i<br />       (setq d (cons 0. d)))<br />     (setq u (vtxv d d))<br />     (if (not(zerop b))      <br />       (setq u ([k*] (1/ b) u)))<br />     (setq hk ([-] imat u)<br />    q  ([*] q hk)<br />    mat ([*] hk mat)<br />    i (1+ i)))<br />   (list q mat))<br /> ;;;------------------------------------QR分解迭代---------------------------------;;;<br /> ;;<br /> (defun QR->EV  (mat eps / d i b t1)<br />   ;; QR-decomposition<br />   ;; by GSLS(SS) 2013-1-2<br />   (setq t1 (getvar "millisecs")<br /> d  (gc:determ mat)<br /> i  0);_Set the maximum number of iterations to prevent stack overflow<br />   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))<br />     (setq b   (householder mat)<br />    mat ([*] (cadr b) (car b))<br />    i   (1+ i)))<br />   (princ (strcat "\nQR-decomposition of iterations is : "<br />    (rtos i 2)<br />    " times ."))<br />   (princ (strcat "\nTotel time of QR-decomposition : "<br />    (rtos (- (getvar "millisecs") t1) 2 0)<br />    " m.s."))<br />   mat)

Givens变换（这是20世纪90年代的新算法，又称平面旋转变换) 是一种重要的正交交换, 它具有计算量小, 数值稳定的优点；欲将一个向量许多分量化为0采用Householder变换；欲将一个向量某个分量化为0采用Givens变换。Givens变换向量解和迭代法求解特征值和特征向量，主要步骤是:
1.先将矩阵A做右旋转相似变换，依次将从左到右的各列下三角元素变换为0，在这个过程中，下三角元素会逐步趋于0，因此需要多次迭代，将矩阵转换为上三角矩阵S；则各个对角线上的元素即为所有特征值。
2.之后可以用幂法的第4步来求解特征向量。

2. ;;--------------------------------Givens变换法-----------------------------------;;;
   
3. (defun Givens  (mat Q / i j aij aii ajj aji ang a b m n0 n r Q1)
   
4.   ;;(Givens a)
   
5.   ;; Givens 变换求上三角阵
   
6.   (setq i  (length mat)
   
7. m0 i
   
8. n0 (length (car mat))
   
9. j -1)
   
10.   (while (< j (1- n0))
    
11.     (setq i m0
    
12.    j (1+ j))
    
13.     (while (> (setq i (1- i)) j)
    
14.       (setq aij (nth j (nth i mat)))
    
15.       (if (not (equal aij 0.0 1e-14))
    
16. (progn
    
17.    (setq aii (nth i (nth i mat))
    
18.   ajj (nth j (nth j mat))
    
19.   aji (nth i (nth j mat)))
    
20.    (if (= aii ajj)
    
21.      (if (> aij 0)
    
22.        (setq ang _pi4)
    
23.        (if (< aij 0)
    
24.   (setq ang (- _pi4))))
    
25.      (setq ang  (/ (atan (/  aij (- ajj aii) 0.5)) 2.))
    
26.      )
    
27.    (setq ang (max (min ang _pi4) (- _pi4)))
    
28.    (setq m m0
    
29.   Q1 nil)
    
30.    (while (<= 0 (setq m (1- m)))
    
31.      (setq n n0
    
32.     r nil)
    
33.      (while (<= 0 (setq n (1- n)))
    
34.        (setq r (cons (cond ((and (= m i) (= n j))
    
35.        (- (sin ang)))
    
36.       ((and (= m j) (= n i))
    
37.        (sin ang))
    
38.       ((and (= m i) (= n i))
    
39.        (cos ang))
    
40.       ((and (= m j) (= n j))
    
41.        (cos ang))
    
42.       ((= m n)
    
43.        1.)
    
44.       (0.0))
    
45.        r)))
    
46.      (setq Q1 (cons r Q1))
    
47.      )
    
48.    (setq Q ([*] Q1 Q))
    
49.    (setq mat ([*] ([*] Q1 mat) ([trp] Q1)))
    
50.    )
    
51. )      
    
52.       )
    
53.     )
    
54.   (list mat Q))
    
55. ;;-------------------
    
56. (defun Givens->EV  (mat eps / d i b t1 q )
    
57.   ;; Givens method main function
    
58.   ;; by GSLS(SS) 2013-1-4
    
59.   ;; (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0)))
    
60.   ;; (Givens->EV a 1e-12) --> (0.0660769 4.18334 18.2577 94.9829 7.50996)
    
61.   (setq t1 (getvar "millisecs")
    
62. d  (gc:determ mat)
    
63. q  ([i] (length (car mat)))
    
64. i  0 ;_Set the maximum number of iterations to prevent stack overflow
    
65. )
    
66.   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))
    
67.     (setq b (Givens mat Q)
    
68.    mat (car b)
    
69.    q (cadr b))
    
70.     (setq i (1+ i)))
    
71.   (print mat)
    
72.   (princ (strcat "\nJacobi iterations is : "
    
73.    (rtos i 2)
    
74.    " times ."))
    
75.   (princ (strcat "\nTotel time of Jacobi solving : "
    
76.    (rtos (- (getvar "millisecs") t1) 2 0)
    
77.    " m.s."))
    
78.   (setq i -1)  
    
79.   (mapcar (function (lambda (r1 )        
    
80.         (nth (setq i (1+ i)) r1)))
    
81.    mat)
    
82.   )

;;--------------------------------Givens变换法-----------------------------------;;;<br /> (defun Givens  (mat Q / i j aij aii ajj aji ang a b m n0 n r Q1)<br />   ;;(Givens a)<br />   ;; Givens 变换求上三角阵<br />   (setq i  (length mat)<br /> m0 i<br /> n0 (length (car mat)) <br /> j -1)<br />   (while (< j (1- n0))<br />     (setq i m0<br />    j (1+ j))<br />     (while (> (setq i (1- i)) j)<br />       (setq aij (nth j (nth i mat)))<br />       (if (not (equal aij 0.0 1e-14))<br /> (progn<br />    (setq aii (nth i (nth i mat))<br />   ajj (nth j (nth j mat))<br />   aji (nth i (nth j mat)))<br />    (if (= aii ajj)<br />      (if (> aij 0)<br />        (setq ang _pi4)<br />        (if (< aij 0)<br />   (setq ang (- _pi4))))<br />      (setq ang  (/ (atan (/  aij (- ajj aii) 0.5)) 2.))<br />      )<br />    (setq ang (max (min ang _pi4) (- _pi4)))<br />    (setq m m0<br />   Q1 nil)<br />    (while (<= 0 (setq m (1- m)))<br />      (setq n n0<br />     r nil)<br />      (while (<= 0 (setq n (1- n)))<br />        (setq r (cons (cond ((and (= m i) (= n j))<br />        (- (sin ang)))<br />       ((and (= m j) (= n i))<br />        (sin ang))<br />       ((and (= m i) (= n i))<br />        (cos ang))<br />       ((and (= m j) (= n j))<br />        (cos ang))<br />       ((= m n)<br />        1.)<br />       (0.0))<br />        r)))<br />      (setq Q1 (cons r Q1))<br />      )<br />    (setq Q ([*] Q1 Q))<br />    (setq mat ([*] ([*] Q1 mat) ([trp] Q1)))<br />    )<br /> )      <br />       )<br />     )<br />   (list mat Q))<br /> ;;-------------------<br /> (defun Givens->EV  (mat eps / d i b t1 q )<br />   ;; Givens method main function<br />   ;; by GSLS(SS) 2013-1-4<br />   ;; (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0)))<br />   ;; (Givens->EV a 1e-12) --> (0.0660769 4.18334 18.2577 94.9829 7.50996) <br />   (setq t1 (getvar "millisecs")<br /> d  (gc:determ mat)<br /> q  ([i] (length (car mat)))<br /> i  0 ;_Set the maximum number of iterations to prevent stack overflow<br /> )<br />   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))<br />     (setq b (Givens mat Q)<br />    mat (car b)<br />    q (cadr b))<br />     (setq i (1+ i)))<br />   (print mat)<br />   (princ (strcat "\nJacobi iterations is : "<br />    (rtos i 2)<br />    " times ."))<br />   (princ (strcat "\nTotel time of Jacobi solving : "<br />    (rtos (- (getvar "millisecs") t1) 2 0)<br />    " m.s."))<br />   (setq i -1)  <br />   (mapcar (function (lambda (r1 )        <br />         (nth (setq i (1+ i)) r1)))<br />    mat)<br />   )

仅求全部特征值而言，同精度下比较，Givens变换的迭代次数仅为QR分解迭代的1/5左右，总计算量约为QR法的一半，效率高了很多。

当然，Givens变换和Jacobi方法结合起来，就可以同时求出特征值和特征向量；但是这里编程起来比较麻烦，需要逐次迭代将从大到小得非对角线上元素采用Givens变换消0；并同时记录变换矩阵的乘积Q=Q*Qi，上三角矩阵S主对角线上的特征值对应的变换矩阵积Q的各列为特征向量；这种方法也可以算是同步求解法之一，据我所知，该法是目前应用最为广泛的方法。

同步求解法首先得列并阵，行式[ (λiI-A)^t | I ]和列式[ λiI-A / I ]都可以；对于行式采用初等行变换将左阵转换为上三角矩阵，主对角线上的元素即为特征值，特征所对应右阵的行即为特征向量；对于列式采用初等列变换，将上阵转换为下三角方阵，主对角线上的元素即为特征值，其对应下阵的各列即为特征向量。该法最为精准，但是对于大型矩阵的求解，要书写计算式就麻烦了。同步求解法，还有其他的方法来实现，如Jacobi叠代法、行列互换法。

下面是特征值与特征向量求解的主要函数，请下载附件文件做测试。

2. ;;;-------------------------------------------------------------------------------;;;
   
3. ;;;                         Get EigenValues and EigenVectors                      ;;;
   
4. ;;;-------------------------------------------------------------------------------;;;
   
5. (defun [E]  (mat / em i ai aii el vl res)
   
6.   ;; get Eigenvalues and Eigenvectors
   
7.   ;;
   
8.   ;; First Use QR-decomposition to get all EigenValues ,
   
9.   ;; Then Use Gaussian-elimination to get all EigenVectors .
   
10.   ;;
    
11.   ;; mat ---- a nonsingular matrix
    
12.   ;;
    
13.   ;; returns a list of all Eigenvalues and Eigenvectors , like '((Value1 Vector1) (Value2 Vector2) ... (Valuen Vectorn))
    
14.   ;;
    
15.   ;; e.g.
    
16.   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.))) ;_([E] a)--> ((4.0 1.0 2.0 1.0) (2.0 -1.0 0.0 1.0) (1.0 1.0 -1.0 1.0))
    
17.   ;;
    
18.   ;; (setq a '((7. 3. -2.) (3. 4. 1.) (-2. -1. 3.))) ;_([E] a)--> ((9.27492 -2.51661 -1.24169 1.0) (3.0 -1.0 2.0 1.0) (1.72508 2.51661 -3.75831 1.0))
    
19.   ;;
    
20.   ;; (setq a '((4. 1. 0.) (1. 0. -1.) (1. 1. -4.))) ;_([E] a)--> ((4.20303 6.81864 1.38439 1.0) (-3.7601 -0.0354877 0.275388 1.0) (-0.442931 -1.03315 4.59022 1.0))
    
21.   ;;  ******if use Power method , this one will too slow .******
    
22.   ;;
    
23.   ;; (setq a '((1. 1. 0.5) (1. 1. 0.25) (0.5 0.25 2.))) ;_([E] a)--> ((2.53653 0.748221 0.649661 1.0) (1.48012 -0.63687 -0.805775 1.0) (-0.0166473 -7.69468 7.32278 1.0))
    
24.   ;;
    
25.   ;; (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0)))
    
26.   ;;          ;_([E] a)--> ((94.9829 0.171168 0.328923 0.502966 1.23721 1.0) (18.2577 -0.391138 -0.491509 -0.584425 -0.385896 1.0) (7.50996 -0.156679 1.91471 1.45052 -1.88531 1.0)
    
27.   ;;        (4.18334 4.56872 -4.5105 3.56226 -1.68936 1.0) (0.0660769 6.41687 3.11375 -4.83309 -0.559052 1.0))
    
28.   ;;
    
29.   ;; (setq a '((2.0 3.0 8.0)  (1.0 0.0 5.0) (-1.0 5.0 0.0))) ;_([E] a)--> ((5.0 4.58333 1.91667 1.0)  (-4.19258 -0.807418 -1.0 1.0)  (1.19258 -6.19258 -1.0 1.0))
    
30.   ;;  ******if use Power method , this one will too slow .******
    
31.   ;;
    
32.   ;; (setq a '((-3. 1. -1.) (-7. 5. -1.) (-6. 6. -2.))) ;_([E] a)--> ((4.0 0.0 1.0 1.0) (-2.0 -1.0 -1.0 0.0) (-2.0 -1.0 -1.0 0.0))
    
33.   ;;  ******if use Power method , this one will too slow .******
    
34.   ;;        
    
35.   ;;        get:     (setq vl ([E] a) v (nth 1 vl))
    
36.   ;;                 
    
37.   ;;        checkEg: (equal (gc:determ ([-] ([λ] (length (car a)) (car v)) a)) 0.0 1e-8)
    
38.   ;;                 
    
39.   ;;        checkEv  (equal (mxv a (cdr v)) (mxv ([λ] (length a) (car v)) (cdr v)) 1e-8)
    
40.   ;;
    
41.   ;; by GSLS(SS) 2013-1-3
    
42.   ;;
    
43.   ;; Any suggestions are welcome , and please post them to chlh_jd@126.com or 56454300@qq.com
    
44.   ;;
    
45.   ;; Thanks Robert for method suggestions .
    
46.   ;; Thanks HighFlyingBird's help .
    
47.   ;; Thanks ElpanovEvgeniy's Gaussian-elimination function , it's really a pretty codes .  ;;----------- QR method  ------------
    
48.   (setq Em (QR->EV mat 1e-12));_1e--10 The tolerance between the matrix modules with the product of it's Trace ,
    
49.                               ;_You can set a larger value like 1e-8 to reduce computations .
    
50.     (setq i 0)
    
51.     (while (and (setq ai (nth i Em)) (setq aii (nth i ai)))
    
52.     (setq el (cons aii el)
    
53.    i (1+ i)))                          
    
54.   ;;-----------------------------------
    
55.   
    
56.   ;;----------- Power method ----------
    
57.   ;_(setq el (Power->EV mat 1e-9))
    
58.   ;;-----------------------------------
    
59.   
    
60.   (foreach a  el  ;_Get all EigenVectors
    
61.     (setq vl (EigenValue->EigenVectors a mat))
    
62.     (if vl
    
63.       (foreach c  vl
    
64. (setq res (cons (cons a c) res)))
    
65.       (setq res (cons (cons a nil) res))))
    
66.   
    
67.   ;;----------- QR method--------------
    
68.   (mapcar (function(lambda (x)
    
69.        (mapcar (function (lambda (y)
    
70.       (if (equal y 0.0 1e-9)
    
71.         0.0
    
72.         y))) x)))
    
73.         res)
    
74.   ;;-----------------------------------  ;;----------- Power method ----------
    
75.   ;|(reverse (mapcar (function(lambda (x)
    
76.        (mapcar (function (lambda (y)
    
77.       (if (equal y 0.0 1e-9)
    
78.         0.0
    
79.         y))) x)))
    
80.         res))|;
    
81.   ;;-----------------------------------
    
82.   
    
83.   )
    
84. ;;
    
85. (defun EigenValue->EigenVectors  (λ mat / n imat ires)
    
86. ;_(setq mat a λ -2. ires nil)
    
87. ;_(if (equal λ 4. 1e-4)(princ))
    
88. ;_(princ (rtos λ 2 8))
    
89.   (setq n    (length mat)
    
90. imat ([i] n)
    
91. mat  ([trp] ([-] ([λ] n λ) mat))
    
92. mat  (mapcar (function (lambda (x y)
    
93.      (append x y)))
    
94.        mat
    
95.        imat);_Creat matrix [(λI-A)^t | I]
    
96. mat  (eea:gauss mat);_Gaussian elimination
    
97. imat nil)
    
98.   (setq
    
99.     mat (mapcar (function (lambda (x / y)
    
100.        (setq x (reverse x))
     
101.        (repeat n
     
102.          (setq y (cons (car x) y)
     
103.         x (cdr x)))
     
104.        (setq imat (cons (reverse y) imat))
     
105.        x))
     
106.   mat)
     
107.     )
     
108.   (setq mat (reverse mat))
     
109.   ;; Check ZeroVector of Left Matrix .
     
110.   (while (<= (apply (function +)
     
111.       (mapcar (function *) (car mat) (car mat)))
     
112.       5e-7)
     
113.     (setq mat  (cdr mat)
     
114.    ires (cons (car imat) ires)
     
115.    imat (cdr imat)))
     
116.   ;; determine Linealy Independent
     
117.   (while (and (cadr mat) (not (vslip (car mat) (cadr mat))))
     
118.     (setq
     
119.       ires (cons
     
120.       (vrefzero (car imat) (cadr imat) (car mat) (cadr mat))
     
121.       ires)
     
122.       imat (cdr imat)
     
123.       mat  (cdr mat)))
     
124.   ;; Result deal ...
     
125.   (mapcar
     
126.     (function reverse)
     
127.     (mapcar (function (lambda (b)
     
128.    (if (equal b 0.0 5e-7)
     
129.      0.0
     
130.      b)))
     
131.      ires))
     
132.   )
     
133. ;;;-------------------------------------高斯消元法--------------------------------;;;
     
134. ;;;
     
135. (defun eea:gauss  (lst)
     
136.   ;; Gauss eliminationby
     
137.   ;; by ElpanovEvgeniy
     
138.   ;; http://www.theswamp.org/index.php?action=post;quote=163485;topic=13505.13505.msg163485#msg163485
     
139.   ;; Implementation Gaussian elimination
     
140.   ;; For text:
     
141.   ;;  1x+2y+3z=2
     
142.   ;;  10x+1y+8z=17
     
143.   ;;  7z+2y=5
     
144.   ;; (eea:gauss '((1.0 2.0 3.0) (10.0 1.0 8.0) (0.0 2.0 7.0)))
     
145.   ;; =>
     
146.   ;; ((1.0 2.0 3.0 2.0) (0.0 -19.0 -22.0 -3.0) (0.0 0.0 4.68421 4.68421))
     
147.   ;;(gauss lst)
     
148.   (if (car lst)
     
149.     (if ;|(zerop (caar lst))|;  (equal (caar lst) 0.0 1e-8) ;_here changed for [E]
     
150.       (if (vl-every ;|(function zerop)|;
     
151.      (function (lambda (x) (equal x 0.0 1e-8))) ;_here changed for [E]
     
152.      (mapcar (function car) lst))
     
153. (if (cdr lst)
     
154.    (cons
     
155.      (car lst)
     
156.      (mapcar
     
157.        (function (lambda (x) (cons 0. x)))
     
158.        (eea:gauss (mapcar (function cdr) (cdr lst)))
     
159.        ) ;_  mapcar
     
160.      ) ;_  cons
     
161.    lst
     
162.    ) ;_  if
     
163. (eea:gauss
     
164.    (cons
     
165.      (mapcar
     
166.        (function +)
     
167.        (car lst)
     
168.        (car (vl-remove-if
     
169.        (function (lambda (x) (zerop (car x))))
     
170.        (cdr lst)))
     
171.        ) ;_  mapcar
     
172.      (cdr lst)
     
173.      ) ;_  cons
     
174.    ) ;_  gauss
     
175. ) ;_  if
     
176.       (cons
     
177. (car lst)
     
178. (mapcar
     
179.    (function (lambda (x) (cons 0. x)))
     
180.    (eea:gauss
     
181.      (mapcar
     
182.        (function
     
183.   (lambda (x / i)
     
184.     (if (and (equal (car x) 0.0 1e-6)
     
185.       (equal (caar lst) 0.0 1e-6)) ;_here add '0 / 0 = 1.'
     
186.       (setq i 1.)
     
187.       (setq i (/ (car x) (caar lst))))
     
188.     ;|(setq i (/ (car x) (caar lst)))|;
     
189.     (mapcar
     
190.       (function -)
     
191.       (cdr x)
     
192.       (mapcar (function (lambda (x1) (* x1 i)))
     
193.        (cdar lst))
     
194.       );_  mapcar
     
195.     );_  lambda
     
196.   );_  function
     
197.        (cdr lst)
     
198.        );_  mapcar
     
199.      );_  test
     
200.    );_  mapcar
     
201. );_  cons
     
202.       );_  if
     
203.     );_  if
     
204.   );_  defun

;;;-------------------------------------------------------------------------------;;;<br /> ;;;                         Get EigenValues and EigenVectors                      ;;;<br /> ;;;-------------------------------------------------------------------------------;;;<br /> (defun [E]  (mat / em i ai aii el vl res)<br />   ;; get Eigenvalues and Eigenvectors<br />   ;;<br />   ;; First Use QR-decomposition to get all EigenValues ,<br />   ;; Then Use Gaussian-elimination to get all EigenVectors .<br />   ;;<br />   ;; mat ---- a nonsingular matrix<br />   ;;<br />   ;; returns a list of all Eigenvalues and Eigenvectors , like '((Value1 Vector1) (Value2 Vector2) ... (Valuen Vectorn))<br />   ;;<br />   ;; e.g.<br />   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.))) ;_([E] a)--> ((4.0 1.0 2.0 1.0) (2.0 -1.0 0.0 1.0) (1.0 1.0 -1.0 1.0))<br />   ;; <br />   ;; (setq a '((7. 3. -2.) (3. 4. 1.) (-2. -1. 3.))) ;_([E] a)--> ((9.27492 -2.51661 -1.24169 1.0) (3.0 -1.0 2.0 1.0) (1.72508 2.51661 -3.75831 1.0))<br />   ;; <br />   ;; (setq a '((4. 1. 0.) (1. 0. -1.) (1. 1. -4.))) ;_([E] a)--> ((4.20303 6.81864 1.38439 1.0) (-3.7601 -0.0354877 0.275388 1.0) (-0.442931 -1.03315 4.59022 1.0))<br />   ;;  ******if use Power method , this one will too slow .******<br />   ;;<br />   ;; (setq a '((1. 1. 0.5) (1. 1. 0.25) (0.5 0.25 2.))) ;_([E] a)--> ((2.53653 0.748221 0.649661 1.0) (1.48012 -0.63687 -0.805775 1.0) (-0.0166473 -7.69468 7.32278 1.0))<br />   ;; <br />   ;; (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0)))<br />   ;;          ;_([E] a)--> ((94.9829 0.171168 0.328923 0.502966 1.23721 1.0) (18.2577 -0.391138 -0.491509 -0.584425 -0.385896 1.0) (7.50996 -0.156679 1.91471 1.45052 -1.88531 1.0)<br />   ;;        (4.18334 4.56872 -4.5105 3.56226 -1.68936 1.0) (0.0660769 6.41687 3.11375 -4.83309 -0.559052 1.0))<br />   ;; <br />   ;; (setq a '((2.0 3.0 8.0)  (1.0 0.0 5.0) (-1.0 5.0 0.0))) ;_([E] a)--> ((5.0 4.58333 1.91667 1.0)  (-4.19258 -0.807418 -1.0 1.0)  (1.19258 -6.19258 -1.0 1.0))<br />   ;;  ******if use Power method , this one will too slow .******<br />   ;;<br />   ;; (setq a '((-3. 1. -1.) (-7. 5. -1.) (-6. 6. -2.))) ;_([E] a)--> ((4.0 0.0 1.0 1.0) (-2.0 -1.0 -1.0 0.0) (-2.0 -1.0 -1.0 0.0))<br />   ;;  ******if use Power method , this one will too slow .******<br />   ;;        <br />   ;;        get:     (setq vl ([E] a) v (nth 1 vl)) <br />   ;;                 <br />   ;;        checkEg: (equal (gc:determ ([-] ([λ] (length (car a)) (car v)) a)) 0.0 1e-8)<br />   ;;                 <br />   ;;        checkEv  (equal (mxv a (cdr v)) (mxv ([λ] (length a) (car v)) (cdr v)) 1e-8)<br />   ;; <br />   ;; by GSLS(SS) 2013-1-3<br />   ;; <br />   ;; Any suggestions are welcome , and please post them to chlh_jd@126.com or 56454300@qq.com<br />   ;;<br />   ;; Thanks Robert for method suggestions .<br />   ;; Thanks HighFlyingBird's help .<br />   ;; Thanks ElpanovEvgeniy's Gaussian-elimination function , it's really a pretty codes .  ;;----------- QR method  ------------<br />   (setq Em (QR->EV mat 1e-12));_1e--10 The tolerance between the matrix modules with the product of it's Trace ,<br />                               ;_You can set a larger value like 1e-8 to reduce computations .<br />     (setq i 0)<br />     (while (and (setq ai (nth i Em)) (setq aii (nth i ai)))<br />     (setq el (cons aii el)<br />    i (1+ i)))                          <br />   ;;-----------------------------------<br />   <br />   ;;----------- Power method ----------<br />   ;_(setq el (Power->EV mat 1e-9))<br />   ;;-----------------------------------<br />   <br />   (foreach a  el  ;_Get all EigenVectors <br />     (setq vl (EigenValue->EigenVectors a mat))<br />     (if vl<br />       (foreach c  vl<br /> (setq res (cons (cons a c) res)))<br />       (setq res (cons (cons a nil) res))))<br />   <br />   ;;----------- QR method--------------<br />   (mapcar (function(lambda (x)<br />        (mapcar (function (lambda (y)<br />       (if (equal y 0.0 1e-9)<br />         0.0<br />         y))) x)))<br />         res)<br />   ;;-----------------------------------  ;;----------- Power method ----------<br />   ;|(reverse (mapcar (function(lambda (x)<br />        (mapcar (function (lambda (y)<br />       (if (equal y 0.0 1e-9)<br />         0.0<br />         y))) x)))<br />         res))|;<br />   ;;-----------------------------------<br />   <br />   )<br /> ;;<br /> (defun EigenValue->EigenVectors  (λ mat / n imat ires)<br /> ;_(setq mat a λ -2. ires nil)<br /> ;_(if (equal λ 4. 1e-4)(princ))<br /> ;_(princ (rtos λ 2 8))<br />   (setq n    (length mat)<br /> imat ([i] n)<br /> mat  ([trp] ([-] ([λ] n λ) mat))<br /> mat  (mapcar (function (lambda (x y)<br />      (append x y)))<br />        mat<br />        imat);_Creat matrix [(λI-A)^t | I]<br /> mat  (eea:gauss mat);_Gaussian elimination<br /> imat nil)<br />   (setq<br />     mat (mapcar (function (lambda (x / y)<br />        (setq x (reverse x))<br />        (repeat n<br />          (setq y (cons (car x) y)<br />         x (cdr x)))<br />        (setq imat (cons (reverse y) imat))<br />        x))<br />   mat)<br />     )<br />   (setq mat (reverse mat))<br />   ;; Check ZeroVector of Left Matrix .<br />   (while (<= (apply (function +)<br />       (mapcar (function *) (car mat) (car mat)))<br />       5e-7)<br />     (setq mat  (cdr mat)<br />    ires (cons (car imat) ires)<br />    imat (cdr imat)))<br />   ;; determine Linealy Independent <br />   (while (and (cadr mat) (not (vslip (car mat) (cadr mat)))) <br />     (setq<br />       ires (cons<br />       (vrefzero (car imat) (cadr imat) (car mat) (cadr mat))<br />       ires)<br />       imat (cdr imat)<br />       mat  (cdr mat)))<br />   ;; Result deal ...<br />   (mapcar<br />     (function reverse)<br />     (mapcar (function (lambda (b)<br />    (if (equal b 0.0 5e-7)<br />      0.0<br />      b)))<br />      ires))<br />   )<br /> ;;;-------------------------------------高斯消元法--------------------------------;;;<br /> ;;;<br /> (defun eea:gauss  (lst)<br />   ;; Gauss eliminationby<br />   ;; by ElpanovEvgeniy<br />   ;; http://www.theswamp.org/index.php?action=post;quote=163485;topic=13505.13505.msg163485#msg163485 <br />   ;; Implementation Gaussian elimination<br />   ;; For text:<br />   ;;  1x+2y+3z=2<br />   ;;  10x+1y+8z=17<br />   ;;  7z+2y=5<br />   ;; (eea:gauss '((1.0 2.0 3.0) (10.0 1.0 8.0) (0.0 2.0 7.0)))<br />   ;; =><br />   ;; ((1.0 2.0 3.0 2.0) (0.0 -19.0 -22.0 -3.0) (0.0 0.0 4.68421 4.68421))<br />   ;;(gauss lst)<br />   (if (car lst)<br />     (if ;|(zerop (caar lst))|;  (equal (caar lst) 0.0 1e-8) ;_here changed for [E]<br />       (if (vl-every ;|(function zerop)|;<br />      (function (lambda (x) (equal x 0.0 1e-8))) ;_here changed for [E]<br />      (mapcar (function car) lst))<br /> (if (cdr lst)<br />    (cons<br />      (car lst)<br />      (mapcar<br />        (function (lambda (x) (cons 0. x)))<br />        (eea:gauss (mapcar (function cdr) (cdr lst)))<br />        ) ;_  mapcar<br />      ) ;_  cons<br />    lst<br />    ) ;_  if<br /> (eea:gauss<br />    (cons<br />      (mapcar<br />        (function +)<br />        (car lst)<br />        (car (vl-remove-if<br />        (function (lambda (x) (zerop (car x))))<br />        (cdr lst)))<br />        ) ;_  mapcar<br />      (cdr lst)<br />      ) ;_  cons<br />    ) ;_  gauss<br /> ) ;_  if<br />       (cons<br /> (car lst)<br /> (mapcar<br />    (function (lambda (x) (cons 0. x)))<br />    (eea:gauss<br />      (mapcar<br />        (function<br />   (lambda (x / i)<br />     (if (and (equal (car x) 0.0 1e-6)<br />       (equal (caar lst) 0.0 1e-6)) ;_here add '0 / 0 = 1.'<br />       (setq i 1.)<br />       (setq i (/ (car x) (caar lst))))<br />     ;|(setq i (/ (car x) (caar lst)))|;<br />     (mapcar<br />       (function -)<br />       (cdr x)<br />       (mapcar (function (lambda (x1) (* x1 i)))<br />        (cdar lst))<br />       );_  mapcar<br />     );_  lambda<br />   );_  function<br />        (cdr lst)<br />        );_  mapcar<br />      );_  test<br />    );_  mapcar<br /> );_  cons<br />       );_  if<br />     );_  if<br />   );_  defun

非常感谢Robert和HighFlyingBird斑竹的热心帮助，同时也致谢ElpanovEvgeniy的高斯消元函数、Gile的矩阵高斯求模函数。
希望大家多多指导

2. (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.))) ([E] a)--> ((4.0 1.0 2.0 1.0) (2.0 -1.0 0.0 1.0) (1.0 1.0 -1.0 1.0))  (setq a '((7. 3. -2.) (3. 4. 1.) (-2. -1. 3.)))([E] a)--> ((9.27492 -2.51661 -1.24169 1.0) (3.0 -1.0 2.0 1.0) (1.72508 2.51661 -3.75831 1.0))   (setq a '((4. 1. 0.) (1. 0. -1.) (1. 1. -4.)))([E] a)--> ((4.20303 6.81864 1.38439 1.0) (-3.7601 -0.0354877 0.275388 1.0) (-0.442931 -1.03315 4.59022 1.0))   (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0)))([E] a)--> ((94.9829 0.171168 0.328923 0.502966 1.23721 1.0) (18.2577 -0.391138 -0.491509 -0.584425 -0.385896 1.0) (7.50996 -0.156679 1.91471 1.45052 -1.88531 1.0)(4.18334 4.56872 -4.5105 3.56226 -1.68936 1.0) (0.0660769 6.41687 3.11375 -4.83309 -0.559052 1.0))

(setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.))) ([E] a)--> ((4.0 1.0 2.0 1.0) (2.0 -1.0 0.0 1.0) (1.0 1.0 -1.0 1.0))  (setq a '((7. 3. -2.) (3. 4. 1.) (-2. -1. 3.)))([E] a)--> ((9.27492 -2.51661 -1.24169 1.0) (3.0 -1.0 2.0 1.0) (1.72508 2.51661 -3.75831 1.0))   (setq a '((4. 1. 0.) (1. 0. -1.) (1. 1. -4.)))([E] a)--> ((4.20303 6.81864 1.38439 1.0) (-3.7601 -0.0354877 0.275388 1.0) (-0.442931 -1.03315 4.59022 1.0))   (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0)))([E] a)--> ((94.9829 0.171168 0.328923 0.502966 1.23721 1.0) (18.2577 -0.391138 -0.491509 -0.584425 -0.385896 1.0) (7.50996 -0.156679 1.91471 1.45052 -1.88531 1.0)(4.18334 4.56872 -4.5105 3.56226 -1.68936 1.0) (0.0660769 6.41687 3.11375 -4.83309 -0.559052 1.0))

qjchen

landsat99 发表于 2022-6-8 18:46
eigen类的lsp实现，难得见到，赞。数值计算在commonlisp或scheme这类lisp中有什么优势特点吗？不了解lisp， ...

很久之前写过一些 矩阵求逆什么的 求方程解的，估计改改也能算特征值和特征向量
http://www.theswamp.org/index.php?topic=13505.msg163149#msg163149



但是可能是水平问题，就写得很辛苦，而autolisp的效率也比较低。所以个人觉得假如计算简单的有限元，几百根杆件以内的，是没有什么问题，非线性的可能就比较麻烦了。可能用objectarx会好些，3d3s就是这么做的。

不知道纯lisp会否好些，作为一个和fortran一样古老的语言活到现在，肯定有它厉害的地方。

帖子中的Evgeniy就是一个大高手，好像用common Lisp写过一个系统。

landsat99

qjchen 发表于 2022-6-10 17:29
很久之前写过一些 矩阵求逆什么的 求方程解的，估计改改也能算特征值和特征向量
http://www.theswamp.or ...

资深大神！！ 深耕lsp十几年，大赞一个

这个矩阵运算的UI方式 太独特新颖了，创意很受启发。。。  相当精彩，果断收藏！
lsp果然神一般的存在于CAD

landsat99

eigen类的lsp实现，难得见到，赞。数值计算在commonlisp或scheme这类lisp中有什么优势特点吗？不了解lisp，，请大神科普下

chlh_jd

修改了下Jacobi函数，可以同时得到矩阵的特征值与特征向量，效率比QR法高了非常多；
使用的是依次对下三角元素消0叠代，每次迭代都必须进行下三角检查0检查，如果与0不在误差范围内则必须进行矩阵计算；
一般迭代收敛到1e-10需要n次迭代，n为方阵行数；每次迭代的最大矩阵乘法运算为1.5(n-1)^2次，但总的矩阵乘法次数有望在
[1.5+1.5*0.5+1.5*0.5^2+...+1.5*0.5^(n-1)](n-1)^2--->n=∞时为3(n-1)^2次以内；算法的复杂程度低于QR法（后续）；且可以改进Givens一次变换的元素数量，设置一个阀值，仅对于元素大于阀值的所有下三角元素进行矩阵运算，依次减小阀值，直到阀值足够小。

2. (defun Givens  (mat Q / i j aij aii ajj aji ang a b m n0 n r Q1)
   
3.   ;;(Givens a)
   
4.   ;; Givens 变换求上三角阵
   
5.   ;; by GSLS(SS) 2013-1-4
   
6.   (setq i  (length mat)
   
7. m0 i
   
8. n0 (length (car mat))
   
9. j  -1)
   
10.   (while (< j (1- n0))
    
11.     (setq i m0
    
12.    j (1+ j))
    
13.     (while (> (setq i (1- i)) j)
    
14.       (setq aij (nth j (nth i mat)))
    
15.       (if (not (equal aij 0.0 1e-14))
    
16. (progn
    
17.    (setq aii (nth i (nth i mat))
    
18.   ajj (nth j (nth j mat))
    
19.   aji (nth i (nth j mat)))
    
20.    (if (= aii ajj)
    
21.      (if (> aij 0)
    
22.        (setq ang _pi4)
    
23.        (if (< aij 0)
    
24.   (setq ang (- _pi4))))
    
25.      (setq ang (/ (atan (/ aij (- ajj aii) 0.5)) 2.))
    
26.      )
    
27.    (setq ang (max (min ang _pi4) (- _pi4)))
    
28.    (setq m  m0
    
29.   Q1 nil)
    
30.    (while (<= 0 (setq m (1- m)))
    
31.      (setq n n0
    
32.     r nil)
    
33.      (while (<= 0 (setq n (1- n)))
    
34.        (setq r (cons (cond ((and (= m i) (= n j))
    
35.        (- (sin ang)))
    
36.       ((and (= m j) (= n i))
    
37.        (sin ang))
    
38.       ((and (= m i) (= n i))
    
39.        (cos ang))
    
40.       ((and (= m j) (= n j))
    
41.        (cos ang))
    
42.       ((= m n)
    
43.        1.)
    
44.       (0.0))
    
45.        r)))
    
46.      (setq Q1 (cons r Q1))
    
47.      )
    
48.    (setq Q ([*] Q1 Q))
    
49.    (setq mat ([*] ([*] Q1 mat) ([trp] Q1)))
    
50.    )
    
51. )
    
52.       )
    
53.     )
    
54.   (list mat Q))
    
55. ;;-------------------------------------------------------------------------------;;;
    
56. (defun Jacobi  (mat eps / d i b t1 q)
    
57.   ;; Jacobi method
    
58.   ;; by GSLS(SS) 2013-1-4
    
59.   ;;
    
60.   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.)))--> ((1.0 0.57735 -0.57735 0.57735)  (4.0 0.408248 0.816497 0.408248)  (2.0 -0.707107 -2.59319e-010 0.707107))
    
61.   ;;
    
62.   ;; (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0))) -->
    
63.   ;;      -->((0.0660769 0.738289 0.358251 -0.556068 -0.0643214 0.115054)  (4.18334 -0.60114 0.59348 -0.468712 0.222282 -0.131577)  (18.2577 0.284885 0.35799 0.425666 0.281067 -0.72835)
    
64.   ;;           (94.9829 0.100149 0.192449 0.29428 0.723881 0.585089) (7.50996 -0.0487036 0.595184 0.450894 -0.586047 0.310849))
    
65.   ;;
    
66.   ;; (Jacobi a 1e-12)
    
67.   (setq t1 (getvar "millisecs")
    
68. d  (gc:determ mat)
    
69. q  ([i] (length (car mat)))
    
70. i  0 ;_Set the maximum number of iterations to prevent stack overflow
    
71. )
    
72.   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))
    
73.     (setq b   (Givens mat Q)
    
74.    mat (car b)
    
75.    q   (cadr b))
    
76.     (setq i (1+ i)))
    
77.   (princ (strcat "\nJacobi iterations is : "
    
78.    (rtos i 2)
    
79.    " times ."))
    
80.   (princ (strcat "\nTotel time of Jacobi solving : "
    
81.    (rtos (- (getvar "millisecs") t1) 2 0)
    
82.    " m.s."))
    
83.   (setq i -1)
    
84.   (mapcar (function (lambda (a b)
    
85.         (cons a b)))
    
86.    (mapcar (function (lambda (r1)
    
87.          (nth (setq i (1+ i)) r1)))
    
88.     mat)
    
89.    q)
    
90.   )

(defun Givens  (mat Q / i j aij aii ajj aji ang a b m n0 n r Q1)<br />   ;;(Givens a)<br />   ;; Givens 变换求上三角阵<br />   ;; by GSLS(SS) 2013-1-4<br />   (setq i  (length mat)<br /> m0 i<br /> n0 (length (car mat))<br /> j  -1)<br />   (while (< j (1- n0))<br />     (setq i m0<br />    j (1+ j))<br />     (while (> (setq i (1- i)) j)<br />       (setq aij (nth j (nth i mat)))<br />       (if (not (equal aij 0.0 1e-14))<br /> (progn<br />    (setq aii (nth i (nth i mat))<br />   ajj (nth j (nth j mat))<br />   aji (nth i (nth j mat)))<br />    (if (= aii ajj)<br />      (if (> aij 0)<br />        (setq ang _pi4)<br />        (if (< aij 0)<br />   (setq ang (- _pi4))))<br />      (setq ang (/ (atan (/ aij (- ajj aii) 0.5)) 2.))<br />      )<br />    (setq ang (max (min ang _pi4) (- _pi4)))<br />    (setq m  m0<br />   Q1 nil)<br />    (while (<= 0 (setq m (1- m)))<br />      (setq n n0<br />     r nil)<br />      (while (<= 0 (setq n (1- n)))<br />        (setq r (cons (cond ((and (= m i) (= n j))<br />        (- (sin ang)))<br />       ((and (= m j) (= n i))<br />        (sin ang))<br />       ((and (= m i) (= n i))<br />        (cos ang))<br />       ((and (= m j) (= n j))<br />        (cos ang))<br />       ((= m n)<br />        1.)<br />       (0.0))<br />        r)))<br />      (setq Q1 (cons r Q1))<br />      )<br />    (setq Q ([*] Q1 Q))<br />    (setq mat ([*] ([*] Q1 mat) ([trp] Q1)))<br />    )<br /> )<br />       )<br />     )<br />   (list mat Q))<br /> ;;-------------------------------------------------------------------------------;;;<br /> (defun Jacobi  (mat eps / d i b t1 q)<br />   ;; Jacobi method <br />   ;; by GSLS(SS) 2013-1-4<br />   ;;<br />   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.)))--> ((1.0 0.57735 -0.57735 0.57735)  (4.0 0.408248 0.816497 0.408248)  (2.0 -0.707107 -2.59319e-010 0.707107))<br />   ;;<br />   ;; (setq a '((4.0 2.0 6.0 8.0 2.0) (2.0 10.0 9.0 13.0 7.0) (6.0 9.0 14.0 20.0 12.0) (8.0 13.0 20.0 54.0 35.0) (2.0 7.0 12.0 35.0 43.0))) --><br />   ;;      -->((0.0660769 0.738289 0.358251 -0.556068 -0.0643214 0.115054)  (4.18334 -0.60114 0.59348 -0.468712 0.222282 -0.131577)  (18.2577 0.284885 0.35799 0.425666 0.281067 -0.72835)<br />   ;;           (94.9829 0.100149 0.192449 0.29428 0.723881 0.585089) (7.50996 -0.0487036 0.595184 0.450894 -0.586047 0.310849))<br />   ;;<br />   ;; (Jacobi a 1e-12) <br />   (setq t1 (getvar "millisecs")<br /> d  (gc:determ mat)<br /> q  ([i] (length (car mat)))<br /> i  0 ;_Set the maximum number of iterations to prevent stack overflow<br /> )<br />   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))<br />     (setq b   (Givens mat Q)<br />    mat (car b)<br />    q   (cadr b))<br />     (setq i (1+ i)))<br />   (princ (strcat "\nJacobi iterations is : "<br />    (rtos i 2)<br />    " times ."))<br />   (princ (strcat "\nTotel time of Jacobi solving : "<br />    (rtos (- (getvar "millisecs") t1) 2 0)<br />    " m.s."))<br />   (setq i -1)<br />   (mapcar (function (lambda (a b)<br />         (cons a b)))<br />    (mapcar (function (lambda (r1)<br />          (nth (setq i (1+ i)) r1)))<br />     mat)<br />    q)<br />   )

chlh_jd

改进QR法函数代码，可以同时求出特征值与特征向量；与Jacobi法相比，要达到准确的特征向量解，需要把求模精度提高1倍，否则求到的特征向量会反号，尽管如此得到的特征向量的精度任然小于Jacobi法，这是因为Jacobi法采用的Givens平面旋转变换比Householder正交变换的数值计算来得稳定。Householder每运算一遍要作3n次矩阵乘法，即QR法每迭代一次需要做3n次矩阵乘法，对于N维方阵，QR法要迭代5~6N次才能得到稳定向量解，则QR法需要共需要15~18n^2次矩阵乘法；与Jacobi法相比，
15~18n^2/[1.5n(n-1)^2] =10~12n倍，如果Jacobi法临近下限3(n-2)^2次矩阵迭代，则比值变为5~6n^2。可见QR法的效率明显低于Jacobi法。
当然QR法也可以仅把方阵变成海森伯格(Hessenberg)上三角矩阵，这样来减少计算量：Ak=QkRk,Ak+1=RkQk。

2. ;;;----------------------------------Householder变换------------------------------;;;
   
3. (defun householder  (q mat / i m n d a b u hk)
   
4.   ;; Use Householder transformation to Get QR matrix for QR-decomposition
   
5.   ;; (householder mat)
   
6.   ;; (setq mat '((2. 3.) (1. 2.) (5. 7.)))
   
7.   ;; (setq mat '((1. 2. -3.) (1. 3. 10.) (1. -1. 6.)))
   
8.   (setq i 0
   
9. n (length (car mat))
   
10. )
    
11.   (while (< i n)
    
12.     (setq d (mapcar (function (lambda (x) (nth i x))) mat))
    
13.     (repeat i
    
14.       (setq d (cdr d)))
    
15.     (setq a (* (sign (car d))
    
16.         (sqrt (apply (function +)
    
17.        (mapcar (function (lambda (x)
    
18.       (* x x)))
    
19.         d))))
    
20.    b (* a (+ a (car d)))
    
21.    d (cons (+ (car d) a)
    
22.     (cdr d)))
    
23.     (repeat i
    
24.       (setq d (cons 0. d)))
    
25.     (setq u (vtxv d d))
    
26.     (if (not (zerop b))
    
27.       (setq u ([k*] (1/ b) u)))
    
28.     (setq hk  ([-] imat u)
    
29.    q   ([*] q hk)
    
30.    mat ([*] ([*] hk mat) ([trp] hk))
    
31.    i   (1+ i)))
    
32.   (list q mat))
    
33. ;;;------------------------------------QR分解迭代---------------------------------;;;
    
34. ;;
    
35. (defun QR->EV  (mat eps / imat q d i b t1)
    
36.   ;; QR-decomposition
    
37.   ;; by GSLS(SS) 2013-1-2
    
38.   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.)))
    
39.   ;; (QR->EV a 5e-11)
    
40.   (setq t1   (getvar "millisecs")
    
41. d    (gc:determ mat)
    
42. imat ([i] (length (car mat)))
    
43. q    imat
    
44. i    0) ;_Set the maximum number of iterations to prevent stack overflow
    
45.   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))
    
46.     (setq b   (householder q mat)
    
47.    mat (cadr b)
    
48.    q   (car b)
    
49.    i   (1+ i)))
    
50.   (princ (strcat "\nQR-decomposition of iterations is : "
    
51.    (rtos i 2)
    
52.    " times ."))
    
53.   (princ (strcat "\nTotel time of QR-decomposition : "
    
54.    (rtos (- (getvar "millisecs") t1) 2 0)
    
55.    " m.s."))
    
56.   (setq i -1)
    
57.   (mapcar (function (lambda (a b)
    
58.         (cons a b)))
    
59.    (mapcar (function (lambda (r1)
    
60.          (nth (setq i (1+ i)) r1)))
    
61.     mat)
    
62.    ([trp] q))
    
63.   )

;;;----------------------------------Householder变换------------------------------;;;<br /> (defun householder  (q mat / i m n d a b u hk)<br />   ;; Use Householder transformation to Get QR matrix for QR-decomposition<br />   ;; (householder mat)<br />   ;; (setq mat '((2. 3.) (1. 2.) (5. 7.)))<br />   ;; (setq mat '((1. 2. -3.) (1. 3. 10.) (1. -1. 6.)))<br />   (setq i 0<br /> n (length (car mat))<br /> )<br />   (while (< i n)<br />     (setq d (mapcar (function (lambda (x) (nth i x))) mat))<br />     (repeat i<br />       (setq d (cdr d)))<br />     (setq a (* (sign (car d))<br />         (sqrt (apply (function +)<br />        (mapcar (function (lambda (x)<br />       (* x x)))<br />         d))))<br />    b (* a (+ a (car d)))<br />    d (cons (+ (car d) a)<br />     (cdr d)))<br />     (repeat i<br />       (setq d (cons 0. d)))<br />     (setq u (vtxv d d))<br />     (if (not (zerop b))<br />       (setq u ([k*] (1/ b) u)))<br />     (setq hk  ([-] imat u)<br />    q   ([*] q hk)<br />    mat ([*] ([*] hk mat) ([trp] hk))<br />    i   (1+ i)))<br />   (list q mat))<br /> ;;;------------------------------------QR分解迭代---------------------------------;;;<br /> ;;<br /> (defun QR->EV  (mat eps / imat q d i b t1)<br />   ;; QR-decomposition<br />   ;; by GSLS(SS) 2013-1-2<br />   ;; (setq a '((2. 1. 0.) (1. 3. 1.) (0. 1. 2.)))<br />   ;; (QR->EV a 5e-11)<br />   (setq t1   (getvar "millisecs")<br /> d    (gc:determ mat)<br /> imat ([i] (length (car mat)))<br /> q    imat<br /> i    0) ;_Set the maximum number of iterations to prevent stack overflow<br />   (while (and (not (equal d ([tr] mat) eps)) (< i 1000))<br />     (setq b   (householder q mat)<br />    mat (cadr b)<br />    q   (car b)<br />    i   (1+ i)))<br />   (princ (strcat "\nQR-decomposition of iterations is : "<br />    (rtos i 2)<br />    " times ."))<br />   (princ (strcat "\nTotel time of QR-decomposition : "<br />    (rtos (- (getvar "millisecs") t1) 2 0)<br />    " m.s."))<br />   (setq i -1)<br />   (mapcar (function (lambda (a b)<br />         (cons a b)))<br />    (mapcar (function (lambda (r1)<br />          (nth (setq i (1+ i)) r1)))<br />     mat)<br />    ([trp] q))<br />   )

dwg001

矩阵方面很好的资料，学习了。

自贡黄明儒

东西很好，就是太深了。有没有简单实用的东西呢？

chlh_jd

矩阵特征值与特征向量的应用在现代科学里面已经非常广泛了：图像问题，趋势问题，矩阵计算机...
朱小平老师有一本书叫《实对称矩阵的拟特征值理论与应用》（内容摘要）
这里有介绍2个应用例子：天气Markov链的稳定状态、人口流动问题；
这里介绍了3个应用例子：动物繁殖的规律问题、商品的市场占有率问题、常染色体遗传问题

但是在ACAD上具体应用，我还没发现；我最近一直在想，二维边界映射问题是否可以通过特征向量矩阵来求解，如果可以那么任意边界1范围内的图形就可以变换到任意边界2内了。

mj0000

太深了，完全看不懂

pengfei2010

矩阵很强大，，，

monkey_w

向老师学习，感谢分享

zhenz02

感谢楼主分享，收藏了