(proclaim
 '(special npardm kntdim nbreak edist level smooth degree dbreak bright bleft
   xbreak charf norm accur b a knots error buffer discrd right nstack npar
   maxstk maxpar maxknt maxaux left interp ibreak factor both break xright
   xleft errori dsctol rightx nintrp leftx xintrp xdd fright fleft fintrp
   ddtemp
) )
(declare (type fixnum npardm))
(declare (type fixnum kntdim))
(declare (type fixnum nbreak))
(declare (type fixnum edist))
(declare (type fixnum level))
(declare (type fixnum smooth))
(declare (type fixnum degree))
(declare (type (simple-array double-float (20)) dbreak))
(declare (type (simple-array double-float (20)) bright))
(declare (type (simple-array double-float (20)) bleft))
(declare (type (simple-array double-float (20)) xbreak))
(declare (type double-float charf))
(declare (type double-float norm))
(declare (type double-float accur))
(declare (type double-float b))
(declare (type double-float a))
(declare (type fixnum knots))
(declare (type double-float error))
(declare (type double-float buffer))
(declare (type t discrd))
(declare (type fixnum right))
(declare (type fixnum nstack))
(declare (type fixnum npar))
(declare (type fixnum maxstk))
(declare (type fixnum maxpar))
(declare (type fixnum maxknt))
(declare (type fixnum maxaux))
(declare (type fixnum left))
(declare (type fixnum interp))
(declare (type fixnum ibreak))
(declare (type (simple-array double-float (20)) factor))
(declare (type fixnum both))
(declare (type fixnum break))
(declare (type (simple-array double-float (50)) xright))
(declare (type (simple-array double-float (50)) xleft))
(declare (type double-float errori))
(declare (type double-float dsctol))
(declare (type fixnum rightx))
(declare (type fixnum nintrp))
(declare (type fixnum leftx))
(declare (type (simple-array double-float (18)) xintrp))
(declare (type (simple-array double-float (20)) xdd))
(declare (type (simple-array double-float (10)) fright))
(declare (type (simple-array double-float (10)) fleft))
(declare (type (simple-array double-float (18)) fintrp))
(declare (type (simple-array double-float (20 20)) ddtemp))

(defun adcomp (f)
 (prog
  ((errint 0.0d0) (f 0.0d0) (polydd 0.0d0)
   (absc (make-array '(4) :element-type double-float)) (aj 0.0d0) (dx 0.0d0)
   (fdervl (make-array '(9) :element-type 'double-float))
   (fdervr (make-array '(9) :element-type 'double-float))
   (fdumb (make-array '(9) :element-type 'double-float)) (r 0.0d0)
   (wgts (make-array '(4) :element-type 'double-float)) (j 0)
  )
  (declare (type double-float errint)) (declare (type double-float f))
  (declare (type double-float polydd))
  (declare (type (simple-array double-float (4)) absc))
  (declare (type double-float aj)) (declare (type double-float dx))
  (declare (type (simple-array double-float (*)) fdervl))
  (declare (type (simple-array double-float (*)) fdervr))
  (declare (type (simple-array double-float (*)) fdumb))
  (declare (type double-float r))
  (declare (type (simple-array double-float (*)) wgts))
  (declare (type fixnum j)) ---->
  (equivalence (fleft (2) |,| fdervl (1)) |,| (fright (2) |,| fdervr (1)))
  (setq r 1.5d0) (replace absc '((- 0.8611363115940526d0)) :end 0)
  (replace absc '((- 0.33998104358485626d0)) :end 0)
  (replace absc '(0.33998104358485626d0) :end 0)
  (replace absc '(0.8611363115940526d0) :end 0)
  (replace wgts '(0.34785484513745385d0) :end 0)
  (replace wgts '(0.6521451548625461d0) :end 0)
  (replace wgts '(0.6521451548625461d0) :end 0)
  (replace wgts '(0.34785484513745385d0) :end 0)
  (setf nintrp (+ (+ degree (* (* -1 2) smooth)) (- 1)))
  (if (or (= break left) (= break right))
   (setf nintrp (+ (+ nintrp smooth) (- (fref dbreak ibreak))))
  )
  (if (= break both)
   (setf nintrp
    (+ (+ (+ nintrp (* 2 smooth)) (- (fref dbreak ibreak)))
     (- (fref dbreak (+ ibreak 1)))
  )))
  (if (= nintrp 0) (go label20)) (setf aj (+ nintrp 1))
  (setf dx (/ (+ (fref xright nstack) (- (fref xleft nstack))) aj))
  (fdo ((j 1 (+ j 1))) ((> j nintrp) nil)
   (tagbody (setf aj j)
    (fset (fref xintrp j) (+ (fref xleft nstack) (* aj dx)))
  ))
  label20 (fset (fref fleft 1) (funcall (f (fref xleft nstack) fdervl)))
  (fset (fref fright 1) (funcall (f (fref xright nstack) fdervr)))
  (setf leftx (+ smooth 1)) (setf rightx leftx) (if (= nintrp 0) (go label40))
  (fdo ((j 1 (+ j 1))) ((> j nintrp) nil)
   (tagbody (fset (fref fintrp j) (funcall (f (fref xintrp j) fdumb))))
  )
  label40 (if (/= break left) (go label50))
  (setf leftx (+ (fref dbreak ibreak) 1))
  (fset (fref fleft leftx) (fref bright ibreak)) label50
  (if (/= break right) (go label60)) (setf rightx (+ (fref dbreak ibreak) 1))
  (fset (fref fright rightx) (fref bleft ibreak)) label60
  (if (/= break both) (go label70)) (setf leftx (+ (fref dbreak ibreak) 1))
  (setf rightx (+ (fref dbreak (+ ibreak 1)) 1))
  (fset (fref fleft leftx) (fref bright ibreak))
  (fset (fref fright rightx) (fref bleft (+ ibreak 1))) label70
  (multiple-value-setq (leftx rightx nintrp) (newton leftx rightx nintrp))
  (setf errori
   (errint f polydd (fref xleft nstack) (fref xright nstack) absc wgts)
  )
  (setf errori (* r errori)) (return (values f))
))