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 #-gcl #:cl-user #+gcl "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 163