;;; Compiled by f2cl version 2.0 beta 2002-05-06
;;; 
;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
;;;           (:coerce-assigns :as-needed) (:array-type ':array)
;;;           (:array-slicing t) (:declare-common nil)
;;;           (:float-format single-float))

(in-package "QUADPACK")


(let ((wg (make-array 8 :element-type 'double-float))
      (xgk (make-array 16 :element-type 'double-float))
      (wgk (make-array 16 :element-type 'double-float)))
  (declare (type (array double-float (16)) wgk xgk)
   (type (array double-float (8)) wg))
  (f2cl-lib:fset (f2cl-lib:fref wg (1) ((1 8))) 0.03075324199611727d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (2) ((1 8))) 0.07036604748810812d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (3) ((1 8))) 0.10715922046717194d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (4) ((1 8))) 0.13957067792615432d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (5) ((1 8))) 0.16626920581699392d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (6) ((1 8))) 0.1861610000155622d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (7) ((1 8))) 0.19843148532711158d0)
  (f2cl-lib:fset (f2cl-lib:fref wg (8) ((1 8))) 0.2025782419255613d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (1) ((1 16))) 0.9980022986933971d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (2) ((1 16))) 0.9879925180204854d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (3) ((1 16))) 0.9677390756791391d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (4) ((1 16))) 0.937273392400706d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (5) ((1 16))) 0.8972645323440819d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (6) ((1 16))) 0.8482065834104272d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (7) ((1 16))) 0.790418501442466d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (8) ((1 16))) 0.7244177313601701d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (9) ((1 16))) 0.650996741297417d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (10) ((1 16))) 0.5709721726085388d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (11) ((1 16))) 0.4850818636402397d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (12) ((1 16))) 0.3941513470775634d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (13) ((1 16))) 0.29918000715316884d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (14) ((1 16))) 0.20119409399743451d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (15) ((1 16))) 0.1011420669187175d0)
  (f2cl-lib:fset (f2cl-lib:fref xgk (16) ((1 16))) 0.0d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (1) ((1 16))) 0.005377479872923349d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (2) ((1 16))) 0.015007947329316122d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (3) ((1 16))) 0.02546084732671532d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (4) ((1 16))) 0.03534636079137585d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (5) ((1 16))) 0.04458975132476488d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (6) ((1 16))) 0.05348152469092809d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (7) ((1 16))) 0.06200956780067064d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (8) ((1 16))) 0.06985412131872826d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (9) ((1 16))) 0.07684968075772038d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (10) ((1 16))) 0.08308050282313302d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (11) ((1 16))) 0.08856444305621176d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (12) ((1 16))) 0.09312659817082532d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (13) ((1 16))) 0.09664272698362368d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (14) ((1 16))) 0.09917359872179196d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (15) ((1 16))) 0.10076984552387559d0)
  (f2cl-lib:fset (f2cl-lib:fref wgk (16) ((1 16))) 0.10133000701479154d0)
  (defun dqk31 (f a b result abserr resabs resasc)
    (declare (type double-float resasc resabs abserr result b a)
     (type (function (double-float) (values double-float &rest t)) f))
    (f2cl-lib:with-multi-array-data
        nil
      (prog ((fv1 (make-array 15 :element-type 'double-float))
             (fv2 (make-array 15 :element-type 'double-float)) (j 0) (jtw 0)
             (jtwm1 0) (absc 0.0d0) (centr 0.0d0) (dhlgth 0.0d0) (epmach 0.0d0)
             (fc 0.0d0) (fsum 0.0d0) (fval1 0.0d0) (fval2 0.0d0) (hlgth 0.0d0)
             (resg 0.0d0) (resk 0.0d0) (reskh 0.0d0) (uflow 0.0d0))
        (declare (type (array double-float (15)) fv2 fv1)
         (type double-float uflow reskh resk resg hlgth fval2 fval1 fsum fc
          epmach dhlgth centr absc)
         (type f2cl-lib:integer4 jtwm1 jtw j))
        (setf epmach (f2cl-lib:d1mach 4))
        (setf uflow (f2cl-lib:d1mach 1))
        (setf centr (* 0.5d0 (+ a b)))
        (setf hlgth (* 0.5d0 (- b a)))
        (setf dhlgth (f2cl-lib:dabs hlgth))
        (setf fc
                (multiple-value-bind
                    (ret-val var-0)
                    (funcall f centr)
                  (declare (ignore))
                  (when var-0 (setf centr var-0))
                  ret-val))
        (setf resg (* (f2cl-lib:fref wg (8) ((1 8))) fc))
        (setf resk (* (f2cl-lib:fref wgk (16) ((1 16))) fc))
        (setf resabs (f2cl-lib:dabs resk))
        (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
                      ((> j 7) nil)
          (tagbody
            (setf jtw (f2cl-lib:int-mul j 2))
            (setf absc (* hlgth (f2cl-lib:fref xgk (jtw) ((1 16)))))
            (setf fval1 (funcall f (- centr absc)))
            (setf fval2 (funcall f (+ centr absc)))
            (f2cl-lib:fset (f2cl-lib:fref fv1 (jtw) ((1 15))) fval1)
            (f2cl-lib:fset (f2cl-lib:fref fv2 (jtw) ((1 15))) fval2)
            (setf fsum (+ fval1 fval2))
            (setf resg (+ resg (* (f2cl-lib:fref wg (j) ((1 8))) fsum)))
            (setf resk (+ resk (* (f2cl-lib:fref wgk (jtw) ((1 16))) fsum)))
            (setf resabs
                    (+ resabs
                       (* (f2cl-lib:fref wgk (jtw) ((1 16)))
                          (+ (f2cl-lib:dabs fval1) (f2cl-lib:dabs fval2)))))
           label10))
        (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
                      ((> j 8) nil)
          (tagbody
            (setf jtwm1 (f2cl-lib:int-sub (f2cl-lib:int-mul j 2) 1))
            (setf absc (* hlgth (f2cl-lib:fref xgk (jtwm1) ((1 16)))))
            (setf fval1 (funcall f (- centr absc)))
            (setf fval2 (funcall f (+ centr absc)))
            (f2cl-lib:fset (f2cl-lib:fref fv1 (jtwm1) ((1 15))) fval1)
            (f2cl-lib:fset (f2cl-lib:fref fv2 (jtwm1) ((1 15))) fval2)
            (setf fsum (+ fval1 fval2))
            (setf resk (+ resk (* (f2cl-lib:fref wgk (jtwm1) ((1 16))) fsum)))
            (setf resabs
                    (+ resabs
                       (* (f2cl-lib:fref wgk (jtwm1) ((1 16)))
                          (+ (f2cl-lib:dabs fval1) (f2cl-lib:dabs fval2)))))
           label15))
        (setf reskh (* resk 0.5d0))
        (setf resasc
                (* (f2cl-lib:fref wgk (16) ((1 16)))
                   (f2cl-lib:dabs (- fc reskh))))
        (f2cl-lib:fdo (j 1 (f2cl-lib:int-add j 1))
                      ((> j 15) nil)
          (tagbody
            (setf resasc
                    (+ resasc
                       (* (f2cl-lib:fref wgk (j) ((1 16)))
                          (+
                           (f2cl-lib:dabs
                            (- (f2cl-lib:fref fv1 (j) ((1 15))) reskh))
                           (f2cl-lib:dabs
                            (- (f2cl-lib:fref fv2 (j) ((1 15))) reskh))))))
           label20))
        (setf result (* resk hlgth))
        (setf resabs (* resabs dhlgth))
        (setf resasc (* resasc dhlgth))
        (setf abserr (f2cl-lib:dabs (* (- resk resg) hlgth)))
        (if (and (/= resasc 0.0d0) (/= abserr 0.0d0))
            (setf abserr
                    (* resasc
                       (f2cl-lib:dmin1 1.0d0
                                       (expt (/ (* 200.0d0 abserr) resasc)
                                             1.5d0)))))
        (if (> resabs (/ uflow (* 50.0d0 epmach)))
            (setf abserr (f2cl-lib:dmax1 (* epmach 50.0d0 resabs) abserr)))
        (go end_label)
       end_label
        (return (values nil nil nil result abserr resabs resasc))))))