← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/numerical/slatec/dqawse.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/dqawse.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 dqawse
12
13
       (f a b alfa beta integr epsabs epsrel limit result abserr neval ier
13
14
        alist blist rlist 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 integr)
17
 
   (type double-float abserr result epsrel epsabs beta alfa b a))
18
 
  (prog ((ri (make-array 25 :element-type 'double-float))
19
 
         (rj (make-array 25 :element-type 'double-float))
20
 
         (rh (make-array 25 :element-type 'double-float))
21
 
         (rg (make-array 25 :element-type 'double-float)) (iroff1 0) (iroff2 0)
22
 
         (k 0) (maxerr 0) (nev 0) (nrmax 0) (area 0.0) (area1 0.0) (area12 0.0)
23
 
         (area2 0.0) (a1 0.0) (a2 0.0) (b1 0.0) (b2 0.0) (centre 0.0)
24
 
         (epmach 0.0) (errbnd 0.0) (errmax 0.0) (error1 0.0) (erro12 0.0)
25
 
         (error2 0.0) (errsum 0.0) (resas1 0.0) (resas2 0.0) (uflow 0.0)
26
 
         (abs$ 0.0f0))
27
 
    (declare (type single-float abs$)
28
 
     (type (simple-array double-float (25)) rj ri rh rg)
29
 
     (type double-float uflow resas2 resas1 errsum error2 erro12 error1 errmax
30
 
      errbnd epmach centre b2 b1 a2 a1 area2 area12 area1 area)
31
 
     (type f2cl-lib:integer4 nrmax nev maxerr k iroff2 iroff1))
32
 
    (setf epmach (f2cl-lib:d1mach 4))
33
 
    (setf uflow (f2cl-lib:d1mach 1))
34
 
    (setf ier 6)
35
 
    (setf neval 0)
36
 
    (setf last$ 0)
37
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (1) ((1 *))) 0.0)
38
 
    (f2cl-lib:fset (f2cl-lib:fref elist (1) ((1 *))) 0.0)
39
 
    (f2cl-lib:fset (f2cl-lib:fref iord (1) ((1 *))) 0)
40
 
    (setf result 0.0)
41
 
    (setf abserr 0.0)
42
 
    (if
43
 
     (or (<= b a)
44
 
         (and (= epsabs 0.0) (< epsrel (max (* 50.0 epmach) 5.0e-29)))
45
 
         (<= alfa -1.0)
46
 
         (<= beta -1.0)
47
 
         (< integr 1)
48
 
         (> integr 4)
49
 
         (< limit 2))
50
 
     (go label999))
51
 
    (setf ier 0)
52
 
    (dqmomo alfa beta ri rj rg rh integr)
53
 
    (setf centre (* 0.5 (+ b a)))
54
 
    (multiple-value-bind
55
 
        (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
56
 
         var-11 var-12 var-13 var-14 var-15)
57
 
        (dqc25s f a b a centre alfa beta ri rj rg rh area1 error1 resas1 integr
58
 
         nev)
59
 
      (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
60
 
      (setf a var-1)
61
 
      (setf b var-2)
62
 
      (setf alfa var-5)
63
 
      (setf beta var-6)
64
 
      (setf area1 var-11)
65
 
      (setf error1 var-12)
66
 
      (setf resas1 var-13)
67
 
      (setf integr var-14)
68
 
      (setf nev var-15))
69
 
    (setf neval nev)
70
 
    (multiple-value-bind
71
 
        (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
72
 
         var-11 var-12 var-13 var-14 var-15)
73
 
        (dqc25s f a b centre b alfa beta ri rj rg rh area2 error2 resas2 integr
74
 
         nev)
75
 
      (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
76
 
      (setf a var-1)
77
 
      (setf b var-2)
78
 
      (setf alfa var-5)
79
 
      (setf beta var-6)
80
 
      (setf area2 var-11)
81
 
      (setf error2 var-12)
82
 
      (setf resas2 var-13)
83
 
      (setf integr var-14)
84
 
      (setf nev var-15))
85
 
    (setf last$ 2)
86
 
    (setf neval (f2cl-lib:int-add neval nev))
87
 
    (setf result (+ area1 area2))
88
 
    (setf abserr (+ error1 error2))
89
 
    (setf errbnd (max epsabs (* epsrel (abs result))))
90
 
    (if (> error2 error1) (go label10))
91
 
    (f2cl-lib:fset (f2cl-lib:fref alist (1) ((1 *))) a)
92
 
    (f2cl-lib:fset (f2cl-lib:fref alist (2) ((1 *))) centre)
93
 
    (f2cl-lib:fset (f2cl-lib:fref blist (1) ((1 *))) centre)
94
 
    (f2cl-lib:fset (f2cl-lib:fref blist (2) ((1 *))) b)
95
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (1) ((1 *))) area1)
96
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (2) ((1 *))) area2)
97
 
    (f2cl-lib:fset (f2cl-lib:fref elist (1) ((1 *))) error1)
98
 
    (f2cl-lib:fset (f2cl-lib:fref elist (2) ((1 *))) error2)
99
 
    (go label20)
100
 
   label10
101
 
    (f2cl-lib:fset (f2cl-lib:fref alist (1) ((1 *))) centre)
102
 
    (f2cl-lib:fset (f2cl-lib:fref alist (2) ((1 *))) a)
103
 
    (f2cl-lib:fset (f2cl-lib:fref blist (1) ((1 *))) b)
104
 
    (f2cl-lib:fset (f2cl-lib:fref blist (2) ((1 *))) centre)
105
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (1) ((1 *))) area2)
106
 
    (f2cl-lib:fset (f2cl-lib:fref rlist (2) ((1 *))) area1)
107
 
    (f2cl-lib:fset (f2cl-lib:fref elist (1) ((1 *))) error2)
108
 
    (f2cl-lib:fset (f2cl-lib:fref elist (2) ((1 *))) error1)
109
 
   label20
110
 
    (f2cl-lib:fset (f2cl-lib:fref iord (1) ((1 *))) 1)
111
 
    (f2cl-lib:fset (f2cl-lib:fref iord (2) ((1 *))) 2)
112
 
    (if (= limit 2) (setf ier 1))
113
 
    (if (or (<= abserr errbnd) (= ier 1)) (go label999))
114
 
    (setf errmax (f2cl-lib:fref elist (1) ((1 *))))
115
 
    (setf maxerr 1)
116
 
    (setf nrmax 1)
117
 
    (setf area result)
118
 
    (setf errsum abserr)
119
 
    (setf iroff1 0)
120
 
    (setf iroff2 0)
121
 
    (f2cl-lib:fdo (last$ 3 (f2cl-lib:int-add last$ 1))
122
 
                  ((> last$ limit) nil)
123
 
      (tagbody
124
 
        (setf a1 (f2cl-lib:fref alist (maxerr) ((1 *))))
125
 
        (setf b1
126
 
                (* 0.5
127
 
                   (+ (f2cl-lib:fref alist (maxerr) ((1 *)))
128
 
                      (f2cl-lib:fref blist (maxerr) ((1 *))))))
129
 
        (setf a2 b1)
130
 
        (setf b2 (f2cl-lib:fref blist (maxerr) ((1 *))))
131
 
        (multiple-value-bind
132
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
133
 
             var-11 var-12 var-13 var-14 var-15)
134
 
            (dqc25s f a b a1 b1 alfa beta ri rj rg rh area1 error1 resas1
135
 
             integr nev)
136
 
          (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
137
 
          (setf a var-1)
138
 
          (setf b var-2)
139
 
          (setf alfa var-5)
140
 
          (setf beta var-6)
141
 
          (setf area1 var-11)
142
 
          (setf error1 var-12)
143
 
          (setf resas1 var-13)
144
 
          (setf integr var-14)
145
 
          (setf nev var-15))
146
 
        (setf neval (f2cl-lib:int-add neval nev))
147
 
        (multiple-value-bind
148
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
149
 
             var-11 var-12 var-13 var-14 var-15)
150
 
            (dqc25s f a b a2 b2 alfa beta ri rj rg rh area2 error2 resas2
151
 
             integr nev)
152
 
          (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
153
 
          (setf a var-1)
154
 
          (setf b var-2)
155
 
          (setf alfa var-5)
156
 
          (setf beta var-6)
157
 
          (setf area2 var-11)
158
 
          (setf error2 var-12)
159
 
          (setf resas2 var-13)
160
 
          (setf integr var-14)
161
 
          (setf nev var-15))
162
 
        (setf neval (f2cl-lib:int-add neval nev))
163
 
        (setf area12 (+ area1 area2))
164
 
        (setf erro12 (+ error1 error2))
165
 
        (setf errsum (- (+ errsum erro12) errmax))
166
 
        (setf area (- (+ area area12) (f2cl-lib:fref rlist (maxerr) ((1 *)))))
167
 
        (if (or (= a a1) (= b b2)) (go label30))
168
 
        (if (or (= resas1 error1) (= resas2 error2)) (go label30))
169
 
        (if
170
 
         (and
171
 
          (< (abs (- (f2cl-lib:fref rlist (maxerr) ((1 *))) area12))
172
 
             (* 1.0e-5 (abs area12)))
173
 
          (>= erro12 (* 0.99 errmax)))
174
 
         (setf iroff1 (f2cl-lib:int-add iroff1 1)))
175
 
        (if (and (> last$ 10) (> erro12 errmax))
176
 
            (setf iroff2 (f2cl-lib:int-add iroff2 1)))
177
 
       label30
178
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (maxerr) ((1 *))) area1)
179
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (last$) ((1 *))) area2)
180
 
        (setf errbnd (max epsabs (* epsrel (abs area))))
181
 
        (if (<= errsum errbnd) (go label35))
182
 
        (if (= last$ limit) (setf ier 1))
183
 
        (if (or (>= iroff1 6) (>= iroff2 20)) (setf ier 2))
184
 
        (if
185
 
         (<= (max (abs a1) (abs b2))
186
 
             (* (+ 1.0 (* 100.0 epmach)) (+ (abs a2) (* 1000.0 uflow))))
187
 
         (setf ier 3))
188
 
       label35
189
 
        (if (> error2 error1) (go label40))
190
 
        (f2cl-lib:fset (f2cl-lib:fref alist (last$) ((1 *))) a2)
191
 
        (f2cl-lib:fset (f2cl-lib:fref blist (maxerr) ((1 *))) b1)
192
 
        (f2cl-lib:fset (f2cl-lib:fref blist (last$) ((1 *))) b2)
193
 
        (f2cl-lib:fset (f2cl-lib:fref elist (maxerr) ((1 *))) error1)
194
 
        (f2cl-lib:fset (f2cl-lib:fref elist (last$) ((1 *))) error2)
195
 
        (go label50)
196
 
       label40
197
 
        (f2cl-lib:fset (f2cl-lib:fref alist (maxerr) ((1 *))) a2)
198
 
        (f2cl-lib:fset (f2cl-lib:fref alist (last$) ((1 *))) a1)
199
 
        (f2cl-lib:fset (f2cl-lib:fref blist (last$) ((1 *))) b1)
200
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (maxerr) ((1 *))) area2)
201
 
        (f2cl-lib:fset (f2cl-lib:fref rlist (last$) ((1 *))) area1)
202
 
        (f2cl-lib:fset (f2cl-lib:fref elist (maxerr) ((1 *))) error2)
203
 
        (f2cl-lib:fset (f2cl-lib:fref elist (last$) ((1 *))) error1)
204
 
       label50
205
 
        (multiple-value-bind
206
 
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
207
 
            (dqpsrt limit last$ maxerr errmax elist iord nrmax)
208
 
          (declare (ignore var-0 var-1 var-4 var-5))
209
 
          (setf maxerr var-2)
210
 
          (setf errmax var-3)
211
 
          (setf nrmax var-6))
212
 
        (if (or (/= ier 0) (<= errsum errbnd)) (go label70))
213
 
       label60))
214
 
   label70
215
 
    (setf result 0.0)
216
 
    (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
217
 
                  ((> k last$) nil)
218
 
      (tagbody
219
 
        (setf result (+ result (f2cl-lib:fref rlist (k) ((1 *)))))
220
 
       label80))
221
 
    (setf abserr errsum)
222
 
   label999
223
 
    (go end_label)
224
 
   end_label
225
 
    (return
226
 
     (values nil
227
 
             a
228
 
             b
229
 
             alfa
230
 
             beta
231
 
             integr
232
 
             nil
233
 
             nil
234
 
             nil
235
 
             result
236
 
             abserr
237
 
             neval
238
 
             ier
239
 
             nil
240
 
             nil
241
 
             nil
242
 
             nil
243
 
             nil
244
 
             last$))))
 
16
           (type (array double-float (*)) elist rlist blist alist)
 
17
           (type f2cl-lib:integer4 last$ ier neval limit integr)
 
18
           (type double-float abserr result epsrel epsabs beta alfa 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 ((ri (make-array 25 :element-type 'double-float))
 
26
           (rj (make-array 25 :element-type 'double-float))
 
27
           (rh (make-array 25 :element-type 'double-float))
 
28
           (rg (make-array 25 :element-type 'double-float)) (iroff1 0)
 
29
           (iroff2 0) (k 0) (maxerr 0) (nev 0) (nrmax 0) (area 0.0) (area1 0.0)
 
30
           (area12 0.0) (area2 0.0) (a1 0.0) (a2 0.0) (b1 0.0) (b2 0.0)
 
31
           (centre 0.0) (epmach 0.0) (errbnd 0.0) (errmax 0.0) (error1 0.0)
 
32
           (erro12 0.0) (error2 0.0) (errsum 0.0) (resas1 0.0) (resas2 0.0)
 
33
           (uflow 0.0) (abs$ 0.0f0))
 
34
      (declare (type single-float abs$)
 
35
               (type (array double-float (25)) rj ri rh rg)
 
36
               (type double-float uflow resas2 resas1 errsum error2 erro12
 
37
                                  error1 errmax errbnd epmach centre b2 b1 a2
 
38
                                  a1 area2 area12 area1 area)
 
39
               (type f2cl-lib:integer4 nrmax nev maxerr k iroff2 iroff1))
 
40
      (setf epmach (f2cl-lib:d1mach 4))
 
41
      (setf uflow (f2cl-lib:d1mach 1))
 
42
      (setf ier 6)
 
43
      (setf neval 0)
 
44
      (setf last$ 0)
 
45
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%)
 
46
                     0.0)
 
47
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%)
 
48
                     0.0)
 
49
      (f2cl-lib:fset (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 0)
 
50
      (setf result 0.0)
 
51
      (setf abserr 0.0)
 
52
      (if
 
53
       (or (<= b a)
 
54
           (and (= epsabs 0.0) (< epsrel (max (* 50.0 epmach) 5.e-29)))
 
55
           (<= alfa -1.0)
 
56
           (<= beta -1.0)
 
57
           (< integr 1)
 
58
           (> integr 4)
 
59
           (< limit 2))
 
60
       (go label999))
 
61
      (setf ier 0)
 
62
      (dqmomo alfa beta ri rj rg rh integr)
 
63
      (setf centre (* 0.5 (+ b a)))
 
64
      (multiple-value-bind
 
65
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 
66
             var-11 var-12 var-13 var-14 var-15)
 
67
          (dqc25s f a b a centre alfa beta ri rj rg rh area1 error1 resas1
 
68
           integr nev)
 
69
        (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
 
70
        (setf a var-1)
 
71
        (setf b var-2)
 
72
        (setf alfa var-5)
 
73
        (setf beta var-6)
 
74
        (setf area1 var-11)
 
75
        (setf error1 var-12)
 
76
        (setf resas1 var-13)
 
77
        (setf integr var-14)
 
78
        (setf nev var-15))
 
79
      (setf neval nev)
 
80
      (multiple-value-bind
 
81
            (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
 
82
             var-11 var-12 var-13 var-14 var-15)
 
83
          (dqc25s f a b centre b alfa beta ri rj rg rh area2 error2 resas2
 
84
           integr nev)
 
85
        (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
 
86
        (setf a var-1)
 
87
        (setf b var-2)
 
88
        (setf alfa var-5)
 
89
        (setf beta var-6)
 
90
        (setf area2 var-11)
 
91
        (setf error2 var-12)
 
92
        (setf resas2 var-13)
 
93
        (setf integr var-14)
 
94
        (setf nev var-15))
 
95
      (setf last$ 2)
 
96
      (setf neval (f2cl-lib:int-add neval nev))
 
97
      (setf result (+ area1 area2))
 
98
      (setf abserr (+ error1 error2))
 
99
      (setf errbnd (max epsabs (* epsrel (abs result))))
 
100
      (if (> error2 error1) (go label10))
 
101
      (f2cl-lib:fset (f2cl-lib:fref alist-%data% (1) ((1 *)) alist-%offset%) a)
 
102
      (f2cl-lib:fset (f2cl-lib:fref alist-%data% (2) ((1 *)) alist-%offset%)
 
103
                     centre)
 
104
      (f2cl-lib:fset (f2cl-lib:fref blist-%data% (1) ((1 *)) blist-%offset%)
 
105
                     centre)
 
106
      (f2cl-lib:fset (f2cl-lib:fref blist-%data% (2) ((1 *)) blist-%offset%) b)
 
107
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%)
 
108
                     area1)
 
109
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (2) ((1 *)) rlist-%offset%)
 
110
                     area2)
 
111
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%)
 
112
                     error1)
 
113
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (2) ((1 *)) elist-%offset%)
 
114
                     error2)
 
115
      (go label20)
 
116
     label10
 
117
      (f2cl-lib:fset (f2cl-lib:fref alist-%data% (1) ((1 *)) alist-%offset%)
 
118
                     centre)
 
119
      (f2cl-lib:fset (f2cl-lib:fref alist-%data% (2) ((1 *)) alist-%offset%) a)
 
120
      (f2cl-lib:fset (f2cl-lib:fref blist-%data% (1) ((1 *)) blist-%offset%) b)
 
121
      (f2cl-lib:fset (f2cl-lib:fref blist-%data% (2) ((1 *)) blist-%offset%)
 
122
                     centre)
 
123
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (1) ((1 *)) rlist-%offset%)
 
124
                     area2)
 
125
      (f2cl-lib:fset (f2cl-lib:fref rlist-%data% (2) ((1 *)) rlist-%offset%)
 
126
                     area1)
 
127
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%)
 
128
                     error2)
 
129
      (f2cl-lib:fset (f2cl-lib:fref elist-%data% (2) ((1 *)) elist-%offset%)
 
130
                     error1)
 
131
     label20
 
132
      (f2cl-lib:fset (f2cl-lib:fref iord-%data% (1) ((1 *)) iord-%offset%) 1)
 
133
      (f2cl-lib:fset (f2cl-lib:fref iord-%data% (2) ((1 *)) iord-%offset%) 2)
 
134
      (if (= limit 2) (setf ier 1))
 
135
      (if (or (<= abserr errbnd) (= ier 1)) (go label999))
 
136
      (setf errmax (f2cl-lib:fref elist-%data% (1) ((1 *)) elist-%offset%))
 
137
      (setf maxerr 1)
 
138
      (setf nrmax 1)
 
139
      (setf area result)
 
140
      (setf errsum abserr)
 
141
      (setf iroff1 0)
 
142
      (setf iroff2 0)
 
143
      (f2cl-lib:fdo (last$ 3 (f2cl-lib:int-add last$ 1))
 
144
                    ((> last$ limit) nil)
 
145
        (tagbody
 
146
          (setf a1
 
147
                  (f2cl-lib:fref alist-%data% (maxerr) ((1 *)) alist-%offset%))
 
148
          (setf b1
 
149
                  (* 0.5
 
150
                     (+
 
151
                      (f2cl-lib:fref alist-%data%
 
152
                                     (maxerr)
 
153
                                     ((1 *))
 
154
                                     alist-%offset%)
 
155
                      (f2cl-lib:fref blist-%data%
 
156
                                     (maxerr)
 
157
                                     ((1 *))
 
158
                                     blist-%offset%))))
 
159
          (setf a2 b1)
 
160
          (setf b2
 
161
                  (f2cl-lib:fref blist-%data% (maxerr) ((1 *)) blist-%offset%))
 
162
          (multiple-value-bind
 
163
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 
164
                 var-10 var-11 var-12 var-13 var-14 var-15)
 
165
              (dqc25s f a b a1 b1 alfa beta ri rj rg rh area1 error1 resas1
 
166
               integr nev)
 
167
            (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
 
168
            (setf a var-1)
 
169
            (setf b var-2)
 
170
            (setf alfa var-5)
 
171
            (setf beta var-6)
 
172
            (setf area1 var-11)
 
173
            (setf error1 var-12)
 
174
            (setf resas1 var-13)
 
175
            (setf integr var-14)
 
176
            (setf nev var-15))
 
177
          (setf neval (f2cl-lib:int-add neval nev))
 
178
          (multiple-value-bind
 
179
                (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
 
180
                 var-10 var-11 var-12 var-13 var-14 var-15)
 
181
              (dqc25s f a b a2 b2 alfa beta ri rj rg rh area2 error2 resas2
 
182
               integr nev)
 
183
            (declare (ignore var-0 var-3 var-4 var-7 var-8 var-9 var-10))
 
184
            (setf a var-1)
 
185
            (setf b var-2)
 
186
            (setf alfa var-5)
 
187
            (setf beta var-6)
 
188
            (setf area2 var-11)
 
189
            (setf error2 var-12)
 
190
            (setf resas2 var-13)
 
191
            (setf integr var-14)
 
192
            (setf nev var-15))
 
193
          (setf neval (f2cl-lib:int-add neval nev))
 
194
          (setf area12 (+ area1 area2))
 
195
          (setf erro12 (+ error1 error2))
 
196
          (setf errsum (- (+ errsum erro12) errmax))
 
197
          (setf area
 
198
                  (- (+ area area12)
 
199
                     (f2cl-lib:fref rlist-%data%
 
200
                                    (maxerr)
 
201
                                    ((1 *))
 
202
                                    rlist-%offset%)))
 
203
          (if (or (= a a1) (= b b2)) (go label30))
 
204
          (if (or (= resas1 error1) (= resas2 error2)) (go label30))
 
205
          (if
 
206
           (and
 
207
            (<
 
208
             (abs
 
209
              (- (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 
210
                 area12))
 
211
             (* 1.e-5 (abs area12)))
 
212
            (>= erro12 (* 0.99 errmax)))
 
213
           (setf iroff1 (f2cl-lib:int-add iroff1 1)))
 
214
          (if (and (> last$ 10) (> erro12 errmax))
 
215
              (setf iroff2 (f2cl-lib:int-add iroff2 1)))
 
216
         label30
 
217
          (f2cl-lib:fset
 
218
           (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 
219
           area1)
 
220
          (f2cl-lib:fset
 
221
           (f2cl-lib:fref rlist-%data% (last$) ((1 *)) rlist-%offset%)
 
222
           area2)
 
223
          (setf errbnd (max epsabs (* epsrel (abs area))))
 
224
          (if (<= errsum errbnd) (go label35))
 
225
          (if (= last$ limit) (setf ier 1))
 
226
          (if (or (>= iroff1 6) (>= iroff2 20)) (setf ier 2))
 
227
          (if
 
228
           (<= (max (abs a1) (abs b2))
 
229
               (* (+ 1.0 (* 100.0 epmach)) (+ (abs a2) (* 1000.0 uflow))))
 
230
           (setf ier 3))
 
231
         label35
 
232
          (if (> error2 error1) (go label40))
 
233
          (f2cl-lib:fset
 
234
           (f2cl-lib:fref alist-%data% (last$) ((1 *)) alist-%offset%)
 
235
           a2)
 
236
          (f2cl-lib:fset
 
237
           (f2cl-lib:fref blist-%data% (maxerr) ((1 *)) blist-%offset%)
 
238
           b1)
 
239
          (f2cl-lib:fset
 
240
           (f2cl-lib:fref blist-%data% (last$) ((1 *)) blist-%offset%)
 
241
           b2)
 
242
          (f2cl-lib:fset
 
243
           (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%)
 
244
           error1)
 
245
          (f2cl-lib:fset
 
246
           (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%)
 
247
           error2)
 
248
          (go label50)
 
249
         label40
 
250
          (f2cl-lib:fset
 
251
           (f2cl-lib:fref alist-%data% (maxerr) ((1 *)) alist-%offset%)
 
252
           a2)
 
253
          (f2cl-lib:fset
 
254
           (f2cl-lib:fref alist-%data% (last$) ((1 *)) alist-%offset%)
 
255
           a1)
 
256
          (f2cl-lib:fset
 
257
           (f2cl-lib:fref blist-%data% (last$) ((1 *)) blist-%offset%)
 
258
           b1)
 
259
          (f2cl-lib:fset
 
260
           (f2cl-lib:fref rlist-%data% (maxerr) ((1 *)) rlist-%offset%)
 
261
           area2)
 
262
          (f2cl-lib:fset
 
263
           (f2cl-lib:fref rlist-%data% (last$) ((1 *)) rlist-%offset%)
 
264
           area1)
 
265
          (f2cl-lib:fset
 
266
           (f2cl-lib:fref elist-%data% (maxerr) ((1 *)) elist-%offset%)
 
267
           error2)
 
268
          (f2cl-lib:fset
 
269
           (f2cl-lib:fref elist-%data% (last$) ((1 *)) elist-%offset%)
 
270
           error1)
 
271
         label50
 
272
          (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5 var-6)
 
273
              (dqpsrt limit last$ maxerr errmax elist iord nrmax)
 
274
            (declare (ignore var-0 var-1 var-4 var-5))
 
275
            (setf maxerr var-2)
 
276
            (setf errmax var-3)
 
277
            (setf nrmax var-6))
 
278
          (if (or (/= ier 0) (<= errsum errbnd)) (go label70))
 
279
         label60))
 
280
     label70
 
281
      (setf result 0.0)
 
282
      (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
 
283
                    ((> k last$) nil)
 
284
        (tagbody
 
285
          (setf result
 
286
                  (+ result
 
287
                     (f2cl-lib:fref rlist-%data% (k) ((1 *)) rlist-%offset%)))
 
288
         label80))
 
289
      (setf abserr errsum)
 
290
     label999
 
291
      (go end_label)
 
292
     end_label
 
293
      (return
 
294
       (values nil
 
295
               a
 
296
               b
 
297
               alfa
 
298
               beta
 
299
               integr
 
300
               nil
 
301
               nil
 
302
               nil
 
303
               result
 
304
               abserr
 
305
               neval
 
306
               ier
 
307
               nil
 
308
               nil
 
309
               nil
 
310
               nil
 
311
               nil
 
312
               last$)))))
245
313