src/numerical/slatec/dqawf.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 dqawf
  21        (f a omega integr epsabs result abserr neval ier limlst lst leniw maxp1
  22         lenw iwork work)
  23   (declare (type (array double-float (*)) work)
  24            (type (array f2cl-lib:integer4 (*)) iwork)
  25            (type (f2cl-lib:integer4) lenw maxp1 leniw lst limlst ier neval
  26                                      integr)
  27            (type (double-float) abserr result epsabs omega a))
  28   (f2cl-lib:with-multi-array-data
  29       ((iwork f2cl-lib:integer4 iwork-%data% iwork-%offset%)
  30        (work double-float work-%data% work-%offset%))
  31     (prog ((limit 0) (ll2 0) (lvl 0) (l1 0) (l2 0) (l3 0) (l4 0) (l5 0) (l6 0))
  32       (declare (type (f2cl-lib:integer4) l6 l5 l4 l3 l2 l1 lvl ll2 limit))
  33       (setf ier 6)
  34       (setf neval 0)
  35       (setf result 0.0)
  36       (setf abserr 0.0)
  37       (if
  38        (or (< limlst 3)
  39            (< leniw (f2cl-lib:int-add limlst 2))
  40            (< maxp1 1)
  41            (< lenw
  42               (f2cl-lib:int-add (f2cl-lib:int-mul leniw 2)
  43                                 (f2cl-lib:int-mul maxp1 25))))
  44        (go label10))
  45       (setf limit (the f2cl-lib:integer4 (truncate (- leniw limlst) 2)))
  46       (setf l1 (f2cl-lib:int-add limlst 1))
  47       (setf l2 (f2cl-lib:int-add limlst l1))
  48       (setf l3 (f2cl-lib:int-add limit l2))
  49       (setf l4 (f2cl-lib:int-add limit l3))
  50       (setf l5 (f2cl-lib:int-add limit l4))
  51       (setf l6 (f2cl-lib:int-add limit l5))
  52       (setf ll2 (f2cl-lib:int-add limit l1))
  53       (multiple-value-bind
  54             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  55              var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18 var-19
  56              var-20 var-21 var-22)
  57           (dqawfe f a omega integr epsabs limlst limit maxp1 result abserr
  58            neval ier
  59            (f2cl-lib:array-slice work-%data%
  60                                  double-float
  61                                  (1)
  62                                  ((1 *))
  63                                  work-%offset%)
  64            (f2cl-lib:array-slice work-%data%
  65                                  double-float
  66                                  (l1)
  67                                  ((1 *))
  68                                  work-%offset%)
  69            (f2cl-lib:array-slice iwork-%data%
  70                                  f2cl-lib:integer4
  71                                  (1)
  72                                  ((1 *))
  73                                  iwork-%offset%)
  74            lst
  75            (f2cl-lib:array-slice work-%data%
  76                                  double-float
  77                                  (l2)
  78                                  ((1 *))
  79                                  work-%offset%)
  80            (f2cl-lib:array-slice work-%data%
  81                                  double-float
  82                                  (l3)
  83                                  ((1 *))
  84                                  work-%offset%)
  85            (f2cl-lib:array-slice work-%data%
  86                                  double-float
  87                                  (l4)
  88                                  ((1 *))
  89                                  work-%offset%)
  90            (f2cl-lib:array-slice work-%data%
  91                                  double-float
  92                                  (l5)
  93                                  ((1 *))
  94                                  work-%offset%)
  95            (f2cl-lib:array-slice iwork-%data%
  96                                  f2cl-lib:integer4
  97                                  (l1)
  98                                  ((1 *))
  99                                  iwork-%offset%)
 100            (f2cl-lib:array-slice iwork-%data%
 101                                  f2cl-lib:integer4
 102                                  (ll2)
 103                                  ((1 *))
 104                                  iwork-%offset%)
 105            (f2cl-lib:array-slice work-%data%
 106                                  double-float
 107                                  (l6)
 108                                  ((1 *))
 109                                  work-%offset%))
 110         (declare (ignore var-0 var-1 var-2 var-4 var-5 var-6 var-7 var-12
 111                          var-13 var-14 var-16 var-17 var-18 var-19 var-20
 112                          var-21 var-22))
 113         (setf integr var-3)
 114         (setf result var-8)
 115         (setf abserr var-9)
 116         (setf neval var-10)
 117         (setf ier var-11)
 118         (setf lst var-15))
 119       (setf lvl 0)
 120      label10
 121       (if (= ier 6) (setf lvl 1))
 122       (if (/= ier 0) (xermsg "SLATEC" "DQAWF" "ABNORMAL RETURN" ier lvl))
 123       (go end_label)
 124      end_label
 125       (return
 126        (values nil
 127                nil
 128                nil
 129                integr
 130                nil
 131                result
 132                abserr
 133                neval
 134                ier
 135                nil
 136                lst
 137                nil
 138                nil
 139                nil
 140                nil
 141                nil)))))
 142
 143 (in-package #:cl-user)
 144 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 145 (eval-when (:load-toplevel :compile-toplevel :execute)
 146   (setf (gethash 'fortran-to-lisp::dqawf fortran-to-lisp::*f2cl-function-info*)
 147           (fortran-to-lisp::make-f2cl-finfo
 148            :arg-types '(t (double-float) (double-float)
 149                         (fortran-to-lisp::integer4) (double-float)
 150                         (double-float) (double-float)
 151                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 152                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 153                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 154                         (fortran-to-lisp::integer4)
 155                         (array fortran-to-lisp::integer4 (*))
 156                         (array double-float (*)))
 157            :return-values '(nil nil nil fortran-to-lisp::integr nil
 158                             fortran-to-lisp::result fortran-to-lisp::abserr
 159                             fortran-to-lisp::neval fortran-to-lisp::ier nil
 160                             fortran-to-lisp::lst nil nil nil nil nil)
 161            :calls '(fortran-to-lisp::xermsg fortran-to-lisp::dqawfe))))
 162