(require "f2cl_macros")

(defun tqli (d e n np z) (declare (type (simple-array double-float (*)) d))
 (declare (type (simple-array double-float (*)) e)) (declare (type fixnum n))
 (declare (type fixnum np))
 (declare (type (simple-array double-float (* *)) z))
 (prog
  ((k 0) (b 0.0d0) (f 0.0d0) (p 0.0d0) (c 0.0d0) (s 0.0d0) (r 0.0d0) (g 0.0d0)
   (dd 0.0d0) (m 0) (iter 0) (l 0) (i 0)
  )
  (declare (type fixnum k)) (declare (type double-float b))
  (declare (type double-float f)) (declare (type double-float p))
  (declare (type double-float c)) (declare (type double-float s))
  (declare (type double-float r)) (declare (type double-float g))
  (declare (type double-float dd)) (declare (type fixnum m))
  (declare (type fixnum iter)) (declare (type fixnum l))
  (declare (type fixnum i))
  (cond
   ((> n 1)
    (fdo ((i 2 (+ i 1))) ((> i n) nil)
     (tagbody (fset (fref e (+ i (- 1))) (fref e i)))
    )
    (fset (fref e n) 0.0)
    (fdo ((l 1 (+ l 1))) ((> l n) nil)
     (tagbody (setf iter 0) label1
      (fdo ((m l (+ m 1))) ((> m (+ n (- 1))) nil)
       (tagbody (setf dd (+ (abs (fref d m)) (abs (fref d (+ m 1)))))
        (if (= (+ (abs (fref e m)) dd) dd) (go label2))
      ))
      (setf m n) label2
      (cond
       ((/= m l) (if (= iter 30) (error "too many iterations"))
        (setf iter (+ iter 1))
        (setf g (/ (+ (fref d (+ l 1)) (- (fref d l))) (* 2.0 (fref e l))))
        (setf r (sqrt (+ (expt g 2) 1.0)))
        (setf g
         (+ (+ (fref d m) (- (fref d l))) (/ (fref e l) (+ g (sign r g))))
        )
        (setf s 1.0) (setf c 1.0) (setf p 0.0)
        (fdo ((i (+ m (- 1)) (+ i (- 1)))) ((> i l) nil)
         (tagbody (setf f (* s (fref e i))) (setf b (* c (fref e i)))
          (cond
           ((>= (abs f) (abs g)) (setf c (/ g f))
            (setf r (sqrt (+ (expt c 2) 1.0))) (fset (fref e (+ i 1)) (* f r))
            (setf s (/ 1.0 r)) (setf c (* c s))
           )
           (t (setf s (/ f g)) (setf r (sqrt (+ (expt s 2) 1.0)))
            (fset (fref e (+ i 1)) (* g r)) (setf c (/ 1.0 r)) (setf s (* s c))
          ))
          (setf g (+ (fref d (+ i 1)) (- p)))
          (setf r (+ (* (+ (fref d i) (- g)) s) (* (* 2.0 c) b)))
          (setf p (* s r)) (fset (fref d (+ i 1)) (+ g p))
          (setf g (+ (* c r) (- b)))
          (fdo ((k 1 (+ k 1))) ((> k n) nil)
           (tagbody (setf f (fref z k (+ i 1)))
            (fset (fref z k (+ i 1)) (+ (* s (fref z k i)) (* c f)))
            (fset (fref z k i) (+ (* c (fref z k i)) (* (* -1 s) f)))
        ))))
        (fset (fref d l) (+ (fref d l) (- p))) (fset (fref e l) g)
        (fset (fref e m) 0.0) (go label1)
  ))))))
  (return (values d e n np z))
))