(require "f2cl_macros")
(require "laguer")

(defun zroots (a m roots polish &key (eps 1.0E-6) (maxm 101))
 (declare (type (simple-array complex (*)) a)) (declare (type fixnum m))
 (declare (type (simple-array complex (*)) roots)) (declare (type t polish))
 (declare (type double-float eps)) (declare (type fixnum maxm))
 (prog
  ((ad (make-array '(maxm) :element-type 'complex)) (x 0.0d0) (b 0.0d0)
   (c 0.0d0) (i 0) (jj 0) (j 0)
  )
  (declare (type (simple-array complex (*)) ad)) (declare (type complex x))
  (declare (type complex b)) (declare (type complex c))
  (declare (type fixnum i)) (declare (type fixnum jj))
  (declare (type fixnum j))
  (fdo ((j 1 (+ j 1))) ((> j (+ m 1)) nil)
   (tagbody (fset (fref ad j) (fref a j)))
  )
  (fdo ((j m (+ j (- 1)))) ((> j 1) nil)
   (tagbody (setf x (cmplx 0.0 0.0))
    (multiple-value-setq (ad j x eps false) (laguer ad j x eps false))
    (if (<= (abs (aimag x)) (* (* 2.0 (expt eps 2)) (abs (real x))))
     (setf x (cmplx (real x) 0.0))
    )
    (fset (fref roots j) x) (setf b (fref ad (+ j 1)))
    (fdo ((jj j (+ jj (- 1)))) ((> jj 1) nil)
     (tagbody (setf c (fref ad jj)) (fset (fref ad jj) b)
      (setf b (+ (* x b) c))
  ))))
  (cond
   (polish
    (fdo ((j 1 (+ j 1))) ((> j m) nil)
     (tagbody
      (multiple-value-setq (a m dummy_var eps true)
       (laguer a m (fref roots j) eps true)
  )))))
  (fdo ((j 2 (+ j 1))) ((> j m) nil)
   (tagbody (setf x (fref roots j))
    (fdo ((i (+ j (- 1)) (+ i (- 1)))) ((> i 1) nil)
     (tagbody (if (<= (real (fref roots i)) (real x)) (go label10))
      (fset (fref roots (+ i 1)) (fref roots i))
    ))
    (setf i 0) label10 (fset (fref roots (+ i 1)) x)
  ))
  (return (values a m roots polish))
))