?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
In documentation for lreduce and rreduce, supply second argument as an explicit list
[maxima.git] / src / numerical / slatec / djairy.lisp
blob328a450c35725c01f0527f7b22bdef46fdea78c8
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 ':simple-array)
14 ;;; (:array-slicing nil) (:declare-common nil)
15 ;;; (:float-format double-float))
16
17 (in-package :slatec)
18
19
20 (let ((n1 14)
21 (n2 23)
22 (n3 19)
23 (n4 15)
24 (m1 12)
25 (m2 21)
26 (m3 17)
27 (m4 13)
28 (fpi12 1.30899693899575)
29 (con2 5.03154716196777)
30 (con3 0.380004589867293)
31 (con4 0.833333333333333)
32 (con5 0.866025403784439)
33 (ak1
34 (make-array 14
35 :element-type 'double-float
36 :initial-contents '(0.220423090987793 -0.1252902427877
37 0.0103881163359194 8.22844152006343e-4
38 -2.34614345891226e-4 1.63824280172116e-5
39 3.06902589573189e-7 -1.29621999359332e-7
40 8.22908158823668e-9 1.53963968623298e-11
41 -3.39165465615682e-11
42 2.03253257423626e-12
43 -1.10679546097884e-14
44 -5.1616949778508e-15)))
45 (ak2
46 (make-array 23
47 :element-type 'double-float
48 :initial-contents '(0.274366150869598 0.00539790969736903
49 -0.0015733922062119 4.2742752824875e-4
50 -1.12124917399925e-4 2.88763171318904e-5
51 -7.36804225370554e-6 1.87290209741024e-6
52 -4.75892793962291e-7 1.21130416955909e-7
53 -3.09245374270614e-8 7.92454705282654e-9
54 -2.03902447167914e-9
55 5.26863056595742e-10
56 -1.36704767639569e-10
57 3.56141039013708e-11
58 -9.3138829654843e-12
59 2.44464450473635e-12
60 -6.43840261990955e-13
61 1.70106030559349e-13
62 -4.50760104503281e-14
63 1.19774799164811e-14
64 -3.19077040865066e-15)))
65 (ak3
66 (make-array 14
67 :element-type 'double-float
68 :initial-contents '(0.280271447340791 -0.00178127042844379
69 4.03422579628999e-5 -1.63249965269003e-6
70 9.21181482476768e-8 -6.52294330229155e-9
71 5.47138404576546e-10
72 -5.2440825180026e-11
73 5.60477904117209e-12
74 -6.56375244639313e-13
75 8.31285761966247e-14
76 -1.12705134691063e-14
77 1.62267976598129e-15
78 -2.46480324312426e-16)))
79 (ajp
80 (make-array 19
81 :element-type 'double-float
82 :initial-contents '(0.0778952966437581 -0.184356363456801
83 0.0301412605216174 0.0305342724277608
84 -0.00495424702513079
85 -0.00172749552563952 2.4313763783919e-4
86 5.04564777517082e-5 -6.16316582695208e-6
87 -9.03986745510768e-7 9.70243778355884e-8
88 1.09639453305205e-8 -1.04716330588766e-9
89 -9.60359441344646e-11
90 8.25358789454134e-12
91 6.36123439018768e-13
92 -4.96629614116015e-14
93 -3.29810288929615e-15
94 2.35798252031104e-16)))
95 (ajn
96 (make-array 19
97 :element-type 'double-float
98 :initial-contents '(0.0380497887617242 -0.245319541845546
99 0.165820623702696 0.0749330045818789
100 -0.0263476288106641 -0.00592535597304981
101 0.00144744409589804 2.18311831322215e-4
102 -4.10662077680304e-5
103 -4.66874994171766e-6 7.1521880727716e-7
104 6.52964770854633e-8 -8.44284027565946e-9
105 -6.44186158976978e-10
106 7.20802286505285e-11
107 4.72465431717846e-12
108 -4.66022632547045e-13
109 -2.67762710389189e-14
110 2.36161316570019e-15)))
111 (a
112 (make-array 15
113 :element-type 'double-float
114 :initial-contents '(0.490275424742791 0.00157647277946204
115 -9.66195963140306e-5 1.35916080268815e-7
116 2.98157342654859e-7 -1.86824767559979e-8
117 -1.03685737667141e-9
118 3.28660818434328e-10
119 -2.5709141063278e-11
120 -2.32357655300677e-12
121 9.57523279048255e-13
122 -1.20340828049719e-13
123 -2.90907716770715e-15
124 4.55656454580149e-15
125 -9.99003874810259e-16)))
126 (b
127 (make-array 15
128 :element-type 'double-float
129 :initial-contents '(0.278593552803079 -0.00352915691882584
130 -2.31149677384994e-5 4.7131784226356e-6
131 -1.12415907931333e-7
132 -2.00100301184339e-8 2.60948075302193e-9
133 -3.55098136101216e-11
134 -3.50849978423875e-11
135 5.83007187954202e-12
136 -2.04644828753326e-13
137 -1.10529179476742e-13
138 2.87724778038775e-14
139 -2.88205111009939e-15
140 -3.32656311696166e-16)))
141 (n1d 14)
142 (n2d 24)
143 (n3d 19)
144 (n4d 15)
145 (m1d 12)
146 (m2d 22)
147 (m3d 17)
148 (m4d 13)
149 (dak1
150 (make-array 14
151 :element-type 'double-float
152 :initial-contents '(0.204567842307887 -0.0661322739905664
153 -0.00849845800989287 0.00312183491556289
154 -2.70016489829432e-4
155 -6.35636298679387e-6 3.02397712409509e-6
156 -2.18311195330088e-7
157 -5.36194289332826e-10 1.1309803562231e-9
158 -7.43023834629073e-11
159 4.28804170826891e-13
160 2.23810925754539e-13
161 -1.39140135641182e-14)))
162 (dak2
163 (make-array 24
164 :element-type 'double-float
165 :initial-contents '(0.29333234388323 -0.00806196784743112
166 0.0024254017233314 -6.82297548850235e-4
167 1.85786427751181e-4 -4.97457447684059e-5
168 1.32090681239497e-5 -3.49528240444943e-6
169 9.24362451078835e-7 -2.44732671521867e-7
170 6.4930783764891e-8 -1.72717621501538e-8
171 4.60725763604656e-9 -1.2324905529155e-9
172 3.30620409488102e-10
173 -8.89252099772401e-11
174 2.39773319878298e-11
175 -6.4801392115345e-12
176 1.75510132023731e-12
177 -4.76303829833637e-13
178 1.2949824110081e-13 -3.5267962221043e-14
179 9.62005151585923e-15
180 -2.62786914342292e-15)))
181 (dak3
182 (make-array 14
183 :element-type 'double-float
184 :initial-contents '(0.284675828811349 0.0025307307261908
185 -4.83481130337976e-5 1.84907283946343e-6
186 -1.01418491178576e-7 7.05925634457153e-9
187 -5.85325291400382e-10
188 5.56357688831339e-11 -5.908890947795e-12
189 6.88574353784436e-13
190 -8.68588256452194e-14
191 1.17374762617213e-14
192 -1.68523146510923e-15
193 2.55374773097056e-16)))
194 (dajp
195 (make-array 19
196 :element-type 'double-float
197 :initial-contents '(0.0653219131311457 -0.120262933688823
198 0.00978010236263823 0.0167948429230505
199 -0.00197146140182132
200 -8.45560295098867e-4 9.42889620701976e-5
201 2.25827860945475e-5 -2.29067870915987e-6
202 -3.76343991136919e-7 3.45663933559565e-8
203 4.29611332003007e-9
204 -3.58673691214989e-10
205 -3.57245881361895e-11
206 2.72696091066336e-12
207 2.26120653095771e-13
208 -1.58763205238303e-14
209 -1.12604374485125e-15
210 7.31327529515367e-17)))
211 (dajn
212 (make-array 19
213 :element-type 'double-float
214 :initial-contents '(0.0108594539632967 0.0853313194857091
215 -0.315277068113058 -0.0878420725294257
216 0.0553251906976048 0.00941674060503241
217 -0.00332187026018996
218 -4.11157343156826e-4 1.01297326891346e-4
219 9.87633682208396e-6 -1.87312969812393e-6
220 -1.50798500131468e-7 2.32687669525394e-8
221 1.59599917419225e-9
222 -2.07665922668385e-10
223 -1.24103350500302e-11
224 1.39631765331043e-12 7.3940097115574e-14
225 -7.328874756275e-15)))
226 (da
227 (make-array 15
228 :element-type 'double-float
229 :initial-contents '(0.491627321104601 0.00311164930427489
230 8.23140762854081e-5 -4.61769776172142e-6
231 -6.13158880534626e-8 2.8729580465652e-8
232 -1.81959715372117e-9
233 -1.44752826642035e-10
234 4.53724043420422e-11
235 -3.99655065847223e-12
236 -3.24089119830323e-13
237 1.62098952568741e-13
238 -2.40765247974057e-14
239 1.69384811284491e-16
240 8.17900786477396e-16)))
241 (db
242 (make-array 15
243 :element-type 'double-float
244 :initial-contents '(-0.277571356944231 0.0044421283341992
245 -8.42328522190089e-5 -2.5804031841871e-6
246 3.42389720217621e-7 -6.24286894709776e-9
247 -2.36377836844577e-9
248 3.16991042656673e-10
249 -4.40995691658191e-12
250 -5.18674221093575e-12
251 9.64874015137022e-13
252 -4.9019057660871e-14
253 -1.77253430678112e-14
254 5.55950610442662e-15
255 -7.1179333757953e-16))))
256 (declare (type (f2cl-lib:integer4) n1 n2 n3 n4 m1 m2 m3 m4 n1d n2d n3d n4d
257 m1d m2d m3d m4d)
258 (type (double-float) fpi12 con2 con3 con4 con5)
259 (type (simple-array double-float (14)) ak1 ak3 dak1 dak3)
260 (type (simple-array double-float (23)) ak2)
261 (type (simple-array double-float (19)) ajp ajn dajp dajn)
262 (type (simple-array double-float (15)) a b da db)
263 (type (simple-array double-float (24)) dak2))
264 (defun djairy (x rx c ai dai)
265 (declare (type (double-float) dai ai c rx x))
266 (prog ((ccv 0.0) (cv 0.0) (ec 0.0) (e1 0.0) (e2 0.0) (f1 0.0) (f2 0.0)
267 (rtrx 0.0) (scv 0.0) (t$ 0.0) (temp1 0.0) (temp2 0.0) (tt 0.0) (i 0)
268 (j 0))
269 (declare (type (f2cl-lib:integer4) j i)
270 (type (double-float) tt temp2 temp1 t$ scv rtrx f2 f1 e2 e1 ec
271 cv ccv))
272 (if (< x 0.0) (go label90))
273 (if (> c 5.0) (go label60))
274 (if (> x 1.2) (go label30))
275 (setf t$ (* (- (+ x x) 1.2) con4))
276 (setf tt (+ t$ t$))
277 (setf j n1)
278 (setf f1 (f2cl-lib:fref ak1 (j) ((1 14))))
279 (setf f2 0.0)
280 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
281 ((> i m1) nil)
282 (tagbody
283 (setf j (f2cl-lib:int-sub j 1))
284 (setf temp1 f1)
285 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref ak1 (j) ((1 14)))))
286 (setf f2 temp1)
287 label10))
288 (setf ai (+ (- (* t$ f1) f2) (f2cl-lib:fref ak1 (1) ((1 14)))))
289 (setf j n1d)
290 (setf f1 (f2cl-lib:fref dak1 (j) ((1 14))))
291 (setf f2 0.0)
292 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
293 ((> i m1d) nil)
294 (tagbody
295 (setf j (f2cl-lib:int-sub j 1))
296 (setf temp1 f1)
297 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref dak1 (j) ((1 14)))))
298 (setf f2 temp1)
299 label20))
300 (setf dai (- (+ (- (* t$ f1) f2) (f2cl-lib:fref dak1 (1) ((1 14))))))
301 (go end_label)
302 label30
303 (setf t$ (* (- (+ x x) con2) con3))
304 (setf tt (+ t$ t$))
305 (setf j n2)
306 (setf f1 (f2cl-lib:fref ak2 (j) ((1 23))))
307 (setf f2 0.0)
308 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
309 ((> i m2) nil)
310 (tagbody
311 (setf j (f2cl-lib:int-sub j 1))
312 (setf temp1 f1)
313 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref ak2 (j) ((1 23)))))
314 (setf f2 temp1)
315 label40))
316 (setf rtrx (f2cl-lib:fsqrt rx))
317 (setf ec (exp (- c)))
318 (setf ai
319 (/ (* ec (+ (- (* t$ f1) f2) (f2cl-lib:fref ak2 (1) ((1 23)))))
320 rtrx))
321 (setf j n2d)
322 (setf f1 (f2cl-lib:fref dak2 (j) ((1 24))))
323 (setf f2 0.0)
324 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
325 ((> i m2d) nil)
326 (tagbody
327 (setf j (f2cl-lib:int-sub j 1))
328 (setf temp1 f1)
329 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref dak2 (j) ((1 24)))))
330 (setf f2 temp1)
331 label50))
332 (setf dai
333 (* (- ec)
334 (+ (- (* t$ f1) f2) (f2cl-lib:fref dak2 (1) ((1 24))))
335 rtrx))
336 (go end_label)
337 label60
338 (setf t$ (- (/ 10.0 c) 1.0))
339 (setf tt (+ t$ t$))
340 (setf j n1)
341 (setf f1 (f2cl-lib:fref ak3 (j) ((1 14))))
342 (setf f2 0.0)
343 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
344 ((> i m1) nil)
345 (tagbody
346 (setf j (f2cl-lib:int-sub j 1))
347 (setf temp1 f1)
348 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref ak3 (j) ((1 14)))))
349 (setf f2 temp1)
350 label70))
351 (setf rtrx (f2cl-lib:fsqrt rx))
352 (setf ec (exp (- c)))
353 (setf ai
354 (/ (* ec (+ (- (* t$ f1) f2) (f2cl-lib:fref ak3 (1) ((1 14)))))
355 rtrx))
356 (setf j n1d)
357 (setf f1 (f2cl-lib:fref dak3 (j) ((1 14))))
358 (setf f2 0.0)
359 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
360 ((> i m1d) nil)
361 (tagbody
362 (setf j (f2cl-lib:int-sub j 1))
363 (setf temp1 f1)
364 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref dak3 (j) ((1 14)))))
365 (setf f2 temp1)
366 label80))
367 (setf dai
368 (* (- rtrx)
369 ec
370 (+ (- (* t$ f1) f2) (f2cl-lib:fref dak3 (1) ((1 14))))))
371 (go end_label)
372 label90
373 (if (> c 5.0) (go label120))
374 (setf t$ (- (* 0.4 c) 1.0))
375 (setf tt (+ t$ t$))
376 (setf j n3)
377 (setf f1 (f2cl-lib:fref ajp (j) ((1 19))))
378 (setf e1 (f2cl-lib:fref ajn (j) ((1 19))))
379 (setf f2 0.0)
380 (setf e2 0.0)
381 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
382 ((> i m3) nil)
383 (tagbody
384 (setf j (f2cl-lib:int-sub j 1))
385 (setf temp1 f1)
386 (setf temp2 e1)
387 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref ajp (j) ((1 19)))))
388 (setf e1 (+ (- (* tt e1) e2) (f2cl-lib:fref ajn (j) ((1 19)))))
389 (setf f2 temp1)
390 (setf e2 temp2)
391 label100))
392 (setf ai
393 (- (+ (- (* t$ e1) e2) (f2cl-lib:fref ajn (1) ((1 19))))
394 (* x (+ (- (* t$ f1) f2) (f2cl-lib:fref ajp (1) ((1 19)))))))
395 (setf j n3d)
396 (setf f1 (f2cl-lib:fref dajp (j) ((1 19))))
397 (setf e1 (f2cl-lib:fref dajn (j) ((1 19))))
398 (setf f2 0.0)
399 (setf e2 0.0)
400 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
401 ((> i m3d) nil)
402 (tagbody
403 (setf j (f2cl-lib:int-sub j 1))
404 (setf temp1 f1)
405 (setf temp2 e1)
406 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref dajp (j) ((1 19)))))
407 (setf e1 (+ (- (* tt e1) e2) (f2cl-lib:fref dajn (j) ((1 19)))))
408 (setf f2 temp1)
409 (setf e2 temp2)
410 label110))
411 (setf dai
412 (+ (* x x (+ (- (* t$ f1) f2) (f2cl-lib:fref dajp (1) ((1 19)))))
413 (+ (- (* t$ e1) e2) (f2cl-lib:fref dajn (1) ((1 19))))))
414 (go end_label)
415 label120
416 (setf t$ (- (/ 10.0 c) 1.0))
417 (setf tt (+ t$ t$))
418 (setf j n4)
419 (setf f1 (f2cl-lib:fref a (j) ((1 15))))
420 (setf e1 (f2cl-lib:fref b (j) ((1 15))))
421 (setf f2 0.0)
422 (setf e2 0.0)
423 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
424 ((> i m4) nil)
425 (tagbody
426 (setf j (f2cl-lib:int-sub j 1))
427 (setf temp1 f1)
428 (setf temp2 e1)
429 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref a (j) ((1 15)))))
430 (setf e1 (+ (- (* tt e1) e2) (f2cl-lib:fref b (j) ((1 15)))))
431 (setf f2 temp1)
432 (setf e2 temp2)
433 label130))
434 (setf temp1 (+ (- (* t$ f1) f2) (f2cl-lib:fref a (1) ((1 15)))))
435 (setf temp2 (+ (- (* t$ e1) e2) (f2cl-lib:fref b (1) ((1 15)))))
436 (setf rtrx (f2cl-lib:fsqrt rx))
437 (setf cv (- c fpi12))
438 (setf ccv (cos cv))
439 (setf scv (sin cv))
440 (setf ai (/ (- (* temp1 ccv) (* temp2 scv)) rtrx))
441 (setf j n4d)
442 (setf f1 (f2cl-lib:fref da (j) ((1 15))))
443 (setf e1 (f2cl-lib:fref db (j) ((1 15))))
444 (setf f2 0.0)
445 (setf e2 0.0)
446 (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
447 ((> i m4d) nil)
448 (tagbody
449 (setf j (f2cl-lib:int-sub j 1))
450 (setf temp1 f1)
451 (setf temp2 e1)
452 (setf f1 (+ (- (* tt f1) f2) (f2cl-lib:fref da (j) ((1 15)))))
453 (setf e1 (+ (- (* tt e1) e2) (f2cl-lib:fref db (j) ((1 15)))))
454 (setf f2 temp1)
455 (setf e2 temp2)
456 label140))
457 (setf temp1 (+ (- (* t$ f1) f2) (f2cl-lib:fref da (1) ((1 15)))))
458 (setf temp2 (+ (- (* t$ e1) e2) (f2cl-lib:fref db (1) ((1 15)))))
459 (setf e1 (+ (* ccv con5) (* 0.5 scv)))
460 (setf e2 (- (* scv con5) (* 0.5 ccv)))
461 (setf dai (* (- (* temp1 e1) (* temp2 e2)) rtrx))
462 (go end_label)
463 end_label
464 (return (values nil nil nil ai dai)))))
465
466 (in-package #:cl-user)
467 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
468 (eval-when (:load-toplevel :compile-toplevel :execute)
469 (setf (gethash 'fortran-to-lisp::djairy
470 fortran-to-lisp::*f2cl-function-info*)
471 (fortran-to-lisp::make-f2cl-finfo
472 :arg-types '((double-float) (double-float) (double-float)
473 (double-float) (double-float))
474 :return-values '(nil nil nil fortran-to-lisp::ai
475 fortran-to-lisp::dai)
476 :calls 'nil)))
477
Maxima, a Computer Algebra System