← Back to branch summary

~ubuntu-branches/debian/squeeze/maxima/squeeze

« back to all changes in this revision

Viewing changes to src/numerical/slatec/dqage.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2006-10-18 14:52:42 UTC
  • mto: (1.1.5 upstream)
  • mto: This revision was merged to the branch mainline in revision 4.
  • Revision ID: james.westby@ubuntu.com-20061018145242-vzyrm5hmxr8kiosf
Import upstream version 5.10.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/numerical/slatec/dqage.lisp
1
 
;;; Compiled by f2cl version 2.0 beta 2002-05-06
 
1
;;; Compiled by f2cl version 2.0 beta Date: 2006/01/31 15:11:05 
 
2
;;; Using Lisp CMU Common Lisp Snapshot 2006-01 (19C)
2
3
;;; 
3
4
;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
4
 
;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
 
5
;;;           (:coerce-assigns :as-needed) (:array-type ':array)
5
6
;;;           (:array-slicing t) (:declare-common nil)
6
7
;;;           (:float-format double-float))
7
8
 
8
 
(in-package "SLATEC")
 
9
(in-package :slatec)
9
10
 
10
11
 
11
12
(defun dqage
12
13
       (f a b epsabs epsrel key limit result abserr neval ier alist blist rlist
13
14
        elist iord last$)
14
15
  (declare (type (array f2cl-lib:integer4 (*)) iord)
15
 
   (type (array double-float (*)) elist rlist blist alist)
16
 
   (type f2cl-lib:integer4 last$ ier neval limit key)
17
 
   (type double-float abserr result epsrel epsabs b a))
18
 
  (prog ((iroff1 0) (iroff2 0) (k 0) (keyf 0) (maxerr 0) (nrmax 0) (area 0.0)
19
 
         (area1 0.0) (area12 0.0) (area2 0.0) (a1 0.0) (a2 0.0) (b1 0.0)
20
 
         (b2 0.0) (defabs 0.0) (defab1 0.0) (defab2 0.0) (epmach 0.0)
21
 
         (errbnd 0.0) (errmax 0.0) (error1 0.0) (error2 0.0) (erro12 0.0)
22
 
         (errsum 0.0) (resabs 0.0) (uflow 0.0) (abs$ 0.0f0))
23
 
    (declare (type single-float abs$)
24
 
     (type double-float uflow resabs errsum erro12 error2 error1 errmax errbnd
25
 
      epmach defab2 defab1 defabs b2 b1 a2 a1 area2 area12 area1 area)
26
 
     (type f2cl-lib:integer4 nrmax maxerr keyf k iroff2 iroff1))
27
 
    (setf epmach (f2cl-lib:d1mach 4))
28
 
    (setf uflow (f2cl-lib:d1mach 1))
29
 
    (setf ier 0)
30
 
    (setf neval 0)
31
 
    (setf last$ 0)
32
 
    (setf result 0.0)
33
 
    (setf abserr 0.0)
34
 
    (f2cl-lib:fset (f2cl-lib:fref alist (1) ((1 *))) a)
35
 
    (f2cl-lib:fset (f2cl-lib:fref blist (1) ((1 *))) b)
36
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (1) ((1 *))) 0.0)
37
 
    (f2cl-lib:fset (f2cl-lib:fref elist (1) ((1 *))) 0.0)
38
 
    (f2cl-lib:fset (f2cl-lib:fref iord (1) ((1 *))) 0)
39
 
    (if (and (<= epsabs 0.0) (< epsrel (max (* 50.0 epmach) 5.0e-29)))
40
 
        (setf ier 6))
41
 
    (if (= ier 6) (go label999))
42
 
    (setf keyf key)
43
 
    (if (<= key 0) (setf keyf 1))
44
 
    (if (>= key 7) (setf keyf 6))
45
 
    (setf neval 0)
46
 
    (if (= keyf 1)
47
 
        (multiple-value-bind
48
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
49
 
            (dqk15 f a b result abserr defabs resabs)
50
 
          (declare (ignore var-0 var-1 var-2))
51
 
          (setf result var-3)
52
 
          (setf abserr var-4)
53
 
          (setf defabs var-5)
54
 
          (setf resabs var-6)))
55
 
    (if (= keyf 2)
56
 
        (multiple-value-bind
57
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
58
 
            (dqk21 f a b result abserr defabs resabs)
59
 
          (declare (ignore var-0 var-1 var-2))
60
 
          (setf result var-3)
61
 
          (setf abserr var-4)
62
 
          (setf defabs var-5)
63
 
          (setf resabs var-6)))
64
 
    (if (= keyf 3)
65
 
        (multiple-value-bind
66
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
67
 
            (dqk31 f a b result abserr defabs resabs)
68
 
          (declare (ignore var-0 var-1 var-2))
69
 
          (setf result var-3)
70
 
          (setf abserr var-4)
71
 
          (setf defabs var-5)
72
 
          (setf resabs var-6)))
73
 
    (if (= keyf 4)
74
 
        (multiple-value-bind
75
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
76
 
            (dqk41 f a b result abserr defabs resabs)
77
 
          (declare (ignore var-0 var-1 var-2))
78
 
          (setf result var-3)
79
 
          (setf abserr var-4)
80
 
          (setf defabs var-5)
81
 
          (setf resabs var-6)))
82
 
    (if (= keyf 5)
83
 
        (multiple-value-bind
84
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
85
 
            (dqk51 f a b result abserr defabs resabs)
86
 
          (declare (ignore var-0 var-1 var-2))
87
 
          (setf result var-3)
88
 
          (setf abserr var-4)
89
 
          (setf defabs var-5)
90
 
          (setf resabs var-6)))
91
 
    (if (= keyf 6)
92
 
        (multiple-value-bind
93
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
94
 
            (dqk61 f a b result abserr defabs resabs)
95
 
          (declare (ignore var-0 var-1 var-2))
96
 
          (setf result var-3)
97
 
          (setf abserr var-4)
98
 
          (setf defabs var-5)
99
 
          (setf resabs var-6)))
100
 
    (setf last$ 1)
101
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (1) ((1 *))) result)
102
 
    (f2cl-lib:fset (f2cl-lib:fref elist (1) ((1 *))) abserr)
103
 
    (f2cl-lib:fset (f2cl-lib:fref iord (1) ((1 *))) 1)
104
 
    (setf errbnd (max epsabs (* epsrel (abs result))))
105
 
    (if (and (<= abserr (* 50.0 epmach defabs)) (> abserr errbnd))
106
 
        (setf ier 2))
107
 
    (if (= limit 1) (setf ier 1))
108
 
    (if
109
 
     (or (/= ier 0) (and (<= abserr errbnd) (/= abserr resabs)) (= abserr 0.0))
110
 
     (go label60))
111
 
    (setf errmax abserr)
112
 
    (setf maxerr 1)
113
 
    (setf area result)
114
 
    (setf errsum abserr)
115
 
    (setf nrmax 1)
116
 
    (setf iroff1 0)
117
 
    (setf iroff2 0)
118
 
    (f2cl-lib:fdo (last$ 2 (f2cl-lib:int-add last$ 1))
119
 
                  ((> last$ limit) nil)
120
 
      (tagbody
121
 
        (setf a1 (f2cl-lib:fref alist (maxerr) ((1 *))))
122
 
        (setf b1
123
 
                (* 0.5
124
 
                   (+ (f2cl-lib:fref alist (maxerr) ((1 *)))
125
 
                      (f2cl-lib:fref blist (maxerr) ((1 *))))))
126
 
        (setf a2 b1)
127
 
        (setf b2 (f2cl-lib:fref blist (maxerr) ((1 *))))
128
 
        (if (= keyf 1)
129
 
            (multiple-value-bind
130
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
131
 
                (dqk15 f a1 b1 area1 error1 resabs defab1)
132
 
              (declare (ignore var-0 var-1 var-2))
133
 
              (setf area1 var-3)
134
 
              (setf error1 var-4)
135
 
              (setf resabs var-5)
136
 
              (setf defab1 var-6)))
137
 
        (if (= keyf 2)
138
 
            (multiple-value-bind
139
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
140
 
                (dqk21 f a1 b1 area1 error1 resabs defab1)
141
 
              (declare (ignore var-0 var-1 var-2))
142
 
              (setf area1 var-3)
143
 
              (setf error1 var-4)
144
 
              (setf resabs var-5)
145
 
              (setf defab1 var-6)))
146
 
        (if (= keyf 3)
147
 
            (multiple-value-bind
148
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
149
 
                (dqk31 f a1 b1 area1 error1 resabs defab1)
150
 
              (declare (ignore var-0 var-1 var-2))
151
 
              (setf area1 var-3)
152
 
              (setf error1 var-4)
153
 
              (setf resabs var-5)
154
 
              (setf defab1 var-6)))
155
 
        (if (= keyf 4)
156
 
            (multiple-value-bind
157
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
158
 
                (dqk41 f a1 b1 area1 error1 resabs defab1)
159
 
              (declare (ignore var-0 var-1 var-2))
160
 
              (setf area1 var-3)
161
 
              (setf error1 var-4)
162
 
              (setf resabs var-5)
163
 
              (setf defab1 var-6)))
164
 
        (if (= keyf 5)
165
 
            (multiple-value-bind
166
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
167
 
                (dqk51 f a1 b1 area1 error1 resabs defab1)
168
 
              (declare (ignore var-0 var-1 var-2))
169
 
              (setf area1 var-3)
170
 
              (setf error1 var-4)
171
 
              (setf resabs var-5)
172
 
              (setf defab1 var-6)))
173
 
        (if (= keyf 6)
174
 
            (multiple-value-bind
175
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
176
 
                (dqk61 f a1 b1 area1 error1 resabs defab1)
177
 
              (declare (ignore var-0 var-1 var-2))
178
 
              (setf area1 var-3)
179
 
              (setf error1 var-4)
180
 
              (setf resabs var-5)
181
 
              (setf defab1 var-6)))
182
 
        (if (= keyf 1)
183
 
            (multiple-value-bind
184
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
185
 
                (dqk15 f a2 b2 area2 error2 resabs defab2)
186
 
              (declare (ignore var-0 var-1 var-2))
187
 
              (setf area2 var-3)
188
 
              (setf error2 var-4)
189
 
              (setf resabs var-5)
190
 
              (setf defab2 var-6)))
191
 
        (if (= keyf 2)
192
 
            (multiple-value-bind
193
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
194
 
                (dqk21 f a2 b2 area2 error2 resabs defab2)
195
 
              (declare (ignore var-0 var-1 var-2))
196
 
              (setf area2 var-3)
197
 
              (setf error2 var-4)
198
 
              (setf resabs var-5)
199
 
              (setf defab2 var-6)))
200
 
        (if (= keyf 3)
201
 
            (multiple-value-bind
202
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
203
 
                (dqk31 f a2 b2 area2 error2 resabs defab2)
204
 
              (declare (ignore var-0 var-1 var-2))
205
 
              (setf area2 var-3)
206
 
              (setf error2 var-4)
207
 
              (setf resabs var-5)
208
 
              (setf defab2 var-6)))
209
 
        (if (= keyf 4)
210
 
            (multiple-value-bind
211
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
212
 
                (dqk41 f a2 b2 area2 error2 resabs defab2)
213
 
              (declare (ignore var-0 var-1 var-2))
214
 
              (setf area2 var-3)
215
 
              (setf error2 var-4)
216
 
              (setf resabs var-5)
217
 
              (setf defab2 var-6)))
218
 
        (if (= keyf 5)
219
 
            (multiple-value-bind
220
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
221
 
                (dqk51 f a2 b2 area2 error2 resabs defab2)
222
 
              (declare (ignore var-0 var-1 var-2))
223
 
              (setf area2 var-3)
224
 
              (setf error2 var-4)
225
 
              (setf resabs var-5)
226
 
              (setf defab2 var-6)))
227
 
        (if (= keyf 6)
228
 
            (multiple-value-bind
229
 
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
230
 
                (dqk61 f a2 b2 area2 error2 resabs defab2)
231
 
              (declare (ignore var-0 var-1 var-2))
232
 
              (setf area2 var-3)
233
 
              (setf error2 var-4)
234
 
              (setf resabs var-5)
235
 
              (setf defab2 var-6)))
236
 
        (setf neval (f2cl-lib:int-add neval 1))
237
 
        (setf area12 (+ area1 area2))
238
 
        (setf erro12 (+ error1 error2))
239
 
        (setf errsum (- (+ errsum erro12) errmax))
240
 
        (setf area (- (+ area area12) (f2cl-lib:fref rlist (maxerr) ((1 *)))))
241
 
        (if (or (= defab1 error1) (= defab2 error2)) (go label5))
242
 
        (if
243
 
         (and
244
 
          (<= (abs (- (f2cl-lib:fref rlist (maxerr) ((1 *))) area12))
245
 
              (* 1.0e-5 (abs area12)))
246
 
          (>= erro12 (* 0.99 errmax)))
247
 
         (setf iroff1 (f2cl-lib:int-add iroff1 1)))
248
 
        (if (and (> last$ 10) (> erro12 errmax))
249
 
            (setf iroff2 (f2cl-lib:int-add iroff2 1)))
250
 
       label5
251
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (maxerr) ((1 *))) area1)
252
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (last$) ((1 *))) area2)
253
 
        (setf errbnd (max epsabs (* epsrel (abs area))))
254
 
        (if (<= errsum errbnd) (go label8))
255
 
        (if (or (>= iroff1 6) (>= iroff2 20)) (setf ier 2))
256
 
        (if (= last$ limit) (setf ier 1))
257
 
        (if
258
 
         (<= (max (abs a1) (abs b2))
259
 
             (* (+ 1.0 (* 100.0 epmach)) (+ (abs a2) (* 1000.0 uflow))))
260
 
         (setf ier 3))
261
 
       label8
262
 
        (if (> error2 error1) (go label10))
263
 
        (f2cl-lib:fset (f2cl-lib:fref alist (last$) ((1 *))) a2)
264
 
        (f2cl-lib:fset (f2cl-lib:fref blist (maxerr) ((1 *))) b1)
265
 
        (f2cl-lib:fset (f2cl-lib:fref blist (last$) ((1 *))) b2)
266
 
        (f2cl-lib:fset (f2cl-lib:fref elist (maxerr) ((1 *))) error1)
267
 
        (f2cl-lib:fset (f2cl-lib:fref elist (last$) ((1 *))) error2)
268
 
        (go label20)
269
 
       label10
270
 
        (f2cl-lib:fset (f2cl-lib:fref alist (maxerr) ((1 *))) a2)
271
 
        (f2cl-lib:fset (f2cl-lib:fref alist (last$) ((1 *))) a1)
272
 
        (f2cl-lib:fset (f2cl-lib:fref blist (last$) ((1 *))) b1)
273
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (maxerr) ((1 *))) area2)
274
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (last$) ((1 *))) area1)
275
 
        (f2cl-lib:fset (f2cl-lib:fref elist (maxerr) ((1 *))) error2)
276
 
        (f2cl-lib:fset (f2cl-lib:fref elist (last$) ((1 *))) error1)
277
 
       label20
278
 
        (multiple-value-bind
279
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
280
 
            (dqpsrt limit last$ maxerr errmax elist iord nrmax)
281
 
          (declare (ignore var-0 var-1 var-4 var-5))
282
 
          (setf maxerr var-2)
283
 
          (setf errmax var-3)
284
 
          (setf nrmax var-6))
285
 
        (if (or (/= ier 0) (<= errsum errbnd)) (go label40))
286
 
       label30))
287
 
   label40
288
 
    (setf result 0.0)
289
 
    (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
290
 
                  ((> k last$) nil)
291
 
      (tagbody
292
 
        (setf result (+ result (f2cl-lib:fref rlist (k) ((1 *)))))
293
 
       label50))
294
 
    (setf abserr errsum)
295
 
   label60
296
 
    (if (/= keyf 1)
297
 
        (setf neval
298
 
                (f2cl-lib:int-mul
299
 
                 (f2cl-lib:int-add (f2cl-lib:int-mul 10 keyf) 1)
300
 
                 (f2cl-lib:int-add (f2cl-lib:int-mul 2 neval) 1))))
301
 
    (if (= keyf 1)
302
 
        (setf neval (f2cl-lib:int-add (f2cl-lib:int-mul 30 neval) 15)))
303
 
   label999
304
 
    (go end_label)
305
 
   end_label
306
 
    (return
307
 
     (values nil
308
 
             nil
309
 
             nil
310
 
             nil
311
 
             nil
312
 
             nil
313
 
             nil
314
 
             result
315
 
             abserr
316
 
             neval
317
 
             ier
318
 
             nil
319
 
             nil
320
 
             nil
321
 
             nil
322
 
             nil
323
 
             last$))))
 
16
           (type (array double-float (*)) elist rlist blist alist)
 
17
           (type f2cl-lib:integer4 last$ ier neval limit key)
 
18
           (type double-float abserr result epsrel epsabs b a))
 
19
  (f2cl-lib:with-multi-array-data
 
20
      ((alist double-float alist-%data% alist-%offset%)
 
21
       (blist double-float blist-%data% blist-%offset%)
 
22
       (rlist double-float rlist-%data% rlist-%offset%)
 
23
       (elist double-float elist-%data% elist-%offset%)
 
24
       (iord f2cl-lib:integer4 iord-%data% iord-%offset%))
 
25
    (prog ((iroff1 0) (iroff2 0) (k 0) (keyf 0) (maxerr 0) (nrmax 0) (area 0.0)
 
26
           (area1 0.0) (area12 0.0) (area2 0.0) (a1 0.0) (a2 0.0) (b1 0.0)
 
27
           (b2 0.0) (defabs 0.0) (defab1 0.0) (defab2 0.0) (epmach 0.0)
 
28
           (errbnd 0.0) (errmax 0.0) (error1 0.0) (error2 0.0) (erro12 0.0)
 
29
           (errsum 0.0) (resabs 0.0) (uflow 0.0) (abs$ 0.0f0))
 
30
      (declare (type single-float abs$)
 
31
               (type double-float uflow resabs errsum erro12 error2 error1
 
32
                                  errmax errbnd epmach defab2 defab1 defabs b2
 
33
                                  b1 a2 a1 area2 area12 area1 area)
 
34
               (type f2cl-lib:integer4 nrmax maxerr keyf k iroff2 iroff1))
 
35
      (setf epmach (f2cl-lib:d1mach 4))
 
36
      (setf uflow (f2cl-lib:d1mach 1))
 
37
      (setf ier 0)
 
38
      (setf neval 0)
 
39
      (setf last$ 0)
 
40
      (setf result 0.0)
 
41
      (setf abserr 0.0)
 
42
      (f2cl-lib:fset (f2cl-lib:fref alist-%data% (1) ((1 *)) alist-%offset%) a)
 
43
      (f2cl-lib:fset (f2cl-lib:fref blist-%data% (1) ((1 *)) blist-%offset%) b)
 
44
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%)
 
45
                     0.0)
 
46
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%)
 
47
                     0.0)
 
48
      (f2cl-lib:fset (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 0)
 
49
      (if (and (<= epsabs 0.0) (< epsrel (max (* 50.0 epmach) 5.e-29)))
 
50
          (setf ier 6))
 
51
      (if (= ier 6) (go label999))
 
52
      (setf keyf key)
 
53
      (if (<= key 0) (setf keyf 1))
 
54
      (if (>= key 7) (setf keyf 6))
 
55
      (setf neval 0)
 
56
      (if (= keyf 1)
 
57
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
58
              (dqk15 f a b result abserr defabs resabs)
 
59
            (declare (ignore var-0 var-1 var-2))
 
60
            (setf result var-3)
 
61
            (setf abserr var-4)
 
62
            (setf defabs var-5)
 
63
            (setf resabs var-6)))
 
64
      (if (= keyf 2)
 
65
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
66
              (dqk21 f a b result abserr defabs resabs)
 
67
            (declare (ignore var-0 var-1 var-2))
 
68
            (setf result var-3)
 
69
            (setf abserr var-4)
 
70
            (setf defabs var-5)
 
71
            (setf resabs var-6)))
 
72
      (if (= keyf 3)
 
73
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
74
              (dqk31 f a b result abserr defabs resabs)
 
75
            (declare (ignore var-0 var-1 var-2))
 
76
            (setf result var-3)
 
77
            (setf abserr var-4)
 
78
            (setf defabs var-5)
 
79
            (setf resabs var-6)))
 
80
      (if (= keyf 4)
 
81
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
82
              (dqk41 f a b result abserr defabs resabs)
 
83
            (declare (ignore var-0 var-1 var-2))
 
84
            (setf result var-3)
 
85
            (setf abserr var-4)
 
86
            (setf defabs var-5)
 
87
            (setf resabs var-6)))
 
88
      (if (= keyf 5)
 
89
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
90
              (dqk51 f a b result abserr defabs resabs)
 
91
            (declare (ignore var-0 var-1 var-2))
 
92
            (setf result var-3)
 
93
            (setf abserr var-4)
 
94
            (setf defabs var-5)
 
95
            (setf resabs var-6)))
 
96
      (if (= keyf 6)
 
97
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
98
              (dqk61 f a b result abserr defabs resabs)
 
99
            (declare (ignore var-0 var-1 var-2))
 
100
            (setf result var-3)
 
101
            (setf abserr var-4)
 
102
            (setf defabs var-5)
 
103
            (setf resabs var-6)))
 
104
      (setf last$ 1)
 
105
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%)
 
106
                     result)
 
107
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%)
 
108
                     abserr)
 
109
      (f2cl-lib:fset (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 1)
 
110
      (setf errbnd (max epsabs (* epsrel (abs result))))
 
111
      (if (and (<= abserr (* 50.0 epmach defabs)) (> abserr errbnd))
 
112
          (setf ier 2))
 
113
      (if (= limit 1) (setf ier 1))
 
114
      (if
 
115
       (or (/= ier 0)
 
116
           (and (<= abserr errbnd) (/= abserr resabs))
 
117
           (= abserr 0.0))
 
118
       (go label60))
 
119
      (setf errmax abserr)
 
120
      (setf maxerr 1)
 
121
      (setf area result)
 
122
      (setf errsum abserr)
 
123
      (setf nrmax 1)
 
124
      (setf iroff1 0)
 
125
      (setf iroff2 0)
 
126
      (f2cl-lib:fdo (last$ 2 (f2cl-lib:int-add last$ 1))
 
127
                    ((> last$ limit) nil)
 
128
        (tagbody
 
129
          (setf a1
 
130
                  (f2cl-lib:fref alist-%data% (maxerr) ((1 *)) alist-%offset%))
 
131
          (setf b1
 
132
                  (* 0.5
 
133
                     (+
 
134
                      (f2cl-lib:fref alist-%data%
 
135
                                     (maxerr)
 
136
                                     ((1 *))
 
137
                                     alist-%offset%)
 
138
                      (f2cl-lib:fref blist-%data%
 
139
                                     (maxerr)
 
140
                                     ((1 *))
 
141
                                     blist-%offset%))))
 
142
          (setf a2 b1)
 
143
          (setf b2
 
144
                  (f2cl-lib:fref blist-%data% (maxerr) ((1 *)) blist-%offset%))
 
145
          (if (= keyf 1)
 
146
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
147
                  (dqk15 f a1 b1 area1 error1 resabs defab1)
 
148
                (declare (ignore var-0 var-1 var-2))
 
149
                (setf area1 var-3)
 
150
                (setf error1 var-4)
 
151
                (setf resabs var-5)
 
152
                (setf defab1 var-6)))
 
153
          (if (= keyf 2)
 
154
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
155
                  (dqk21 f a1 b1 area1 error1 resabs defab1)
 
156
                (declare (ignore var-0 var-1 var-2))
 
157
                (setf area1 var-3)
 
158
                (setf error1 var-4)
 
159
                (setf resabs var-5)
 
160
                (setf defab1 var-6)))
 
161
          (if (= keyf 3)
 
162
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
163
                  (dqk31 f a1 b1 area1 error1 resabs defab1)
 
164
                (declare (ignore var-0 var-1 var-2))
 
165
                (setf area1 var-3)
 
166
                (setf error1 var-4)
 
167
                (setf resabs var-5)
 
168
                (setf defab1 var-6)))
 
169
          (if (= keyf 4)
 
170
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
171
                  (dqk41 f a1 b1 area1 error1 resabs defab1)
 
172
                (declare (ignore var-0 var-1 var-2))
 
173
                (setf area1 var-3)
 
174
                (setf error1 var-4)
 
175
                (setf resabs var-5)
 
176
                (setf defab1 var-6)))
 
177
          (if (= keyf 5)
 
178
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
179
                  (dqk51 f a1 b1 area1 error1 resabs defab1)
 
180
                (declare (ignore var-0 var-1 var-2))
 
181
                (setf area1 var-3)
 
182
                (setf error1 var-4)
 
183
                (setf resabs var-5)
 
184
                (setf defab1 var-6)))
 
185
          (if (= keyf 6)
 
186
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
187
                  (dqk61 f a1 b1 area1 error1 resabs defab1)
 
188
                (declare (ignore var-0 var-1 var-2))
 
189
                (setf area1 var-3)
 
190
                (setf error1 var-4)
 
191
                (setf resabs var-5)
 
192
                (setf defab1 var-6)))
 
193
          (if (= keyf 1)
 
194
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
195
                  (dqk15 f a2 b2 area2 error2 resabs defab2)
 
196
                (declare (ignore var-0 var-1 var-2))
 
197
                (setf area2 var-3)
 
198
                (setf error2 var-4)
 
199
                (setf resabs var-5)
 
200
                (setf defab2 var-6)))
 
201
          (if (= keyf 2)
 
202
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
203
                  (dqk21 f a2 b2 area2 error2 resabs defab2)
 
204
                (declare (ignore var-0 var-1 var-2))
 
205
                (setf area2 var-3)
 
206
                (setf error2 var-4)
 
207
                (setf resabs var-5)
 
208
                (setf defab2 var-6)))
 
209
          (if (= keyf 3)
 
210
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
211
                  (dqk31 f a2 b2 area2 error2 resabs defab2)
 
212
                (declare (ignore var-0 var-1 var-2))
 
213
                (setf area2 var-3)
 
214
                (setf error2 var-4)
 
215
                (setf resabs var-5)
 
216
                (setf defab2 var-6)))
 
217
          (if (= keyf 4)
 
218
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
219
                  (dqk41 f a2 b2 area2 error2 resabs defab2)
 
220
                (declare (ignore var-0 var-1 var-2))
 
221
                (setf area2 var-3)
 
222
                (setf error2 var-4)
 
223
                (setf resabs var-5)
 
224
                (setf defab2 var-6)))
 
225
          (if (= keyf 5)
 
226
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
227
                  (dqk51 f a2 b2 area2 error2 resabs defab2)
 
228
                (declare (ignore var-0 var-1 var-2))
 
229
                (setf area2 var-3)
 
230
                (setf error2 var-4)
 
231
                (setf resabs var-5)
 
232
                (setf defab2 var-6)))
 
233
          (if (= keyf 6)
 
234
              (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
235
                  (dqk61 f a2 b2 area2 error2 resabs defab2)
 
236
                (declare (ignore var-0 var-1 var-2))
 
237
                (setf area2 var-3)
 
238
                (setf error2 var-4)
 
239
                (setf resabs var-5)
 
240
                (setf defab2 var-6)))
 
241
          (setf neval (f2cl-lib:int-add neval 1))
 
242
          (setf area12 (+ area1 area2))
 
243
          (setf erro12 (+ error1 error2))
 
244
          (setf errsum (- (+ errsum erro12) errmax))
 
245
          (setf area
 
246
                  (- (+ area area12)
 
247
                     (f2cl-lib:fref rlist-%data%
 
248
                                    (maxerr)
 
249
                                    ((1 *))
 
250
                                    rlist-%offset%)))
 
251
          (if (or (= defab1 error1) (= defab2 error2)) (go label5))
 
252
          (if
 
253
           (and
 
254
            (<=
 
255
             (abs
 
256
              (- (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 
257
                 area12))
 
258
             (* 1.e-5 (abs area12)))
 
259
            (>= erro12 (* 0.99 errmax)))
 
260
           (setf iroff1 (f2cl-lib:int-add iroff1 1)))
 
261
          (if (and (> last$ 10) (> erro12 errmax))
 
262
              (setf iroff2 (f2cl-lib:int-add iroff2 1)))
 
263
         label5
 
264
          (f2cl-lib:fset
 
265
           (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 
266
           area1)
 
267
          (f2cl-lib:fset
 
268
           (f2cl-lib:fref rlist-%data% (last$) ((1 *)) rlist-%offset%)
 
269
           area2)
 
270
          (setf errbnd (max epsabs (* epsrel (abs area))))
 
271
          (if (<= errsum errbnd) (go label8))
 
272
          (if (or (>= iroff1 6) (>= iroff2 20)) (setf ier 2))
 
273
          (if (= last$ limit) (setf ier 1))
 
274
          (if
 
275
           (<= (max (abs a1) (abs b2))
 
276
               (* (+ 1.0 (* 100.0 epmach)) (+ (abs a2) (* 1000.0 uflow))))
 
277
           (setf ier 3))
 
278
         label8
 
279
          (if (> error2 error1) (go label10))
 
280
          (f2cl-lib:fset
 
281
           (f2cl-lib:fref alist-%data% (last$) ((1 *)) alist-%offset%)
 
282
           a2)
 
283
          (f2cl-lib:fset
 
284
           (f2cl-lib:fref blist-%data% (maxerr) ((1 *)) blist-%offset%)
 
285
           b1)
 
286
          (f2cl-lib:fset
 
287
           (f2cl-lib:fref blist-%data% (last$) ((1 *)) blist-%offset%)
 
288
           b2)
 
289
          (f2cl-lib:fset
 
290
           (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%)
 
291
           error1)
 
292
          (f2cl-lib:fset
 
293
           (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%)
 
294
           error2)
 
295
          (go label20)
 
296
         label10
 
297
          (f2cl-lib:fset
 
298
           (f2cl-lib:fref alist-%data% (maxerr) ((1 *)) alist-%offset%)
 
299
           a2)
 
300
          (f2cl-lib:fset
 
301
           (f2cl-lib:fref alist-%data% (last$) ((1 *)) alist-%offset%)
 
302
           a1)
 
303
          (f2cl-lib:fset
 
304
           (f2cl-lib:fref blist-%data% (last$) ((1 *)) blist-%offset%)
 
305
           b1)
 
306
          (f2cl-lib:fset
 
307
           (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 
308
           area2)
 
309
          (f2cl-lib:fset
 
310
           (f2cl-lib:fref rlist-%data% (last$) ((1 *)) rlist-%offset%)
 
311
           area1)
 
312
          (f2cl-lib:fset
 
313
           (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%)
 
314
           error2)
 
315
          (f2cl-lib:fset
 
316
           (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%)
 
317
           error1)
 
318
         label20
 
319
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
320
              (dqpsrt limit last$ maxerr errmax elist iord nrmax)
 
321
            (declare (ignore var-0 var-1 var-4 var-5))
 
322
            (setf maxerr var-2)
 
323
            (setf errmax var-3)
 
324
            (setf nrmax var-6))
 
325
          (if (or (/= ier 0) (<= errsum errbnd)) (go label40))
 
326
         label30))
 
327
     label40
 
328
      (setf result 0.0)
 
329
      (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 
330
                    ((> k last$) nil)
 
331
        (tagbody
 
332
          (setf result
 
333
                  (+ result
 
334
                     (f2cl-lib:fref rlist-%data% (k) ((1 *)) rlist-%offset%)))
 
335
         label50))
 
336
      (setf abserr errsum)
 
337
     label60
 
338
      (if (/= keyf 1)
 
339
          (setf neval
 
340
                  (f2cl-lib:int-mul
 
341
                   (f2cl-lib:int-add (f2cl-lib:int-mul 10 keyf) 1)
 
342
                   (f2cl-lib:int-add (f2cl-lib:int-mul 2 neval) 1))))
 
343
      (if (= keyf 1)
 
344
          (setf neval (f2cl-lib:int-add (f2cl-lib:int-mul 30 neval) 15)))
 
345
     label999
 
346
      (go end_label)
 
347
     end_label
 
348
      (return
 
349
       (values nil
 
350
               nil
 
351
               nil
 
352
               nil
 
353
               nil
 
354
               nil
 
355
               nil
 
356
               result
 
357
               abserr
 
358
               neval
 
359
               ier
 
360
               nil
 
361
               nil
 
362
               nil
 
363
               nil
 
364
               nil
 
365
               last$)))))
324
366