?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Don't use fname to define functions
[maxima.git] / src / numerical / slatec / zunhj.lisp
blobb26c4a0c4bb155212580f4ed0ab7d82a20615244
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 ((ar
21 (make-array 14
22 :element-type 'double-float
23 :initial-contents '(1.0 0.10416666666666667
24 0.08355034722222222 0.12822657455632716
25 0.29184902646414046 0.8816272674437576
26 3.3214082818627677 14.995762986862555
27 78.92301301158652 474.4515388682643
28 3207.490090890662 24086.549640874004
29 198923.1191695098 1791902.0077753437)))
30 (br
31 (make-array 14
32 :element-type 'double-float
33 :initial-contents '(1.0 -0.14583333333333334
34 -0.09874131944444445
35 -0.14331205391589505
36 -0.31722720267841353 -0.9424291479571203
37 -3.5112030408263544 -15.727263620368046
38 -82.28143909718594 -492.3553705236705
39 -3316.2185685479726 -24827.67424520859
40 -204526.5873151298 -1838444.91706821)))
41 (c
42 (make-array 105
43 :element-type 'double-float
44 :initial-contents '(1.0 -0.20833333333333334 0.125
45 0.3342013888888889 -0.4010416666666667
46 0.0703125 -1.0258125964506173
47 1.8464626736111112 -0.8912109375
48 0.0732421875 4.669584423426247
49 -11.207002616222994 8.78912353515625
50 -2.3640869140625 0.112152099609375
51 -28.212072558200244 84.63621767460073
52 -91.81824154324002 42.53499874538846
53 -7.368794359479632 0.22710800170898438
54 212.57013003921713 -765.2524681411817
55 1059.9904525279999 -699.5796273761325
56 218.1905117442116 -26.491430486951554
57 0.5725014209747314 -1919.457662318407
58 8061.722181737309 -13586.550006434138
59 11655.393336864534 -5305.646978613403
60 1200.9029132163525 -108.09091978839466
61 1.7277275025844574 20204.29133096615
62 -96980.59838863752 192547.00123253153
63 -203400.17728041555 122200.46498301746
64 -41192.65496889755 7109.514302489364
65 -493.915304773088 6.074042001273483
66 -242919.18790055133 1311763.6146629772
67 -2998015.9185381066 3763271.297656404
68 -2813563.226586534 1268365.2733216248
69 -331645.1724845636 45218.76898136273
70 -2499.8304818112097 24.380529699556064
71 3284469.853072038 -1.9706819118432228e7
72 5.095260249266464e7 -7.410514821153265e7
73 6.634451227472903e7 -3.756717666076335e7
74 1.3288767166421818e7 -2785618.1280864547
75 308186.4046126624 -13886.08975371704
76 110.01714026924674 -4.932925366450996e7
77 3.2557307418576574e8
78 -9.394623596815784e8 1.55359689957058e9
79 -1.6210805521083372e9
80 1.1068428168230145e9
81 -4.958897842750303e8 1.420629077975331e8
82 -2.447406272573873e7 2243768.1779224495
83 -84005.43360302408 551.3358961220206
84 8.147890961183121e8 -5.866481492051847e9
85 1.8688207509295826e10
86 -3.4632043388158775e10
87 4.1280185579753975e10
88 -3.3026599749800724e10
89 1.79542137311556e10 -6.563293792619285e9
90 1.5592798648792574e9
91 -2.2510566188941526e8
92 1.7395107553978164e7 -549842.3275722887
93 3038.090510922384 -1.4679261247695616e10
94 1.144982377320258e11
95 -3.990961752244665e11
96 8.192186695485773e11
97 -1.0983751560812233e12
98 1.0081581068653821e12
99 -6.453648692453765e11
100 2.879006499061506e11
101 -8.786707217802327e10
102 1.763473060683497e10
103 -2.167164983223795e9
104 1.4315787671888897e8 -3871833.442572613
105 18257.755474293175)))
106 (alfa
107 (make-array 180
108 :element-type 'double-float
109 :initial-contents '(-0.0044444444444444444
110 -9.22077922077922e-4
111 -8.848928848928849e-5
112 1.6592768783244973e-4
113 2.466913727417929e-4
114 2.659955893462548e-4
115 2.6182429706150096e-4
116 2.487304373446556e-4
117 2.3272104008323209e-4
118 2.1636248571236508e-4
119 2.0073885876275234e-4
120 1.8626763663754517e-4
121 1.730607759178765e-4
122 1.6109170592901574e-4
123 1.5027477416090814e-4
124 1.405034973912698e-4
125 1.316688165459228e-4
126 1.2366744559825325e-4
127 1.1640527147473791e-4
128 1.0979829837271337e-4
129 1.0377241042299283e-4
130 9.826260783693634e-5
131 9.321205172495032e-5
132 8.857108524787117e-5
133 8.429631057157003e-5
134 8.034975484077912e-5
135 7.669813453592074e-5
136 7.331221574817778e-5
137 7.016626251631414e-5
138 6.723756337901603e-5 6.93735541354589e-4
139 2.3224174518292166e-4
140 -1.419862735566912e-5
141 -1.1644493167204864e-4
142 -1.5080355805304876e-4
143 -1.5512192491809622e-4
144 -1.4680975664646556e-4
145 -1.3381550386749137e-4
146 -1.1974497568425405e-4
147 -1.0618431920797402e-4
148 -9.376995498911944e-5
149 -8.269230455881933e-5
150 -7.293743481552213e-5
151 -6.440423577210163e-5
152 -5.69611566009369e-5
153 -5.0473104430356164e-5
154 -4.481348680088828e-5
155 -3.9868872771759884e-5
156 -3.554005329720425e-5
157 -3.174142566090225e-5
158 -2.839967939041748e-5
159 -2.5452272063487058e-5
160 -2.2845929716472455e-5
161 -2.053527531064806e-5
162 -1.848162176276661e-5
163 -1.665193300213938e-5
164 -1.5017941298011949e-5
165 -1.3555403137904052e-5
166 -1.2243474647385812e-5
167 -1.1064188481130817e-5
168 -3.5421197145774384e-4
169 -1.5616126394515941e-4
170 3.044655035949364e-5
171 1.301986557732427e-4
172 1.6747110669971228e-4
173 1.7022258768359256e-4
174 1.5650142760859472e-4
175 1.3633917097744512e-4
176 1.1488669202982512e-4
177 9.458690930346882e-5
178 7.644984192508983e-5
179 6.0757033496519734e-5
180 4.743942992905088e-5
181 3.627575120053443e-5
182 2.699397149792249e-5
183 1.9321093824793926e-5
184 1.3005667479396321e-5
185 7.826208667444966e-6
186 3.592574858193516e-6
187 1.4404004981425182e-7
188 -2.653967696979391e-6
189 -4.913468670984859e-6
190 -6.727392960912483e-6
191 -8.17269379678658e-6
192 -9.313047150935612e-6
193 -1.0201141879801643e-5
194 -1.0880596251059288e-5
195 -1.1387548150960355e-5
196 -1.1751967567455642e-5
197 -1.1998736487094414e-5
198 3.781941992017729e-4
199 2.0247195276181616e-4
200 -6.379385063188624e-5
201 -2.385982306030059e-4
202 -3.109162560273616e-4
203 -3.1368011524757634e-4
204 -2.789502737913234e-4
205 -2.2856408261914138e-4
206 -1.7524528034084676e-4
207 -1.2554406306069035e-4
208 -8.229828728202083e-5
209 -4.628607305881165e-5
210 -1.7233430236696227e-5
211 5.6069048230460226e-6
212 2.313954431482868e-5
213 3.626427458567939e-5
214 4.5800612449018877e-5
215 5.2459529495911405e-5
216 5.683962085458153e-5
217 5.9434982039310406e-5
218 6.0647852757842175e-5
219 6.080239077884365e-5
220 6.0157789453946036e-5
221 5.891996573446985e-5 5.72515823777593e-5
222 5.528043755858526e-5
223 5.310637738028802e-5
224 5.080693020123257e-5
225 4.8441864762009484e-5
226 4.6056858160747536e-5
227 -6.911413972882942e-4
228 -4.299766330588719e-4
229 1.83067735980039e-4 6.600881475420142e-4
230 8.759649699511859e-4
231 8.773352359582355e-4
232 7.493695853789907e-4 5.63832329756981e-4
233 3.680593199714432e-4
234 1.884645355144556e-4
235 3.7066305766490415e-5
236 -8.28520220232137e-5
237 -1.72751952869173e-4
238 -2.3631487360587297e-4
239 -2.779661506949067e-4
240 -3.0207951415545694e-4
241 -3.125947126438201e-4
242 -3.1287255875806717e-4
243 -3.056780384663244e-4
244 -2.932264706145573e-4
245 -2.772556555829348e-4
246 -2.591039284670317e-4
247 -2.3978401439648034e-4
248 -2.2004826004542284e-4
249 -2.0044391109497149e-4
250 -1.8135869221097068e-4
251 -1.6305767447865748e-4
252 -1.4571267217520584e-4
253 -1.294254219839246e-4
254 -1.1424569194244596e-4
255 0.0019282196424877589
256 0.0013559257630202223
257 -7.17858090421303e-4
258 -0.0025808480257527035
259 -0.0034927113082616847
260 -0.003469862993409606
261 -0.002822852333513102
262 -0.0018810307640489134
263 -8.895317183839476e-4
264 3.8791210263103525e-6
265 7.286885401196914e-4
266 0.0012656637305345775
267 0.0016251815837267443
268 0.0018320315321637317
269 0.0019158838899052792
270 0.0019058884675554615
271 0.0018279898242182574
272 0.0017038950642112153
273 0.0015509712717109768
274 0.0013826142185227616
275 0.0012088142423006478
276 0.0010367653263834496
277 8.714379180686191e-4 7.16080155297701e-4
278 5.726370025581294e-4
279 4.420898194658023e-4
280 3.2472494850309055e-4
281 2.2034204273024659e-4
282 1.2841289840135388e-4
283 4.8200592455209545e-5)))
284 (beta
285 (make-array 210
286 :element-type 'double-float
287 :initial-contents '(0.01799887214135533 0.005599649110643881
288 0.0028850140223113277
289 0.0018009660676105393
290 0.001247531105891992
291 9.228788765729383e-4
292 7.144304217272874e-4
293 5.717872817897049e-4
294 4.6943100760648155e-4
295 3.9323283546291665e-4
296 3.348188893182977e-4
297 2.8895214849575154e-4
298 2.522116155495733e-4
299 2.2228058079888332e-4
300 1.975418380330625e-4
301 1.7683685501971802e-4
302 1.593168996618211e-4
303 1.4434793019733397e-4
304 1.314480681199654e-4
305 1.2024544494930288e-4
306 1.104491445045994e-4
307 1.0182877074056726e-4
308 9.419982242042375e-5
309 8.741305457538345e-5
310 8.134662621628014e-5
311 7.590022696462193e-5
312 7.099063006341535e-5
313 6.654828748424682e-5 6.25146958969275e-5
314 5.884033944262518e-5
315 -0.0014928295321342917
316 -8.782047095463894e-4
317 -5.029165495720346e-4
318 -2.94822138512746e-4
319 -1.7546399697078284e-4
320 -1.0400855046081644e-4
321 -5.961419530464579e-5
322 -3.1203892907609836e-5
323 -1.2608973598023005e-5
324 -2.4289260857573037e-7
325 8.059961654142736e-6
326 1.3650700926214739e-5
327 1.7396412547292627e-5
328 1.9867297884213378e-5
329 2.1446326379082263e-5
330 2.2395465923245652e-5
331 2.2896778381471263e-5
332 2.307853898111778e-5
333 2.3032197608090914e-5
334 2.2823607372034874e-5
335 2.250058811052924e-5
336 2.2098101536199144e-5
337 2.164184274481039e-5
338 2.1150764925622083e-5
339 2.0638874978217072e-5
340 2.0116524199708165e-5
341 1.9591345014117925e-5
342 1.9068936791043675e-5
343 1.8553371964163667e-5
344 1.804757222596742e-5
345 5.522130767212928e-4
346 4.4793258155238465e-4
347 2.795206539920206e-4
348 1.524681561984466e-4
349 6.932711056570436e-5
350 1.762586830699914e-5
351 -1.3574499634326914e-5
352 -3.179724133504272e-5
353 -4.188618616966934e-5
354 -4.6900488937914104e-5
355 -4.8766544741378735e-5
356 -4.8701003118673505e-5
357 -4.747556208900866e-5
358 -4.558130581386284e-5
359 -4.33309644511266e-5
360 -4.0923019315775034e-5
361 -3.848226386032213e-5
362 -3.608571675354105e-5
363 -3.377933061233674e-5
364 -3.158885607721096e-5
365 -2.952695617508073e-5
366 -2.7597891482833575e-5
367 -2.5800617466688372e-5
368 -2.413083567612802e-5
369 -2.2582350951834605e-5
370 -2.1147965676891298e-5
371 -1.9820063888529493e-5
372 -1.8590987080106508e-5
373 -1.7453269984421023e-5
374 -1.63997823854498e-5
375 -4.746177965599598e-4
376 -4.778645671473215e-4
377 -3.2039022806703763e-4
378 -1.6110501611996228e-4
379 -4.257781012854352e-5
380 3.445712942949675e-5 7.97092684075675e-5
381 1.031382367082722e-4
382 1.1246677526220416e-4
383 1.131036421084814e-4
384 1.0865163484877427e-4
385 1.0143795159766197e-4
386 9.29298396593364e-5 8.4029313301609e-5
387 7.52727991349134e-5 6.696325219757309e-5
388 5.925645473231947e-5
389 5.2216930882697554e-5
390 4.585394851653606e-5
391 4.014455138914868e-5
392 3.504817300313281e-5
393 3.0515799503434667e-5
394 2.6495611995051603e-5
395 2.2936363369099816e-5
396 1.9789305666402162e-5
397 1.7009198463641262e-5
398 1.45547428261524e-5 1.238866409958784e-5
399 1.0477587607658323e-5
400 8.791799549784793e-6
401 7.364658105725784e-4 8.72790805146194e-4
402 6.226148625731351e-4
403 2.8599815419430417e-4
404 3.847376728793661e-6
405 -1.8790600363697156e-4
406 -2.9760364659455455e-4
407 -3.4599812683265633e-4
408 -3.5338247091603773e-4
409 -3.3571563577504876e-4
410 -3.043211247890398e-4
411 -2.6672272304761283e-4
412 -2.2765421412281953e-4
413 -1.8992261185456235e-4
414 -1.5505891859909386e-4
415 -1.2377824076187363e-4
416 -9.629261477176441e-5
417 -7.251783277144253e-5
418 -5.220700288956338e-5
419 -3.5034775051190054e-5
420 -2.0648976103555174e-5
421 -8.701060968497671e-6
422 1.136986866751003e-6
423 9.164264741227788e-6
424 1.564777854288726e-5
425 2.0822362948246685e-5
426 2.4892338100459516e-5
427 2.803405095741463e-5
428 3.039877746298619e-5
429 3.211567314067006e-5
430 -0.0018018219196388571
431 -0.0024340296293804253
432 -0.001834226635498568
433 -7.622045963540097e-4
434 2.3907947525692722e-4
435 9.492661171768811e-4
436 0.0013446744970154036
437 0.0014845749525944918
438 0.001447323398306176
439 0.0013026826128565718
440 0.0011035159737564268
441 8.860474404197917e-4
442 6.730732081656654e-4
443 4.7760387285658237e-4
444 3.0599192635878935e-4
445 1.6031569459472162e-4
446 4.007495552706133e-5
447 -5.666074616352516e-5
448 -1.3250618677298264e-4
449 -1.9029618798961406e-4
450 -2.328114503769374e-4
451 -2.6262881146466884e-4
452 -2.8205046986759866e-4
453 -2.9308156319286116e-4
454 -2.974359621763166e-4
455 -2.965573342393481e-4
456 -2.916473633120909e-4
457 -2.836962038377342e-4
458 -2.7351231709567335e-4
459 -2.617501558067686e-4
460 0.006385858912120509 0.00962374215806378
461 0.0076187806120700105
462 0.0028321905554562804
463 -0.002098413520127201
464 -0.005738267642166265
465 -0.0077080424449541465
466 -0.008210116922648444
467 -0.007658245203469054
468 -0.006472097293910452
469 -0.004991324120049665
470 -0.0034561228971313326
471 -0.002017855800141708
472 -7.594306867819614e-4
473 2.841736315238591e-4
474 0.001108916675863374
475 0.0017290149387272878
476 0.002168125908026847
477 0.002453577104945397
478 0.0026128182105833488
479 0.002671410396562769
480 0.0026520307339598045
481 0.002574116528772873
482 0.0024538912623609443
483 0.002304600580717955
484 0.0021368483768671267
485 0.001958965284788709
486 0.0017773700867945441
487 0.0015969028076583906
488 0.0014211197566443854)))
489 (gama
490 (make-array 30
491 :element-type 'double-float
492 :initial-contents '(0.6299605249474366 0.25198420997897464
493 0.15479030041565583 0.11071306241615901
494 0.08573093955273949 0.06971613169586843
495 0.05860856718937136 0.05046988735363107
496 0.04426005806891548 0.039372066154350994
497 0.03542831959244554 0.032181885750209825
498 0.029464624079115768
499 0.027158167711293448
500 0.025176827297386177 0.02345707553060789
501 0.02195083901349072 0.020621082823564625
502 0.019438824089788084
503 0.018381063380068317
504 0.017429321323196318
505 0.016568583778661234
506 0.015786528598791844 0.01507295014940956
507 0.014419325083995464
508 0.013818480573534178
509 0.013264337899427657
510 0.012751712197049864
511 0.012276154531876277
512 0.01183382623984824)))
513 (ex1 0.3333333333333333)
514 (ex2 0.6666666666666666)
515 (hpi 1.5707963267948966)
516 (gpi 3.141592653589793)
517 (thpi 4.71238898038469)
518 (zeror 0.0)
519 (zeroi 0.0)
520 (coner 1.0)
521 (conei 0.0))
522 (declare (type (simple-array double-float (14)) ar br)
523 (type (simple-array double-float (105)) c)
524 (type (simple-array double-float (180)) alfa)
525 (type (simple-array double-float (210)) beta)
526 (type (simple-array double-float (30)) gama)
527 (type (double-float) ex1 ex2 hpi gpi thpi zeror zeroi coner conei))
528 (defun zunhj
529 (zr zi fnu ipmtr tol phir phii argr argi zeta1r zeta1i zeta2r zeta2i
530 asumr asumi bsumr bsumi)
531 (declare (type (f2cl-lib:integer4) ipmtr)
532 (type (double-float) bsumi bsumr asumi asumr zeta2i zeta2r zeta1i
533 zeta1r argi argr phii phir tol fnu zi zr))
534 (prog ((ap (make-array 30 :element-type 'double-float))
535 (pr (make-array 30 :element-type 'double-float))
536 (pi$ (make-array 30 :element-type 'double-float))
537 (upr (make-array 14 :element-type 'double-float))
538 (upi (make-array 14 :element-type 'double-float))
539 (crr (make-array 14 :element-type 'double-float))
540 (cri (make-array 14 :element-type 'double-float))
541 (drr (make-array 14 :element-type 'double-float))
542 (dri (make-array 14 :element-type 'double-float)) (ias 0) (ibs 0)
543 (is 0) (j 0) (jr 0) (ju 0) (k 0) (kmax 0) (kp1 0) (ks 0) (l 0)
544 (lr 0) (lrp1 0) (l1 0) (l2 0) (m 0) (idum 0) (ang 0.0) (atol 0.0)
545 (aw2 0.0) (azth 0.0) (btol 0.0) (fn13 0.0) (fn23 0.0) (pp 0.0)
546 (przthi 0.0) (przthr 0.0) (ptfni 0.0) (ptfnr 0.0) (raw 0.0)
547 (raw2 0.0) (razth 0.0) (rfnu 0.0) (rfnu2 0.0) (rfn13 0.0)
548 (rtzti 0.0) (rtztr 0.0) (rzthi 0.0) (rzthr 0.0) (sti 0.0) (str 0.0)
549 (sumai 0.0) (sumar 0.0) (sumbi 0.0) (sumbr 0.0) (test 0.0)
550 (tfni 0.0) (tfnr 0.0) (tzai 0.0) (tzar 0.0) (t2i 0.0) (t2r 0.0)
551 (wi 0.0) (wr 0.0) (w2i 0.0) (w2r 0.0) (zai 0.0) (zar 0.0) (zbi 0.0)
552 (zbr 0.0) (zci 0.0) (zcr 0.0) (zetai 0.0) (zetar 0.0) (zthi 0.0)
553 (zthr 0.0) (ac 0.0))
554 (declare (type (simple-array double-float (14)) upr upi drr dri crr cri)
555 (type (simple-array double-float (30)) pr pi$ ap)
556 (type (double-float) ac zthr zthi zetar zetai zcr zci zbr zbi
557 zar zai w2r w2i wr wi t2r t2i tzar tzai
558 tfnr tfni test sumbr sumbi sumar sumai str
559 sti rzthr rzthi rtztr rtzti rfn13 rfnu2
560 rfnu razth raw2 raw ptfnr ptfni przthr
561 przthi pp fn23 fn13 btol azth aw2 atol ang)
562 (type (f2cl-lib:integer4) idum m l2 l1 lrp1 lr l ks kp1 kmax k
563 ju jr j is ibs ias))
564 (setf rfnu (/ 1.0 fnu))
565 (setf test (* (f2cl-lib:d1mach 1) 1000.0))
566 (setf ac (* fnu test))
567 (if (or (> (abs zr) ac) (> (abs zi) ac)) (go label15))
568 (setf zeta1r (+ (* 2.0 (abs (f2cl-lib:flog test))) fnu))
569 (setf zeta1i 0.0)
570 (setf zeta2r fnu)
571 (setf zeta2i 0.0)
572 (setf phir 1.0)
573 (setf phii 0.0)
574 (setf argr 1.0)
575 (setf argi 0.0)
576 (go end_label)
577 label15
578 (setf zbr (* zr rfnu))
579 (setf zbi (* zi rfnu))
580 (setf rfnu2 (* rfnu rfnu))
581 (setf fn13 (expt fnu ex1))
582 (setf fn23 (* fn13 fn13))
583 (setf rfn13 (/ 1.0 fn13))
584 (setf w2r (+ (- coner (* zbr zbr)) (* zbi zbi)))
585 (setf w2i (- conei (* zbr zbi) (* zbr zbi)))
586 (setf aw2 (coerce (realpart (zabs w2r w2i)) 'double-float))
587 (if (> aw2 0.25) (go label130))
588 (setf k 1)
589 (setf (f2cl-lib:fref pr (1) ((1 30))) coner)
590 (setf (f2cl-lib:fref pi$ (1) ((1 30))) conei)
591 (setf sumar (f2cl-lib:fref gama (1) ((1 30))))
592 (setf sumai zeroi)
593 (setf (f2cl-lib:fref ap (1) ((1 30))) 1.0)
594 (if (< aw2 tol) (go label20))
595 (f2cl-lib:fdo (k 2 (f2cl-lib:int-add k 1))
596 ((> k 30) nil)
597 (tagbody
598 (setf (f2cl-lib:fref pr (k) ((1 30)))
599 (-
600 (* (f2cl-lib:fref pr ((f2cl-lib:int-sub k 1)) ((1 30))) w2r)
601 (* (f2cl-lib:fref pi$ ((f2cl-lib:int-sub k 1)) ((1 30)))
602 w2i)))
603 (setf (f2cl-lib:fref pi$ (k) ((1 30)))
604 (+
605 (* (f2cl-lib:fref pr ((f2cl-lib:int-sub k 1)) ((1 30))) w2i)
606 (* (f2cl-lib:fref pi$ ((f2cl-lib:int-sub k 1)) ((1 30)))
607 w2r)))
608 (setf sumar
609 (+ sumar
610 (* (f2cl-lib:fref pr (k) ((1 30)))
611 (f2cl-lib:fref gama (k) ((1 30))))))
612 (setf sumai
613 (+ sumai
614 (* (f2cl-lib:fref pi$ (k) ((1 30)))
615 (f2cl-lib:fref gama (k) ((1 30))))))
616 (setf (f2cl-lib:fref ap (k) ((1 30)))
617 (* (f2cl-lib:fref ap ((f2cl-lib:int-sub k 1)) ((1 30))) aw2))
618 (if (< (f2cl-lib:fref ap (k) ((1 30))) tol) (go label20))
619 label10))
620 (setf k 30)
621 label20
622 (setf kmax k)
623 (setf zetar (- (* w2r sumar) (* w2i sumai)))
624 (setf zetai (+ (* w2r sumai) (* w2i sumar)))
625 (setf argr (* zetar fn23))
626 (setf argi (* zetai fn23))
627 (multiple-value-bind (var-0 var-1 var-2 var-3)
628 (zsqrt$ sumar sumai zar zai)
629 (declare (ignore var-0 var-1))
630 (setf zar var-2)
631 (setf zai var-3))
632 (multiple-value-bind (var-0 var-1 var-2 var-3)
633 (zsqrt$ w2r w2i str sti)
634 (declare (ignore var-0 var-1))
635 (setf str var-2)
636 (setf sti var-3))
637 (setf zeta2r (* str fnu))
638 (setf zeta2i (* sti fnu))
639 (setf str (+ coner (* ex2 (- (* zetar zar) (* zetai zai)))))
640 (setf sti (+ conei (* ex2 (+ (* zetar zai) (* zetai zar)))))
641 (setf zeta1r (- (* str zeta2r) (* sti zeta2i)))
642 (setf zeta1i (+ (* str zeta2i) (* sti zeta2r)))
643 (setf zar (+ zar zar))
644 (setf zai (+ zai zai))
645 (multiple-value-bind (var-0 var-1 var-2 var-3)
646 (zsqrt$ zar zai str sti)
647 (declare (ignore var-0 var-1))
648 (setf str var-2)
649 (setf sti var-3))
650 (setf phir (* str rfn13))
651 (setf phii (* sti rfn13))
652 (if (= ipmtr 1) (go label120))
653 (setf sumbr zeror)
654 (setf sumbi zeroi)
655 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
656 ((> k kmax) nil)
657 (tagbody
658 (setf sumbr
659 (+ sumbr
660 (* (f2cl-lib:fref pr (k) ((1 30)))
661 (f2cl-lib:fref beta (k) ((1 210))))))
662 (setf sumbi
663 (+ sumbi
664 (* (f2cl-lib:fref pi$ (k) ((1 30)))
665 (f2cl-lib:fref beta (k) ((1 210))))))
666 label30))
667 (setf asumr zeror)
668 (setf asumi zeroi)
669 (setf bsumr sumbr)
670 (setf bsumi sumbi)
671 (setf l1 0)
672 (setf l2 30)
673 (setf btol (* tol (+ (abs bsumr) (abs bsumi))))
674 (setf atol tol)
675 (setf pp 1.0)
676 (setf ias 0)
677 (setf ibs 0)
678 (if (< rfnu2 tol) (go label110))
679 (f2cl-lib:fdo (is 2 (f2cl-lib:int-add is 1))
680 ((> is 7) nil)
681 (tagbody
682 (setf atol (/ atol rfnu2))
683 (setf pp (* pp rfnu2))
684 (if (= ias 1) (go label60))
685 (setf sumar zeror)
686 (setf sumai zeroi)
687 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
688 ((> k kmax) nil)
689 (tagbody
690 (setf m (f2cl-lib:int-add l1 k))
691 (setf sumar
692 (+ sumar
693 (* (f2cl-lib:fref pr (k) ((1 30)))
694 (f2cl-lib:fref alfa (m) ((1 180))))))
695 (setf sumai
696 (+ sumai
697 (* (f2cl-lib:fref pi$ (k) ((1 30)))
698 (f2cl-lib:fref alfa (m) ((1 180))))))
699 (if (< (f2cl-lib:fref ap (k) ((1 30))) atol) (go label50))
700 label40))
701 label50
702 (setf asumr (+ asumr (* sumar pp)))
703 (setf asumi (+ asumi (* sumai pp)))
704 (if (< pp tol) (setf ias 1))
705 label60
706 (if (= ibs 1) (go label90))
707 (setf sumbr zeror)
708 (setf sumbi zeroi)
709 (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
710 ((> k kmax) nil)
711 (tagbody
712 (setf m (f2cl-lib:int-add l2 k))
713 (setf sumbr
714 (+ sumbr
715 (* (f2cl-lib:fref pr (k) ((1 30)))
716 (f2cl-lib:fref beta (m) ((1 210))))))
717 (setf sumbi
718 (+ sumbi
719 (* (f2cl-lib:fref pi$ (k) ((1 30)))
720 (f2cl-lib:fref beta (m) ((1 210))))))
721 (if (< (f2cl-lib:fref ap (k) ((1 30))) atol) (go label80))
722 label70))
723 label80
724 (setf bsumr (+ bsumr (* sumbr pp)))
725 (setf bsumi (+ bsumi (* sumbi pp)))
726 (if (< pp btol) (setf ibs 1))
727 label90
728 (if (and (= ias 1) (= ibs 1)) (go label110))
729 (setf l1 (f2cl-lib:int-add l1 30))
730 (setf l2 (f2cl-lib:int-add l2 30))
731 label100))
732 label110
733 (setf asumr (+ asumr coner))
734 (setf pp (* rfnu rfn13))
735 (setf bsumr (* bsumr pp))
736 (setf bsumi (* bsumi pp))
737 label120
738 (go end_label)
739 label130
740 (multiple-value-bind (var-0 var-1 var-2 var-3)
741 (zsqrt$ w2r w2i wr wi)
742 (declare (ignore var-0 var-1))
743 (setf wr var-2)
744 (setf wi var-3))
745 (if (< wr 0.0) (setf wr 0.0))
746 (if (< wi 0.0) (setf wi 0.0))
747 (setf str (+ coner wr))
748 (setf sti wi)
749 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
750 (zdiv str sti zbr zbi zar zai)
751 (declare (ignore var-0 var-1 var-2 var-3))
752 (setf zar var-4)
753 (setf zai var-5))
754 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4)
755 (zlog zar zai zcr zci idum)
756 (declare (ignore var-0 var-1))
757 (setf zcr var-2)
758 (setf zci var-3)
759 (setf idum var-4))
760 (if (< zci 0.0) (setf zci 0.0))
761 (if (> zci hpi) (setf zci hpi))
762 (if (< zcr 0.0) (setf zcr 0.0))
763 (setf zthr (* (- zcr wr) 1.5))
764 (setf zthi (* (- zci wi) 1.5))
765 (setf zeta1r (* zcr fnu))
766 (setf zeta1i (* zci fnu))
767 (setf zeta2r (* wr fnu))
768 (setf zeta2i (* wi fnu))
769 (setf azth (coerce (realpart (zabs zthr zthi)) 'double-float))
770 (setf ang thpi)
771 (if (and (>= zthr 0.0) (< zthi 0.0)) (go label140))
772 (setf ang hpi)
773 (if (= zthr 0.0) (go label140))
774 (setf ang (f2cl-lib:datan (/ zthi zthr)))
775 (if (< zthr 0.0) (setf ang (+ ang gpi)))
776 label140
777 (setf pp (expt azth ex2))
778 (setf ang (* ang ex2))
779 (setf zetar (* pp (cos ang)))
780 (setf zetai (* pp (sin ang)))
781 (if (< zetai 0.0) (setf zetai 0.0))
782 (setf argr (* zetar fn23))
783 (setf argi (* zetai fn23))
784 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
785 (zdiv zthr zthi zetar zetai rtztr rtzti)
786 (declare (ignore var-0 var-1 var-2 var-3))
787 (setf rtztr var-4)
788 (setf rtzti var-5))
789 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
790 (zdiv rtztr rtzti wr wi zar zai)
791 (declare (ignore var-0 var-1 var-2 var-3))
792 (setf zar var-4)
793 (setf zai var-5))
794 (setf tzar (+ zar zar))
795 (setf tzai (+ zai zai))
796 (multiple-value-bind (var-0 var-1 var-2 var-3)
797 (zsqrt$ tzar tzai str sti)
798 (declare (ignore var-0 var-1))
799 (setf str var-2)
800 (setf sti var-3))
801 (setf phir (* str rfn13))
802 (setf phii (* sti rfn13))
803 (if (= ipmtr 1) (go label120))
804 (setf raw (/ 1.0 (f2cl-lib:fsqrt aw2)))
805 (setf str (* wr raw))
806 (setf sti (* (- wi) raw))
807 (setf tfnr (* str rfnu raw))
808 (setf tfni (* sti rfnu raw))
809 (setf razth (/ 1.0 azth))
810 (setf str (* zthr razth))
811 (setf sti (* (- zthi) razth))
812 (setf rzthr (* str razth rfnu))
813 (setf rzthi (* sti razth rfnu))
814 (setf zcr (* rzthr (f2cl-lib:fref ar (2) ((1 14)))))
815 (setf zci (* rzthi (f2cl-lib:fref ar (2) ((1 14)))))
816 (setf raw2 (/ 1.0 aw2))
817 (setf str (* w2r raw2))
818 (setf sti (* (- w2i) raw2))
819 (setf t2r (* str raw2))
820 (setf t2i (* sti raw2))
821 (setf str
822 (+ (* t2r (f2cl-lib:fref c (2) ((1 105))))
823 (f2cl-lib:fref c (3) ((1 105)))))
824 (setf sti (* t2i (f2cl-lib:fref c (2) ((1 105)))))
825 (setf (f2cl-lib:fref upr (2) ((1 14))) (- (* str tfnr) (* sti tfni)))
826 (setf (f2cl-lib:fref upi (2) ((1 14))) (+ (* str tfni) (* sti tfnr)))
827 (setf bsumr (+ (f2cl-lib:fref upr (2) ((1 14))) zcr))
828 (setf bsumi (+ (f2cl-lib:fref upi (2) ((1 14))) zci))
829 (setf asumr zeror)
830 (setf asumi zeroi)
831 (if (< rfnu tol) (go label220))
832 (setf przthr rzthr)
833 (setf przthi rzthi)
834 (setf ptfnr tfnr)
835 (setf ptfni tfni)
836 (setf (f2cl-lib:fref upr (1) ((1 14))) coner)
837 (setf (f2cl-lib:fref upi (1) ((1 14))) conei)
838 (setf pp 1.0)
839 (setf btol (* tol (+ (abs bsumr) (abs bsumi))))
840 (setf ks 0)
841 (setf kp1 2)
842 (setf l 3)
843 (setf ias 0)
844 (setf ibs 0)
845 (f2cl-lib:fdo (lr 2 (f2cl-lib:int-add lr 2))
846 ((> lr 12) nil)
847 (tagbody
848 (setf lrp1 (f2cl-lib:int-add lr 1))
849 (f2cl-lib:fdo (k lr (f2cl-lib:int-add k 1))
850 ((> k lrp1) nil)
851 (tagbody
852 (setf ks (f2cl-lib:int-add ks 1))
853 (setf kp1 (f2cl-lib:int-add kp1 1))
854 (setf l (f2cl-lib:int-add l 1))
855 (setf zar (f2cl-lib:fref c (l) ((1 105))))
856 (setf zai zeroi)
857 (f2cl-lib:fdo (j 2 (f2cl-lib:int-add j 1))
858 ((> j kp1) nil)
859 (tagbody
860 (setf l (f2cl-lib:int-add l 1))
861 (setf str
862 (+ (- (* zar t2r) (* t2i zai))
863 (f2cl-lib:fref c (l) ((1 105)))))
864 (setf zai (+ (* zar t2i) (* zai t2r)))
865 (setf zar str)
866 label150))
867 (setf str (- (* ptfnr tfnr) (* ptfni tfni)))
868 (setf ptfni (+ (* ptfnr tfni) (* ptfni tfnr)))
869 (setf ptfnr str)
870 (setf (f2cl-lib:fref upr (kp1) ((1 14)))
871 (- (* ptfnr zar) (* ptfni zai)))
872 (setf (f2cl-lib:fref upi (kp1) ((1 14)))
873 (+ (* ptfni zar) (* ptfnr zai)))
874 (setf (f2cl-lib:fref crr (ks) ((1 14)))
875 (* przthr
876 (f2cl-lib:fref br
877 ((f2cl-lib:int-add ks 1))
878 ((1 14)))))
879 (setf (f2cl-lib:fref cri (ks) ((1 14)))
880 (* przthi
881 (f2cl-lib:fref br
882 ((f2cl-lib:int-add ks 1))
883 ((1 14)))))
884 (setf str (- (* przthr rzthr) (* przthi rzthi)))
885 (setf przthi (+ (* przthr rzthi) (* przthi rzthr)))
886 (setf przthr str)
887 (setf (f2cl-lib:fref drr (ks) ((1 14)))
888 (* przthr
889 (f2cl-lib:fref ar
890 ((f2cl-lib:int-add ks 2))
891 ((1 14)))))
892 (setf (f2cl-lib:fref dri (ks) ((1 14)))
893 (* przthi
894 (f2cl-lib:fref ar
895 ((f2cl-lib:int-add ks 2))
896 ((1 14)))))
897 label160))
898 (setf pp (* pp rfnu2))
899 (if (= ias 1) (go label180))
900 (setf sumar (f2cl-lib:fref upr (lrp1) ((1 14))))
901 (setf sumai (f2cl-lib:fref upi (lrp1) ((1 14))))
902 (setf ju lrp1)
903 (f2cl-lib:fdo (jr 1 (f2cl-lib:int-add jr 1))
904 ((> jr lr) nil)
905 (tagbody
906 (setf ju (f2cl-lib:int-sub ju 1))
907 (setf sumar
908 (-
909 (+ sumar
910 (* (f2cl-lib:fref crr (jr) ((1 14)))
911 (f2cl-lib:fref upr (ju) ((1 14)))))
912 (* (f2cl-lib:fref cri (jr) ((1 14)))
913 (f2cl-lib:fref upi (ju) ((1 14))))))
914 (setf sumai
915 (+ sumai
916 (* (f2cl-lib:fref crr (jr) ((1 14)))
917 (f2cl-lib:fref upi (ju) ((1 14))))
918 (* (f2cl-lib:fref cri (jr) ((1 14)))
919 (f2cl-lib:fref upr (ju) ((1 14))))))
920 label170))
921 (setf asumr (+ asumr sumar))
922 (setf asumi (+ asumi sumai))
923 (setf test (+ (abs sumar) (abs sumai)))
924 (if (and (< pp tol) (< test tol)) (setf ias 1))
925 label180
926 (if (= ibs 1) (go label200))
927 (setf sumbr
928 (-
929 (+ (f2cl-lib:fref upr ((f2cl-lib:int-add lr 2)) ((1 14)))
930 (* (f2cl-lib:fref upr (lrp1) ((1 14))) zcr))
931 (* (f2cl-lib:fref upi (lrp1) ((1 14))) zci)))
932 (setf sumbi
933 (+ (f2cl-lib:fref upi ((f2cl-lib:int-add lr 2)) ((1 14)))
934 (* (f2cl-lib:fref upr (lrp1) ((1 14))) zci)
935 (* (f2cl-lib:fref upi (lrp1) ((1 14))) zcr)))
936 (setf ju lrp1)
937 (f2cl-lib:fdo (jr 1 (f2cl-lib:int-add jr 1))
938 ((> jr lr) nil)
939 (tagbody
940 (setf ju (f2cl-lib:int-sub ju 1))
941 (setf sumbr
942 (-
943 (+ sumbr
944 (* (f2cl-lib:fref drr (jr) ((1 14)))
945 (f2cl-lib:fref upr (ju) ((1 14)))))
946 (* (f2cl-lib:fref dri (jr) ((1 14)))
947 (f2cl-lib:fref upi (ju) ((1 14))))))
948 (setf sumbi
949 (+ sumbi
950 (* (f2cl-lib:fref drr (jr) ((1 14)))
951 (f2cl-lib:fref upi (ju) ((1 14))))
952 (* (f2cl-lib:fref dri (jr) ((1 14)))
953 (f2cl-lib:fref upr (ju) ((1 14))))))
954 label190))
955 (setf bsumr (+ bsumr sumbr))
956 (setf bsumi (+ bsumi sumbi))
957 (setf test (+ (abs sumbr) (abs sumbi)))
958 (if (and (< pp btol) (< test btol)) (setf ibs 1))
959 label200
960 (if (and (= ias 1) (= ibs 1)) (go label220))
961 label210))
962 label220
963 (setf asumr (+ asumr coner))
964 (setf str (* (- bsumr) rfn13))
965 (setf sti (* (- bsumi) rfn13))
966 (multiple-value-bind (var-0 var-1 var-2 var-3 var-4 var-5)
967 (zdiv str sti rtztr rtzti bsumr bsumi)
968 (declare (ignore var-0 var-1 var-2 var-3))
969 (setf bsumr var-4)
970 (setf bsumi var-5))
971 (go label120)
972 end_label
973 (return
974 (values nil
975 nil
976 nil
977 nil
978 nil
979 phir
980 phii
981 argr
982 argi
983 zeta1r
984 zeta1i
985 zeta2r
986 zeta2i
987 asumr
988 asumi
989 bsumr
990 bsumi)))))
991
992 (in-package #:cl-user)
993 #+#.(cl:if (cl:find-package '#:f2cl) '(and) '(or))
994 (eval-when (:load-toplevel :compile-toplevel :execute)
995 (setf (gethash 'fortran-to-lisp::zunhj fortran-to-lisp::*f2cl-function-info*)
996 (fortran-to-lisp::make-f2cl-finfo
997 :arg-types '((double-float) (double-float) (double-float)
998 (fortran-to-lisp::integer4) (double-float)
999 (double-float) (double-float) (double-float)
1000 (double-float) (double-float) (double-float)
1001 (double-float) (double-float) (double-float)
1002 (double-float) (double-float) (double-float))
1003 :return-values '(nil nil nil nil nil fortran-to-lisp::phir
1004 fortran-to-lisp::phii fortran-to-lisp::argr
1005 fortran-to-lisp::argi fortran-to-lisp::zeta1r
1006 fortran-to-lisp::zeta1i fortran-to-lisp::zeta2r
1007 fortran-to-lisp::zeta2i fortran-to-lisp::asumr
1008 fortran-to-lisp::asumi fortran-to-lisp::bsumr
1009 fortran-to-lisp::bsumi)
1010 :calls '(fortran-to-lisp::zlog fortran-to-lisp::zdiv
1011 fortran-to-lisp::zsqrt$ fortran-to-lisp::zabs
1012 fortran-to-lisp::d1mach))))
1013
Maxima, a Computer Algebra System