src/numerical/slatec/dqags.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   3 ;;;  "f2cl2.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   4 ;;;  "f2cl3.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   5 ;;;  "f2cl4.l,v 96616d88fb7e 2008/02/22 22:19:34 rtoy $"
   6 ;;;  "f2cl5.l,v 46c1f6a93b0d 2012/05/03 04:40:28 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v fceac530ef0c 2011/11/26 04:02:26 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp snapshot-2012-04 (20C Unicode)
  11 ;;;
  12 ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  13 ;;;           (:coerce-assigns :as-needed) (:array-type ':array)
  14 ;;;           (:array-slicing t) (:declare-common nil)
  15 ;;;           (:float-format double-float))
  16
  17 (in-package :slatec)
  18
  19
  20 (defun dqags
  21        (f a b epsabs epsrel result abserr neval ier limit lenw last$ iwork
  22         work)
  23   (declare (type (array double-float (*)) work)
  24            (type (array f2cl-lib:integer4 (*)) iwork)
  25            (type (f2cl-lib:integer4) last$ lenw limit ier neval)
  26            (type (double-float) abserr result epsrel epsabs b a))
  27   (f2cl-lib:with-multi-array-data
  28       ((iwork f2cl-lib:integer4 iwork-%data% iwork-%offset%)
  29        (work double-float work-%data% work-%offset%))
  30     (prog ((lvl 0) (l1 0) (l2 0) (l3 0))
  31       (declare (type (f2cl-lib:integer4) l3 l2 l1 lvl))
  32       (setf ier 6)
  33       (setf neval 0)
  34       (setf last$ 0)
  35       (setf result 0.0)
  36       (setf abserr 0.0)
  37       (if (or (< limit 1) (< lenw (f2cl-lib:int-mul limit 4))) (go label10))
  38       (setf l1 (f2cl-lib:int-add limit 1))
  39       (setf l2 (f2cl-lib:int-add limit l1))
  40       (setf l3 (f2cl-lib:int-add limit l2))
  41       (multiple-value-bind
  42             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  43              var-11 var-12 var-13 var-14 var-15)
  44           (dqagse f a b epsabs epsrel limit result abserr neval ier
  45            (f2cl-lib:array-slice work-%data%
  46                                  double-float
  47                                  (1)
  48                                  ((1 *))
  49                                  work-%offset%)
  50            (f2cl-lib:array-slice work-%data%
  51                                  double-float
  52                                  (l1)
  53                                  ((1 *))
  54                                  work-%offset%)
  55            (f2cl-lib:array-slice work-%data%
  56                                  double-float
  57                                  (l2)
  58                                  ((1 *))
  59                                  work-%offset%)
  60            (f2cl-lib:array-slice work-%data%
  61                                  double-float
  62                                  (l3)
  63                                  ((1 *))
  64                                  work-%offset%)
  65            iwork last$)
  66         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-10 var-11
  67                          var-12 var-13 var-14))
  68         (setf result var-6)
  69         (setf abserr var-7)
  70         (setf neval var-8)
  71         (setf ier var-9)
  72         (setf last$ var-15))
  73       (setf lvl 0)
  74      label10
  75       (if (= ier 6) (setf lvl 1))
  76       (if (/= ier 0) (xermsg "SLATEC" "DQAGS" "ABNORMAL RETURN" ier lvl))
  77       (go end_label)
  78      end_label
  79       (return
  80        (values nil
  81                nil
  82                nil
  83                nil
  84                nil
  85                result
  86                abserr
  87                neval
  88                ier
  89                nil
  90                nil
  91                last$
  92                nil
  93                nil)))))
  94
  95 (in-package #:cl-user)
  96 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  97 (eval-when (:load-toplevel :compile-toplevel :execute)
  98   (setf (gethash 'fortran-to-lisp::dqags fortran-to-lisp::*f2cl-function-info*)
  99           (fortran-to-lisp::make-f2cl-finfo
 100            :arg-types '(t (double-float) (double-float) (double-float)
 101                         (double-float) (double-float) (double-float)
 102                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 103                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 104                         (fortran-to-lisp::integer4)
 105                         (array fortran-to-lisp::integer4 (*))
 106                         (array double-float (*)))
 107            :return-values '(nil nil nil nil nil fortran-to-lisp::result
 108                             fortran-to-lisp::abserr fortran-to-lisp::neval
 109                             fortran-to-lisp::ier nil nil fortran-to-lisp::last$
 110                             nil nil)
 111            :calls '(fortran-to-lisp::xermsg fortran-to-lisp::dqagse))))
 112