src/numerical/slatec/dqagp.lisp

   1 ;;; Compiled by f2cl version:
   2 ;;; ("f2cl1.l,v f0f149e72999 2010/10/08 03:05:30 rtoy $"
   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 11bea7dae5a0 2011/06/11 17:53:39 toy $"
   7 ;;;  "f2cl6.l,v 1d5cbacbb977 2008/08/24 00:56:27 rtoy $"
   8 ;;;  "macros.l,v 11bea7dae5a0 2011/06/11 17:53:39 toy $")
   9
  10 ;;; Using Lisp CMU Common Lisp Snapshot 2011-10 ce1db1c (20B 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 dqagp
  21        (f a b npts2 points epsabs epsrel result abserr neval ier leniw lenw
  22         last$ iwork work)
  23   (declare (type (array f2cl-lib:integer4 (*)) iwork)
  24            (type (array double-float (*)) work points)
  25            (type (f2cl-lib:integer4) last$ lenw leniw ier neval npts2)
  26            (type (double-float) abserr result epsrel epsabs b a))
  27   (f2cl-lib:with-multi-array-data
  28       ((points double-float points-%data% points-%offset%)
  29        (work double-float work-%data% work-%offset%)
  30        (iwork f2cl-lib:integer4 iwork-%data% iwork-%offset%))
  31     (prog ((limit 0) (lvl 0) (l1 0) (l2 0) (l3 0) (l4 0))
  32       (declare (type (f2cl-lib:integer4) l4 l3 l2 l1 lvl limit))
  33       (setf ier 6)
  34       (setf neval 0)
  35       (setf last$ 0)
  36       (setf result 0.0)
  37       (setf abserr 0.0)
  38       (if
  39        (or (< leniw (f2cl-lib:int-sub (f2cl-lib:int-mul 3 npts2) 2))
  40            (< lenw (f2cl-lib:int-sub (f2cl-lib:int-mul leniw 2) npts2))
  41            (< npts2 2))
  42        (go label10))
  43       (setf limit (the f2cl-lib:integer4 (truncate (- leniw npts2) 2)))
  44       (setf l1 (f2cl-lib:int-add limit 1))
  45       (setf l2 (f2cl-lib:int-add limit l1))
  46       (setf l3 (f2cl-lib:int-add limit l2))
  47       (setf l4 (f2cl-lib:int-add limit l3))
  48       (multiple-value-bind
  49             (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  50              var-11 var-12 var-13 var-14 var-15 var-16 var-17 var-18 var-19
  51              var-20)
  52           (dqagpe f a b npts2 points epsabs epsrel limit result abserr neval
  53            ier
  54            (f2cl-lib:array-slice work-%data%
  55                                  double-float
  56                                  (1)
  57                                  ((1 *))
  58                                  work-%offset%)
  59            (f2cl-lib:array-slice work-%data%
  60                                  double-float
  61                                  (l1)
  62                                  ((1 *))
  63                                  work-%offset%)
  64            (f2cl-lib:array-slice work-%data%
  65                                  double-float
  66                                  (l2)
  67                                  ((1 *))
  68                                  work-%offset%)
  69            (f2cl-lib:array-slice work-%data%
  70                                  double-float
  71                                  (l3)
  72                                  ((1 *))
  73                                  work-%offset%)
  74            (f2cl-lib:array-slice work-%data%
  75                                  double-float
  76                                  (l4)
  77                                  ((1 *))
  78                                  work-%offset%)
  79            (f2cl-lib:array-slice iwork-%data%
  80                                  f2cl-lib:integer4
  81                                  (1)
  82                                  ((1 *))
  83                                  iwork-%offset%)
  84            (f2cl-lib:array-slice iwork-%data%
  85                                  f2cl-lib:integer4
  86                                  (l1)
  87                                  ((1 *))
  88                                  iwork-%offset%)
  89            (f2cl-lib:array-slice iwork-%data%
  90                                  f2cl-lib:integer4
  91                                  (l2)
  92                                  ((1 *))
  93                                  iwork-%offset%)
  94            last$)
  95         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-12
  96                          var-13 var-14 var-15 var-16 var-17 var-18 var-19))
  97         (setf result var-8)
  98         (setf abserr var-9)
  99         (setf neval var-10)
 100         (setf ier var-11)
 101         (setf last$ var-20))
 102       (setf lvl 0)
 103      label10
 104       (if (= ier 6) (setf lvl 1))
 105       (if (/= ier 0)
 106           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
 107               (xermsg "SLATEC" "DQAGP" "ABNORMAL RETURN" ier lvl)
 108             (declare (ignore var-0 var-1 var-2))
 109             (when var-3
 110               (setf ier var-3))
 111             (when var-4
 112               (setf lvl var-4))))
 113       (go end_label)
 114      end_label
 115       (return
 116        (values nil
 117                nil
 118                nil
 119                nil
 120                nil
 121                nil
 122                nil
 123                result
 124                abserr
 125                neval
 126                ier
 127                nil
 128                nil
 129                last$
 130                nil
 131                nil)))))
 132
 133 (in-package #:cl-user)
 134 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 135 (eval-when (:load-toplevel :compile-toplevel :execute)
 136   (setf (gethash 'fortran-to-lisp::dqagp fortran-to-lisp::*f2cl-function-info*)
 137           (fortran-to-lisp::make-f2cl-finfo
 138            :arg-types '(t (double-float) (double-float)
 139                         (fortran-to-lisp::integer4) (array double-float (*))
 140                         (double-float) (double-float) (double-float)
 141                         (double-float) (fortran-to-lisp::integer4)
 142                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 143                         (fortran-to-lisp::integer4) (fortran-to-lisp::integer4)
 144                         (array fortran-to-lisp::integer4 (*))
 145                         (array double-float (*)))
 146            :return-values '(nil nil nil nil nil nil nil fortran-to-lisp::result
 147                             fortran-to-lisp::abserr fortran-to-lisp::neval
 148                             fortran-to-lisp::ier nil nil fortran-to-lisp::last$
 149                             nil nil)
 150            :calls '(fortran-to-lisp::dqagpe))))
 151