(defun hqr (a n np wr wi) (declare (type (simple-array double-float (* *)) a))
 (declare (type fixnum n)) (declare (type fixnum np))
 (declare (type (simple-array double-float (*)) wr))
 (declare (type (simple-array double-float (*)) wi))
 (prog
  ((k 0) (v 0.0d0) (u 0.0d0) (r 0.0d0) (m 0) (z 0.0d0) (q 0.0d0) (p 0.0d0)
   (w 0.0d0) (y 0.0d0) (x 0.0d0) (s 0.0d0) (l 0) (its 0) (t_ 0.0d0) (nn 0)
   (j 0) (i 0) (anorm 0.0d0)
  )
  (declare (type fixnum k)) (declare (type double-float v))
  (declare (type double-float u)) (declare (type double-float r))
  (declare (type fixnum m)) (declare (type double-float z))
  (declare (type double-float q)) (declare (type double-float p))
  (declare (type double-float w)) (declare (type double-float y))
  (declare (type double-float x)) (declare (type double-float s))
  (declare (type fixnum l)) (declare (type fixnum its))
  (declare (type double-float t_)) (declare (type fixnum nn))
  (declare (type fixnum j)) (declare (type fixnum i))
  (declare (type double-float anorm)) (setf anorm (abs (fref a 1 1)))
  (fdo ((i 2 (+ i 1))) ((> i n) nil)
   (tagbody
    (fdo ((j (+ i (- 1)) (+ j 1))) ((> j n) nil)
     (tagbody (setf anorm (+ anorm (abs (fref a i j)))))
  )))
  (setf nn n) (setf t_ 0.0) label1
  (cond
   ((>= nn 1)
    (tagbody (setf its 0) label2
     (fdo ((l nn (+ l (- 1)))) ((> l 2) nil)
      (tagbody
       (setf s (+ (abs (fref a (+ l (- 1)) (+ l (- 1)))) (abs (fref a l l))))
       (if (= s 0.0) (setf s anorm))
       (if (= (+ (abs (fref a l (+ l (- 1)))) s) s) (go label3))
     ))
     (setf l 1) label3 (setf x (fref a nn nn))
     (cond
      ((= l nn) (fset (fref wr nn) (+ x t_)) (fset (fref wi nn) 0.0)
       (setf nn (+ nn (- 1)))
      )
      (t (setf y (fref a (+ nn (- 1)) (+ nn (- 1))))
       (setf w (* (fref a nn (+ nn (- 1))) (fref a (+ nn (- 1)) nn)))
       (cond
        ((= l (+ nn (- 1))) (setf p (* 0.5 (+ y (- x))))
         (setf q (+ (expt p 2) w)) (setf z (sqrt (abs q))) (setf x (+ x t_))
         (cond
          ((>= q 0.0) (setf z (+ p (sign z p))) (fset (fref wr nn) (+ x z))
           (fset (fref wr (+ nn (- 1))) (fref wr nn))
           (if (/= z 0.0) (fset (fref wr nn) (+ x (/ (* -1 w) z))))
           (fset (fref wi nn) 0.0) (fset (fref wi (+ nn (- 1))) 0.0)
          )
          (t (fset (fref wr nn) (+ x p))
           (fset (fref wr (+ nn (- 1))) (fref wr nn)) (fset (fref wi nn) z)
           (fset (fref wi (+ nn (- 1))) (- z))
         ))
         (setf nn (+ nn (- 2)))
        )
        (t
         (tagbody (if (= its 30) (error "too many iterations"))
          (cond
           ((or (= its 10) (= its 20)) (setf t_ (+ t_ x))
            (fdo ((i 1 (+ i 1))) ((> i nn) nil)
             (tagbody (fset (fref a i i) (+ (fref a i i) (- x))))
            )
            (setf s
             (+ (abs (fref a nn (+ nn (- 1))))
              (abs (fref a (+ nn (- 1)) (+ nn (- 2))))
            ))
            (setf x (* 0.75 s)) (setf y x)
            (setf w (* (* -1 0.4375) (expt s 2)))
          ))
          (setf its (+ its 1))
          (fdo ((m (+ nn (- 2)) (+ m (- 1)))) ((> m l) nil)
           (tagbody (setf z (fref a m m)) (setf r (+ x (- z)))
            (setf s (+ y (- z)))
            (setf p
             (+ (/ (+ (* r s) (- w)) (fref a (+ m 1) m)) (fref a m (+ m 1)))
            )
            (setf q (+ (+ (+ (fref a (+ m 1) (+ m 1)) (- z)) (- r)) (- s)))
            (setf r (fref a (+ m 2) (+ m 1)))
            (setf s (+ (+ (abs p) (abs q)) (abs r))) (setf p (/ p s))
            (setf q (/ q s)) (setf r (/ r s)) (if (= m l) (go label4))
            (setf u (* (abs (fref a m (+ m (- 1)))) (+ (abs q) (abs r))))
            (setf v
             (* (abs p)
              (+ (+ (abs (fref a (+ m (- 1)) (+ m (- 1)))) (abs z))
               (abs (fref a (+ m 1) (+ m 1)))
            )))
            (if (= (+ u v) v) (go label4))
          ))
          label4
          (fdo ((i (+ m 2) (+ i 1))) ((> i nn) nil)
           (tagbody (fset (fref a i (+ i (- 2))) 0.0)
            (if (/= i (+ m 2)) (fset (fref a i (+ i (- 3))) 0.0))
          ))
          (fdo ((k m (+ k 1))) ((> k (+ nn (- 1))) nil)
           (tagbody
            (cond
             ((/= k m) (setf p (fref a k (+ k (- 1))))
              (setf q (fref a (+ k 1) (+ k (- 1)))) (setf r 0.0)
              (if (/= k (+ nn (- 1))) (setf r (fref a (+ k 2) (+ k (- 1)))))
              (setf x (+ (+ (abs p) (abs q)) (abs r)))
              (cond
               ((/= x 0.0) (setf p (/ p x)) (setf q (/ q x)) (setf r (/ r x)))
            )))
            (setf s (sign (sqrt (+ (+ (expt p 2) (expt q 2)) (expt r 2))) p))
            (cond
             ((/= s 0.0)
              (cond
               ((= k m)
                (if (/= l m)
                 (fset (fref a k (+ k (- 1))) (- (fref a k (+ k (- 1)))))
               ))
               (t (fset (fref a k (+ k (- 1))) (* (* -1 s) x)))
              )
              (setf p (+ p s)) (setf x (/ p s)) (setf y (/ q s))
              (setf z (/ r s)) (setf q (/ q p)) (setf r (/ r p))
              (fdo ((j k (+ j 1))) ((> j nn) nil)
               (tagbody (setf p (+ (fref a k j) (* q (fref a (+ k 1) j))))
                (cond
                 ((/= k (+ nn (- 1))) (setf p (+ p (* r (fref a (+ k 2) j))))
                  (fset (fref a (+ k 2) j)
                   (+ (fref a (+ k 2) j) (* (* -1 p) z))
                )))
                (fset (fref a (+ k 1) j) (+ (fref a (+ k 1) j) (* (* -1 p) y)))
                (fset (fref a k j) (+ (fref a k j) (* (* -1 p) x)))
              ))
              (fdo ((i l (+ i 1))) ((> i (min nn (+ k 3))) nil)
               (tagbody
                (setf p (+ (* x (fref a i k)) (* y (fref a i (+ k 1)))))
                (cond
                 ((/= k (+ nn (- 1))) (setf p (+ p (* z (fref a i (+ k 2)))))
                  (fset (fref a i (+ k 2))
                   (+ (fref a i (+ k 2)) (* (* -1 p) r))
                )))
                (fset (fref a i (+ k 1)) (+ (fref a i (+ k 1)) (* (* -1 p) q)))
                (fset (fref a i k) (+ (fref a i k) (- p)))
          ))))))
          (go label2)
     )))))
     (go label1)
  )))
  (return (values a n np wr wi))
))