src/numerical/slatec/dqag.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 dqag
  21        (f a b epsabs epsrel key 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 key)
  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       (cond
  38         ((and (>= limit 1) (>= lenw (f2cl-lib:int-mul limit 4)))
  39          (setf l1 (f2cl-lib:int-add limit 1))
  40          (setf l2 (f2cl-lib:int-add limit l1))
  41          (setf l3 (f2cl-lib:int-add limit l2))
  42          (multiple-value-bind
  43                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  44                 var-10 var-11 var-12 var-13 var-14 var-15 var-16)
  45              (dqage f a b epsabs epsrel key limit result abserr neval ier
  46               (f2cl-lib:array-slice work-%data%
  47                                     double-float
  48                                     (1)
  49                                     ((1 *))
  50                                     work-%offset%)
  51               (f2cl-lib:array-slice work-%data%
  52                                     double-float
  53                                     (l1)
  54                                     ((1 *))
  55                                     work-%offset%)
  56               (f2cl-lib:array-slice work-%data%
  57                                     double-float
  58                                     (l2)
  59                                     ((1 *))
  60                                     work-%offset%)
  61               (f2cl-lib:array-slice work-%data%
  62                                     double-float
  63                                     (l3)
  64                                     ((1 *))
  65                                     work-%offset%)
  66               iwork last$)
  67            (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-11
  68                             var-12 var-13 var-14 var-15))
  69            (setf result var-7)
  70            (setf abserr var-8)
  71            (setf neval var-9)
  72            (setf ier var-10)
  73            (setf last$ var-16))
  74          (setf lvl 0)))
  75       (if (= ier 6) (setf lvl 1))
  76       (if (/= ier 0) (xermsg "SLATEC" "DQAG" "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                nil
  86                result
  87                abserr
  88                neval
  89                ier
  90                nil
  91                nil
  92                last$
  93                nil
  94                nil)))))
  95
  96 (in-package #:cl-user)
  97 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
  98 (eval-when (:load-toplevel :compile-toplevel :execute)
  99   (setf (gethash 'fortran-to-lisp::dqag fortran-to-lisp::*f2cl-function-info*)
 100           (fortran-to-lisp::make-f2cl-finfo
 101            :arg-types '(t (double-float) (double-float) (double-float)
 102                         (double-float) (fortran-to-lisp::integer4)
 103                         (double-float) (double-float)
 104                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 105                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 106                         (fortran-to-lisp::integer4)
 107                         (array fortran-to-lisp::integer4 (*))
 108                         (array double-float (*)))
 109            :return-values '(nil nil nil nil nil nil fortran-to-lisp::result
 110                             fortran-to-lisp::abserr fortran-to-lisp::neval
 111                             fortran-to-lisp::ier nil nil fortran-to-lisp::last$
 112                             nil nil)
 113            :calls '(fortran-to-lisp::xermsg fortran-to-lisp::dqage))))
 114