src/numerical/slatec/dqaws.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 dqaws
  21        (f a b alfa beta integr epsabs epsrel result abserr neval ier limit lenw
  22         last$ iwork 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 integr)
  26            (type (double-float) abserr result epsrel epsabs beta alfa 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 2) (< 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 var-16 var-17 var-18)
  44           (dqawse f a b alfa beta integr epsabs epsrel limit result abserr
  45            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-6 var-7 var-8 var-13 var-14 var-15 var-16
  68                          var-17))
  69         (setf a var-1)
  70         (setf b var-2)
  71         (setf alfa var-3)
  72         (setf beta var-4)
  73         (setf integr var-5)
  74         (setf result var-9)
  75         (setf abserr var-10)
  76         (setf neval var-11)
  77         (setf ier var-12)
  78         (setf last$ var-18))
  79       (setf lvl 0)
  80      label10
  81       (if (= ier 6) (setf lvl 1))
  82       (if (/= ier 0) (xermsg "SLATEC" "DQAWS" "ABNORMAL RETURN" ier lvl))
  83       (go end_label)
  84      end_label
  85       (return
  86        (values nil
  87                a
  88                b
  89                alfa
  90                beta
  91                integr
  92                nil
  93                nil
  94                result
  95                abserr
  96                neval
  97                ier
  98                nil
  99                nil
 100                last$
 101                nil
 102                nil)))))
 103
 104 (in-package #:cl-user)
 105 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 106 (eval-when (:load-toplevel :compile-toplevel :execute)
 107   (setf (gethash 'fortran-to-lisp::dqaws fortran-to-lisp::*f2cl-function-info*)
 108           (fortran-to-lisp::make-f2cl-finfo
 109            :arg-types '(t (double-float) (double-float) (double-float)
 110                         (double-float) (fortran-to-lisp::integer4)
 111                         (double-float) (double-float) (double-float)
 112                         (double-float) (fortran-to-lisp::integer4)
 113                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 114                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 115                         (array fortran-to-lisp::integer4 (*))
 116                         (array double-float (*)))
 117            :return-values '(nil fortran-to-lisp::a fortran-to-lisp::b
 118                             fortran-to-lisp::alfa fortran-to-lisp::beta
 119                             fortran-to-lisp::integr nil nil
 120                             fortran-to-lisp::result fortran-to-lisp::abserr
 121                             fortran-to-lisp::neval fortran-to-lisp::ier nil nil
 122                             fortran-to-lisp::last$ nil nil)
 123            :calls '(fortran-to-lisp::xermsg fortran-to-lisp::dqawse))))
 124