src/numerical/slatec/dqawce.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 dqawce
  21        (f a b c epsabs epsrel limit result abserr neval ier alist blist rlist
  22         elist iord last$)
  23   (declare (type (array f2cl-lib:integer4 (*)) iord)
  24            (type (array double-float (*)) elist rlist blist alist)
  25            (type (f2cl-lib:integer4) last$ ier neval limit)
  26            (type (double-float) abserr result epsrel epsabs c b a))
  27   (f2cl-lib:with-multi-array-data
  28       ((alist double-float alist-%data% alist-%offset%)
  29        (blist double-float blist-%data% blist-%offset%)
  30        (rlist double-float rlist-%data% rlist-%offset%)
  31        (elist double-float elist-%data% elist-%offset%)
  32        (iord f2cl-lib:integer4 iord-%data% iord-%offset%))
  33     (prog ((iroff1 0) (iroff2 0) (k 0) (krule 0) (maxerr 0) (nev 0) (nrmax 0)
  34            (aa 0.0) (area 0.0) (area1 0.0) (area12 0.0) (area2 0.0) (a1 0.0)
  35            (a2 0.0) (bb 0.0) (b1 0.0) (b2 0.0) (epmach 0.0) (errbnd 0.0)
  36            (errmax 0.0) (error1 0.0) (erro12 0.0) (error2 0.0) (errsum 0.0)
  37            (uflow 0.0))
  38       (declare (type (double-float) uflow errsum error2 erro12 error1 errmax
  39                                     errbnd epmach b2 b1 bb a2 a1 area2 area12
  40                                     area1 area aa)
  41                (type (f2cl-lib:integer4) nrmax nev maxerr krule k iroff2
  42                                          iroff1))
  43       (setf epmach (f2cl-lib:d1mach 4))
  44       (setf uflow (f2cl-lib:d1mach 1))
  45       (setf ier 6)
  46       (setf neval 0)
  47       (setf last$ 0)
  48       (setf (f2cl-lib:fref alist-%data% (1) ((1 *)) alist-%offset%) a)
  49       (setf (f2cl-lib:fref blist-%data% (1) ((1 *)) blist-%offset%) b)
  50       (setf (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%) 0.0)
  51       (setf (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%) 0.0)
  52       (setf (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 0)
  53       (setf result 0.0)
  54       (setf abserr 0.0)
  55       (if
  56        (or (= c a)
  57            (= c b)
  58            (and (<= epsabs 0.0) (< epsrel (max (* 50.0 epmach) 5.0e-29))))
  59        (go label999))
  60       (setf aa a)
  61       (setf bb b)
  62       (if (<= a b) (go label10))
  63       (setf aa b)
  64       (setf bb a)
  65      label10
  66       (setf ier 0)
  67       (setf krule 1)
  68       (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
  69           (dqc25c f aa bb c result abserr krule neval)
  70         (declare (ignore var-0 var-1 var-2))
  71         (setf c var-3)
  72         (setf result var-4)
  73         (setf abserr var-5)
  74         (setf krule var-6)
  75         (setf neval var-7))
  76       (setf last$ 1)
  77       (setf (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%) result)
  78       (setf (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%) abserr)
  79       (setf (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 1)
  80       (setf (f2cl-lib:fref alist-%data% (1) ((1 *)) alist-%offset%) a)
  81       (setf (f2cl-lib:fref blist-%data% (1) ((1 *)) blist-%offset%) b)
  82       (setf errbnd (max epsabs (* epsrel (abs result))))
  83       (if (= limit 1) (setf ier 1))
  84       (if (or (< abserr (min (* 0.01 (abs result)) errbnd)) (= ier 1))
  85           (go label70))
  86       (setf (f2cl-lib:fref alist-%data% (1) ((1 *)) alist-%offset%) aa)
  87       (setf (f2cl-lib:fref blist-%data% (1) ((1 *)) blist-%offset%) bb)
  88       (setf (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%) result)
  89       (setf errmax abserr)
  90       (setf maxerr 1)
  91       (setf area result)
  92       (setf errsum abserr)
  93       (setf nrmax 1)
  94       (setf iroff1 0)
  95       (setf iroff2 0)
  96       (f2cl-lib:fdo (last$ 2 (f2cl-lib:int-add last$ 1))
  97                     ((> last$ limit) nil)
  98         (tagbody
  99           (setf a1
 100                   (f2cl-lib:fref alist-%data% (maxerr) ((1 *)) alist-%offset%))
 101           (setf b1
 102                   (* 0.5
 103                      (+
 104                       (f2cl-lib:fref alist-%data%
 105                                      (maxerr)
 106                                      ((1 *))
 107                                      alist-%offset%)
 108                       (f2cl-lib:fref blist-%data%
 109                                      (maxerr)
 110                                      ((1 *))
 111                                      blist-%offset%))))
 112           (setf b2
 113                   (f2cl-lib:fref blist-%data% (maxerr) ((1 *)) blist-%offset%))
 114           (if (and (<= c b1) (> c a1)) (setf b1 (* 0.5 (+ c b2))))
 115           (if (and (> c b1) (< c b2)) (setf b1 (* 0.5 (+ a1 c))))
 116           (setf a2 b1)
 117           (setf krule 2)
 118           (multiple-value-bind
 119                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 120               (dqc25c f a1 b1 c area1 error1 krule nev)
 121             (declare (ignore var-0 var-1 var-2))
 122             (setf c var-3)
 123             (setf area1 var-4)
 124             (setf error1 var-5)
 125             (setf krule var-6)
 126             (setf nev var-7))
 127           (setf neval (f2cl-lib:int-add neval nev))
 128           (multiple-value-bind
 129                 (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7)
 130               (dqc25c f a2 b2 c area2 error2 krule nev)
 131             (declare (ignore var-0 var-1 var-2))
 132             (setf c var-3)
 133             (setf area2 var-4)
 134             (setf error2 var-5)
 135             (setf krule var-6)
 136             (setf nev var-7))
 137           (setf neval (f2cl-lib:int-add neval nev))
 138           (setf area12 (+ area1 area2))
 139           (setf erro12 (+ error1 error2))
 140           (setf errsum (- (+ errsum erro12) errmax))
 141           (setf area
 142                   (- (+ area area12)
 143                      (f2cl-lib:fref rlist-%data%
 144                                     (maxerr)
 145                                     ((1 *))
 146                                     rlist-%offset%)))
 147           (if
 148            (and
 149             (<
 150              (abs
 151               (- (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 152                  area12))
 153              (* 1.0e-5 (abs area12)))
 154             (>= erro12 (* 0.99 errmax))
 155             (= krule 0))
 156            (setf iroff1 (f2cl-lib:int-add iroff1 1)))
 157           (if (and (> last$ 10) (> erro12 errmax) (= krule 0))
 158               (setf iroff2 (f2cl-lib:int-add iroff2 1)))
 159           (setf (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 160                   area1)
 161           (setf (f2cl-lib:fref rlist-%data% (last$) ((1 *)) rlist-%offset%)
 162                   area2)
 163           (setf errbnd (max epsabs (* epsrel (abs area))))
 164           (if (<= errsum errbnd) (go label15))
 165           (if (and (>= iroff1 6) (> iroff2 20)) (setf ier 2))
 166           (if (= last$ limit) (setf ier 1))
 167           (if
 168            (<= (max (abs a1) (abs b2))
 169                (* (+ 1.0 (* 100.0 epmach)) (+ (abs a2) (* 1000.0 uflow))))
 170            (setf ier 3))
 171          label15
 172           (if (> error2 error1) (go label20))
 173           (setf (f2cl-lib:fref alist-%data% (last$) ((1 *)) alist-%offset%) a2)
 174           (setf (f2cl-lib:fref blist-%data% (maxerr) ((1 *)) blist-%offset%)
 175                   b1)
 176           (setf (f2cl-lib:fref blist-%data% (last$) ((1 *)) blist-%offset%) b2)
 177           (setf (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%)
 178                   error1)
 179           (setf (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%)
 180                   error2)
 181           (go label30)
 182          label20
 183           (setf (f2cl-lib:fref alist-%data% (maxerr) ((1 *)) alist-%offset%)
 184                   a2)
 185           (setf (f2cl-lib:fref alist-%data% (last$) ((1 *)) alist-%offset%) a1)
 186           (setf (f2cl-lib:fref blist-%data% (last$) ((1 *)) blist-%offset%) b1)
 187           (setf (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 188                   area2)
 189           (setf (f2cl-lib:fref rlist-%data% (last$) ((1 *)) rlist-%offset%)
 190                   area1)
 191           (setf (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%)
 192                   error2)
 193           (setf (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%)
 194                   error1)
 195          label30
 196           (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 197               (dqpsrt limit last$ maxerr errmax elist iord nrmax)
 198             (declare (ignore var-0 var-1 var-4 var-5))
 199             (setf maxerr var-2)
 200             (setf errmax var-3)
 201             (setf nrmax var-6))
 202           (if (or (/= ier 0) (<= errsum errbnd)) (go label50))
 203          label40))
 204      label50
 205       (setf result 0.0)
 206       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 207                     ((> k last$) nil)
 208         (tagbody
 209           (setf result
 210                   (+ result
 211                      (f2cl-lib:fref rlist-%data% (k) ((1 *)) rlist-%offset%)))
 212          label60))
 213       (setf abserr errsum)
 214      label70
 215       (if (= aa b) (setf result (- result)))
 216      label999
 217       (go end_label)
 218      end_label
 219       (return
 220        (values nil
 221                nil
 222                nil
 223                c
 224                nil
 225                nil
 226                nil
 227                result
 228                abserr
 229                neval
 230                ier
 231                nil
 232                nil
 233                nil
 234                nil
 235                nil
 236                last$)))))
 237
 238 (in-package #:cl-user)
 239 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
 240 (eval-when (:load-toplevel :compile-toplevel :execute)
 241   (setf (gethash 'fortran-to-lisp::dqawce
 242                  fortran-to-lisp::*f2cl-function-info*)
 243           (fortran-to-lisp::make-f2cl-finfo
 244            :arg-types '(t (double-float) (double-float) (double-float)
 245                         (double-float) (double-float)
 246                         (fortran-to-lisp::integer4) (double-float)
 247                         (double-float) (fortran-to-lisp::integer4)
 248                         (fortran-to-lisp::integer4) (array double-float (*))
 249                         (array double-float (*)) (array double-float (*))
 250                         (array double-float (*))
 251                         (array fortran-to-lisp::integer4 (*))
 252                         (fortran-to-lisp::integer4))
 253            :return-values '(nil nil nil fortran-to-lisp::c nil nil nil
 254                             fortran-to-lisp::result fortran-to-lisp::abserr
 255                             fortran-to-lisp::neval fortran-to-lisp::ier nil nil
 256                             nil nil nil fortran-to-lisp::last$)
 257            :calls '(fortran-to-lisp::dqpsrt fortran-to-lisp::dqc25c
 258                     fortran-to-lisp::d1mach))))
 259