(require "f2cl_macros")

(defun tred2 (a n np d e &key (evec t))
 (declare (type (simple-array double-float (* *)) a))
 (declare (type fixnum n)) (declare (type fixnum np))
 (declare (type (simple-array double-float (*)) d))
 (declare (type (simple-array double-float (*)) e))
 (prog
  ((hh 0.0d0) (j 0) (g 0.0d0) (f 0.0d0) (k 0) (scale 0.0d0) (h 0.0d0) (l 0)
   (i 0)
  )
  (declare (type double-float hh)) (declare (type fixnum j))
  (declare (type double-float g)) (declare (type double-float f))
  (declare (type fixnum k)) (declare (type double-float scale))
  (declare (type double-float h)) (declare (type fixnum l))
  (declare (type fixnum i))
  (cond
   ((> n 1)
    (fdo ((i n (+ i (- 1)))) ((> i 2) nil)
     (tagbody (setf l (+ i (- 1))) (setf h 0.0) (setf scale 0.0)
      (cond
       ((> l 1)
        (fdo ((k 1 (+ k 1))) ((> k l) nil)
         (tagbody (setf scale (+ scale (abs (fref a i k)))))
        )
        (cond ((= scale 0.0) (fset (fref e i) (fref a i l)))
         (t
          (fdo ((k 1 (+ k 1))) ((> k l) nil)
           (tagbody (fset (fref a i k) (/ (fref a i k) scale))
            (setf h (+ h (expt (fref a i k) 2)))
          ))
          (setf f (fref a i l)) (setf g (- (sign (sqrt h) f)))
          (fset (fref e i) (* scale g)) (setf h (+ h (* (* -1 f) g)))
          (fset (fref a i l) (+ f (- g))) (setf f 0.0)
          (fdo ((j 1 (+ j 1))) ((> j l) nil)
           (tagbody (if evec (fset (fref a j i) (/ (fref a i j) h)))
                    (setf g 0.0)
            (fdo ((k 1 (+ k 1))) ((> k j) nil)
             (tagbody (setf g (+ g (* (fref a j k) (fref a i k)))))
            )
            (cond
             ((> l j)
              (fdo ((k (+ j 1) (+ k 1))) ((> k l) nil)
               (tagbody (setf g (+ g (* (fref a k j) (fref a i k)))))
            )))
            (fset (fref e j) (/ g h))
            (setf f (+ f (* (fref e j) (fref a i j))))
          ))
          (setf hh (/ f (+ h h)))
          (fdo ((j 1 (+ j 1))) ((> j l) nil)
           (tagbody (setf f (fref a i j))
            (setf g (+ (fref e j) (* (* -1 hh) f))) (fset (fref e j) g)
            (fdo ((k 1 (+ k 1))) ((> k j) nil)
             (tagbody
              (fset (fref a j k)
               (+ (+ (fref a j k) (* (* -1 f) (fref e k)))
                (* (* -1 g) (fref a i k))
       )))))))))
       (t (fset (fref e i) (fref a i l)))
      )
      (fset (fref d i) h)
  ))))
  (fset (fref d 1) 0.0) (fset (fref e 1) 0.0)
  (fdo ((i 1 (+ i 1))) ((> i n) nil)
   (tagbody (if evec (tagbody (setf l (+ i (- 1)))
    (cond
     ((/= (fref d i) 0.0)
      (fdo ((j 1 (+ j 1))) ((> j l) nil)
       (tagbody (setf g 0.0)
        (fdo ((k 1 (+ k 1))) ((> k l) nil)
         (tagbody (setf g (+ g (* (fref a i k) (fref a k j)))))
        )
        (fdo ((k 1 (+ k 1))) ((> k l) nil)
         (tagbody
          (fset (fref a k j) (+ (fref a k j) (* (* -1 g) (fref a k i))))
    ))))))))
    (fset (fref d i) (fref a i i)) (if evec (tagbody (fset (fref a i i) 1.0)
    (cond
     ((>= l 1)
      (fdo ((j 1 (+ j 1))) ((> j l) nil)
       (tagbody (fset (fref a i j) 0.0) (fset (fref a j i) 0.0))
  )))))))
  (return (values a n np d e))
))