Fix bug #4307: partswitch affects op and operatorp
[maxima.git] / src / ellipt.lisp
blob51cb8840e19d33558b12fa04bb6384bb5954ae85
1 ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10-*- ;;;;
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; The data in this file contains enhancements. ;;;;;
4 ;;; ;;;;;
5 ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
6 ;;; All rights reserved ;;;;;
7 ;;; ;;;;;
8 ;;; Copyright (c) 2001 by Raymond Toy. Replaced everything and added ;;;;;
9 ;;; support for symbolic manipulation of all 12 Jacobian elliptic ;;;;;
10 ;;; functions and the complete and incomplete elliptic integral ;;;;;
11 ;;; of the first, second and third kinds. ;;;;;
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 (in-package :maxima)
15 ;;(macsyma-module ellipt)
17 ;;;
18 ;;; Jacobian elliptic functions and elliptic integrals.
19 ;;;
20 ;;; References:
21 ;;;
22 ;;; [1] Abramowitz and Stegun
23 ;;; [2] Lawden, Elliptic Functions and Applications, Springer-Verlag, 1989
24 ;;; [3] Whittaker & Watson, A Course of Modern Analysis
25 ;;;
26 ;;; We use the definitions from Abramowitz and Stegun where our
27 ;;; sn(u,m) is sn(u|m). That is, the second arg is the parameter,
28 ;;; instead of the modulus k or modular angle alpha.
29 ;;;
30 ;;; Note that m = k^2 and k = sin(alpha).
31 ;;;
34 ;; Routines for computing the basic elliptic functions sn, cn, and dn.
37 ;; A&S gives several methods for computing elliptic functions
38 ;; including the AGM method (16.4) and ascending and descending Landen
39 ;; transformations (16.12 and 16.14). The latter are actually quite
40 ;; fast, only requiring simple arithmetic and square roots for the
41 ;; transformation until the last step. The AGM requires evaluation of
42 ;; several trigonometric functions at each stage.
44 ;; However, the Landen transformations appear to have some round-off
45 ;; issues. For example, using the ascending transform to compute cn,
46 ;; cn(100,.7) > 1e10. This is clearly not right since |cn| <= 1.
49 (in-package #:bigfloat)
51 (declaim (inline descending-transform ascending-transform))
53 (defun ascending-transform (u m)
54 ;; A&S 16.14.1
56 ;; Take care in computing this transform. For the case where
57 ;; m is complex, we should compute sqrt(mu1) first as
58 ;; (1-sqrt(m))/(1+sqrt(m)), and then square this to get mu1.
59 ;; If not, we may choose the wrong branch when computing
60 ;; sqrt(mu1).
61 (let* ((root-m (sqrt m))
62 (mu (/ (* 4 root-m)
63 (expt (1+ root-m) 2)))
64 (root-mu1 (/ (- 1 root-m) (+ 1 root-m)))
65 (v (/ u (1+ root-mu1))))
66 (values v mu root-mu1)))
68 (defun descending-transform (u m)
69 ;; Note: Don't calculate mu first, as given in 16.12.1. We
70 ;; should calculate sqrt(mu) = (1-sqrt(m1)/(1+sqrt(m1)), and
71 ;; then compute mu = sqrt(mu)^2. If we calculate mu first,
72 ;; sqrt(mu) loses information when m or m1 is complex.
73 (let* ((root-m1 (sqrt (- 1 m)))
74 (root-mu (/ (- 1 root-m1) (+ 1 root-m1)))
75 (mu (* root-mu root-mu))
76 (v (/ u (1+ root-mu))))
77 (values v mu root-mu)))
80 ;; This appears to work quite well for both real and complex values
81 ;; of u.
82 (defun elliptic-sn-descending (u m)
83 (cond ((= m 1)
84 ;; A&S 16.6.1
85 (tanh u))
86 ((< (abs m) (epsilon u))
87 ;; A&S 16.6.1
88 (sin u))
90 (multiple-value-bind (v mu root-mu)
91 (descending-transform u m)
92 (let* ((new-sn (elliptic-sn-descending v mu)))
93 (/ (* (1+ root-mu) new-sn)
94 (1+ (* root-mu new-sn new-sn))))))))
96 (defun sn (u m)
97 (cond ((zerop m)
98 ;; jacobi_sn(u,0) = sin(u). Should we use A&S 16.13.1 if m
99 ;; is small enough?
101 ;; sn(u,m) = sin(u) - 1/4*m(u-sin(u)*cos(u))*cos(u)
102 (sin u))
103 ((= m 1)
104 ;; jacobi_sn(u,1) = tanh(u). Should we use A&S 16.15.1 if m
105 ;; is close enough to 1?
107 ;; sn(u,m) = tanh(u) + 1/4*(1-m)*(sinh(u)*cosh(u)-u)*sech(u)^2
108 (tanh u))
110 ;; Use the ascending Landen transformation to compute sn.
111 (let ((s (elliptic-sn-descending u m)))
112 (if (and (realp u) (realp m))
113 (realpart s)
114 s)))))
116 (defun dn (u m)
117 (cond ((zerop m)
118 ;; jacobi_dn(u,0) = 1. Should we use A&S 16.13.3 for small m?
120 ;; dn(u,m) = 1 - 1/2*m*sin(u)^2
122 ((= m 1)
123 ;; jacobi_dn(u,1) = sech(u). Should we use A&S 16.15.3 if m
124 ;; is close enough to 1?
126 ;; dn(u,m) = sech(u) + 1/4*(1-m)*(sinh(u)*cosh(u)+u)*tanh(u)*sech(u)
127 (/ (cosh u)))
129 ;; Use the Gauss transformation from
130 ;; http://functions.wolfram.com/09.29.16.0013.01:
133 ;; dn((1+sqrt(m))*z, 4*sqrt(m)/(1+sqrt(m))^2)
134 ;; = (1-sqrt(m)*sn(z, m)^2)/(1+sqrt(m)*sn(z,m)^2)
136 ;; So
138 ;; dn(y, mu) = (1-sqrt(m)*sn(z, m)^2)/(1+sqrt(m)*sn(z,m)^2)
140 ;; where z = y/(1+sqrt(m)) and mu=4*sqrt(m)/(1+sqrt(m))^2.
142 ;; Solve for m, and we get
144 ;; sqrt(m) = -(mu+2*sqrt(1-mu)-2)/mu or (-mu+2*sqrt(1-mu)+2)/mu.
146 ;; I don't think it matters which sqrt we use, so I (rtoy)
147 ;; arbitrarily choose the first one above.
149 ;; Note that (1-sqrt(1-mu))/(1+sqrt(1-mu)) is the same as
150 ;; -(mu+2*sqrt(1-mu)-2)/mu. Also, the former is more
151 ;; accurate for small mu.
152 (let* ((root (let ((root-1-m (sqrt (- 1 m))))
153 (/ (- 1 root-1-m)
154 (+ 1 root-1-m))))
155 (z (/ u (+ 1 root)))
156 (s (elliptic-sn-descending z (* root root)))
157 (p (* root s s )))
158 (/ (- 1 p)
159 (+ 1 p))))))
161 (defun cn (u m)
162 (cond ((zerop m)
163 ;; jacobi_cn(u,0) = cos(u). Should we use A&S 16.13.2 for
164 ;; small m?
166 ;; cn(u,m) = cos(u) + 1/4*m*(u-sin(u)*cos(u))*sin(u)
167 (cos u))
168 ((= m 1)
169 ;; jacobi_cn(u,1) = sech(u). Should we use A&S 16.15.3 if m
170 ;; is close enough to 1?
172 ;; cn(u,m) = sech(u) - 1/4*(1-m)*(sinh(u)*cosh(u)-u)*tanh(u)*sech(u)
173 (/ (cosh u)))
175 ;; Use the ascending Landen transformation, A&S 16.14.3.
176 (multiple-value-bind (v mu root-mu1)
177 (ascending-transform u m)
178 (let ((d (dn v mu)))
179 (* (/ (+ 1 root-mu1) mu)
180 (/ (- (* d d) root-mu1)
181 d)))))))
183 (in-package :maxima)
185 ;; Tell maxima what the derivatives are.
187 ;; Lawden says the derivative wrt to k but that's not what we want.
189 ;; Here's the derivation we used, based on how Lawden get's his results.
191 ;; Let
193 ;; diff(sn(u,m),m) = s
194 ;; diff(cn(u,m),m) = p
195 ;; diff(dn(u,m),m) = q
197 ;; From the derivatives of sn, cn, dn wrt to u, we have
199 ;; diff(sn(u,m),u) = cn(u)*dn(u)
200 ;; diff(cn(u,m),u) = -cn(u)*dn(u)
201 ;; diff(dn(u,m),u) = -m*sn(u)*cn(u)
204 ;; Differentiate these wrt to m:
206 ;; diff(s,u) = p*dn + cn*q
207 ;; diff(p,u) = -p*dn - q*dn
208 ;; diff(q,u) = -sn*cn - m*s*cn - m*sn*q
210 ;; Also recall that
212 ;; sn(u)^2 + cn(u)^2 = 1
213 ;; dn(u)^2 + m*sn(u)^2 = 1
215 ;; Differentiate these wrt to m:
217 ;; sn*s + cn*p = 0
218 ;; 2*dn*q + sn^2 + 2*m*sn*s = 0
220 ;; Thus,
222 ;; p = -s*sn/cn
223 ;; q = -m*s*sn/dn - sn^2/dn/2
225 ;; So
226 ;; diff(s,u) = -s*sn*dn/cn - m*s*sn*cn/dn - sn^2*cn/dn/2
228 ;; or
230 ;; diff(s,u) + s*(sn*dn/cn + m*sn*cn/dn) = -1/2*sn^2*cn/dn
232 ;; diff(s,u) + s*sn/cn/dn*(dn^2 + m*cn^2) = -1/2*sn^2*cn/dn
234 ;; Multiply through by the integrating factor 1/cn/dn:
236 ;; diff(s/cn/dn, u) = -1/2*sn^2/dn^2 = -1/2*sd^2.
238 ;; Integrate this to get
240 ;; s/cn/dn = C + -1/2*int sd^2
242 ;; It can be shown that C is zero.
244 ;; We know that (by differentiating this expression)
246 ;; int dn^2 = (1-m)*u+m*sn*cd + m*(1-m)*int sd^2
248 ;; or
250 ;; int sd^2 = 1/m/(1-m)*int dn^2 - u/m - sn*cd/(1-m)
252 ;; Thus, we get
254 ;; s/cn/dn = u/(2*m) + sn*cd/(2*(1-m)) - 1/2/m/(1-m)*int dn^2
256 ;; or
258 ;; s = 1/(2*m)*u*cn*dn + 1/(2*(1-m))*sn*cn^2 - 1/2/(m*(1-m))*cn*dn*E(u)
260 ;; where E(u) = int dn^2 = elliptic_e(am(u)) = elliptic_e(asin(sn(u)))
262 ;; This is our desired result:
264 ;; s = 1/(2*m)*cn*dn*[u - elliptic_e(asin(sn(u)),m)/(1-m)] + sn*cn^2/2/(1-m)
267 ;; Since diff(cn(u,m),m) = p = -s*sn/cn, we have
269 ;; p = -1/(2*m)*sn*dn[u - elliptic_e(asin(sn(u)),m)/(1-m)] - sn^2*cn/2/(1-m)
271 ;; diff(dn(u,m),m) = q = -m*s*sn/dn - sn^2/dn/2
273 ;; q = -1/2*sn*cn*[u-elliptic_e(asin(sn),m)/(1-m)] - m*sn^2*cn^2/dn/2/(1-m)
275 ;; - sn^2/dn/2
277 ;; = -1/2*sn*cn*[u-elliptic_e(asin(sn),m)/(1-m)] + dn*sn^2/2/(m-1)
279 (defprop %jacobi_sn
280 ((u m)
281 ((mtimes) ((%jacobi_cn) u m) ((%jacobi_dn) u m))
282 ((mplus simp)
283 ((mtimes simp) ((rat simp) 1 2)
284 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
285 ((mexpt simp) ((%jacobi_cn simp) u m) 2) ((%jacobi_sn simp) u m))
286 ((mtimes simp) ((rat simp) 1 2) ((mexpt simp) m -1)
287 ((%jacobi_cn simp) u m) ((%jacobi_dn simp) u m)
288 ((mplus simp) u
289 ((mtimes simp) -1 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
290 ((%elliptic_e simp) ((%asin simp) ((%jacobi_sn simp) u m)) m))))))
291 grad)
293 (defprop %jacobi_cn
294 ((u m)
295 ((mtimes simp) -1 ((%jacobi_sn simp) u m) ((%jacobi_dn simp) u m))
296 ((mplus simp)
297 ((mtimes simp) ((rat simp) -1 2)
298 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
299 ((%jacobi_cn simp) u m) ((mexpt simp) ((%jacobi_sn simp) u m) 2))
300 ((mtimes simp) ((rat simp) -1 2) ((mexpt simp) m -1)
301 ((%jacobi_dn simp) u m) ((%jacobi_sn simp) u m)
302 ((mplus simp) u
303 ((mtimes simp) -1 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
304 ((%elliptic_e simp) ((%asin simp) ((%jacobi_sn simp) u m)) m))))))
305 grad)
307 (defprop %jacobi_dn
308 ((u m)
309 ((mtimes) -1 m ((%jacobi_sn) u m) ((%jacobi_cn) u m))
310 ((mplus simp)
311 ((mtimes simp) ((rat simp) -1 2)
312 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
313 ((%jacobi_dn simp) u m) ((mexpt simp) ((%jacobi_sn simp) u m) 2))
314 ((mtimes simp) ((rat simp) -1 2) ((%jacobi_cn simp) u m)
315 ((%jacobi_sn simp) u m)
316 ((mplus simp) u
317 ((mtimes simp) -1
318 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
319 ((%elliptic_e simp) ((%asin simp) ((%jacobi_sn simp) u m)) m))))))
320 grad)
322 ;; The inverse elliptic functions.
324 ;; F(phi|m) = asn(sin(phi),m)
326 ;; so asn(u,m) = F(asin(u)|m)
327 (defprop %inverse_jacobi_sn
328 ((x m)
329 ;; Lawden 3.1.2:
330 ;; inverse_jacobi_sn(x) = integrate(1/sqrt(1-t^2)/sqrt(1-m*t^2),t,0,x)
331 ;; -> 1/sqrt(1-x^2)/sqrt(1-m*x^2)
332 ((mtimes simp)
333 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))
334 ((rat simp) -1 2))
335 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m ((mexpt simp) x 2)))
336 ((rat simp) -1 2)))
337 ;; diff(F(asin(u)|m),m)
338 ((mtimes simp) ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
339 ((mplus simp)
340 ((mtimes simp) -1 x
341 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))
342 ((rat simp) 1 2))
343 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m ((mexpt simp) x 2)))
344 ((rat simp) -1 2)))
345 ((mtimes simp) ((mexpt simp) m -1)
346 ((mplus simp) ((%elliptic_e simp) ((%asin simp) x) m)
347 ((mtimes simp) -1 ((mplus simp) 1 ((mtimes simp) -1 m))
348 ((%elliptic_f simp) ((%asin simp) x) m)))))))
349 grad)
351 ;; Let u = inverse_jacobi_cn(x). Then jacobi_cn(u) = x or
352 ;; sqrt(1-jacobi_sn(u)^2) = x. Or
354 ;; jacobi_sn(u) = sqrt(1-x^2)
356 ;; So u = inverse_jacobi_sn(sqrt(1-x^2),m) = inverse_jacob_cn(x,m)
358 (defprop %inverse_jacobi_cn
359 ((x m)
360 ;; Whittaker and Watson, 22.121
361 ;; inverse_jacobi_cn(u,m) = integrate(1/sqrt(1-t^2)/sqrt(1-m+m*t^2), t, u, 1)
362 ;; -> -1/sqrt(1-x^2)/sqrt(1-m+m*x^2)
363 ((mtimes simp) -1
364 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))
365 ((rat simp) -1 2))
366 ((mexpt simp)
367 ((mplus simp) 1 ((mtimes simp) -1 m)
368 ((mtimes simp) m ((mexpt simp) x 2)))
369 ((rat simp) -1 2)))
370 ((mtimes simp) ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
371 ((mplus simp)
372 ((mtimes simp) -1
373 ((mexpt simp)
374 ((mplus simp) 1
375 ((mtimes simp) -1 m ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))))
376 ((rat simp) -1 2))
377 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2))) ((rat simp) 1 2))
378 ((mabs simp) x))
379 ((mtimes simp) ((mexpt simp) m -1)
380 ((mplus simp)
381 ((%elliptic_e simp)
382 ((%asin simp)
383 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2))) ((rat simp) 1 2)))
385 ((mtimes simp) -1 ((mplus simp) 1 ((mtimes simp) -1 m))
386 ((%elliptic_f simp)
387 ((%asin simp)
388 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2))) ((rat simp) 1 2)))
389 m)))))))
390 grad)
392 ;; Let u = inverse_jacobi_dn(x). Then
394 ;; jacobi_dn(u) = x or
396 ;; x^2 = jacobi_dn(u)^2 = 1 - m*jacobi_sn(u)^2
398 ;; so jacobi_sn(u) = sqrt(1-x^2)/sqrt(m)
400 ;; or u = inverse_jacobi_sn(sqrt(1-x^2)/sqrt(m))
401 (defprop %inverse_jacobi_dn
402 ((x m)
403 ;; Whittaker and Watson, 22.121
404 ;; inverse_jacobi_dn(u,m) = integrate(1/sqrt(1-t^2)/sqrt(t^2-(1-m)), t, u, 1)
405 ;; -> -1/sqrt(1-x^2)/sqrt(x^2+m-1)
406 ((mtimes simp)
407 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))
408 ((rat simp) -1 2))
409 ((mexpt simp) ((mplus simp) -1 m ((mexpt simp) x 2)) ((rat simp) -1 2)))
410 ((mplus simp)
411 ((mtimes simp) ((rat simp) -1 2) ((mexpt simp) m ((rat simp) -3 2))
412 ((mexpt simp)
413 ((mplus simp) 1
414 ((mtimes simp) -1 ((mexpt simp) m -1)
415 ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))))
416 ((rat simp) -1 2))
417 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))
418 ((rat simp) 1 2))
419 ((mexpt simp) ((mabs simp) x) -1))
420 ((mtimes simp) ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
421 ((mplus simp)
422 ((mtimes simp) -1 ((mexpt simp) m ((rat simp) -1 2))
423 ((mexpt simp)
424 ((mplus simp) 1
425 ((mtimes simp) -1 ((mexpt simp) m -1)
426 ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))))
427 ((rat simp) 1 2))
428 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 ((mexpt simp) x 2)))
429 ((rat simp) 1 2))
430 ((mexpt simp) ((mabs simp) x) -1))
431 ((mtimes simp) ((mexpt simp) m -1)
432 ((mplus simp)
433 ((%elliptic_e simp)
434 ((%asin simp)
435 ((mtimes simp) ((mexpt simp) m ((rat simp) -1 2))
436 ((mexpt simp) ((mplus simp) 1
437 ((mtimes simp) -1 ((mexpt simp) x 2)))
438 ((rat simp) 1 2))))
440 ((mtimes simp) -1 ((mplus simp) 1 ((mtimes simp) -1 m))
441 ((%elliptic_f simp)
442 ((%asin simp)
443 ((mtimes simp) ((mexpt simp) m ((rat simp) -1 2))
444 ((mexpt simp) ((mplus simp) 1
445 ((mtimes simp) -1 ((mexpt simp) x 2)))
446 ((rat simp) 1 2))))
447 m))))))))
448 grad)
451 ;; Possible forms of a complex number:
453 ;; 2.3
454 ;; $%i
455 ;; ((mplus simp) 2.3 ((mtimes simp) 2.3 $%i))
456 ;; ((mplus simp) 2.3 $%i))
457 ;; ((mtimes simp) 2.3 $%i)
461 ;; Is argument u a complex number with real and imagpart satisfying predicate ntypep?
462 (defun complex-number-p (u &optional (ntypep 'numberp))
463 (let ((R 0) (I 0))
464 (labels ((a1 (x) (cadr x))
465 (a2 (x) (caddr x))
466 (a3+ (x) (cdddr x))
467 (N (x) (funcall ntypep x)) ; N
468 (i (x) (and (eq x '$%i) (N 1))) ; %i
469 (N+i (x) (and (null (a3+ x)) ; mplus test is precondition
470 (N (setq R (a1 x)))
471 (or (and (i (a2 x)) (setq I 1) t)
472 (and (mtimesp (a2 x)) (N*i (a2 x))))))
473 (N*i (x) (and (null (a3+ x)) ; mtimes test is precondition
474 (N (setq I (a1 x)))
475 (eq (a2 x) '$%i))))
476 (declare (inline a1 a2 a3+ N i N+i N*i))
477 (cond ((N u) (values t u 0)) ;2.3
478 ((atom u) (if (i u) (values t 0 1))) ;%i
479 ((mplusp u) (if (N+i u) (values t R I))) ;N+%i, N+N*%i
480 ((mtimesp u) (if (N*i u) (values t R I))) ;N*%i
481 (t nil)))))
483 (defun complexify (x)
484 ;; Convert a Lisp number to a maxima number
485 (cond ((realp x) x)
486 ((complexp x) (add (realpart x) (mul '$%i (imagpart x))))
487 (t (merror (intl:gettext "COMPLEXIFY: argument must be a Lisp real or complex number.~%COMPLEXIFY: found: ~:M") x))))
489 (defun kc-arg (exp m)
490 ;; Replace elliptic_kc(m) in the expression with sym. Check to see
491 ;; if the resulting expression is linear in sym and the constant
492 ;; term is zero. If so, return the coefficient of sym, i.e, the
493 ;; coefficient of elliptic_kc(m).
494 (let* ((sym (gensym))
495 (arg (maxima-substitute sym `((%elliptic_kc) ,m) exp)))
496 (if (and (not (equalp arg exp))
497 (linearp arg sym)
498 (zerop1 (coefficient arg sym 0)))
499 (coefficient arg sym 1)
500 nil)))
502 (defun kc-arg2 (exp m)
503 ;; Replace elliptic_kc(m) in the expression with sym. Check to see
504 ;; if the resulting expression is linear in sym and the constant
505 ;; term is zero. If so, return the coefficient of sym, i.e, the
506 ;; coefficient of elliptic_kc(m), and the constant term. Otherwise,
507 ;; return NIL.
508 (let* ((sym (gensym))
509 (arg (maxima-substitute sym `((%elliptic_kc) ,m) exp)))
510 (if (and (not (equalp arg exp))
511 (linearp arg sym))
512 (list (coefficient arg sym 1)
513 (coefficient arg sym 0))
514 nil)))
516 ;; Tell maxima how to simplify the functions
518 (def-simplifier jacobi_sn (u m)
519 (let (coef args)
520 (cond
521 ((float-numerical-eval-p u m)
522 (to (bigfloat::sn (bigfloat:to ($float u)) (bigfloat:to ($float m)))))
523 ((setf args (complex-float-numerical-eval-p u m))
524 (destructuring-bind (u m)
525 args
526 (to (bigfloat::sn (bigfloat:to ($float u)) (bigfloat:to ($float m))))))
527 ((bigfloat-numerical-eval-p u m)
528 (to (bigfloat::sn (bigfloat:to ($bfloat u)) (bigfloat:to ($bfloat m)))))
529 ((setf args (complex-bigfloat-numerical-eval-p u m))
530 (destructuring-bind (u m)
531 args
532 (to (bigfloat::sn (bigfloat:to ($bfloat u)) (bigfloat:to ($bfloat m))))))
533 ((zerop1 u)
534 ;; A&S 16.5.1
536 ((zerop1 m)
537 ;; A&S 16.6.1
538 (ftake '%sin u))
539 ((onep1 m)
540 ;; A&S 16.6.1
541 (ftake '%tanh u))
542 ((and $trigsign (mminusp* u))
543 (neg (ftake* '%jacobi_sn (neg u) m)))
544 ((and $triginverses
545 (listp u)
546 (member (caar u) '(%inverse_jacobi_sn
547 %inverse_jacobi_ns
548 %inverse_jacobi_cn
549 %inverse_jacobi_nc
550 %inverse_jacobi_dn
551 %inverse_jacobi_nd
552 %inverse_jacobi_sc
553 %inverse_jacobi_cs
554 %inverse_jacobi_sd
555 %inverse_jacobi_ds
556 %inverse_jacobi_cd
557 %inverse_jacobi_dc))
558 (alike1 (third u) m))
559 (let ((inv-arg (second u)))
560 (ecase (caar u)
561 (%inverse_jacobi_sn
562 ;; jacobi_sn(inverse_jacobi_sn(u,m), m) = u
563 inv-arg)
564 (%inverse_jacobi_ns
565 ;; inverse_jacobi_ns(u,m) = inverse_jacobi_sn(1/u,m)
566 (div 1 inv-arg))
567 (%inverse_jacobi_cn
568 ;; sn(x)^2 + cn(x)^2 = 1 so sn(x) = sqrt(1-cn(x)^2)
569 (power (sub 1 (mul inv-arg inv-arg)) 1//2))
570 (%inverse_jacobi_nc
571 ;; inverse_jacobi_nc(u) = inverse_jacobi_cn(1/u)
572 (ftake '%jacobi_sn (ftake '%inverse_jacobi_cn (div 1 inv-arg) m)
574 (%inverse_jacobi_dn
575 ;; dn(x)^2 + m*sn(x)^2 = 1 so
576 ;; sn(x) = 1/sqrt(m)*sqrt(1-dn(x)^2)
577 (mul (div 1 (power m 1//2))
578 (power (sub 1 (mul inv-arg inv-arg)) 1//2)))
579 (%inverse_jacobi_nd
580 ;; inverse_jacobi_nd(u) = inverse_jacobi_dn(1/u)
581 (ftake '%jacobi_sn (ftake '%inverse_jacobi_dn (div 1 inv-arg) m)
583 (%inverse_jacobi_sc
584 ;; See below for inverse_jacobi_sc.
585 (div inv-arg (power (add 1 (mul inv-arg inv-arg)) 1//2)))
586 (%inverse_jacobi_cs
587 ;; inverse_jacobi_cs(u) = inverse_jacobi_sc(1/u)
588 (ftake '%jacobi_sn (ftake '%inverse_jacobi_sc (div 1 inv-arg) m)
590 (%inverse_jacobi_sd
591 ;; See below for inverse_jacobi_sd
592 (div inv-arg (power (add 1 (mul m (mul inv-arg inv-arg))) 1//2)))
593 (%inverse_jacobi_ds
594 ;; inverse_jacobi_ds(u) = inverse_jacobi_sd(1/u)
595 (ftake '%jacobi_sn (ftake '%inverse_jacobi_sd (div 1 inv-arg) m)
597 (%inverse_jacobi_cd
598 ;; See below
599 (div (power (sub 1 (mul inv-arg inv-arg)) 1//2)
600 (power (sub 1 (mul m (mul inv-arg inv-arg))) 1//2)))
601 (%inverse_jacobi_dc
602 (ftake '%jacobi_sn (ftake '%inverse_jacobi_cd (div 1 inv-arg) m) m)))))
603 ;; A&S 16.20.1 (Jacobi's Imaginary transformation)
604 ((and $%iargs (multiplep u '$%i))
605 (mul '$%i
606 (ftake* '%jacobi_sc (coeff u '$%i 1) (add 1 (neg m)))))
607 ((setq coef (kc-arg2 u m))
608 ;; sn(m*K+u)
610 ;; A&S 16.8.1
611 (destructuring-bind (lin const)
612 coef
613 (cond ((integerp lin)
614 (ecase (mod lin 4)
616 ;; sn(4*m*K + u) = sn(u), sn(0) = 0
617 (if (zerop1 const)
619 (ftake '%jacobi_sn const m)))
621 ;; sn(4*m*K + K + u) = sn(K+u) = cd(u)
622 ;; sn(K) = 1
623 (if (zerop1 const)
625 (ftake '%jacobi_cd const m)))
627 ;; sn(4*m*K+2*K + u) = sn(2*K+u) = -sn(u)
628 ;; sn(2*K) = 0
629 (if (zerop1 const)
631 (neg (ftake '%jacobi_sn const m))))
633 ;; sn(4*m*K+3*K+u) = sn(2*K + K + u) = -sn(K+u) = -cd(u)
634 ;; sn(3*K) = -1
635 (if (zerop1 const)
637 (neg (ftake '%jacobi_cd const m))))))
638 ((and (alike1 lin 1//2)
639 (zerop1 const))
640 ;; A&S 16.5.2
642 ;; sn(1/2*K) = 1/sqrt(1+sqrt(1-m))
643 (div 1
644 (power (add 1 (power (sub 1 m) 1//2))
645 1//2)))
646 ((and (alike1 lin 3//2)
647 (zerop1 const))
648 ;; A&S 16.5.2
650 ;; sn(1/2*K + K) = cd(1/2*K,m)
651 (ftake '%jacobi_cd (mul 1//2
652 (ftake '%elliptic_kc m))
655 (give-up)))))
657 ;; Nothing to do
658 (give-up)))))
660 (def-simplifier jacobi_cn (u m)
661 (let (coef args)
662 (cond
663 ((float-numerical-eval-p u m)
664 (to (bigfloat::cn (bigfloat:to ($float u)) (bigfloat:to ($float m)))))
665 ((setf args (complex-float-numerical-eval-p u m))
666 (destructuring-bind (u m)
667 args
668 (to (bigfloat::cn (bigfloat:to ($float u)) (bigfloat:to ($float m))))))
669 ((bigfloat-numerical-eval-p u m)
670 (to (bigfloat::cn (bigfloat:to ($bfloat u)) (bigfloat:to ($bfloat m)))))
671 ((setf args (complex-bigfloat-numerical-eval-p u m))
672 (destructuring-bind (u m)
673 args
674 (to (bigfloat::cn (bigfloat:to ($bfloat u)) (bigfloat:to ($bfloat m))))))
675 ((zerop1 u)
676 ;; A&S 16.5.1
678 ((zerop1 m)
679 ;; A&S 16.6.2
680 (ftake '%cos u))
681 ((onep1 m)
682 ;; A&S 16.6.2
683 (ftake '%sech u))
684 ((and $trigsign (mminusp* u))
685 (ftake* '%jacobi_cn (neg u) m))
686 ((and $triginverses
687 (listp u)
688 (member (caar u) '(%inverse_jacobi_sn
689 %inverse_jacobi_ns
690 %inverse_jacobi_cn
691 %inverse_jacobi_nc
692 %inverse_jacobi_dn
693 %inverse_jacobi_nd
694 %inverse_jacobi_sc
695 %inverse_jacobi_cs
696 %inverse_jacobi_sd
697 %inverse_jacobi_ds
698 %inverse_jacobi_cd
699 %inverse_jacobi_dc))
700 (alike1 (third u) m))
701 (cond ((eq (caar u) '%inverse_jacobi_cn)
702 (second u))
704 ;; I'm lazy. Use cn(x) = sqrt(1-sn(x)^2). Hope
705 ;; this is right.
706 (power (sub 1 (power (ftake '%jacobi_sn u (third u)) 2))
707 1//2))))
708 ;; A&S 16.20.2 (Jacobi's Imaginary transformation)
709 ((and $%iargs (multiplep u '$%i))
710 (ftake* '%jacobi_nc (coeff u '$%i 1) (add 1 (neg m))))
711 ((setq coef (kc-arg2 u m))
712 ;; cn(m*K+u)
714 ;; A&S 16.8.2
715 (destructuring-bind (lin const)
716 coef
717 (cond ((integerp lin)
718 (ecase (mod lin 4)
720 ;; cn(4*m*K + u) = cn(u),
721 ;; cn(0) = 1
722 (if (zerop1 const)
724 (ftake '%jacobi_cn const m)))
726 ;; cn(4*m*K + K + u) = cn(K+u) = -sqrt(m1)*sd(u)
727 ;; cn(K) = 0
728 (if (zerop1 const)
730 (neg (mul (power (sub 1 m) 1//2)
731 (ftake '%jacobi_sd const m)))))
733 ;; cn(4*m*K + 2*K + u) = cn(2*K+u) = -cn(u)
734 ;; cn(2*K) = -1
735 (if (zerop1 const)
737 (neg (ftake '%jacobi_cn const m))))
739 ;; cn(4*m*K + 3*K + u) = cn(2*K + K + u) =
740 ;; -cn(K+u) = sqrt(m1)*sd(u)
742 ;; cn(3*K) = 0
743 (if (zerop1 const)
745 (mul (power (sub 1 m) 1//2)
746 (ftake '%jacobi_sd const m))))))
747 ((and (alike1 lin 1//2)
748 (zerop1 const))
749 ;; A&S 16.5.2
750 ;; cn(1/2*K) = (1-m)^(1/4)/sqrt(1+sqrt(1-m))
751 (mul (power (sub 1 m) (div 1 4))
752 (power (add 1
753 (power (sub 1 m)
754 1//2))
755 1//2)))
757 (give-up)))))
759 (give-up)))))
761 (def-simplifier jacobi_dn (u m)
762 (let (coef args)
763 (cond
764 ((float-numerical-eval-p u m)
765 (to (bigfloat::dn (bigfloat:to ($float u)) (bigfloat:to ($float m)))))
766 ((setf args (complex-float-numerical-eval-p u m))
767 (destructuring-bind (u m)
768 args
769 (to (bigfloat::dn (bigfloat:to ($float u)) (bigfloat:to ($float m))))))
770 ((bigfloat-numerical-eval-p u m)
771 (to (bigfloat::dn (bigfloat:to ($bfloat u)) (bigfloat:to ($bfloat m)))))
772 ((setf args (complex-bigfloat-numerical-eval-p u m))
773 (destructuring-bind (u m)
774 args
775 (to (bigfloat::dn (bigfloat:to ($bfloat u)) (bigfloat:to ($bfloat m))))))
776 ((zerop1 u)
777 ;; A&S 16.5.1
779 ((zerop1 m)
780 ;; A&S 16.6.3
782 ((onep1 m)
783 ;; A&S 16.6.3
784 (ftake '%sech u))
785 ((and $trigsign (mminusp* u))
786 (ftake* '%jacobi_dn (neg u) m))
787 ((and $triginverses
788 (listp u)
789 (member (caar u) '(%inverse_jacobi_sn
790 %inverse_jacobi_ns
791 %inverse_jacobi_cn
792 %inverse_jacobi_nc
793 %inverse_jacobi_dn
794 %inverse_jacobi_nd
795 %inverse_jacobi_sc
796 %inverse_jacobi_cs
797 %inverse_jacobi_sd
798 %inverse_jacobi_ds
799 %inverse_jacobi_cd
800 %inverse_jacobi_dc))
801 (alike1 (third u) m))
802 (cond ((eq (caar u) '%inverse_jacobi_dn)
803 ;; jacobi_dn(inverse_jacobi_dn(u,m), m) = u
804 (second u))
806 ;; Express in terms of sn:
807 ;; dn(x) = sqrt(1-m*sn(x)^2)
808 (power (sub 1 (mul m
809 (power (ftake '%jacobi_sn u m) 2)))
810 1//2))))
811 ((zerop1 ($ratsimp (sub u (power (sub 1 m) 1//2))))
812 ;; A&S 16.5.3
813 ;; dn(sqrt(1-m),m) = K(m)
814 (ftake '%elliptic_kc m))
815 ;; A&S 16.20.2 (Jacobi's Imaginary transformation)
816 ((and $%iargs (multiplep u '$%i))
817 (ftake* '%jacobi_dc (coeff u '$%i 1)
818 (add 1 (neg m))))
819 ((setq coef (kc-arg2 u m))
820 ;; A&S 16.8.3
822 ;; dn(m*K+u) has period 2K
824 (destructuring-bind (lin const)
825 coef
826 (cond ((integerp lin)
827 (ecase (mod lin 2)
829 ;; dn(2*m*K + u) = dn(u)
830 ;; dn(0) = 1
831 (if (zerop1 const)
833 ;; dn(4*m*K+2*K + u) = dn(2*K+u) = dn(u)
834 (ftake '%jacobi_dn const m)))
836 ;; dn(2*m*K + K + u) = dn(K + u) = sqrt(1-m)*nd(u)
837 ;; dn(K) = sqrt(1-m)
838 (if (zerop1 const)
839 (power (sub 1 m) 1//2)
840 (mul (power (sub 1 m) 1//2)
841 (ftake '%jacobi_nd const m))))))
842 ((and (alike1 lin 1//2)
843 (zerop1 const))
844 ;; A&S 16.5.2
845 ;; dn(1/2*K) = (1-m)^(1/4)
846 (power (sub 1 m)
847 (div 1 4)))
849 (give-up)))))
850 (t (give-up)))))
852 ;; Should we simplify the inverse elliptic functions into the
853 ;; appropriate incomplete elliptic integral? I think we should leave
854 ;; it, but perhaps allow some way to do that transformation if
855 ;; desired.
857 (def-simplifier inverse_jacobi_sn (u m)
858 (let (args)
859 ;; To numerically evaluate inverse_jacobi_sn (asn), use
861 ;; asn(x,m) = F(asin(x),m)
863 ;; But F(phi,m) = sin(phi)*rf(cos(phi)^2, 1-m*sin(phi)^2,1). Thus
865 ;; asn(x,m) = F(asin(x),m)
866 ;; = x*rf(1-x^2,1-m*x^2,1)
868 ;; I (rtoy) am not 100% about the first identity above for all
869 ;; complex values of x and m, but tests seem to indicate that it
870 ;; produces the correct value as verified by verifying
871 ;; jacobi_sn(inverse_jacobi_sn(x,m),m) = x.
872 (cond ((float-numerical-eval-p u m)
873 (let ((uu (bigfloat:to ($float u)))
874 (mm (bigfloat:to ($float m))))
875 (complexify
876 (* uu
877 (bigfloat::bf-rf (bigfloat:to (- 1 (* uu uu)))
878 (bigfloat:to (- 1 (* mm uu uu)))
879 1)))))
880 ((setf args (complex-float-numerical-eval-p u m))
881 (destructuring-bind (u m)
882 args
883 (let ((uu (bigfloat:to ($float u)))
884 (mm (bigfloat:to ($float m))))
885 (complexify (* uu (bigfloat::bf-rf (- 1 (* uu uu))
886 (- 1 (* mm uu uu))
887 1))))))
888 ((bigfloat-numerical-eval-p u m)
889 (let ((uu (bigfloat:to u))
890 (mm (bigfloat:to m)))
891 (to (bigfloat:* uu
892 (bigfloat::bf-rf (bigfloat:- 1 (bigfloat:* uu uu))
893 (bigfloat:- 1 (bigfloat:* mm uu uu))
894 1)))))
895 ((setf args (complex-bigfloat-numerical-eval-p u m))
896 (destructuring-bind (u m)
897 args
898 (let ((uu (bigfloat:to u))
899 (mm (bigfloat:to m)))
900 (to (bigfloat:* uu
901 (bigfloat::bf-rf (bigfloat:- 1 (bigfloat:* uu uu))
902 (bigfloat:- 1 (bigfloat:* mm uu uu))
903 1))))))
904 ((zerop1 u)
905 ;; asn(0,m) = 0
907 ((onep1 u)
908 ;; asn(1,m) = elliptic_kc(m)
909 (ftake '%elliptic_kc m))
910 ((and (numberp u) (onep1 (- u)))
911 ;; asn(-1,m) = -elliptic_kc(m)
912 (mul -1 (ftake '%elliptic_kc m)))
913 ((zerop1 m)
914 ;; asn(x,0) = F(asin(x),0) = asin(x)
915 (ftake '%asin u))
916 ((onep1 m)
917 ;; asn(x,1) = F(asin(x),1) = log(tan(pi/4+asin(x)/2))
918 (ftake '%elliptic_f (ftake '%asin u) 1))
919 ((and (eq $triginverses '$all)
920 (listp u)
921 (eq (caar u) '%jacobi_sn)
922 (alike1 (third u) m))
923 ;; inverse_jacobi_sn(sn(u)) = u
924 (second u))
926 ;; Nothing to do
927 (give-up)))))
929 (def-simplifier inverse_jacobi_cn (u m)
930 (let (args)
931 (cond ((float-numerical-eval-p u m)
932 ;; Numerically evaluate acn
934 ;; acn(x,m) = F(acos(x),m)
935 (to (elliptic-f (cl:acos ($float u)) ($float m))))
936 ((setf args (complex-float-numerical-eval-p u m))
937 (destructuring-bind (u m)
938 args
939 (to (elliptic-f (cl:acos (bigfloat:to ($float u)))
940 (bigfloat:to ($float m))))))
941 ((bigfloat-numerical-eval-p u m)
942 (to (bigfloat::bf-elliptic-f (bigfloat:acos (bigfloat:to u))
943 (bigfloat:to m))))
944 ((setf args (complex-bigfloat-numerical-eval-p u m))
945 (destructuring-bind (u m)
946 args
947 (to (bigfloat::bf-elliptic-f (bigfloat:acos (bigfloat:to u))
948 (bigfloat:to m)))))
949 ((zerop1 m)
950 ;; asn(x,0) = F(acos(x),0) = acos(x)
951 (ftake '%elliptic_f (ftake '%acos u) 0))
952 ((onep1 m)
953 ;; asn(x,1) = F(asin(x),1) = log(tan(pi/2+asin(x)/2))
954 (ftake '%elliptic_f (ftake '%acos u) 1))
955 ((zerop1 u)
956 (ftake '%elliptic_kc m))
957 ((onep1 u)
959 ((and (eq $triginverses '$all)
960 (listp u)
961 (eq (caar u) '%jacobi_cn)
962 (alike1 (third u) m))
963 ;; inverse_jacobi_cn(cn(u)) = u
964 (second u))
966 ;; Nothing to do
967 (give-up)))))
969 (def-simplifier inverse_jacobi_dn (u m)
970 (let (args)
971 (cond ((float-numerical-eval-p u m)
972 (to (bigfloat::bf-inverse-jacobi-dn (bigfloat:to (float u))
973 (bigfloat:to (float m)))))
974 ((setf args (complex-float-numerical-eval-p u m))
975 (destructuring-bind (u m)
976 args
977 (let ((uu (bigfloat:to ($float u)))
978 (mm (bigfloat:to ($float m))))
979 (to (bigfloat::bf-inverse-jacobi-dn uu mm)))))
980 ((bigfloat-numerical-eval-p u m)
981 (let ((uu (bigfloat:to u))
982 (mm (bigfloat:to m)))
983 (to (bigfloat::bf-inverse-jacobi-dn uu mm))))
984 ((setf args (complex-bigfloat-numerical-eval-p u m))
985 (destructuring-bind (u m)
986 args
987 (to (bigfloat::bf-inverse-jacobi-dn (bigfloat:to u) (bigfloat:to m)))))
988 ((onep1 m)
989 ;; x = dn(u,1) = sech(u). so u = asech(x)
990 (ftake '%asech u))
991 ((onep1 u)
992 ;; jacobi_dn(0,m) = 1
994 ((zerop1 ($ratsimp (sub u (power (sub 1 m) 1//2))))
995 ;; jacobi_dn(K(m),m) = sqrt(1-m) so
996 ;; inverse_jacobi_dn(sqrt(1-m),m) = K(m)
997 (ftake '%elliptic_kc m))
998 ((and (eq $triginverses '$all)
999 (listp u)
1000 (eq (caar u) '%jacobi_dn)
1001 (alike1 (third u) m))
1002 ;; inverse_jacobi_dn(dn(u)) = u
1003 (second u))
1005 ;; Nothing to do
1006 (give-up)))))
1008 ;;;; Elliptic integrals
1010 (let ((errtol (expt (* 4 +flonum-epsilon+) 1/6))
1011 (c1 (float 1/24))
1012 (c2 (float 3/44))
1013 (c3 (float 1/14)))
1014 (declare (type flonum errtol c1 c2 c3))
1015 (defun crf (x y z)
1016 "Compute Carlson's incomplete or complete elliptic integral of the
1017 first kind:
1022 RF(x, y, z) = I ----------------------------------- dt
1023 ] SQRT(x + t) SQRT(y + t) SQRT(z + t)
1027 x, y, and z may be complex.
1029 (declare (number x y z))
1030 (let ((x (coerce x '(complex flonum)))
1031 (y (coerce y '(complex flonum)))
1032 (z (coerce z '(complex flonum))))
1033 (declare (type (complex flonum) x y z))
1034 (loop
1035 (let* ((mu (/ (+ x y z) 3))
1036 (x-dev (- 2 (/ (+ mu x) mu)))
1037 (y-dev (- 2 (/ (+ mu y) mu)))
1038 (z-dev (- 2 (/ (+ mu z) mu))))
1039 (when (< (max (abs x-dev) (abs y-dev) (abs z-dev)) errtol)
1040 (let ((e2 (- (* x-dev y-dev) (* z-dev z-dev)))
1041 (e3 (* x-dev y-dev z-dev)))
1042 (return (/ (+ 1
1043 (* e2 (- (* c1 e2)
1044 1/10
1045 (* c2 e3)))
1046 (* c3 e3))
1047 (sqrt mu)))))
1048 (let* ((x-root (sqrt x))
1049 (y-root (sqrt y))
1050 (z-root (sqrt z))
1051 (lam (+ (* x-root (+ y-root z-root)) (* y-root z-root))))
1052 (setf x (* (+ x lam) 1/4))
1053 (setf y (* (+ y lam) 1/4))
1054 (setf z (* (+ z lam) 1/4))))))))
1056 ;; Elliptic integral of the first kind (Legendre's form):
1059 ;; phi
1060 ;; /
1061 ;; [ 1
1062 ;; I ------------------- ds
1063 ;; ] 2
1064 ;; / SQRT(1 - m SIN (s))
1065 ;; 0
1067 (defun elliptic-f (phi-arg m-arg)
1068 (flet ((base (phi-arg m-arg)
1069 (cond ((and (realp m-arg) (realp phi-arg))
1070 (let ((phi (float phi-arg))
1071 (m (float m-arg)))
1072 (cond ((> m 1)
1073 ;; A&S 17.4.15
1075 ;; F(phi|m) = 1/sqrt(m)*F(theta|1/m)
1077 ;; with sin(theta) = sqrt(m)*sin(phi)
1078 (/ (elliptic-f (cl:asin (* (sqrt m) (sin phi))) (/ m))
1079 (sqrt m)))
1080 ((< m 0)
1081 ;; A&S 17.4.17
1082 (let* ((m (- m))
1083 (m+1 (+ 1 m))
1084 (root (sqrt m+1))
1085 (m/m+1 (/ m m+1)))
1086 (- (/ (elliptic-f (float (/ pi 2)) m/m+1)
1087 root)
1088 (/ (elliptic-f (- (float (/ pi 2)) phi) m/m+1)
1089 root))))
1090 ((= m 0)
1091 ;; A&S 17.4.19
1092 phi)
1093 ((= m 1)
1094 ;; A&S 17.4.21
1096 1 ;; F(phi,1) = log(sec(phi)+tan(phi))
1097 ;; = log(tan(pi/4+pi/2))
1098 (log (cl:tan (+ (/ phi 2) (float (/ pi 4))))))
1099 ((minusp phi)
1100 (- (elliptic-f (- phi) m)))
1101 ((> phi pi)
1102 ;; A&S 17.4.3
1103 (multiple-value-bind (s phi-rem)
1104 (truncate phi (float pi))
1105 (+ (* 2 s (elliptic-k m))
1106 (elliptic-f phi-rem m))))
1107 ((<= phi (/ pi 2))
1108 (let ((sin-phi (sin phi))
1109 (cos-phi (cos phi))
1110 (k (sqrt m)))
1111 (* sin-phi
1112 (bigfloat::bf-rf (* cos-phi cos-phi)
1113 (* (- 1 (* k sin-phi))
1114 (+ 1 (* k sin-phi)))
1115 1.0))))
1116 ((< phi pi)
1117 (+ (* 2 (elliptic-k m))
1118 (elliptic-f (- phi (float pi)) m)))
1120 (error "Shouldn't happen! Unhandled case in elliptic-f: ~S ~S~%"
1121 phi-arg m-arg)))))
1123 (let ((phi (coerce phi-arg '(complex flonum)))
1124 (m (coerce m-arg '(complex flonum))))
1125 (let ((sin-phi (sin phi))
1126 (cos-phi (cos phi))
1127 (k (sqrt m)))
1128 (* sin-phi
1129 (crf (* cos-phi cos-phi)
1130 (* (- 1 (* k sin-phi))
1131 (+ 1 (* k sin-phi)))
1132 1.0))))))))
1133 ;; Elliptic F is quasi-periodic wrt to z:
1135 ;; F(z|m) = F(z - pi*round(Re(z)/pi)|m) + 2*round(Re(z)/pi)*K(m)
1136 (let ((period (round (realpart phi-arg) pi)))
1137 (+ (base (- phi-arg (* pi period)) m-arg)
1138 (if (zerop period)
1140 (* 2 period
1141 (bigfloat:to (elliptic-k m-arg))))))))
1143 ;; Complete elliptic integral of the first kind
1144 (defun elliptic-k (m)
1145 (cond ((realp m)
1146 (cond ((< m 0)
1147 ;; A&S 17.4.17
1148 (let* ((m (- m))
1149 (m+1 (+ 1 m))
1150 (root (sqrt m+1))
1151 (m/m+1 (/ m m+1)))
1152 (- (/ (elliptic-k m/m+1)
1153 root)
1154 (/ (elliptic-f 0.0 m/m+1)
1155 root))))
1156 ((= m 0)
1157 ;; A&S 17.4.19
1158 (float (/ pi 2)))
1159 ((= m 1)
1160 (maxima::merror
1161 (intl:gettext "elliptic_kc: elliptic_kc(1) is undefined.")))
1163 (bigfloat::bf-rf 0.0 (- 1 m)
1164 1.0))))
1166 (bigfloat::bf-rf 0.0 (- 1 m)
1167 1.0))))
1169 ;; Elliptic integral of the second kind (Legendre's form):
1172 ;; phi
1173 ;; /
1174 ;; [ 2
1175 ;; I SQRT(1 - m SIN (s)) ds
1176 ;; ]
1177 ;; /
1178 ;; 0
1180 (defun elliptic-e (phi m)
1181 (declare (type flonum phi m))
1182 (flet ((base (phi m)
1183 (cond ((= m 0)
1184 ;; A&S 17.4.23
1185 phi)
1186 ((= m 1)
1187 ;; A&S 17.4.25
1188 (sin phi))
1190 (let* ((sin-phi (sin phi))
1191 (cos-phi (cos phi))
1192 (k (sqrt m))
1193 (y (* (- 1 (* k sin-phi))
1194 (+ 1 (* k sin-phi)))))
1195 (to (- (* sin-phi
1196 (bigfloat::bf-rf (* cos-phi cos-phi) y 1.0))
1197 (* (/ m 3)
1198 (expt sin-phi 3)
1199 (bigfloat::bf-rd (* cos-phi cos-phi) y 1.0)))))))))
1200 ;; Elliptic E is quasi-periodic wrt to phi:
1202 ;; E(z|m) = E(z - %pi*round(Re(z)/%pi)|m) + 2*round(Re(z)/%pi)*E(m)
1203 (let ((period (round (realpart phi) pi)))
1204 (+ (base (- phi (* pi period)) m)
1205 (* 2 period (elliptic-ec m))))))
1207 ;; Complete version
1208 (defun elliptic-ec (m)
1209 (declare (type flonum m))
1210 (cond ((= m 0)
1211 ;; A&S 17.4.23
1212 (float (/ pi 2)))
1213 ((= m 1)
1214 ;; A&S 17.4.25
1215 1.0)
1217 (let* ((y (- 1 m)))
1218 (to (- (bigfloat::bf-rf 0.0 y 1.0)
1219 (* (/ m 3)
1220 (bigfloat::bf-rd 0.0 y 1.0))))))))
1223 ;; Define the elliptic integrals for maxima
1225 ;; We use the definitions given in A&S 17.2.6 and 17.2.8. In particular:
1227 ;; phi
1228 ;; /
1229 ;; [ 1
1230 ;; F(phi|m) = I ------------------- ds
1231 ;; ] 2
1232 ;; / SQRT(1 - m SIN (s))
1233 ;; 0
1235 ;; and
1237 ;; phi
1238 ;; /
1239 ;; [ 2
1240 ;; E(phi|m) = I SQRT(1 - m SIN (s)) ds
1241 ;; ]
1242 ;; /
1243 ;; 0
1245 ;; That is, we do not use the modular angle, alpha, as the second arg;
1246 ;; the parameter m = sin(alpha)^2 is used.
1250 ;; The derivative of F(phi|m) wrt to phi is easy. The derivative wrt
1251 ;; to m is harder. Here is a derivation. Hope I got it right.
1253 ;; diff(integrate(1/sqrt(1-m*sin(x)^2),x,0,phi), m);
1255 ;; PHI
1256 ;; / 2
1257 ;; [ SIN (x)
1258 ;; I ------------------ dx
1259 ;; ] 2 3/2
1260 ;; / (1 - m SIN (x))
1261 ;; 0
1262 ;; --------------------------
1263 ;; 2
1266 ;; Now use the following relationship that is easily verified:
1268 ;; 2 2
1269 ;; (1 - m) SIN (x) COS (x) COS(x) SIN(x)
1270 ;; ------------------- = ------------------- - DIFF(-------------------, x)
1271 ;; 2 2 2
1272 ;; SQRT(1 - m SIN (x)) SQRT(1 - m SIN (x)) SQRT(1 - m SIN (x))
1275 ;; Now integrate this to get:
1278 ;; PHI
1279 ;; / 2
1280 ;; [ SIN (x)
1281 ;; (1 - m) I ------------------- dx =
1282 ;; ] 2
1283 ;; / SQRT(1 - m SIN (x))
1284 ;; 0
1287 ;; PHI
1288 ;; / 2
1289 ;; [ COS (x)
1290 ;; + I ------------------- dx
1291 ;; ] 2
1292 ;; / SQRT(1 - m SIN (x))
1293 ;; 0
1294 ;; COS(PHI) SIN(PHI)
1295 ;; - ---------------------
1296 ;; 2
1297 ;; SQRT(1 - m SIN (PHI))
1299 ;; Use the fact that cos(x)^2 = 1 - sin(x)^2 to show that this
1300 ;; integral on the RHS is:
1303 ;; (1 - m) elliptic_F(PHI, m) + elliptic_E(PHI, m)
1304 ;; -------------------------------------------
1305 ;; m
1306 ;; So, finally, we have
1310 ;; d
1311 ;; 2 -- (elliptic_F(PHI, m)) =
1312 ;; dm
1314 ;; elliptic_E(PHI, m) - (1 - m) elliptic_F(PHI, m) COS(PHI) SIN(PHI)
1315 ;; ---------------------------------------------- - ---------------------
1316 ;; m 2
1317 ;; SQRT(1 - m SIN (PHI))
1318 ;; ----------------------------------------------------------------------
1319 ;; 1 - m
1321 (defprop %elliptic_f
1322 ((phi m)
1323 ;; diff wrt phi
1324 ;; 1/sqrt(1-m*sin(phi)^2)
1325 ((mexpt simp)
1326 ((mplus simp) 1 ((mtimes simp) -1 m ((mexpt simp) ((%sin simp) phi) 2)))
1327 ((rat simp) -1 2))
1328 ;; diff wrt m
1329 ((mtimes simp) ((rat simp) 1 2)
1330 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
1331 ((mplus simp)
1332 ((mtimes simp) ((mexpt simp) m -1)
1333 ((mplus simp) ((%elliptic_e simp) phi m)
1334 ((mtimes simp) -1 ((mplus simp) 1 ((mtimes simp) -1 m))
1335 ((%elliptic_f simp) phi m))))
1336 ((mtimes simp) -1 ((%cos simp) phi) ((%sin simp) phi)
1337 ((mexpt simp)
1338 ((mplus simp) 1
1339 ((mtimes simp) -1 m ((mexpt simp) ((%sin simp) phi) 2)))
1340 ((rat simp) -1 2))))))
1341 grad)
1344 ;; The derivative of E(phi|m) wrt to m is much simpler to derive than F(phi|m).
1346 ;; Take the derivative of the definition to get
1348 ;; PHI
1349 ;; / 2
1350 ;; [ SIN (x)
1351 ;; I ------------------- dx
1352 ;; ] 2
1353 ;; / SQRT(1 - m SIN (x))
1354 ;; 0
1355 ;; - ---------------------------
1356 ;; 2
1358 ;; It is easy to see that
1360 ;; PHI
1361 ;; / 2
1362 ;; [ SIN (x)
1363 ;; elliptic_F(PHI, m) - m I ------------------- dx = elliptic_E(PHI, m)
1364 ;; ] 2
1365 ;; / SQRT(1 - m SIN (x))
1366 ;; 0
1368 ;; So we finally have
1370 ;; d elliptic_E(PHI, m) - elliptic_F(PHI, m)
1371 ;; -- (elliptic_E(PHI, m)) = ---------------------------------------
1372 ;; dm 2 m
1374 (defprop %elliptic_e
1375 ((phi m)
1376 ;; sqrt(1-m*sin(phi)^2)
1377 ((mexpt simp)
1378 ((mplus simp) 1 ((mtimes simp) -1 m ((mexpt simp) ((%sin simp) phi) 2)))
1379 ((rat simp) 1 2))
1380 ;; diff wrt m
1381 ((mtimes simp) ((rat simp) 1 2) ((mexpt simp) m -1)
1382 ((mplus simp) ((%elliptic_e simp) phi m)
1383 ((mtimes simp) -1 ((%elliptic_f simp) phi m)))))
1384 grad)
1386 (def-simplifier elliptic_f (phi m)
1387 (let (args)
1388 (cond ((float-numerical-eval-p phi m)
1389 ;; Numerically evaluate it
1390 (to (elliptic-f ($float phi) ($float m))))
1391 ((setf args (complex-float-numerical-eval-p phi m))
1392 (destructuring-bind (phi m)
1393 args
1394 (to (elliptic-f (bigfloat:to ($float phi))
1395 (bigfloat:to ($float m))))))
1396 ((bigfloat-numerical-eval-p phi m)
1397 (to (bigfloat::bf-elliptic-f (bigfloat:to ($bfloat phi))
1398 (bigfloat:to ($bfloat m)))))
1399 ((setf args (complex-bigfloat-numerical-eval-p phi m))
1400 (destructuring-bind (phi m)
1401 args
1402 (to (bigfloat::bf-elliptic-f (bigfloat:to ($bfloat phi))
1403 (bigfloat:to ($bfloat m))))))
1404 ((zerop1 phi)
1406 ((zerop1 m)
1407 ;; A&S 17.4.19
1408 phi)
1409 ((onep1 m)
1410 ;; A&S 17.4.21. Let's pick the log tan form. But this
1411 ;; isn't right if we know that abs(phi) > %pi/2, where
1412 ;; elliptic_f is undefined (or infinity).
1413 (cond ((not (eq '$pos (csign (sub ($abs phi) (div '$%pi 2)))))
1414 (ftake '%log
1415 (ftake '%tan
1416 (add (mul '$%pi (div 1 4))
1417 (mul 1//2 phi)))))
1419 (merror (intl:gettext "elliptic_f: elliptic_f(~:M, ~:M) is undefined.")
1420 phi m))))
1421 ((alike1 phi (div '$%pi 2))
1422 ;; Complete elliptic integral
1423 (ftake '%elliptic_kc m))
1425 ;; Nothing to do
1426 (give-up)))))
1428 (def-simplifier elliptic_e (phi m)
1429 (let (args)
1430 (cond ((float-numerical-eval-p phi m)
1431 ;; Numerically evaluate it
1432 (elliptic-e ($float phi) ($float m)))
1433 ((complex-float-numerical-eval-p phi m)
1434 (complexify (bigfloat::bf-elliptic-e (complex ($float ($realpart phi)) ($float ($imagpart phi)))
1435 (complex ($float ($realpart m)) ($float ($imagpart m))))))
1436 ((bigfloat-numerical-eval-p phi m)
1437 (to (bigfloat::bf-elliptic-e (bigfloat:to ($bfloat phi))
1438 (bigfloat:to ($bfloat m)))))
1439 ((setf args (complex-bigfloat-numerical-eval-p phi m))
1440 (destructuring-bind (phi m)
1441 args
1442 (to (bigfloat::bf-elliptic-e (bigfloat:to ($bfloat phi))
1443 (bigfloat:to ($bfloat m))))))
1444 ((zerop1 phi)
1446 ((zerop1 m)
1447 ;; A&S 17.4.23
1448 phi)
1449 ((onep1 m)
1450 ;; A&S 17.4.25, but handle periodicity:
1451 ;; elliptic_e(x,m) = elliptic_e(x-%pi*round(x/%pi), m)
1452 ;; + 2*round(x/%pi)*elliptic_ec(m)
1454 ;; Or
1456 ;; elliptic_e(x,1) = sin(x-%pi*round(x/%pi)) + 2*round(x/%pi)*elliptic_ec(m)
1458 (let ((mult-pi (ftake '%round (div phi '$%pi))))
1459 (add (ftake '%sin (sub phi
1460 (mul '$%pi
1461 mult-pi)))
1462 (mul 2
1463 (mul mult-pi
1464 (ftake '%elliptic_ec m))))))
1465 ((alike1 phi (div '$%pi 2))
1466 ;; Complete elliptic integral
1467 (ftake '%elliptic_ec m))
1468 ((and ($numberp phi)
1469 (let ((r ($round (div phi '$%pi))))
1470 (and ($numberp r)
1471 (not (zerop1 r)))))
1472 ;; Handle the case where phi is a number where we can apply
1473 ;; the periodicity property without blowing up the
1474 ;; expression.
1475 (add (ftake '%elliptic_e
1476 (add phi
1477 (mul (mul -1 '$%pi)
1478 (ftake '%round (div phi '$%pi))))
1480 (mul 2
1481 (mul (ftake '%round (div phi '$%pi))
1482 (ftake '%elliptic_ec m)))))
1484 ;; Nothing to do
1485 (give-up)))))
1487 ;; Complete elliptic integrals
1489 ;; elliptic_kc(m) = elliptic_f(%pi/2, m)
1491 ;; elliptic_ec(m) = elliptic_e(%pi/2, m)
1494 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1496 ;;; We support a simplim%function. The function is looked up in simplimit and
1497 ;;; handles specific values of the function.
1499 (defprop %elliptic_kc simplim%elliptic_kc simplim%function)
1501 (defun simplim%elliptic_kc (expr var val)
1502 ;; Look for the limit of the argument
1503 (let ((m (limit (cadr expr) var val 'think)))
1504 (cond ((onep1 m)
1505 ;; For an argument 1 return $infinity.
1506 '$infinity)
1508 ;; All other cases are handled by the simplifier of the function.
1509 (simplify (list '(%elliptic_kc) m))))))
1511 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1513 (def-simplifier elliptic_kc (m)
1514 (let (args)
1515 (cond ((onep1 m)
1516 ;; elliptic_kc(1) is complex infinity. Maxima can not handle
1517 ;; infinities correctly, throw a Maxima error.
1518 (merror
1519 (intl:gettext "elliptic_kc: elliptic_kc(~:M) is undefined.")
1521 ((float-numerical-eval-p m)
1522 ;; Numerically evaluate it
1523 (to (elliptic-k ($float m))))
1524 ((complex-float-numerical-eval-p m)
1525 (complexify (bigfloat::bf-elliptic-k (complex ($float ($realpart m)) ($float ($imagpart m))))))
1526 ((setf args (complex-bigfloat-numerical-eval-p m))
1527 (destructuring-bind (m)
1528 args
1529 (to (bigfloat::bf-elliptic-k (bigfloat:to ($bfloat m))))))
1530 ((zerop1 m)
1531 (mul 1//2 '$%pi))
1532 ((alike1 m 1//2)
1533 ;; http://functions.wolfram.com/EllipticIntegrals/EllipticK/03/01/
1535 ;; elliptic_kc(1/2) = 8*%pi^(3/2)/gamma(-1/4)^2
1536 (div (mul 8 (power '$%pi (div 3 2)))
1537 (power (gm (div -1 4)) 2)))
1538 ((eql -1 m)
1539 ;; elliptic_kc(-1) = gamma(1/4)^2/(4*sqrt(2*%pi))
1540 (div (power (gm (div 1 4)) 2)
1541 (mul 4 (power (mul 2 '$%pi) 1//2))))
1542 ((alike1 m (add 17 (mul -12 (power 2 1//2))))
1543 ;; elliptic_kc(17-12*sqrt(2)) = 2*(2+sqrt(2))*%pi^(3/2)/gamma(-1/4)^2
1544 (div (mul 2 (mul (add 2 (power 2 1//2))
1545 (power '$%pi (div 3 2))))
1546 (power (gm (div -1 4)) 2)))
1547 ((or (alike1 m (div (add 2 (power 3 1//2))
1549 (alike1 m (add (div (power 3 1//2)
1551 1//2)))
1552 ;; elliptic_kc((sqrt(3)+2)/4) = sqrt(%pi)*gamma(1/3)/gamma(5/6).
1554 ;; First evaluate this integral, where y = sqrt(1+t^3).
1556 ;; integrate(1/y,t,-1,inf) = integrate(1/y,t,-1,0) + integrate(1/y,t,0,inf).
1558 ;; The second integral, maxima gives beta(1/6,1/3)/3.
1560 ;; For the first, we can use the change of variable x=-u^(1/3) to get
1562 ;; integrate(1/sqrt(1-u)/u^(2/3),u,0,1)
1564 ;; which is a beta integral that maxima can evaluate to
1565 ;; beta(1/3,1/2)/3. Then we see the value of the initial
1566 ;; integral is
1568 ;; beta(1/6,1/3)/3 + beta(1/3,1/2)/3
1570 ;; (Thanks to Guilherme Namen for this derivation on the mailing list, 2023-03-09.)
1572 ;; We can simplify this expression by converting to gamma functions:
1574 ;; beta(1/6,1/3)/3 + beta(1/3,1/2)/3 =
1575 ;; (gamma(1/3)*(gamma(1/6)*gamma(5/6)+%pi))/(3*sqrt(%pi)*gamma(5/6));
1577 ;; Using the reflection formula gamma(1-z)*gamma(z) =
1578 ;; %pi/sin(%pi*z), we can write gamma(1/6)*gamma(5/6) =
1579 ;; %pi/sin(%pi*1/6) = 2*%pi. Finally, we have
1581 ;; sqrt(%pi)*gamma(1/3)/gamma(5/6);
1583 ;; All that remains is to show that integrate(1/y,t) can be
1584 ;; written as an inverse_jacobi_cn function with modulus
1585 ;; (sqrt(3)+2)/4.
1587 ;; First apply the substitution
1589 ;; s = (t+sqrt(3)+1)/(t-sqrt(3)+1). We then have the integral
1591 ;; C*integrate(1/sqrt(s^2-1)/sqrt(s^2+4*sqrt(3)+7),s)
1593 ;; where C is some constant. From A&S 14.4.49, we can see
1594 ;; this integral is the inverse_jacobi_nc function with
1595 ;; modulus of (4*sqrt(3)+7)/(4*sqrt(3)+7+1) =
1596 ;; (sqrt(3)+2)/4.
1597 (div (mul (power '$%pi 1//2)
1598 (ftake '%gamma (div 1 3)))
1599 (ftake '%gamma (div 5 6))))
1600 ($hypergeometric_representation
1601 ;; See http://functions.wolfram.com/08.02.26.0001.01
1603 ;; elliptic_kc(z) = %pi/2*%f[2,1]([1/2,1/2],[1], z)
1605 (mul (div '$%pi 2)
1606 (ftake '%hypergeometric
1607 (make-mlist 1//2 1//2)
1608 (make-mlist 1)
1609 m)))
1611 ;; Nothing to do
1612 (give-up)))))
1614 (defprop %elliptic_kc
1615 ((m)
1616 ;; diff wrt m
1617 ((mtimes)
1618 ((rat) 1 2)
1619 ((mplus) ((%elliptic_ec) m)
1620 ((mtimes) -1
1621 ((%elliptic_kc) m)
1622 ((mplus) 1 ((mtimes) -1 m))))
1623 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
1624 ((mexpt) m -1)))
1625 grad)
1627 (def-simplifier elliptic_ec (m)
1628 (let (args)
1629 (cond ((float-numerical-eval-p m)
1630 ;; Numerically evaluate it
1631 (elliptic-ec ($float m)))
1632 ((setf args (complex-float-numerical-eval-p m))
1633 (destructuring-bind (m)
1634 args
1635 (complexify (bigfloat::bf-elliptic-ec (bigfloat:to ($float m))))))
1636 ((setf args (complex-bigfloat-numerical-eval-p m))
1637 (destructuring-bind (m)
1638 args
1639 (to (bigfloat::bf-elliptic-ec (bigfloat:to ($bfloat m))))))
1640 ;; Some special cases we know about.
1641 ((zerop1 m)
1642 (div '$%pi 2))
1643 ((onep1 m)
1645 ((alike1 m 1//2)
1646 ;; elliptic_ec(1/2). Use the identity
1648 ;; elliptic_ec(z)*elliptic_kc(1-z) - elliptic_kc(z)*elliptic_kc(1-z)
1649 ;; + elliptic_ec(1-z)*elliptic_kc(z) = %pi/2;
1651 ;; Let z = 1/2 to get
1653 ;; %pi^(3/2)*'elliptic_ec(1/2)/gamma(3/4)^2-%pi^3/(4*gamma(3/4)^4) = %pi/2
1655 ;; since we know that elliptic_kc(1/2) = %pi^(3/2)/(2*gamma(3/4)^2). Hence
1657 ;; elliptic_ec(1/2)
1658 ;; = (2*%pi*gamma(3/4)^4+%pi^3)/(4*%pi^(3/2)*gamma(3/4)^2)
1659 ;; = gamma(3/4)^2/(2*sqrt(%pi))+%pi^(3/2)/(4*gamma(3/4)^2)
1661 (add (div (power (ftake '%gamma (div 3 4)) 2)
1662 (mul 2 (power '$%pi 1//2)))
1663 (div (power '$%pi (div 3 2))
1664 (mul 4 (power (ftake '%gamma (div 3 4)) 2)))))
1665 ((zerop1 (add 1 m))
1666 ;; elliptic_ec(-1). Use the identity
1667 ;; http://functions.wolfram.com/08.01.17.0002.01
1670 ;; elliptic_ec(z) = sqrt(1 - z)*elliptic_ec(z/(z-1))
1672 ;; Let z = -1 to get
1674 ;; elliptic_ec(-1) = sqrt(2)*elliptic_ec(1/2)
1676 ;; Should we expand out elliptic_ec(1/2) using the above result?
1677 (mul (power 2 1//2)
1678 (ftake '%elliptic_ec 1//2)))
1679 ($hypergeometric_representation
1680 ;; See http://functions.wolfram.com/08.01.26.0001.01
1682 ;; elliptic_ec(z) = %pi/2*%f[2,1]([-1/2,1/2],[1], z)
1684 (mul (div '$%pi 2)
1685 (ftake '%hypergeometric
1686 (make-mlist -1//2 1//2)
1687 (make-mlist 1)
1688 m)))
1690 ;; Nothing to do
1691 (give-up)))))
1693 (defprop %elliptic_ec
1694 ((m)
1695 ((mtimes) ((rat) 1 2)
1696 ((mplus) ((%elliptic_ec) m)
1697 ((mtimes) -1 ((%elliptic_kc)
1698 m)))
1699 ((mexpt) m -1)))
1700 grad)
1703 ;; Elliptic integral of the third kind:
1705 ;; (A&S 17.2.14)
1707 ;; phi
1708 ;; /
1709 ;; [ 1
1710 ;; PI(n;phi|m) = I ----------------------------------- ds
1711 ;; ] 2 2
1712 ;; / SQRT(1 - m SIN (s)) (1 - n SIN (s))
1713 ;; 0
1715 ;; As with E and F, we do not use the modular angle alpha but the
1716 ;; parameter m = sin(alpha)^2.
1718 (def-simplifier elliptic_pi (n phi m)
1719 (let (args)
1720 (cond
1721 ((float-numerical-eval-p n phi m)
1722 ;; Numerically evaluate it
1723 (elliptic-pi ($float n) ($float phi) ($float m)))
1724 ((setf args (complex-float-numerical-eval-p n phi m))
1725 (destructuring-bind (n phi m)
1726 args
1727 (elliptic-pi (bigfloat:to ($float n))
1728 (bigfloat:to ($float phi))
1729 (bigfloat:to ($float m)))))
1730 ((bigfloat-numerical-eval-p n phi m)
1731 (to (bigfloat::bf-elliptic-pi (bigfloat:to n)
1732 (bigfloat:to phi)
1733 (bigfloat:to m))))
1734 ((setq args (complex-bigfloat-numerical-eval-p n phi m))
1735 (destructuring-bind (n phi m)
1736 args
1737 (to (bigfloat::bf-elliptic-pi (bigfloat:to n)
1738 (bigfloat:to phi)
1739 (bigfloat:to m)))))
1740 ((zerop1 n)
1741 (ftake '%elliptic_f phi m))
1742 ((zerop1 m)
1743 ;; 3 cases depending on n < 1, n > 1, or n = 1.
1744 (let ((s (asksign (add -1 n))))
1745 (case s
1746 ($positive
1747 (div (ftake '%atanh (mul (power (add n -1) 1//2)
1748 (ftake '%tan phi)))
1749 (power (add n -1) 1//2)))
1750 ($negative
1751 (div (ftake '%atan (mul (power (sub 1 n) 1//2)
1752 (ftake '%tan phi)))
1753 (power (sub 1 n) 1//2)))
1754 ($zero
1755 (ftake '%tan phi)))))
1757 ;; Nothing to do
1758 (give-up)))))
1760 ;; Complete elliptic-pi. That is phi = %pi/2. Then
1761 ;; elliptic_pi(n,m)
1762 ;; = Rf(0, 1-m,1) + Rj(0,1-m,1-n)*n/3;
1763 (defun elliptic-pi-complete (n m)
1764 (to (bigfloat:+ (bigfloat::bf-rf 0 (- 1 m) 1)
1765 (bigfloat:* 1/3 n (bigfloat::bf-rj 0 (- 1 m) 1 (- 1 n))))))
1767 ;; To compute elliptic_pi for all z, we use the property
1768 ;; (http://functions.wolfram.com/08.06.16.0002.01)
1770 ;; elliptic_pi(n, z + %pi*k, m)
1771 ;; = 2*k*elliptic_pi(n, %pi/2, m) + elliptic_pi(n, z, m)
1773 ;; So we are left with computing the integral for 0 <= z < %pi. Using
1774 ;; Carlson's formulation produces the wrong values for %pi/2 < z <
1775 ;; %pi. How to do that?
1777 ;; Let
1779 ;; I(a,b) = integrate(1/(1-n*sin(x)^2)/sqrt(1 - m*sin(x)^2), x, a, b)
1781 ;; That is, I(a,b) is the integral for the elliptic_pi function but
1782 ;; with a lower limit of a and an upper limit of b.
1784 ;; Then, we want to compute I(0, z), with %pi <= z < %pi. Let w = z +
1785 ;; %pi/2, 0 <= w < %pi/2. Then
1787 ;; I(0, w+%pi/2) = I(0, %pi/2) + I(%pi/2, w+%pi/2)
1789 ;; To evaluate I(%pi/2, w+%pi/2), use a change of variables:
1791 ;; changevar('integrate(1/(1-n*sin(x)^2)/sqrt(1 - m*sin(x)^2), x, %pi/2, w + %pi/2),
1792 ;; x-%pi+u,u,x)
1794 ;; = integrate(-1/(sqrt(1-m*sin(u)^2)*(1-n*sin(u)^2)),u,%pi/2-w,%pi/2)
1795 ;; = I(%pi/2-w,%pi/2)
1796 ;; = I(0,%pi/2) - I(0,%pi/2-w)
1798 ;; Thus,
1800 ;; I(0,%pi/2+w) = 2*I(0,%pi/2) - I(0,%pi/2-w)
1802 ;; This allows us to compute the general result with 0 <= z < %pi
1804 ;; I(0, k*%pi + z) = 2*k*I(0,%pi/2) + I(0,z);
1806 ;; If 0 <= z < %pi/2, then the we are done. If %pi/2 <= z < %pi, let
1807 ;; z = w+%pi/2. Then
1809 ;; I(0,z) = 2*I(0,%pi/2) - I(0,%pi/2-w)
1811 ;; Or, since w = z-%pi/2:
1813 ;; I(0,z) = 2*I(0,%pi/2) - I(0,%pi-z)
1815 (defun elliptic-pi (n phi m)
1816 ;; elliptic_pi(n, -phi, m) = -elliptic_pi(n, phi, m). That is, it
1817 ;; is an odd function of phi.
1818 (when (minusp (realpart phi))
1819 (return-from elliptic-pi (- (elliptic-pi n (- phi) m))))
1821 ;; Note: Carlson's DRJ has n defined as the negative of the n given
1822 ;; in A&S.
1823 (flet ((base (n phi m)
1824 ;; elliptic_pi(n,phi,m) =
1825 ;; sin(phi)*Rf(cos(phi)^2, 1-m*sin(phi)^2, 1)
1826 ;; - (-n / 3) * sin(phi)^3
1827 ;; * Rj(cos(phi)^2, 1-m*sin(phi)^2, 1, 1-n*sin(phi)^2)
1828 (let* ((nn (- n))
1829 (sin-phi (sin phi))
1830 (cos-phi (cos phi))
1831 (k (sqrt m))
1832 (k2sin (* (- 1 (* k sin-phi))
1833 (+ 1 (* k sin-phi)))))
1834 (- (* sin-phi (bigfloat::bf-rf (expt cos-phi 2) k2sin 1.0))
1835 (* (/ nn 3) (expt sin-phi 3)
1836 (bigfloat::bf-rj (expt cos-phi 2) k2sin 1.0
1837 (- 1 (* n (expt sin-phi 2)))))))))
1838 ;; FIXME: Reducing the arg by pi has significant round-off.
1839 ;; Consider doing something better.
1840 (let* ((cycles (round (realpart phi) pi))
1841 (rem (- phi (* cycles pi))))
1842 (let ((complete (elliptic-pi-complete n m)))
1843 (to (+ (* 2 cycles complete)
1844 (base n rem m)))))))
1846 ;;; Deriviatives from functions.wolfram.com
1847 ;;; http://functions.wolfram.com/EllipticIntegrals/EllipticPi3/20/
1848 (defprop %elliptic_pi
1849 ((n z m)
1850 ;Derivative wrt first argument
1851 ((mtimes) ((rat) 1 2)
1852 ((mexpt) ((mplus) m ((mtimes) -1 n)) -1)
1853 ((mexpt) ((mplus) -1 n) -1)
1854 ((mplus)
1855 ((mtimes) ((mexpt) n -1)
1856 ((mplus) ((mtimes) -1 m) ((mexpt) n 2))
1857 ((%elliptic_pi) n z m))
1858 ((%elliptic_e) z m)
1859 ((mtimes) ((mplus) m ((mtimes) -1 n)) ((mexpt) n -1)
1860 ((%elliptic_f) z m))
1861 ((mtimes) ((rat) -1 2) n
1862 ((mexpt)
1863 ((mplus) 1 ((mtimes) -1 m ((mexpt) ((%sin) z) 2)))
1864 ((rat) 1 2))
1865 ((mexpt)
1866 ((mplus) 1 ((mtimes) -1 n ((mexpt) ((%sin) z) 2)))
1868 ((%sin) ((mtimes) 2 z)))))
1869 ;derivative wrt second argument
1870 ((mtimes)
1871 ((mexpt)
1872 ((mplus) 1 ((mtimes) -1 m ((mexpt) ((%sin) z) 2)))
1873 ((rat) -1 2))
1874 ((mexpt)
1875 ((mplus) 1 ((mtimes) -1 n ((mexpt) ((%sin) z) 2))) -1))
1876 ;Derivative wrt third argument
1877 ((mtimes) ((rat) 1 2)
1878 ((mexpt) ((mplus) ((mtimes) -1 m) n) -1)
1879 ((mplus) ((%elliptic_pi) n z m)
1880 ((mtimes) ((mexpt) ((mplus) -1 m) -1)
1881 ((%elliptic_e) z m))
1882 ((mtimes) ((rat) -1 2) ((mexpt) ((mplus) -1 m) -1) m
1883 ((mexpt)
1884 ((mplus) 1 ((mtimes) -1 m ((mexpt) ((%sin) z) 2)))
1885 ((rat) -1 2))
1886 ((%sin) ((mtimes) 2 z))))))
1887 grad)
1889 (in-package #:bigfloat)
1890 ;; Translation of Jim FitzSimons' bigfloat implementation of elliptic
1891 ;; integrals from http://www.getnet.com/~cherry/elliptbf3.mac.
1893 ;; The algorithms are based on B.C. Carlson's "Numerical Computation
1894 ;; of Real or Complex Elliptic Integrals". These are updated to the
1895 ;; algorithms in Journal of Computational and Applied Mathematics 118
1896 ;; (2000) 71-85 "Reduction Theorems for Elliptic Integrands with the
1897 ;; Square Root of two quadritic factors"
1900 ;; NOTE: Despite the names indicating these are for bigfloat numbers,
1901 ;; the algorithms and routines are generic and will work with floats
1902 ;; and bigfloats.
1904 (defun bferrtol (&rest args)
1905 ;; Compute error tolerance as sqrt(2^(-fpprec)). Not sure this is
1906 ;; quite right, but it makes the routines more accurate as fpprec
1907 ;; increases.
1908 (sqrt (reduce #'min (mapcar #'(lambda (x)
1909 (if (rationalp (realpart x))
1910 maxima::+flonum-epsilon+
1911 (epsilon x)))
1912 args))))
1914 ;; rc(x,y) = integrate(1/2*(t+x)^(-1/2)/(t+y), t, 0, inf)
1916 ;; log(x) = (x-1)*rc(((1+x)/2)^2, x), x > 0
1917 ;; asin(x) = x * rc(1-x^2, 1), |x|<= 1
1918 ;; acos(x) = sqrt(1-x^2)*rc(x^2,1), 0 <= x <=1
1919 ;; atan(x) = x * rc(1,1+x^2)
1920 ;; asinh(x) = x * rc(1+x^2,1)
1921 ;; acosh(x) = sqrt(x^2-1) * rc(x^2,1), x >= 1
1922 ;; atanh(x) = x * rc(1,1-x^2), |x|<=1
1924 (defun bf-rc (x y)
1925 (let ((yn y)
1926 xn z w a an pwr4 n epslon lambda sn s)
1927 (cond ((and (zerop (imagpart yn))
1928 (minusp (realpart yn)))
1929 (setf xn (- x y))
1930 (setf yn (- yn))
1931 (setf z yn)
1932 (setf w (sqrt (/ x xn))))
1934 (setf xn x)
1935 (setf z yn)
1936 (setf w 1)))
1937 (setf a (/ (+ xn yn yn) 3))
1938 (setf epslon (/ (abs (- a xn)) (bferrtol x y)))
1939 (setf an a)
1940 (setf pwr4 1)
1941 (setf n 0)
1942 (loop while (> (* epslon pwr4) (abs an))
1944 (setf pwr4 (/ pwr4 4))
1945 (setf lambda (+ (* 2 (sqrt xn) (sqrt yn)) yn))
1946 (setf an (/ (+ an lambda) 4))
1947 (setf xn (/ (+ xn lambda) 4))
1948 (setf yn (/ (+ yn lambda) 4))
1949 (incf n))
1950 ;; c2=3/10,c3=1/7,c4=3/8,c5=9/22,c6=159/208,c7=9/8
1951 (setf sn (/ (* pwr4 (- z a)) an))
1952 (setf s (* sn sn (+ 3/10
1953 (* sn (+ 1/7
1954 (* sn (+ 3/8
1955 (* sn (+ 9/22
1956 (* sn (+ 159/208
1957 (* sn 9/8))))))))))))
1958 (/ (* w (+ 1 s))
1959 (sqrt an))))
1963 ;; See https://dlmf.nist.gov/19.16.E5:
1965 ;; rd(x,y,z) = integrate(3/2/sqrt(t+x)/sqrt(t+y)/sqrt(t+z)/(t+z), t, 0, inf)
1967 ;; rd(1,1,1) = 1
1968 ;; E(K) = rf(0, 1-K^2, 1) - (K^2/3)*rd(0,1-K^2,1)
1970 ;; B = integrate(s^2/sqrt(1-s^4), s, 0 ,1)
1971 ;; = beta(3/4,1/2)/4
1972 ;; = sqrt(%pi)*gamma(3/4)/gamma(1/4)
1973 ;; = 1/3*rd(0,2,1)
1975 (defun bf-rd (x y z)
1976 (let* ((xn x)
1977 (yn y)
1978 (zn z)
1979 (a (/ (+ xn yn (* 3 zn)) 5))
1980 (epslon (/ (max (abs (- a xn))
1981 (abs (- a yn))
1982 (abs (- a zn)))
1983 (bferrtol x y z)))
1984 (an a)
1985 (sigma 0)
1986 (power4 1)
1987 (n 0)
1988 xnroot ynroot znroot lam)
1989 (loop while (> (* power4 epslon) (abs an))
1991 (setf xnroot (sqrt xn))
1992 (setf ynroot (sqrt yn))
1993 (setf znroot (sqrt zn))
1994 (setf lam (+ (* xnroot ynroot)
1995 (* xnroot znroot)
1996 (* ynroot znroot)))
1997 (setf sigma (+ sigma (/ power4
1998 (* znroot (+ zn lam)))))
1999 (setf power4 (* power4 1/4))
2000 (setf xn (* (+ xn lam) 1/4))
2001 (setf yn (* (+ yn lam) 1/4))
2002 (setf zn (* (+ zn lam) 1/4))
2003 (setf an (* (+ an lam) 1/4))
2004 (incf n))
2005 ;; c1=-3/14,c2=1/6,c3=9/88,c4=9/22,c5=-3/22,c6=-9/52,c7=3/26
2006 (let* ((xndev (/ (* (- a x) power4) an))
2007 (yndev (/ (* (- a y) power4) an))
2008 (zndev (- (* (+ xndev yndev) 1/3)))
2009 (ee2 (- (* xndev yndev) (* 6 zndev zndev)))
2010 (ee3 (* (- (* 3 xndev yndev)
2011 (* 8 zndev zndev))
2012 zndev))
2013 (ee4 (* 3 (- (* xndev yndev) (* zndev zndev)) zndev zndev))
2014 (ee5 (* xndev yndev zndev zndev zndev))
2015 (s (+ 1
2016 (* -3/14 ee2)
2017 (* 1/6 ee3)
2018 (* 9/88 ee2 ee2)
2019 (* -3/22 ee4)
2020 (* -9/52 ee2 ee3)
2021 (* 3/26 ee5)
2022 (* -1/16 ee2 ee2 ee2)
2023 (* 3/10 ee3 ee3)
2024 (* 3/20 ee2 ee4)
2025 (* 45/272 ee2 ee2 ee3)
2026 (* -9/68 (+ (* ee2 ee5) (* ee3 ee4))))))
2027 (+ (* 3 sigma)
2028 (/ (* power4 s)
2029 (expt an 3/2))))))
2031 ;; See https://dlmf.nist.gov/19.16.E1
2033 ;; rf(x,y,z) = 1/2*integrate(1/(sqrt(t+x)*sqrt(t+y)*sqrt(t+z)), t, 0, inf);
2035 ;; rf(1,1,1) = 1
2036 (defun bf-rf (x y z)
2037 (let* ((xn x)
2038 (yn y)
2039 (zn z)
2040 (a (/ (+ xn yn zn) 3))
2041 (epslon (/ (max (abs (- a xn))
2042 (abs (- a yn))
2043 (abs (- a zn)))
2044 (bferrtol x y z)))
2045 (an a)
2046 (power4 1)
2047 (n 0)
2048 xnroot ynroot znroot lam)
2049 (loop while (> (* power4 epslon) (abs an))
2051 (setf xnroot (sqrt xn))
2052 (setf ynroot (sqrt yn))
2053 (setf znroot (sqrt zn))
2054 (setf lam (+ (* xnroot ynroot)
2055 (* xnroot znroot)
2056 (* ynroot znroot)))
2057 (setf power4 (* power4 1/4))
2058 (setf xn (* (+ xn lam) 1/4))
2059 (setf yn (* (+ yn lam) 1/4))
2060 (setf zn (* (+ zn lam) 1/4))
2061 (setf an (* (+ an lam) 1/4))
2062 (incf n))
2063 ;; c1=-3/14,c2=1/6,c3=9/88,c4=9/22,c5=-3/22,c6=-9/52,c7=3/26
2064 (let* ((xndev (/ (* (- a x) power4) an))
2065 (yndev (/ (* (- a y) power4) an))
2066 (zndev (- (+ xndev yndev)))
2067 (ee2 (- (* xndev yndev) (* 6 zndev zndev)))
2068 (ee3 (* xndev yndev zndev))
2069 (s (+ 1
2070 (* -1/10 ee2)
2071 (* 1/14 ee3)
2072 (* 1/24 ee2 ee2)
2073 (* -3/44 ee2 ee3))))
2074 (/ s (sqrt an)))))
2076 (defun bf-rj1 (x y z p)
2077 (let* ((xn x)
2078 (yn y)
2079 (zn z)
2080 (pn p)
2081 (en (* (- pn xn)
2082 (- pn yn)
2083 (- pn zn)))
2084 (sigma 0)
2085 (power4 1)
2086 (k 0)
2087 (a (/ (+ xn yn zn pn pn) 5))
2088 (epslon (/ (max (abs (- a xn))
2089 (abs (- a yn))
2090 (abs (- a zn))
2091 (abs (- a pn)))
2092 (bferrtol x y z p)))
2093 (an a)
2094 xnroot ynroot znroot pnroot lam dn)
2095 (loop while (> (* power4 epslon) (abs an))
2097 (setf xnroot (sqrt xn))
2098 (setf ynroot (sqrt yn))
2099 (setf znroot (sqrt zn))
2100 (setf pnroot (sqrt pn))
2101 (setf lam (+ (* xnroot ynroot)
2102 (* xnroot znroot)
2103 (* ynroot znroot)))
2104 (setf dn (* (+ pnroot xnroot)
2105 (+ pnroot ynroot)
2106 (+ pnroot znroot)))
2107 (setf sigma (+ sigma
2108 (/ (* power4
2109 (bf-rc 1 (+ 1 (/ en (* dn dn)))))
2110 dn)))
2111 (setf power4 (* power4 1/4))
2112 (setf en (/ en 64))
2113 (setf xn (* (+ xn lam) 1/4))
2114 (setf yn (* (+ yn lam) 1/4))
2115 (setf zn (* (+ zn lam) 1/4))
2116 (setf pn (* (+ pn lam) 1/4))
2117 (setf an (* (+ an lam) 1/4))
2118 (incf k))
2119 (let* ((xndev (/ (* (- a x) power4) an))
2120 (yndev (/ (* (- a y) power4) an))
2121 (zndev (/ (* (- a z) power4) an))
2122 (pndev (* -0.5 (+ xndev yndev zndev)))
2123 (ee2 (+ (* xndev yndev)
2124 (* xndev zndev)
2125 (* yndev zndev)
2126 (* -3 pndev pndev)))
2127 (ee3 (+ (* xndev yndev zndev)
2128 (* 2 ee2 pndev)
2129 (* 4 pndev pndev pndev)))
2130 (ee4 (* (+ (* 2 xndev yndev zndev)
2131 (* ee2 pndev)
2132 (* 3 pndev pndev pndev))
2133 pndev))
2134 (ee5 (* xndev yndev zndev pndev pndev))
2135 (s (+ 1
2136 (* -3/14 ee2)
2137 (* 1/6 ee3)
2138 (* 9/88 ee2 ee2)
2139 (* -3/22 ee4)
2140 (* -9/52 ee2 ee3)
2141 (* 3/26 ee5)
2142 (* -1/16 ee2 ee2 ee2)
2143 (* 3/10 ee3 ee3)
2144 (* 3/20 ee2 ee4)
2145 (* 45/272 ee2 ee2 ee3)
2146 (* -9/68 (+ (* ee2 ee5) (* ee3 ee4))))))
2147 (+ (* 6 sigma)
2148 (/ (* power4 s)
2149 (sqrt (* an an an)))))))
2151 (defun bf-rj (x y z p)
2152 (let* ((xn x)
2153 (yn y)
2154 (zn z)
2155 (qn (- p)))
2156 (cond ((and (and (zerop (imagpart xn)) (>= (realpart xn) 0))
2157 (and (zerop (imagpart yn)) (>= (realpart yn) 0))
2158 (and (zerop (imagpart zn)) (>= (realpart zn) 0))
2159 (and (zerop (imagpart qn)) (> (realpart qn) 0)))
2160 (destructuring-bind (xn yn zn)
2161 (sort (list xn yn zn) #'<)
2162 (let* ((pn (+ yn (* (- zn yn) (/ (- yn xn) (+ yn qn)))))
2163 (s (- (* (- pn yn) (bf-rj1 xn yn zn pn))
2164 (* 3 (bf-rf xn yn zn)))))
2165 (setf s (+ s (* 3 (sqrt (/ (* xn yn zn)
2166 (+ (* xn zn) (* pn qn))))
2167 (bf-rc (+ (* xn zn) (* pn qn)) (* pn qn)))))
2168 (/ s (+ yn qn)))))
2170 (bf-rj1 x y z p)))))
2172 (defun bf-rg (x y z)
2173 (* 0.5
2174 (+ (* z (bf-rf x y z))
2175 (* (- z x)
2176 (- y z)
2177 (bf-rd x y z)
2178 1/3)
2179 (sqrt (/ (* x y) z)))))
2181 ;; elliptic_f(phi,m) = sin(phi)*rf(cos(phi)^2, 1-m*sin(phi)^2,1)
2182 (defun bf-elliptic-f (phi m)
2183 (flet ((base (phi m)
2184 (cond ((= m 1)
2185 ;; F(z|1) = log(tan(z/2+%pi/4))
2186 (log (tan (+ (/ phi 2) (/ (%pi phi) 4)))))
2188 (let ((s (sin phi))
2189 (c (cos phi)))
2190 (* s (bf-rf (* c c) (- 1 (* m s s)) 1)))))))
2191 ;; Handle periodicity (see elliptic-f)
2192 (let* ((bfpi (%pi phi))
2193 (period (round (realpart phi) bfpi)))
2194 (+ (base (- phi (* bfpi period)) m)
2195 (if (zerop period)
2197 (* 2 period (bf-elliptic-k m)))))))
2199 ;; elliptic_kc(k) = rf(0, 1-k^2,1)
2201 ;; or
2202 ;; elliptic_kc(m) = rf(0, 1-m,1)
2204 (defun bf-elliptic-k (m)
2205 (cond ((= m 0)
2206 (if (maxima::$bfloatp m)
2207 (maxima::$bfloat (maxima::div 'maxima::$%pi 2))
2208 (float (/ pi 2) 1e0)))
2209 ((= m 1)
2210 (maxima::merror
2211 (intl:gettext "elliptic_kc: elliptic_kc(1) is undefined.")))
2213 (bf-rf 0 (- 1 m) 1))))
2215 ;; elliptic_e(phi, k) = sin(phi)*rf(cos(phi)^2,1-k^2*sin(phi)^2,1)
2216 ;; - (k^2/3)*sin(phi)^3*rd(cos(phi)^2, 1-k^2*sin(phi)^2,1)
2219 ;; or
2220 ;; elliptic_e(phi, m) = sin(phi)*rf(cos(phi)^2,1-m*sin(phi)^2,1)
2221 ;; - (m/3)*sin(phi)^3*rd(cos(phi)^2, 1-m*sin(phi)^2,1)
2223 (defun bf-elliptic-e (phi m)
2224 (flet ((base (phi m)
2225 (let* ((s (sin phi))
2226 (c (cos phi))
2227 (c2 (* c c))
2228 (s2 (- 1 (* m s s))))
2229 (- (* s (bf-rf c2 s2 1))
2230 (* (/ m 3) (* s s s) (bf-rd c2 s2 1))))))
2231 ;; Elliptic E is quasi-periodic wrt to phi:
2233 ;; E(z|m) = E(z - %pi*round(Re(z)/%pi)|m) + 2*round(Re(z)/%pi)*E(m)
2234 (let* ((bfpi (%pi phi))
2235 (period (round (realpart phi) bfpi)))
2236 (+ (base (- phi (* bfpi period)) m)
2237 (* 2 period (bf-elliptic-ec m))))))
2240 ;; elliptic_ec(k) = rf(0,1-k^2,1) - (k^2/3)*rd(0,1-k^2,1);
2242 ;; or
2243 ;; elliptic_ec(m) = rf(0,1-m,1) - (m/3)*rd(0,1-m,1);
2245 (defun bf-elliptic-ec (m)
2246 (cond ((= m 0)
2247 (if (typep m 'bigfloat)
2248 (bigfloat (maxima::$bfloat (maxima::div 'maxima::$%pi 2)))
2249 (float (/ pi 2) 1e0)))
2250 ((= m 1)
2251 (if (typep m 'bigfloat)
2252 (bigfloat 1)
2253 1e0))
2255 (let ((m1 (- 1 m)))
2256 (- (bf-rf 0 m1 1)
2257 (* m 1/3 (bf-rd 0 m1 1)))))))
2259 (defun bf-elliptic-pi-complete (n m)
2260 (+ (bf-rf 0 (- 1 m) 1)
2261 (* 1/3 n (bf-rj 0 (- 1 m) 1 (- 1 n)))))
2263 (defun bf-elliptic-pi (n phi m)
2264 ;; Note: Carlson's DRJ has n defined as the negative of the n given
2265 ;; in A&S.
2266 (flet ((base (n phi m)
2267 (let* ((nn (- n))
2268 (sin-phi (sin phi))
2269 (cos-phi (cos phi))
2270 (k (sqrt m))
2271 (k2sin (* (- 1 (* k sin-phi))
2272 (+ 1 (* k sin-phi)))))
2273 (- (* sin-phi (bf-rf (expt cos-phi 2) k2sin 1.0))
2274 (* (/ nn 3) (expt sin-phi 3)
2275 (bf-rj (expt cos-phi 2) k2sin 1.0
2276 (- 1 (* n (expt sin-phi 2)))))))))
2277 ;; FIXME: Reducing the arg by pi has significant round-off.
2278 ;; Consider doing something better.
2279 (let* ((bf-pi (%pi (realpart phi)))
2280 (cycles (round (realpart phi) bf-pi))
2281 (rem (- phi (* cycles bf-pi))))
2282 (let ((complete (bf-elliptic-pi-complete n m)))
2283 (+ (* 2 cycles complete)
2284 (base n rem m))))))
2286 ;; Compute inverse_jacobi_sn, for float or bigfloat args.
2287 (defun bf-inverse-jacobi-sn (u m)
2288 (* u (bf-rf (- 1 (* u u))
2289 (- 1 (* m u u))
2290 1)))
2292 ;; Compute inverse_jacobi_dn. We use the following identity
2293 ;; from Gradshteyn & Ryzhik, 8.153.6
2295 ;; w = dn(z|m) = cn(sqrt(m)*z, 1/m)
2297 ;; Solve for z to get
2299 ;; z = inverse_jacobi_dn(w,m)
2300 ;; = 1/sqrt(m) * inverse_jacobi_cn(w, 1/m)
2301 (defun bf-inverse-jacobi-dn (w m)
2302 (cond ((= w 1)
2303 (float 0 w))
2304 ((= m 1)
2305 ;; jacobi_dn(x,1) = sech(x) so the inverse is asech(x)
2306 (maxima::take '(maxima::%asech) (maxima::to w)))
2308 ;; We should do something better to make sure that things
2309 ;; that should be real are real.
2310 (/ (to (maxima::take '(maxima::%inverse_jacobi_cn)
2311 (maxima::to w)
2312 (maxima::to (/ m))))
2313 (sqrt m)))))
2315 (in-package :maxima)
2317 ;; Define Carlson's elliptic integrals.
2319 (def-simplifier carlson_rc (x y)
2320 (let (args)
2321 (flet ((calc (x y)
2322 (flet ((floatify (z)
2323 ;; If z is a complex rational, convert to a
2324 ;; complex double-float. Otherwise, leave it as
2325 ;; is. If we don't do this, %i is handled as
2326 ;; #c(0 1), which makes bf-rc use single-float
2327 ;; arithmetic instead of the desired
2328 ;; double-float.
2329 (if (and (complexp z) (rationalp (realpart z)))
2330 (complex (float (realpart z))
2331 (float (imagpart z)))
2332 z)))
2333 (to (bigfloat::bf-rc (floatify (bigfloat:to x))
2334 (floatify (bigfloat:to y)))))))
2335 ;; See comments from bf-rc
2336 (cond ((float-numerical-eval-p x y)
2337 (calc ($float x) ($float y)))
2338 ((bigfloat-numerical-eval-p x y)
2339 (calc ($bfloat x) ($bfloat y)))
2340 ((setf args (complex-float-numerical-eval-p x y))
2341 (destructuring-bind (x y)
2342 args
2343 (calc ($float x) ($float y))))
2344 ((setf args (complex-bigfloat-numerical-eval-p x y))
2345 (destructuring-bind (x y)
2346 args
2347 (calc ($bfloat x) ($bfloat y))))
2348 ((and (zerop1 x)
2349 (onep1 y))
2350 ;; rc(0, 1) = %pi/2
2351 (div '$%pi 2))
2352 ((and (zerop1 x)
2353 (alike1 y (div 1 4)))
2354 ;; rc(0,1/4) = %pi
2355 '$%pi)
2356 ((and (eql x 2)
2357 (onep1 y))
2358 ;; rc(2,1) = 1/2*integrate(1/sqrt(t+2)/(t+1), t, 0, inf)
2359 ;; = (log(sqrt(2)+1)-log(sqrt(2)-1))/2
2360 ;; ratsimp(logcontract(%)),algebraic:
2361 ;; = -log(3-2^(3/2))/2
2362 ;; = -log(sqrt(3-2^(3/2)))
2363 ;; = -log(sqrt(2)-1)
2364 ;; = log(1/(sqrt(2)-1))
2365 ;; ratsimp(%),algebraic;
2366 ;; = log(sqrt(2)+1)
2367 (ftake '%log (add 1 (power 2 1//2))))
2368 ((and (alike x '$%i)
2369 (alike y (add 1 '$%i)))
2370 ;; rc(%i, %i+1) = 1/2*integrate(1/sqrt(t+%i)/(t+%i+1), t, 0, inf)
2371 ;; = %pi/2-atan((-1)^(1/4))
2372 ;; ratsimp(logcontract(ratsimp(rectform(%o42)))),algebraic;
2373 ;; = (%i*log(3-2^(3/2))+%pi)/4
2374 ;; = (%i*log(3-2^(3/2)))/4+%pi/4
2375 ;; = %i*log(sqrt(3-2^(3/2)))/2+%pi/4
2376 ;; sqrtdenest(%);
2377 ;; = %pi/4 + %i*log(sqrt(2)-1)/2
2378 (add (div '$%pi 4)
2379 (mul '$%i
2380 1//2
2381 (ftake '%log (sub (power 2 1//2) 1)))))
2382 ((and (zerop1 x)
2383 (alike1 y '$%i))
2384 ;; rc(0,%i) = 1/2*integrate(1/(sqrt(t)*(t+%i)), t, 0, inf)
2385 ;; = -((sqrt(2)*%i-sqrt(2))*%pi)/4
2386 ;; = ((1-%i)*%pi)/2^(3/2)
2387 (div (mul (sub 1 '$%i)
2388 '$%pi)
2389 (power 2 3//2)))
2390 ((and (alike1 x y)
2391 (eq ($sign ($realpart x)) '$pos))
2392 ;; carlson_rc(x,x) = 1/2*integrate(1/sqrt(t+x)/(t+x), t, 0, inf)
2393 ;; = 1/sqrt(x)
2394 (power x -1//2))
2395 ((and (alike1 x (power (div (add 1 y) 2) 2))
2396 (eq ($sign ($realpart y)) '$pos))
2397 ;; Rc(((1+x)/2)^2,x) = log(x)/(x-1) for x > 0.
2399 ;; This is done by looking at Rc(x,y) and seeing if
2400 ;; ((1+y)/2)^2 is the same as x.
2401 (div (ftake '%log y)
2402 (sub y 1)))
2404 (give-up))))))
2406 (def-simplifier carlson_rd (x y z)
2407 (let (args)
2408 (flet ((calc (x y z)
2409 (to (bigfloat::bf-rd (bigfloat:to x)
2410 (bigfloat:to y)
2411 (bigfloat:to z)))))
2412 ;; See https://dlmf.nist.gov/19.20.E18
2413 (cond ((and (eql x 1)
2414 (eql x y)
2415 (eql y z))
2416 ;; Rd(1,1,1) = 1
2418 ((and (alike1 x y)
2419 (alike1 y z))
2420 ;; Rd(x,x,x) = x^(-3/2)
2421 (power x (div -3 2)))
2422 ((and (zerop1 x)
2423 (alike1 y z))
2424 ;; Rd(0,y,y) = 3/4*%pi*y^(-3/2)
2425 (mul (div 3 4)
2426 '$%pi
2427 (power y (div -3 2))))
2428 ((alike1 y z)
2429 ;; Rd(x,y,y) = 3/(2*(y-x))*(Rc(x, y) - sqrt(x)/y)
2430 (mul (div 3 (mul 2 (sub y x)))
2431 (sub (ftake '%carlson_rc x y)
2432 (div (power x 1//2)
2433 y))))
2434 ((alike1 x y)
2435 ;; Rd(x,x,z) = 3/(z-x)*(Rc(z,x) - 1/sqrt(z))
2436 (mul (div 3 (sub z x))
2437 (sub (ftake '%carlson_rc z x)
2438 (div 1 (power z 1//2)))))
2439 ((and (eql z 1)
2440 (or (and (eql x 0)
2441 (eql y 2))
2442 (and (eql x 2)
2443 (eql y 0))))
2444 ;; Rd(0,2,1) = 3*(gamma(3/4)^2)/sqrt(2*%pi)
2445 ;; See https://dlmf.nist.gov/19.20.E22.
2447 ;; But that's the same as
2448 ;; 3*sqrt(%pi)*gamma(3/4)/gamma(1/4). We can see this by
2449 ;; taking the ratio to get
2450 ;; gamma(1/4)*gamma(3/4)/sqrt(2)*%pi. But
2451 ;; gamma(1/4)*gamma(3/4) = beta(1/4,3/4) = sqrt(2)*%pi.
2452 ;; Hence, the ratio is 1.
2454 ;; Note also that Rd(x,y,z) = Rd(y,x,z)
2455 (mul 3
2456 (power '$%pi 1//2)
2457 (div (ftake '%gamma (div 3 4))
2458 (ftake '%gamma (div 1 4)))))
2459 ((and (or (eql x 0) (eql y 0))
2460 (eql z 1))
2461 ;; 1/3*m*Rd(0,1-m,1) = K(m) - E(m).
2462 ;; See https://dlmf.nist.gov/19.25.E1
2464 ;; Thus, Rd(0,y,1) = 3/(1-y)*(K(1-y) - E(1-y))
2466 ;; Note that Rd(x,y,z) = Rd(y,x,z).
2467 (let ((m (sub 1 y)))
2468 (mul (div 3 m)
2469 (sub (ftake '%elliptic_kc m)
2470 (ftake '%elliptic_ec m)))))
2471 ((or (and (eql x 0)
2472 (eql y 1))
2473 (and (eql x 1)
2474 (eql y 0)))
2475 ;; 1/3*m*(1-m)*Rd(0,1,1-m) = E(m) - (1-m)*K(m)
2476 ;; See https://dlmf.nist.gov/19.25.E1
2478 ;; Thus
2479 ;; Rd(0,1,z) = 3/(z*(1-z))*(E(1-z) - z*K(1-z))
2480 ;; Recall that Rd(x,y,z) = Rd(y,x,z).
2481 (mul (div 3 (mul z (sub 1 z)))
2482 (sub (ftake '%elliptic_ec (sub 1 z))
2483 (mul z
2484 (ftake '%elliptic_kc (sub 1 z))))))
2485 ((float-numerical-eval-p x y z)
2486 (calc ($float x) ($float y) ($float z)))
2487 ((bigfloat-numerical-eval-p x y z)
2488 (calc ($bfloat x) ($bfloat y) ($bfloat z)))
2489 ((setf args (complex-float-numerical-eval-p x y z))
2490 (destructuring-bind (x y z)
2491 args
2492 (calc ($float x) ($float y) ($float z))))
2493 ((setf args (complex-bigfloat-numerical-eval-p x y z))
2494 (destructuring-bind (x y z)
2495 args
2496 (calc ($bfloat x) ($bfloat y) ($bfloat z))))
2498 (give-up))))))
2500 (def-simplifier carlson_rf (x y z)
2501 (let (args)
2502 (flet ((calc (x y z)
2503 (to (bigfloat::bf-rf (bigfloat:to x)
2504 (bigfloat:to y)
2505 (bigfloat:to z)))))
2506 ;; See https://dlmf.nist.gov/19.20.i
2507 (cond ((and (alike1 x y)
2508 (alike1 y z))
2509 ;; Rf(x,x,x) = x^(-1/2)
2510 (power x -1//2))
2511 ((and (zerop1 x)
2512 (alike1 y z))
2513 ;; Rf(0,y,y) = 1/2*%pi*y^(-1/2)
2514 (mul 1//2 '$%pi
2515 (power y -1//2)))
2516 ((alike1 y z)
2517 (ftake '%carlson_rc x y))
2518 ((some #'(lambda (args)
2519 (destructuring-bind (x y z)
2520 args
2521 (and (zerop1 x)
2522 (eql y 1)
2523 (eql z 2))))
2524 (list (list x y z)
2525 (list x z y)
2526 (list y x z)
2527 (list y z x)
2528 (list z x y)
2529 (list z y x)))
2530 ;; Rf(0,1,2) = (gamma(1/4))^2/(4*sqrt(2*%pi))
2532 ;; And Rf is symmetric in all the args, so check every
2533 ;; permutation too. This could probably be simplified
2534 ;; without consing all the lists, but I'm lazy.
2535 (div (power (ftake '%gamma (div 1 4)) 2)
2536 (mul 4 (power (mul 2 '$%pi) 1//2))))
2537 ((some #'(lambda (args)
2538 (destructuring-bind (x y z)
2539 args
2540 (and (alike1 x '$%i)
2541 (alike1 y (mul -1 '$%i))
2542 (eql z 0))))
2543 (list (list x y z)
2544 (list x z y)
2545 (list y x z)
2546 (list y z x)
2547 (list z x y)
2548 (list z y x)))
2549 ;; rf(%i, -%i, 0)
2550 ;; = 1/2*integrate(1/sqrt(t^2+1)/sqrt(t),t,0,inf)
2551 ;; = beta(1/4,1/4)/4;
2552 ;; makegamma(%)
2553 ;; = gamma(1/4)^2/(4*sqrt(%pi))
2555 ;; Rf is symmetric, so check all the permutations too.
2556 (div (power (ftake '%gamma (div 1 4)) 2)
2557 (mul 4 (power '$%pi 1//2))))
2558 ((setf args
2559 (some #'(lambda (args)
2560 (destructuring-bind (x y z)
2561 args
2562 ;; Check that x = 0 and z = 1, and
2563 ;; return y.
2564 (and (zerop1 x)
2565 (eql z 1)
2566 y)))
2567 (list (list x y z)
2568 (list x z y)
2569 (list y x z)
2570 (list y z x)
2571 (list z x y)
2572 (list z y x))))
2573 ;; Rf(0,1-m,1) = elliptic_kc(m).
2574 ;; See https://dlmf.nist.gov/19.25.E1
2575 (ftake '%elliptic_kc (sub 1 args)))
2576 ((some #'(lambda (args)
2577 (destructuring-bind (x y z)
2578 args
2579 (and (alike1 x '$%i)
2580 (alike1 y (mul -1 '$%i))
2581 (eql z 0))))
2582 (list (list x y z)
2583 (list x z y)
2584 (list y x z)
2585 (list y z x)
2586 (list z x y)
2587 (list z y x)))
2588 ;; rf(%i, -%i, 0)
2589 ;; = 1/2*integrate(1/sqrt(t^2+1)/sqrt(t),t,0,inf)
2590 ;; = beta(1/4,1/4)/4;
2591 ;; makegamma(%)
2592 ;; = gamma(1/4)^2/(4*sqrt(%pi))
2594 ;; Rf is symmetric, so check all the permutations too.
2595 (div (power (ftake '%gamma (div 1 4)) 2)
2596 (mul 4 (power '$%pi 1//2))))
2597 ((float-numerical-eval-p x y z)
2598 (calc ($float x) ($float y) ($float z)))
2599 ((bigfloat-numerical-eval-p x y z)
2600 (calc ($bfloat x) ($bfloat y) ($bfloat z)))
2601 ((setf args (complex-float-numerical-eval-p x y z))
2602 (destructuring-bind (x y z)
2603 args
2604 (calc ($float x) ($float y) ($float z))))
2605 ((setf args (complex-bigfloat-numerical-eval-p x y z))
2606 (destructuring-bind (x y z)
2607 args
2608 (calc ($bfloat x) ($bfloat y) ($bfloat z))))
2610 (give-up))))))
2612 (def-simplifier carlson_rj (x y z p)
2613 (let (args)
2614 (flet ((calc (x y z p)
2615 (to (bigfloat::bf-rj (bigfloat:to x)
2616 (bigfloat:to y)
2617 (bigfloat:to z)
2618 (bigfloat:to p)))))
2619 ;; See https://dlmf.nist.gov/19.20.iii
2620 (cond ((and (alike1 x y)
2621 (alike1 y z)
2622 (alike1 z p))
2623 ;; Rj(x,x,x,x) = x^(-3/2)
2624 (power x (div -3 2)))
2625 ((alike1 z p)
2626 ;; Rj(x,y,z,z) = Rd(x,y,z)
2627 (ftake '%carlson_rd x y z))
2628 ((and (zerop1 x)
2629 (alike1 y z))
2630 ;; Rj(0,y,y,p) = 3*%pi/(2*(y*sqrt(p)+p*sqrt(y)))
2631 (div (mul 3 '$%pi)
2632 (mul 2
2633 (add (mul y (power p 1//2))
2634 (mul p (power y 1//2))))))
2635 ((alike1 y z)
2636 ;; Rj(x,y,y,p) = 3/(p-y)*(Rc(x,y) - Rc(x,p))
2637 (mul (div 3 (sub p y))
2638 (sub (ftake '%carlson_rc x y)
2639 (ftake '%carlson_rc x p))))
2640 ((and (alike1 y z)
2641 (alike1 y p))
2642 ;; Rj(x,y,y,y) = Rd(x,y,y)
2643 (ftake '%carlson_rd x y y))
2644 ((float-numerical-eval-p x y z p)
2645 (calc ($float x) ($float y) ($float z) ($float p)))
2646 ((bigfloat-numerical-eval-p x y z p)
2647 (calc ($bfloat x) ($bfloat y) ($bfloat z) ($bfloat p)))
2648 ((setf args (complex-float-numerical-eval-p x y z p))
2649 (destructuring-bind (x y z p)
2650 args
2651 (calc ($float x) ($float y) ($float z) ($float p))))
2652 ((setf args (complex-bigfloat-numerical-eval-p x y z p))
2653 (destructuring-bind (x y z p)
2654 args
2655 (calc ($bfloat x) ($bfloat y) ($bfloat z) ($bfloat p))))
2657 (give-up))))))
2659 ;;; Other Jacobian elliptic functions
2661 ;; jacobi_ns(u,m) = 1/jacobi_sn(u,m)
2662 (defprop %jacobi_ns
2663 ((u m)
2664 ;; diff wrt u
2665 ((mtimes) -1 ((%jacobi_cn) u m) ((%jacobi_dn) u m)
2666 ((mexpt) ((%jacobi_sn) u m) -2))
2667 ;; diff wrt m
2668 ((mtimes) -1 ((mexpt) ((%jacobi_sn) u m) -2)
2669 ((mplus)
2670 ((mtimes) ((rat) 1 2)
2671 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
2672 ((mexpt) ((%jacobi_cn) u m) 2)
2673 ((%jacobi_sn) u m))
2674 ((mtimes) ((rat) 1 2) ((mexpt) m -1)
2675 ((%jacobi_cn) u m) ((%jacobi_dn) u m)
2676 ((mplus) u
2677 ((mtimes) -1
2678 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
2679 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
2680 m)))))))
2681 grad)
2683 (def-simplifier jacobi_ns (u m)
2684 (let (coef args)
2685 (cond
2686 ((float-numerical-eval-p u m)
2687 (to (bigfloat:/ (bigfloat::sn (bigfloat:to ($float u))
2688 (bigfloat:to ($float m))))))
2689 ((setf args (complex-float-numerical-eval-p u m))
2690 (destructuring-bind (u m)
2691 args
2692 (to (bigfloat:/ (bigfloat::sn (bigfloat:to ($float u))
2693 (bigfloat:to ($float m)))))))
2694 ((bigfloat-numerical-eval-p u m)
2695 (let ((uu (bigfloat:to ($bfloat u)))
2696 (mm (bigfloat:to ($bfloat m))))
2697 (to (bigfloat:/ (bigfloat::sn uu mm)))))
2698 ((setf args (complex-bigfloat-numerical-eval-p u m))
2699 (destructuring-bind (u m)
2700 args
2701 (let ((uu (bigfloat:to ($bfloat u)))
2702 (mm (bigfloat:to ($bfloat m))))
2703 (to (bigfloat:/ (bigfloat::sn uu mm))))))
2704 ((zerop1 m)
2705 ;; A&S 16.6.10
2706 (ftake '%csc u))
2707 ((onep1 m)
2708 ;; A&S 16.6.10
2709 (ftake '%coth u))
2710 ((zerop1 u)
2711 (dbz-err1 'jacobi_ns))
2712 ((and $trigsign (mminusp* u))
2713 ;; ns is odd
2714 (neg (ftake* '%jacobi_ns (neg u) m)))
2715 ((and $triginverses
2716 (listp u)
2717 (member (caar u) '(%inverse_jacobi_sn
2718 %inverse_jacobi_ns
2719 %inverse_jacobi_cn
2720 %inverse_jacobi_nc
2721 %inverse_jacobi_dn
2722 %inverse_jacobi_nd
2723 %inverse_jacobi_sc
2724 %inverse_jacobi_cs
2725 %inverse_jacobi_sd
2726 %inverse_jacobi_ds
2727 %inverse_jacobi_cd
2728 %inverse_jacobi_dc))
2729 (alike1 (third u) m))
2730 (cond ((eq (caar u) '%inverse_jacobi_ns)
2731 (second u))
2733 ;; Express in terms of sn:
2734 ;; ns(x) = 1/sn(x)
2735 (div 1 (ftake '%jacobi_sn u m)))))
2736 ;; A&S 16.20 (Jacobi's Imaginary transformation)
2737 ((and $%iargs (multiplep u '$%i))
2738 ;; ns(i*u) = 1/sn(i*u) = -i/sc(u,m1) = -i*cs(u,m1)
2739 (neg (mul '$%i
2740 (ftake* '%jacobi_cs (coeff u '$%i 1) (add 1 (neg m))))))
2741 ((setq coef (kc-arg2 u m))
2742 ;; A&S 16.8.10
2744 ;; ns(m*K+u) = 1/sn(m*K+u)
2746 (destructuring-bind (lin const)
2747 coef
2748 (cond ((integerp lin)
2749 (ecase (mod lin 4)
2751 ;; ns(4*m*K+u) = ns(u)
2752 ;; ns(0) = infinity
2753 (if (zerop1 const)
2754 (dbz-err1 'jacobi_ns)
2755 (ftake '%jacobi_ns const m)))
2757 ;; ns(4*m*K + K + u) = ns(K+u) = dc(u)
2758 ;; ns(K) = 1
2759 (if (zerop1 const)
2761 (ftake '%jacobi_dc const m)))
2763 ;; ns(4*m*K+2*K + u) = ns(2*K+u) = -ns(u)
2764 ;; ns(2*K) = infinity
2765 (if (zerop1 const)
2766 (dbz-err1 'jacobi_ns)
2767 (neg (ftake '%jacobi_ns const m))))
2769 ;; ns(4*m*K+3*K+u) = ns(2*K + K + u) = -ns(K+u) = -dc(u)
2770 ;; ns(3*K) = -1
2771 (if (zerop1 const)
2773 (neg (ftake '%jacobi_dc const m))))))
2774 ((and (alike1 lin 1//2)
2775 (zerop1 const))
2776 (div 1 (ftake '%jacobi_sn u m)))
2778 (give-up)))))
2780 ;; Nothing to do
2781 (give-up)))))
2783 ;; jacobi_nc(u,m) = 1/jacobi_cn(u,m)
2784 (defprop %jacobi_nc
2785 ((u m)
2786 ;; wrt u
2787 ((mtimes) ((mexpt) ((%jacobi_cn) u m) -2)
2788 ((%jacobi_dn) u m) ((%jacobi_sn) u m))
2789 ;; wrt m
2790 ((mtimes) -1 ((mexpt) ((%jacobi_cn) u m) -2)
2791 ((mplus)
2792 ((mtimes) ((rat) -1 2)
2793 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
2794 ((%jacobi_cn) u m) ((mexpt) ((%jacobi_sn) u m) 2))
2795 ((mtimes) ((rat) -1 2) ((mexpt) m -1)
2796 ((%jacobi_dn) u m) ((%jacobi_sn) u m)
2797 ((mplus) u
2798 ((mtimes) -1 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
2799 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m)) m)))))))
2800 grad)
2802 (def-simplifier jacobi_nc (u m)
2803 (let (coef args)
2804 (cond
2805 ((float-numerical-eval-p u m)
2806 (to (bigfloat:/ (bigfloat::cn (bigfloat:to ($float u))
2807 (bigfloat:to ($float m))))))
2808 ((setf args (complex-float-numerical-eval-p u m))
2809 (destructuring-bind (u m)
2810 args
2811 (to (bigfloat:/ (bigfloat::cn (bigfloat:to ($float u))
2812 (bigfloat:to ($float m)))))))
2813 ((bigfloat-numerical-eval-p u m)
2814 (let ((uu (bigfloat:to ($bfloat u)))
2815 (mm (bigfloat:to ($bfloat m))))
2816 (to (bigfloat:/ (bigfloat::cn uu mm)))))
2817 ((setf args (complex-bigfloat-numerical-eval-p u m))
2818 (destructuring-bind (u m)
2819 args
2820 (let ((uu (bigfloat:to ($bfloat u)))
2821 (mm (bigfloat:to ($bfloat m))))
2822 (to (bigfloat:/ (bigfloat::cn uu mm))))))
2823 ((zerop1 u)
2825 ((zerop1 m)
2826 ;; A&S 16.6.8
2827 (ftake '%sec u))
2828 ((onep1 m)
2829 ;; A&S 16.6.8
2830 (ftake '%cosh u))
2831 ((and $trigsign (mminusp* u))
2832 ;; nc is even
2833 (ftake* '%jacobi_nc (neg u) m))
2834 ((and $triginverses
2835 (listp u)
2836 (member (caar u) '(%inverse_jacobi_sn
2837 %inverse_jacobi_ns
2838 %inverse_jacobi_cn
2839 %inverse_jacobi_nc
2840 %inverse_jacobi_dn
2841 %inverse_jacobi_nd
2842 %inverse_jacobi_sc
2843 %inverse_jacobi_cs
2844 %inverse_jacobi_sd
2845 %inverse_jacobi_ds
2846 %inverse_jacobi_cd
2847 %inverse_jacobi_dc))
2848 (alike1 (third u) m))
2849 (cond ((eq (caar u) '%inverse_jacobi_nc)
2850 (second u))
2852 ;; Express in terms of cn:
2853 ;; nc(x) = 1/cn(x)
2854 (div 1 (ftake '%jacobi_cn u m)))))
2855 ;; A&S 16.20 (Jacobi's Imaginary transformation)
2856 ((and $%iargs (multiplep u '$%i))
2857 ;; nc(i*u) = 1/cn(i*u) = 1/nc(u,1-m) = cn(u,1-m)
2858 (ftake* '%jacobi_cn (coeff u '$%i 1) (add 1 (neg m))))
2859 ((setq coef (kc-arg2 u m))
2860 ;; A&S 16.8.8
2862 ;; nc(u) = 1/cn(u)
2864 (destructuring-bind (lin const)
2865 coef
2866 (cond ((integerp lin)
2867 (ecase (mod lin 4)
2869 ;; nc(4*m*K+u) = nc(u)
2870 ;; nc(0) = 1
2871 (if (zerop1 const)
2873 (ftake '%jacobi_nc const m)))
2875 ;; nc(4*m*K+K+u) = nc(K+u) = -ds(u)/sqrt(1-m)
2876 ;; nc(K) = infinity
2877 (if (zerop1 const)
2878 (dbz-err1 'jacobi_nc)
2879 (neg (div (ftake '%jacobi_ds const m)
2880 (power (sub 1 m) 1//2)))))
2882 ;; nc(4*m*K+2*K+u) = nc(2*K+u) = -nc(u)
2883 ;; nc(2*K) = -1
2884 (if (zerop1 const)
2886 (neg (ftake '%jacobi_nc const m))))
2888 ;; nc(4*m*K+3*K+u) = nc(3*K+u) = nc(2*K+K+u) =
2889 ;; -nc(K+u) = ds(u)/sqrt(1-m)
2891 ;; nc(3*K) = infinity
2892 (if (zerop1 const)
2893 (dbz-err1 'jacobi_nc)
2894 (div (ftake '%jacobi_ds const m)
2895 (power (sub 1 m) 1//2))))))
2896 ((and (alike1 1//2 lin)
2897 (zerop1 const))
2898 (div 1 (ftake '%jacobi_cn u m)))
2900 (give-up)))))
2902 ;; Nothing to do
2903 (give-up)))))
2905 ;; jacobi_nd(u,m) = 1/jacobi_dn(u,m)
2906 (defprop %jacobi_nd
2907 ((u m)
2908 ;; wrt u
2909 ((mtimes) m ((%jacobi_cn) u m)
2910 ((mexpt) ((%jacobi_dn) u m) -2) ((%jacobi_sn) u m))
2911 ;; wrt m
2912 ((mtimes) -1 ((mexpt) ((%jacobi_dn) u m) -2)
2913 ((mplus)
2914 ((mtimes) ((rat) -1 2)
2915 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
2916 ((%jacobi_dn) u m)
2917 ((mexpt) ((%jacobi_sn) u m) 2))
2918 ((mtimes) ((rat) -1 2) ((%jacobi_cn) u m)
2919 ((%jacobi_sn) u m)
2920 ((mplus) u
2921 ((mtimes) -1
2922 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
2923 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
2924 m)))))))
2925 grad)
2927 (def-simplifier jacobi_nd (u m)
2928 (let (coef args)
2929 (cond
2930 ((float-numerical-eval-p u m)
2931 (to (bigfloat:/ (bigfloat::dn (bigfloat:to ($float u))
2932 (bigfloat:to ($float m))))))
2933 ((setf args (complex-float-numerical-eval-p u m))
2934 (destructuring-bind (u m)
2935 args
2936 (to (bigfloat:/ (bigfloat::dn (bigfloat:to ($float u))
2937 (bigfloat:to ($float m)))))))
2938 ((bigfloat-numerical-eval-p u m)
2939 (let ((uu (bigfloat:to ($bfloat u)))
2940 (mm (bigfloat:to ($bfloat m))))
2941 (to (bigfloat:/ (bigfloat::dn uu mm)))))
2942 ((setf args (complex-bigfloat-numerical-eval-p u m))
2943 (destructuring-bind (u m)
2944 args
2945 (let ((uu (bigfloat:to ($bfloat u)))
2946 (mm (bigfloat:to ($bfloat m))))
2947 (to (bigfloat:/ (bigfloat::dn uu mm))))))
2948 ((zerop1 u)
2950 ((zerop1 m)
2951 ;; A&S 16.6.6
2953 ((onep1 m)
2954 ;; A&S 16.6.6
2955 (ftake '%cosh u))
2956 ((and $trigsign (mminusp* u))
2957 ;; nd is even
2958 (ftake* '%jacobi_nd (neg u) m))
2959 ((and $triginverses
2960 (listp u)
2961 (member (caar u) '(%inverse_jacobi_sn
2962 %inverse_jacobi_ns
2963 %inverse_jacobi_cn
2964 %inverse_jacobi_nc
2965 %inverse_jacobi_dn
2966 %inverse_jacobi_nd
2967 %inverse_jacobi_sc
2968 %inverse_jacobi_cs
2969 %inverse_jacobi_sd
2970 %inverse_jacobi_ds
2971 %inverse_jacobi_cd
2972 %inverse_jacobi_dc))
2973 (alike1 (third u) m))
2974 (cond ((eq (caar u) '%inverse_jacobi_nd)
2975 (second u))
2977 ;; Express in terms of dn:
2978 ;; nd(x) = 1/dn(x)
2979 (div 1 (ftake '%jacobi_dn u m)))))
2980 ;; A&S 16.20 (Jacobi's Imaginary transformation)
2981 ((and $%iargs (multiplep u '$%i))
2982 ;; nd(i*u) = 1/dn(i*u) = 1/dc(u,1-m) = cd(u,1-m)
2983 (ftake* '%jacobi_cd (coeff u '$%i 1) (add 1 (neg m))))
2984 ((setq coef (kc-arg2 u m))
2985 ;; A&S 16.8.6
2987 (destructuring-bind (lin const)
2988 coef
2989 (cond ((integerp lin)
2990 ;; nd has period 2K
2991 (ecase (mod lin 2)
2993 ;; nd(2*m*K+u) = nd(u)
2994 ;; nd(0) = 1
2995 (if (zerop1 const)
2997 (ftake '%jacobi_nd const m)))
2999 ;; nd(2*m*K+K+u) = nd(K+u) = dn(u)/sqrt(1-m)
3000 ;; nd(K) = 1/sqrt(1-m)
3001 (if (zerop1 const)
3002 (power (sub 1 m) -1//2)
3003 (div (ftake '%jacobi_nd const m)
3004 (power (sub 1 m) 1//2))))))
3006 (give-up)))))
3008 ;; Nothing to do
3009 (give-up)))))
3011 ;; jacobi_sc(u,m) = jacobi_sn/jacobi_cn
3012 (defprop %jacobi_sc
3013 ((u m)
3014 ;; wrt u
3015 ((mtimes) ((mexpt) ((%jacobi_cn) u m) -2)
3016 ((%jacobi_dn) u m))
3017 ;; wrt m
3018 ((mplus)
3019 ((mtimes) ((mexpt) ((%jacobi_cn) u m) -1)
3020 ((mplus)
3021 ((mtimes) ((rat) 1 2)
3022 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3023 ((mexpt) ((%jacobi_cn) u m) 2)
3024 ((%jacobi_sn) u m))
3025 ((mtimes) ((rat) 1 2) ((mexpt) m -1)
3026 ((%jacobi_cn) u m) ((%jacobi_dn) u m)
3027 ((mplus) u
3028 ((mtimes) -1
3029 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3030 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3031 m))))))
3032 ((mtimes) -1 ((mexpt) ((%jacobi_cn) u m) -2)
3033 ((%jacobi_sn) u m)
3034 ((mplus)
3035 ((mtimes) ((rat) -1 2)
3036 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3037 ((%jacobi_cn) u m)
3038 ((mexpt) ((%jacobi_sn) u m) 2))
3039 ((mtimes) ((rat) -1 2) ((mexpt) m -1)
3040 ((%jacobi_dn) u m) ((%jacobi_sn) u m)
3041 ((mplus) u
3042 ((mtimes) -1
3043 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3044 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3045 m))))))))
3046 grad)
3048 (def-simplifier jacobi_sc (u m)
3049 (let (coef args)
3050 (cond
3051 ((float-numerical-eval-p u m)
3052 (let ((fu (bigfloat:to ($float u)))
3053 (fm (bigfloat:to ($float m))))
3054 (to (bigfloat:/ (bigfloat::sn fu fm) (bigfloat::cn fu fm)))))
3055 ((setf args (complex-float-numerical-eval-p u m))
3056 (destructuring-bind (u m)
3057 args
3058 (let ((fu (bigfloat:to ($float u)))
3059 (fm (bigfloat:to ($float m))))
3060 (to (bigfloat:/ (bigfloat::sn fu fm) (bigfloat::cn fu fm))))))
3061 ((bigfloat-numerical-eval-p u m)
3062 (let ((uu (bigfloat:to ($bfloat u)))
3063 (mm (bigfloat:to ($bfloat m))))
3064 (to (bigfloat:/ (bigfloat::sn uu mm)
3065 (bigfloat::cn uu mm)))))
3066 ((setf args (complex-bigfloat-numerical-eval-p u m))
3067 (destructuring-bind (u m)
3068 args
3069 (let ((uu (bigfloat:to ($bfloat u)))
3070 (mm (bigfloat:to ($bfloat m))))
3071 (to (bigfloat:/ (bigfloat::sn uu mm)
3072 (bigfloat::cn uu mm))))))
3073 ((zerop1 u)
3075 ((zerop1 m)
3076 ;; A&S 16.6.9
3077 (ftake '%tan u))
3078 ((onep1 m)
3079 ;; A&S 16.6.9
3080 (ftake '%sinh u))
3081 ((and $trigsign (mminusp* u))
3082 ;; sc is odd
3083 (neg (ftake* '%jacobi_sc (neg u) m)))
3084 ((and $triginverses
3085 (listp u)
3086 (member (caar u) '(%inverse_jacobi_sn
3087 %inverse_jacobi_ns
3088 %inverse_jacobi_cn
3089 %inverse_jacobi_nc
3090 %inverse_jacobi_dn
3091 %inverse_jacobi_nd
3092 %inverse_jacobi_sc
3093 %inverse_jacobi_cs
3094 %inverse_jacobi_sd
3095 %inverse_jacobi_ds
3096 %inverse_jacobi_cd
3097 %inverse_jacobi_dc))
3098 (alike1 (third u) m))
3099 (cond ((eq (caar u) '%inverse_jacobi_sc)
3100 (second u))
3102 ;; Express in terms of sn and cn
3103 ;; sc(x) = sn(x)/cn(x)
3104 (div (ftake '%jacobi_sn u m)
3105 (ftake '%jacobi_cn u m)))))
3106 ;; A&S 16.20 (Jacobi's Imaginary transformation)
3107 ((and $%iargs (multiplep u '$%i))
3108 ;; sc(i*u) = sn(i*u)/cn(i*u) = i*sc(u,m1)/nc(u,m1) = i*sn(u,m1)
3109 (mul '$%i
3110 (ftake* '%jacobi_sn (coeff u '$%i 1) (add 1 (neg m)))))
3111 ((setq coef (kc-arg2 u m))
3112 ;; A&S 16.8.9
3113 ;; sc(2*m*K+u) = sc(u)
3114 (destructuring-bind (lin const)
3115 coef
3116 (cond ((integerp lin)
3117 (ecase (mod lin 2)
3119 ;; sc(2*m*K+ u) = sc(u)
3120 ;; sc(0) = 0
3121 (if (zerop1 const)
3123 (ftake '%jacobi_sc const m)))
3125 ;; sc(2*m*K + K + u) = sc(K+u)= - cs(u)/sqrt(1-m)
3126 ;; sc(K) = infinity
3127 (if (zerop1 const)
3128 (dbz-err1 'jacobi_sc)
3129 (mul -1
3130 (div (ftake* '%jacobi_cs const m)
3131 (power (sub 1 m) 1//2)))))))
3132 ((and (alike1 lin 1//2)
3133 (zerop1 const))
3134 ;; From A&S 16.3.3 and 16.5.2:
3135 ;; sc(1/2*K) = 1/(1-m)^(1/4)
3136 (power (sub 1 m) (div -1 4)))
3138 (give-up)))))
3140 ;; Nothing to do
3141 (give-up)))))
3143 ;; jacobi_sd(u,m) = jacobi_sn/jacobi_dn
3144 (defprop %jacobi_sd
3145 ((u m)
3146 ;; wrt u
3147 ((mtimes) ((%jacobi_cn) u m)
3148 ((mexpt) ((%jacobi_dn) u m) -2))
3149 ;; wrt m
3150 ((mplus)
3151 ((mtimes) ((mexpt) ((%jacobi_dn) u m) -1)
3152 ((mplus)
3153 ((mtimes) ((rat) 1 2)
3154 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3155 ((mexpt) ((%jacobi_cn) u m) 2)
3156 ((%jacobi_sn) u m))
3157 ((mtimes) ((rat) 1 2) ((mexpt) m -1)
3158 ((%jacobi_cn) u m) ((%jacobi_dn) u m)
3159 ((mplus) u
3160 ((mtimes) -1
3161 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3162 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3163 m))))))
3164 ((mtimes) -1 ((mexpt) ((%jacobi_dn) u m) -2)
3165 ((%jacobi_sn) u m)
3166 ((mplus)
3167 ((mtimes) ((rat) -1 2)
3168 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3169 ((%jacobi_dn) u m)
3170 ((mexpt) ((%jacobi_sn) u m) 2))
3171 ((mtimes) ((rat) -1 2) ((%jacobi_cn) u m)
3172 ((%jacobi_sn) u m)
3173 ((mplus) u
3174 ((mtimes) -1
3175 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3176 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3177 m))))))))
3178 grad)
3180 (def-simplifier jacobi_sd (u m)
3181 (let (coef args)
3182 (cond
3183 ((float-numerical-eval-p u m)
3184 (let ((fu (bigfloat:to ($float u)))
3185 (fm (bigfloat:to ($float m))))
3186 (to (bigfloat:/ (bigfloat::sn fu fm) (bigfloat::dn fu fm)))))
3187 ((setf args (complex-float-numerical-eval-p u m))
3188 (destructuring-bind (u m)
3189 args
3190 (let ((fu (bigfloat:to ($float u)))
3191 (fm (bigfloat:to ($float m))))
3192 (to (bigfloat:/ (bigfloat::sn fu fm) (bigfloat::dn fu fm))))))
3193 ((bigfloat-numerical-eval-p u m)
3194 (let ((uu (bigfloat:to ($bfloat u)))
3195 (mm (bigfloat:to ($bfloat m))))
3196 (to (bigfloat:/ (bigfloat::sn uu mm)
3197 (bigfloat::dn uu mm)))))
3198 ((setf args (complex-bigfloat-numerical-eval-p u m))
3199 (destructuring-bind (u m)
3200 args
3201 (let ((uu (bigfloat:to ($bfloat u)))
3202 (mm (bigfloat:to ($bfloat m))))
3203 (to (bigfloat:/ (bigfloat::sn uu mm)
3204 (bigfloat::dn uu mm))))))
3205 ((zerop1 u)
3207 ((zerop1 m)
3208 ;; A&S 16.6.5
3209 (ftake '%sin u))
3210 ((onep1 m)
3211 ;; A&S 16.6.5
3212 (ftake '%sinh u))
3213 ((and $trigsign (mminusp* u))
3214 ;; sd is odd
3215 (neg (ftake* '%jacobi_sd (neg u) m)))
3216 ((and $triginverses
3217 (listp u)
3218 (member (caar u) '(%inverse_jacobi_sn
3219 %inverse_jacobi_ns
3220 %inverse_jacobi_cn
3221 %inverse_jacobi_nc
3222 %inverse_jacobi_dn
3223 %inverse_jacobi_nd
3224 %inverse_jacobi_sc
3225 %inverse_jacobi_cs
3226 %inverse_jacobi_sd
3227 %inverse_jacobi_ds
3228 %inverse_jacobi_cd
3229 %inverse_jacobi_dc))
3230 (alike1 (third u) m))
3231 (cond ((eq (caar u) '%inverse_jacobi_sd)
3232 (second u))
3234 ;; Express in terms of sn and dn
3235 (div (ftake '%jacobi_sn u m)
3236 (ftake '%jacobi_dn u m)))))
3237 ;; A&S 16.20 (Jacobi's Imaginary transformation)
3238 ((and $%iargs (multiplep u '$%i))
3239 ;; sd(i*u) = sn(i*u)/dn(i*u) = i*sc(u,m1)/dc(u,m1) = i*sd(u,m1)
3240 (mul '$%i
3241 (ftake* '%jacobi_sd (coeff u '$%i 1) (add 1 (neg m)))))
3242 ((setq coef (kc-arg2 u m))
3243 ;; A&S 16.8.5
3244 ;; sd(4*m*K+u) = sd(u)
3245 (destructuring-bind (lin const)
3246 coef
3247 (cond ((integerp lin)
3248 (ecase (mod lin 4)
3250 ;; sd(4*m*K+u) = sd(u)
3251 ;; sd(0) = 0
3252 (if (zerop1 const)
3254 (ftake '%jacobi_sd const m)))
3256 ;; sd(4*m*K+K+u) = sd(K+u) = cn(u)/sqrt(1-m)
3257 ;; sd(K) = 1/sqrt(m1)
3258 (if (zerop1 const)
3259 (power (sub 1 m) 1//2)
3260 (div (ftake '%jacobi_cn const m)
3261 (power (sub 1 m) 1//2))))
3263 ;; sd(4*m*K+2*K+u) = sd(2*K+u) = -sd(u)
3264 ;; sd(2*K) = 0
3265 (if (zerop1 const)
3267 (neg (ftake '%jacobi_sd const m))))
3269 ;; sd(4*m*K+3*K+u) = sd(3*K+u) = sd(2*K+K+u) =
3270 ;; -sd(K+u) = -cn(u)/sqrt(1-m)
3271 ;; sd(3*K) = -1/sqrt(m1)
3272 (if (zerop1 const)
3273 (neg (power (sub 1 m) -1//2))
3274 (neg (div (ftake '%jacobi_cn const m)
3275 (power (sub 1 m) 1//2)))))))
3276 ((and (alike1 lin 1//2)
3277 (zerop1 const))
3278 ;; jacobi_sn/jacobi_dn
3279 (div (ftake '%jacobi_sn
3280 (mul 1//2
3281 (ftake '%elliptic_kc m))
3283 (ftake '%jacobi_dn
3284 (mul 1//2
3285 (ftake '%elliptic_kc m))
3286 m)))
3288 (give-up)))))
3290 ;; Nothing to do
3291 (give-up)))))
3293 ;; jacobi_cs(u,m) = jacobi_cn/jacobi_sn
3294 (defprop %jacobi_cs
3295 ((u m)
3296 ;; wrt u
3297 ((mtimes) -1 ((%jacobi_dn) u m)
3298 ((mexpt) ((%jacobi_sn) u m) -2))
3299 ;; wrt m
3300 ((mplus)
3301 ((mtimes) -1 ((%jacobi_cn) u m)
3302 ((mexpt) ((%jacobi_sn) u m) -2)
3303 ((mplus)
3304 ((mtimes) ((rat) 1 2)
3305 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3306 ((mexpt) ((%jacobi_cn) u m) 2)
3307 ((%jacobi_sn) u m))
3308 ((mtimes) ((rat) 1 2) ((mexpt) m -1)
3309 ((%jacobi_cn) u m) ((%jacobi_dn) u m)
3310 ((mplus) u
3311 ((mtimes) -1
3312 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3313 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3314 m))))))
3315 ((mtimes) ((mexpt) ((%jacobi_sn) u m) -1)
3316 ((mplus)
3317 ((mtimes) ((rat) -1 2)
3318 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3319 ((%jacobi_cn) u m)
3320 ((mexpt) ((%jacobi_sn) u m) 2))
3321 ((mtimes) ((rat) -1 2) ((mexpt) m -1)
3322 ((%jacobi_dn) u m) ((%jacobi_sn) u m)
3323 ((mplus) u
3324 ((mtimes) -1
3325 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3326 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3327 m))))))))
3328 grad)
3330 (def-simplifier jacobi_cs (u m)
3331 (let (coef args)
3332 (cond
3333 ((float-numerical-eval-p u m)
3334 (let ((fu (bigfloat:to ($float u)))
3335 (fm (bigfloat:to ($float m))))
3336 (to (bigfloat:/ (bigfloat::cn fu fm) (bigfloat::sn fu fm)))))
3337 ((setf args (complex-float-numerical-eval-p u m))
3338 (destructuring-bind (u m)
3339 args
3340 (let ((fu (bigfloat:to ($float u)))
3341 (fm (bigfloat:to ($float m))))
3342 (to (bigfloat:/ (bigfloat::cn fu fm) (bigfloat::sn fu fm))))))
3343 ((bigfloat-numerical-eval-p u m)
3344 (let ((uu (bigfloat:to ($bfloat u)))
3345 (mm (bigfloat:to ($bfloat m))))
3346 (to (bigfloat:/ (bigfloat::cn uu mm)
3347 (bigfloat::sn uu mm)))))
3348 ((setf args (complex-bigfloat-numerical-eval-p u m))
3349 (destructuring-bind (u m)
3350 args
3351 (let ((uu (bigfloat:to ($bfloat u)))
3352 (mm (bigfloat:to ($bfloat m))))
3353 (to (bigfloat:/ (bigfloat::cn uu mm)
3354 (bigfloat::sn uu mm))))))
3355 ((zerop1 m)
3356 ;; A&S 16.6.12
3357 (ftake '%cot u))
3358 ((onep1 m)
3359 ;; A&S 16.6.12
3360 (ftake '%csch u))
3361 ((zerop1 u)
3362 (dbz-err1 'jacobi_cs))
3363 ((and $trigsign (mminusp* u))
3364 ;; cs is odd
3365 (neg (ftake* '%jacobi_cs (neg u) m)))
3366 ((and $triginverses
3367 (listp u)
3368 (member (caar u) '(%inverse_jacobi_sn
3369 %inverse_jacobi_ns
3370 %inverse_jacobi_cn
3371 %inverse_jacobi_nc
3372 %inverse_jacobi_dn
3373 %inverse_jacobi_nd
3374 %inverse_jacobi_sc
3375 %inverse_jacobi_cs
3376 %inverse_jacobi_sd
3377 %inverse_jacobi_ds
3378 %inverse_jacobi_cd
3379 %inverse_jacobi_dc))
3380 (alike1 (third u) m))
3381 (cond ((eq (caar u) '%inverse_jacobi_cs)
3382 (second u))
3384 ;; Express in terms of cn an sn
3385 (div (ftake '%jacobi_cn u m)
3386 (ftake '%jacobi_sn u m)))))
3387 ;; A&S 16.20 (Jacobi's Imaginary transformation)
3388 ((and $%iargs (multiplep u '$%i))
3389 ;; cs(i*u) = cn(i*u)/sn(i*u) = -i*nc(u,m1)/sc(u,m1) = -i*ns(u,m1)
3390 (neg (mul '$%i
3391 (ftake* '%jacobi_ns (coeff u '$%i 1) (add 1 (neg m))))))
3392 ((setq coef (kc-arg2 u m))
3393 ;; A&S 16.8.12
3395 ;; cs(2*m*K + u) = cs(u)
3396 (destructuring-bind (lin const)
3397 coef
3398 (cond ((integerp lin)
3399 (ecase (mod lin 2)
3401 ;; cs(2*m*K + u) = cs(u)
3402 ;; cs(0) = infinity
3403 (if (zerop1 const)
3404 (dbz-err1 'jacobi_cs)
3405 (ftake '%jacobi_cs const m)))
3407 ;; cs(K+u) = -sqrt(1-m)*sc(u)
3408 ;; cs(K) = 0
3409 (if (zerop1 const)
3411 (neg (mul (power (sub 1 m) 1//2)
3412 (ftake '%jacobi_sc const m)))))))
3413 ((and (alike1 lin 1//2)
3414 (zerop1 const))
3415 ;; 1/jacobi_sc
3416 (div 1
3417 (ftake '%jacobi_sc (mul 1//2
3418 (ftake '%elliptic_kc m))
3419 m)))
3421 (give-up)))))
3423 ;; Nothing to do
3424 (give-up)))))
3426 ;; jacobi_cd(u,m) = jacobi_cn/jacobi_dn
3427 (defprop %jacobi_cd
3428 ((u m)
3429 ;; wrt u
3430 ((mtimes) ((mplus) -1 m)
3431 ((mexpt) ((%jacobi_dn) u m) -2)
3432 ((%jacobi_sn) u m))
3433 ;; wrt m
3434 ((mplus)
3435 ((mtimes) -1 ((%jacobi_cn) u m)
3436 ((mexpt) ((%jacobi_dn) u m) -2)
3437 ((mplus)
3438 ((mtimes) ((rat) -1 2)
3439 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3440 ((%jacobi_dn) u m)
3441 ((mexpt) ((%jacobi_sn) u m) 2))
3442 ((mtimes) ((rat) -1 2) ((%jacobi_cn) u m)
3443 ((%jacobi_sn) u m)
3444 ((mplus) u
3445 ((mtimes) -1
3446 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3447 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3448 m))))))
3449 ((mtimes) ((mexpt) ((%jacobi_dn) u m) -1)
3450 ((mplus)
3451 ((mtimes) ((rat) -1 2)
3452 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3453 ((%jacobi_cn) u m)
3454 ((mexpt) ((%jacobi_sn) u m) 2))
3455 ((mtimes) ((rat) -1 2) ((mexpt) m -1)
3456 ((%jacobi_dn) u m) ((%jacobi_sn) u m)
3457 ((mplus) u
3458 ((mtimes) -1
3459 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3460 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3461 m))))))))
3462 grad)
3464 (def-simplifier jacobi_cd (u m)
3465 (let (coef args)
3466 (cond
3467 ((float-numerical-eval-p u m)
3468 (let ((fu (bigfloat:to ($float u)))
3469 (fm (bigfloat:to ($float m))))
3470 (to (bigfloat:/ (bigfloat::cn fu fm) (bigfloat::dn fu fm)))))
3471 ((setf args (complex-float-numerical-eval-p u m))
3472 (destructuring-bind (u m)
3473 args
3474 (let ((fu (bigfloat:to ($float u)))
3475 (fm (bigfloat:to ($float m))))
3476 (to (bigfloat:/ (bigfloat::cn fu fm) (bigfloat::dn fu fm))))))
3477 ((bigfloat-numerical-eval-p u m)
3478 (let ((uu (bigfloat:to ($bfloat u)))
3479 (mm (bigfloat:to ($bfloat m))))
3480 (to (bigfloat:/ (bigfloat::cn uu mm) (bigfloat::dn uu mm)))))
3481 ((setf args (complex-bigfloat-numerical-eval-p u m))
3482 (destructuring-bind (u m)
3483 args
3484 (let ((uu (bigfloat:to ($bfloat u)))
3485 (mm (bigfloat:to ($bfloat m))))
3486 (to (bigfloat:/ (bigfloat::cn uu mm) (bigfloat::dn uu mm))))))
3487 ((zerop1 u)
3489 ((zerop1 m)
3490 ;; A&S 16.6.4
3491 (ftake '%cos u))
3492 ((onep1 m)
3493 ;; A&S 16.6.4
3495 ((and $trigsign (mminusp* u))
3496 ;; cd is even
3497 (ftake* '%jacobi_cd (neg u) m))
3498 ((and $triginverses
3499 (listp u)
3500 (member (caar u) '(%inverse_jacobi_sn
3501 %inverse_jacobi_ns
3502 %inverse_jacobi_cn
3503 %inverse_jacobi_nc
3504 %inverse_jacobi_dn
3505 %inverse_jacobi_nd
3506 %inverse_jacobi_sc
3507 %inverse_jacobi_cs
3508 %inverse_jacobi_sd
3509 %inverse_jacobi_ds
3510 %inverse_jacobi_cd
3511 %inverse_jacobi_dc))
3512 (alike1 (third u) m))
3513 (cond ((eq (caar u) '%inverse_jacobi_cd)
3514 (second u))
3516 ;; Express in terms of cn and dn
3517 (div (ftake '%jacobi_cn u m)
3518 (ftake '%jacobi_dn u m)))))
3519 ;; A&S 16.20 (Jacobi's Imaginary transformation)
3520 ((and $%iargs (multiplep u '$%i))
3521 ;; cd(i*u) = cn(i*u)/dn(i*u) = nc(u,m1)/dc(u,m1) = nd(u,m1)
3522 (ftake* '%jacobi_nd (coeff u '$%i 1) (add 1 (neg m))))
3523 ((setf coef (kc-arg2 u m))
3524 ;; A&S 16.8.4
3526 (destructuring-bind (lin const)
3527 coef
3528 (cond ((integerp lin)
3529 (ecase (mod lin 4)
3531 ;; cd(4*m*K + u) = cd(u)
3532 ;; cd(0) = 1
3533 (if (zerop1 const)
3535 (ftake '%jacobi_cd const m)))
3537 ;; cd(4*m*K + K + u) = cd(K+u) = -sn(u)
3538 ;; cd(K) = 0
3539 (if (zerop1 const)
3541 (neg (ftake '%jacobi_sn const m))))
3543 ;; cd(4*m*K + 2*K + u) = cd(2*K+u) = -cd(u)
3544 ;; cd(2*K) = -1
3545 (if (zerop1 const)
3547 (neg (ftake '%jacobi_cd const m))))
3549 ;; cd(4*m*K + 3*K + u) = cd(2*K + K + u) =
3550 ;; -cd(K+u) = sn(u)
3551 ;; cd(3*K) = 0
3552 (if (zerop1 const)
3554 (ftake '%jacobi_sn const m)))))
3555 ((and (alike1 lin 1//2)
3556 (zerop1 const))
3557 ;; jacobi_cn/jacobi_dn
3558 (div (ftake '%jacobi_cn
3559 (mul 1//2
3560 (ftake '%elliptic_kc m))
3562 (ftake '%jacobi_dn
3563 (mul 1//2
3564 (ftake '%elliptic_kc m))
3565 m)))
3567 ;; Nothing to do
3568 (give-up)))))
3570 ;; Nothing to do
3571 (give-up)))))
3573 ;; jacobi_ds(u,m) = jacobi_dn/jacobi_sn
3574 (defprop %jacobi_ds
3575 ((u m)
3576 ;; wrt u
3577 ((mtimes) -1 ((%jacobi_cn) u m)
3578 ((mexpt) ((%jacobi_sn) u m) -2))
3579 ;; wrt m
3580 ((mplus)
3581 ((mtimes) -1 ((%jacobi_dn) u m)
3582 ((mexpt) ((%jacobi_sn) u m) -2)
3583 ((mplus)
3584 ((mtimes) ((rat) 1 2)
3585 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3586 ((mexpt) ((%jacobi_cn) u m) 2)
3587 ((%jacobi_sn) u m))
3588 ((mtimes) ((rat) 1 2) ((mexpt) m -1)
3589 ((%jacobi_cn) u m) ((%jacobi_dn) u m)
3590 ((mplus) u
3591 ((mtimes) -1
3592 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3593 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3594 m))))))
3595 ((mtimes) ((mexpt) ((%jacobi_sn) u m) -1)
3596 ((mplus)
3597 ((mtimes) ((rat) -1 2)
3598 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3599 ((%jacobi_dn) u m)
3600 ((mexpt) ((%jacobi_sn) u m) 2))
3601 ((mtimes) ((rat) -1 2) ((%jacobi_cn) u m)
3602 ((%jacobi_sn) u m)
3603 ((mplus) u
3604 ((mtimes) -1
3605 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3606 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3607 m))))))))
3608 grad)
3610 (def-simplifier jacobi_ds (u m)
3611 (let (coef args)
3612 (cond
3613 ((float-numerical-eval-p u m)
3614 (let ((fu (bigfloat:to ($float u)))
3615 (fm (bigfloat:to ($float m))))
3616 (to (bigfloat:/ (bigfloat::dn fu fm) (bigfloat::sn fu fm)))))
3617 ((setf args (complex-float-numerical-eval-p u m))
3618 (destructuring-bind (u m)
3619 args
3620 (let ((fu (bigfloat:to ($float u)))
3621 (fm (bigfloat:to ($float m))))
3622 (to (bigfloat:/ (bigfloat::dn fu fm) (bigfloat::sn fu fm))))))
3623 ((bigfloat-numerical-eval-p u m)
3624 (let ((uu (bigfloat:to ($bfloat u)))
3625 (mm (bigfloat:to ($bfloat m))))
3626 (to (bigfloat:/ (bigfloat::dn uu mm)
3627 (bigfloat::sn uu mm)))))
3628 ((setf args (complex-bigfloat-numerical-eval-p u m))
3629 (destructuring-bind (u m)
3630 args
3631 (let ((uu (bigfloat:to ($bfloat u)))
3632 (mm (bigfloat:to ($bfloat m))))
3633 (to (bigfloat:/ (bigfloat::dn uu mm)
3634 (bigfloat::sn uu mm))))))
3635 ((zerop1 m)
3636 ;; A&S 16.6.11
3637 (ftake '%csc u))
3638 ((onep1 m)
3639 ;; A&S 16.6.11
3640 (ftake '%csch u))
3641 ((zerop1 u)
3642 (dbz-err1 'jacobi_ds))
3643 ((and $trigsign (mminusp* u))
3644 (neg (ftake* '%jacobi_ds (neg u) m)))
3645 ((and $triginverses
3646 (listp u)
3647 (member (caar u) '(%inverse_jacobi_sn
3648 %inverse_jacobi_ns
3649 %inverse_jacobi_cn
3650 %inverse_jacobi_nc
3651 %inverse_jacobi_dn
3652 %inverse_jacobi_nd
3653 %inverse_jacobi_sc
3654 %inverse_jacobi_cs
3655 %inverse_jacobi_sd
3656 %inverse_jacobi_ds
3657 %inverse_jacobi_cd
3658 %inverse_jacobi_dc))
3659 (alike1 (third u) m))
3660 (cond ((eq (caar u) '%inverse_jacobi_ds)
3661 (second u))
3663 ;; Express in terms of dn and sn
3664 (div (ftake '%jacobi_dn u m)
3665 (ftake '%jacobi_sn u m)))))
3666 ;; A&S 16.20 (Jacobi's Imaginary transformation)
3667 ((and $%iargs (multiplep u '$%i))
3668 ;; ds(i*u) = dn(i*u)/sn(i*u) = -i*dc(u,m1)/sc(u,m1) = -i*ds(u,m1)
3669 (neg (mul '$%i
3670 (ftake* '%jacobi_ds (coeff u '$%i 1) (add 1 (neg m))))))
3671 ((setf coef (kc-arg2 u m))
3672 ;; A&S 16.8.11
3673 (destructuring-bind (lin const)
3674 coef
3675 (cond ((integerp lin)
3676 (ecase (mod lin 4)
3678 ;; ds(4*m*K + u) = ds(u)
3679 ;; ds(0) = infinity
3680 (if (zerop1 const)
3681 (dbz-err1 'jacobi_ds)
3682 (ftake '%jacobi_ds const m)))
3684 ;; ds(4*m*K + K + u) = ds(K+u) = sqrt(1-m)*nc(u)
3685 ;; ds(K) = sqrt(1-m)
3686 (if (zerop1 const)
3687 (power (sub 1 m) 1//2)
3688 (mul (power (sub 1 m) 1//2)
3689 (ftake '%jacobi_nc const m))))
3691 ;; ds(4*m*K + 2*K + u) = ds(2*K+u) = -ds(u)
3692 ;; ds(0) = pole
3693 (if (zerop1 const)
3694 (dbz-err1 'jacobi_ds)
3695 (neg (ftake '%jacobi_ds const m))))
3697 ;; ds(4*m*K + 3*K + u) = ds(2*K + K + u) =
3698 ;; -ds(K+u) = -sqrt(1-m)*nc(u)
3699 ;; ds(3*K) = -sqrt(1-m)
3700 (if (zerop1 const)
3701 (neg (power (sub 1 m) 1//2))
3702 (neg (mul (power (sub 1 m) 1//2)
3703 (ftake '%jacobi_nc u m)))))))
3704 ((and (alike1 lin 1//2)
3705 (zerop1 const))
3706 ;; jacobi_dn/jacobi_sn
3707 (div
3708 (ftake '%jacobi_dn
3709 (mul 1//2 (ftake '%elliptic_kc m))
3711 (ftake '%jacobi_sn
3712 (mul 1//2 (ftake '%elliptic_kc m))
3713 m)))
3715 ;; Nothing to do
3716 (give-up)))))
3718 ;; Nothing to do
3719 (give-up)))))
3721 ;; jacobi_dc(u,m) = jacobi_dn/jacobi_cn
3722 (defprop %jacobi_dc
3723 ((u m)
3724 ;; wrt u
3725 ((mtimes) ((mplus) 1 ((mtimes) -1 m))
3726 ((mexpt) ((%jacobi_cn) u m) -2)
3727 ((%jacobi_sn) u m))
3728 ;; wrt m
3729 ((mplus)
3730 ((mtimes) ((mexpt) ((%jacobi_cn) u m) -1)
3731 ((mplus)
3732 ((mtimes) ((rat) -1 2)
3733 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3734 ((%jacobi_dn) u m)
3735 ((mexpt) ((%jacobi_sn) u m) 2))
3736 ((mtimes) ((rat) -1 2) ((%jacobi_cn) u m)
3737 ((%jacobi_sn) u m)
3738 ((mplus) u
3739 ((mtimes) -1
3740 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3741 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3742 m))))))
3743 ((mtimes) -1 ((mexpt) ((%jacobi_cn) u m) -2)
3744 ((%jacobi_dn) u m)
3745 ((mplus)
3746 ((mtimes) ((rat) -1 2)
3747 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3748 ((%jacobi_cn) u m)
3749 ((mexpt) ((%jacobi_sn) u m) 2))
3750 ((mtimes) ((rat) -1 2) ((mexpt) m -1)
3751 ((%jacobi_dn) u m) ((%jacobi_sn) u m)
3752 ((mplus) u
3753 ((mtimes) -1
3754 ((mexpt) ((mplus) 1 ((mtimes) -1 m)) -1)
3755 ((%elliptic_e) ((%asin) ((%jacobi_sn) u m))
3756 m))))))))
3757 grad)
3759 (def-simplifier jacobi_dc (u m)
3760 (let (coef args)
3761 (cond
3762 ((float-numerical-eval-p u m)
3763 (let ((fu (bigfloat:to ($float u)))
3764 (fm (bigfloat:to ($float m))))
3765 (to (bigfloat:/ (bigfloat::dn fu fm) (bigfloat::cn fu fm)))))
3766 ((setf args (complex-float-numerical-eval-p u m))
3767 (destructuring-bind (u m)
3768 args
3769 (let ((fu (bigfloat:to ($float u)))
3770 (fm (bigfloat:to ($float m))))
3771 (to (bigfloat:/ (bigfloat::dn fu fm) (bigfloat::cn fu fm))))))
3772 ((bigfloat-numerical-eval-p u m)
3773 (let ((uu (bigfloat:to ($bfloat u)))
3774 (mm (bigfloat:to ($bfloat m))))
3775 (to (bigfloat:/ (bigfloat::dn uu mm)
3776 (bigfloat::cn uu mm)))))
3777 ((setf args (complex-bigfloat-numerical-eval-p u m))
3778 (destructuring-bind (u m)
3779 args
3780 (let ((uu (bigfloat:to ($bfloat u)))
3781 (mm (bigfloat:to ($bfloat m))))
3782 (to (bigfloat:/ (bigfloat::dn uu mm)
3783 (bigfloat::cn uu mm))))))
3784 ((zerop1 u)
3786 ((zerop1 m)
3787 ;; A&S 16.6.7
3788 (ftake '%sec u))
3789 ((onep1 m)
3790 ;; A&S 16.6.7
3792 ((and $trigsign (mminusp* u))
3793 (ftake* '%jacobi_dc (neg u) m))
3794 ((and $triginverses
3795 (listp u)
3796 (member (caar u) '(%inverse_jacobi_sn
3797 %inverse_jacobi_ns
3798 %inverse_jacobi_cn
3799 %inverse_jacobi_nc
3800 %inverse_jacobi_dn
3801 %inverse_jacobi_nd
3802 %inverse_jacobi_sc
3803 %inverse_jacobi_cs
3804 %inverse_jacobi_sd
3805 %inverse_jacobi_ds
3806 %inverse_jacobi_cd
3807 %inverse_jacobi_dc))
3808 (alike1 (third u) m))
3809 (cond ((eq (caar u) '%inverse_jacobi_dc)
3810 (second u))
3812 ;; Express in terms of dn and cn
3813 (div (ftake '%jacobi_dn u m)
3814 (ftake '%jacobi_cn u m)))))
3815 ;; A&S 16.20 (Jacobi's Imaginary transformation)
3816 ((and $%iargs (multiplep u '$%i))
3817 ;; dc(i*u) = dn(i*u)/cn(i*u) = dc(u,m1)/nc(u,m1) = dn(u,m1)
3818 (ftake* '%jacobi_dn (coeff u '$%i 1) (add 1 (neg m))))
3819 ((setf coef (kc-arg2 u m))
3820 ;; See A&S 16.8.7
3821 (destructuring-bind (lin const)
3822 coef
3823 (cond ((integerp lin)
3824 (ecase (mod lin 4)
3826 ;; dc(4*m*K + u) = dc(u)
3827 ;; dc(0) = 1
3828 (if (zerop1 const)
3830 (ftake '%jacobi_dc const m)))
3832 ;; dc(4*m*K + K + u) = dc(K+u) = -ns(u)
3833 ;; dc(K) = pole
3834 (if (zerop1 const)
3835 (dbz-err1 'jacobi_dc)
3836 (neg (ftake '%jacobi_ns const m))))
3838 ;; dc(4*m*K + 2*K + u) = dc(2*K+u) = -dc(u)
3839 ;; dc(2K) = -1
3840 (if (zerop1 const)
3842 (neg (ftake '%jacobi_dc const m))))
3844 ;; dc(4*m*K + 3*K + u) = dc(2*K + K + u) =
3845 ;; -dc(K+u) = ns(u)
3846 ;; dc(3*K) = ns(0) = inf
3847 (if (zerop1 const)
3848 (dbz-err1 'jacobi_dc)
3849 (ftake '%jacobi_dc const m)))))
3850 ((and (alike1 lin 1//2)
3851 (zerop1 const))
3852 ;; jacobi_dn/jacobi_cn
3853 (div
3854 (ftake '%jacobi_dn
3855 (mul 1//2 (ftake '%elliptic_kc m))
3857 (ftake '%jacobi_cn
3858 (mul 1//2 (ftake '%elliptic_kc m))
3859 m)))
3861 ;; Nothing to do
3862 (give-up)))))
3864 ;; Nothing to do
3865 (give-up)))))
3867 ;;; Other inverse Jacobian functions
3869 ;; inverse_jacobi_ns(x)
3871 ;; Let u = inverse_jacobi_ns(x). Then jacobi_ns(u) = x or
3872 ;; 1/jacobi_sn(u) = x or
3874 ;; jacobi_sn(u) = 1/x
3876 ;; so u = inverse_jacobi_sn(1/x)
3877 (defprop %inverse_jacobi_ns
3878 ((x m)
3879 ;; Whittaker and Watson, example in 22.122
3880 ;; inverse_jacobi_ns(u,m) = integrate(1/sqrt(t^2-1)/sqrt(t^2-m), t, u, inf)
3881 ;; -> -1/sqrt(x^2-1)/sqrt(x^2-m)
3882 ((mtimes) -1
3883 ((mexpt) ((mplus) -1 ((mexpt) x 2)) ((rat) -1 2))
3884 ((mexpt)
3885 ((mplus) ((mtimes simp ratsimp) -1 m) ((mexpt) x 2))
3886 ((rat) -1 2)))
3887 ;; wrt m
3888 ; ((%derivative) ((%inverse_jacobi_ns) x m) m 1)
3889 nil)
3890 grad)
3892 (def-simplifier inverse_jacobi_ns (u m)
3893 (let (args)
3894 (cond
3895 ((float-numerical-eval-p u m)
3896 ;; Numerically evaluate asn
3898 ;; ans(x,m) = asn(1/x,m) = F(asin(1/x),m)
3899 (to (elliptic-f (cl:asin (/ ($float u))) ($float m))))
3900 ((complex-float-numerical-eval-p u m)
3901 (to (elliptic-f (cl:asin (/ (complex ($realpart ($float u)) ($imagpart ($float u)))))
3902 (complex ($realpart ($float m)) ($imagpart ($float m))))))
3903 ((bigfloat-numerical-eval-p u m)
3904 (to (bigfloat::bf-elliptic-f (bigfloat:asin (bigfloat:/ (bigfloat:to ($bfloat u))))
3905 (bigfloat:to ($bfloat m)))))
3906 ((setf args (complex-bigfloat-numerical-eval-p u m))
3907 (destructuring-bind (u m)
3908 args
3909 (to (bigfloat::bf-elliptic-f (bigfloat:asin (bigfloat:/ (bigfloat:to ($bfloat u))))
3910 (bigfloat:to ($bfloat m))))))
3911 ((zerop1 m)
3912 ;; ans(x,0) = F(asin(1/x),0) = asin(1/x)
3913 (ftake '%elliptic_f (ftake '%asin (div 1 u)) 0))
3914 ((onep1 m)
3915 ;; ans(x,1) = F(asin(1/x),1) = log(tan(pi/2+asin(1/x)/2))
3916 (ftake '%elliptic_f (ftake '%asin (div 1 u)) 1))
3917 ((onep1 u)
3918 (ftake '%elliptic_kc m))
3919 ((alike1 u -1)
3920 (neg (ftake '%elliptic_kc m)))
3921 ((and (eq $triginverses '$all)
3922 (listp u)
3923 (eq (caar u) '%jacobi_ns)
3924 (alike1 (third u) m))
3925 ;; inverse_jacobi_ns(ns(u)) = u
3926 (second u))
3928 ;; Nothing to do
3929 (give-up)))))
3931 ;; inverse_jacobi_nc(x)
3933 ;; Let u = inverse_jacobi_nc(x). Then jacobi_nc(u) = x or
3934 ;; 1/jacobi_cn(u) = x or
3936 ;; jacobi_cn(u) = 1/x
3938 ;; so u = inverse_jacobi_cn(1/x)
3939 (defprop %inverse_jacobi_nc
3940 ((x m)
3941 ;; Whittaker and Watson, example in 22.122
3942 ;; inverse_jacobi_nc(u,m) = integrate(1/sqrt(t^2-1)/sqrt((1-m)*t^2+m), t, 1, u)
3943 ;; -> 1/sqrt(x^2-1)/sqrt((1-m)*x^2+m)
3944 ((mtimes)
3945 ((mexpt) ((mplus) -1 ((mexpt) x 2)) ((rat) -1 2))
3946 ((mexpt)
3947 ((mplus) m
3948 ((mtimes) -1 ((mplus) -1 m) ((mexpt) x 2)))
3949 ((rat) -1 2)))
3950 ;; wrt m
3951 ; ((%derivative) ((%inverse_jacobi_nc) x m) m 1)
3952 nil)
3953 grad)
3955 (def-simplifier inverse_jacobi_nc (u m)
3956 (cond ((or (float-numerical-eval-p u m)
3957 (complex-float-numerical-eval-p u m)
3958 (bigfloat-numerical-eval-p u m)
3959 (complex-bigfloat-numerical-eval-p u m))
3961 (ftake '%inverse_jacobi_cn ($rectform (div 1 u)) m))
3962 ((onep1 u)
3964 ((alike1 u -1)
3965 (mul 2 (ftake '%elliptic_kc m)))
3966 ((and (eq $triginverses '$all)
3967 (listp u)
3968 (eq (caar u) '%jacobi_nc)
3969 (alike1 (third u) m))
3970 ;; inverse_jacobi_nc(nc(u)) = u
3971 (second u))
3973 ;; Nothing to do
3974 (give-up))))
3976 ;; inverse_jacobi_nd(x)
3978 ;; Let u = inverse_jacobi_nd(x). Then jacobi_nd(u) = x or
3979 ;; 1/jacobi_dn(u) = x or
3981 ;; jacobi_dn(u) = 1/x
3983 ;; so u = inverse_jacobi_dn(1/x)
3984 (defprop %inverse_jacobi_nd
3985 ((x m)
3986 ;; Whittaker and Watson, example in 22.122
3987 ;; inverse_jacobi_nd(u,m) = integrate(1/sqrt(t^2-1)/sqrt(1-(1-m)*t^2), t, 1, u)
3988 ;; -> 1/sqrt(u^2-1)/sqrt(1-(1-m)*t^2)
3989 ((mtimes)
3990 ((mexpt) ((mplus) -1 ((mexpt simp ratsimp) x 2))
3991 ((rat) -1 2))
3992 ((mexpt)
3993 ((mplus) 1
3994 ((mtimes) ((mplus) -1 m) ((mexpt simp ratsimp) x 2)))
3995 ((rat) -1 2)))
3996 ;; wrt m
3997 ; ((%derivative) ((%inverse_jacobi_nd) x m) m 1)
3998 nil)
3999 grad)
4001 (def-simplifier inverse_jacobi_nd (u m)
4002 (cond ((or (float-numerical-eval-p u m)
4003 (complex-float-numerical-eval-p u m)
4004 (bigfloat-numerical-eval-p u m)
4005 (complex-bigfloat-numerical-eval-p u m))
4006 (ftake '%inverse_jacobi_dn ($rectform (div 1 u)) m))
4007 ((onep1 u)
4009 ((onep1 ($ratsimp (mul (power (sub 1 m) 1//2) u)))
4010 ;; jacobi_nd(1/sqrt(1-m),m) = K(m). This follows from
4011 ;; jacobi_dn(sqrt(1-m),m) = K(m).
4012 (ftake '%elliptic_kc m))
4013 ((and (eq $triginverses '$all)
4014 (listp u)
4015 (eq (caar u) '%jacobi_nd)
4016 (alike1 (third u) m))
4017 ;; inverse_jacobi_nd(nd(u)) = u
4018 (second u))
4020 ;; Nothing to do
4021 (give-up))))
4023 ;; inverse_jacobi_sc(x)
4025 ;; Let u = inverse_jacobi_sc(x). Then jacobi_sc(u) = x or
4026 ;; x = jacobi_sn(u)/jacobi_cn(u)
4028 ;; x^2 = sn^2/cn^2
4029 ;; = sn^2/(1-sn^2)
4031 ;; so
4033 ;; sn^2 = x^2/(1+x^2)
4035 ;; sn(u) = x/sqrt(1+x^2)
4037 ;; u = inverse_sn(x/sqrt(1+x^2))
4039 (defprop %inverse_jacobi_sc
4040 ((x m)
4041 ;; Whittaker and Watson, example in 22.122
4042 ;; inverse_jacobi_sc(u,m) = integrate(1/sqrt(1+t^2)/sqrt(1+(1-m)*t^2), t, 0, u)
4043 ;; -> 1/sqrt(1+x^2)/sqrt(1+(1-m)*x^2)
4044 ((mtimes)
4045 ((mexpt) ((mplus) 1 ((mexpt) x 2))
4046 ((rat) -1 2))
4047 ((mexpt)
4048 ((mplus) 1
4049 ((mtimes) -1 ((mplus) -1 m) ((mexpt) x 2)))
4050 ((rat) -1 2)))
4051 ;; wrt m
4052 ; ((%derivative) ((%inverse_jacobi_sc) x m) m 1)
4053 nil)
4054 grad)
4056 (def-simplifier inverse_jacobi_sc (u m)
4057 (cond ((or (float-numerical-eval-p u m)
4058 (complex-float-numerical-eval-p u m)
4059 (bigfloat-numerical-eval-p u m)
4060 (complex-bigfloat-numerical-eval-p u m))
4061 (ftake '%inverse_jacobi_sn
4062 ($rectform (div u (power (add 1 (mul u u)) 1//2)))
4064 ((zerop1 u)
4065 ;; jacobi_sc(0,m) = 0
4067 ((and (eq $triginverses '$all)
4068 (listp u)
4069 (eq (caar u) '%jacobi_sc)
4070 (alike1 (third u) m))
4071 ;; inverse_jacobi_sc(sc(u)) = u
4072 (second u))
4074 ;; Nothing to do
4075 (give-up))))
4077 ;; inverse_jacobi_sd(x)
4079 ;; Let u = inverse_jacobi_sd(x). Then jacobi_sd(u) = x or
4080 ;; x = jacobi_sn(u)/jacobi_dn(u)
4082 ;; x^2 = sn^2/dn^2
4083 ;; = sn^2/(1-m*sn^2)
4085 ;; so
4087 ;; sn^2 = x^2/(1+m*x^2)
4089 ;; sn(u) = x/sqrt(1+m*x^2)
4091 ;; u = inverse_sn(x/sqrt(1+m*x^2))
4093 (defprop %inverse_jacobi_sd
4094 ((x m)
4095 ;; Whittaker and Watson, example in 22.122
4096 ;; inverse_jacobi_sd(u,m) = integrate(1/sqrt(1-(1-m)*t^2)/sqrt(1+m*t^2), t, 0, u)
4097 ;; -> 1/sqrt(1-(1-m)*x^2)/sqrt(1+m*x^2)
4098 ((mtimes)
4099 ((mexpt)
4100 ((mplus) 1 ((mtimes) ((mplus) -1 m) ((mexpt) x 2)))
4101 ((rat) -1 2))
4102 ((mexpt) ((mplus) 1 ((mtimes) m ((mexpt) x 2)))
4103 ((rat) -1 2)))
4104 ;; wrt m
4105 ; ((%derivative) ((%inverse_jacobi_sd) x m) m 1)
4106 nil)
4107 grad)
4109 (def-simplifier inverse_jacobi_sd (u m)
4110 (cond ((or (float-numerical-eval-p u m)
4111 (complex-float-numerical-eval-p u m)
4112 (bigfloat-numerical-eval-p u m)
4113 (complex-bigfloat-numerical-eval-p u m))
4114 (ftake '%inverse_jacobi_sn
4115 ($rectform (div u (power (add 1 (mul m (mul u u))) 1//2)))
4117 ((zerop1 u)
4119 ((eql 0 ($ratsimp (sub u (div 1 (power (sub 1 m) 1//2)))))
4120 ;; inverse_jacobi_sd(1/sqrt(1-m), m) = elliptic_kc(m)
4122 ;; We can see this from inverse_jacobi_sd(x,m) =
4123 ;; inverse_jacobi_sn(x/sqrt(1+m*x^2), m). So
4124 ;; inverse_jacobi_sd(1/sqrt(1-m),m) = inverse_jacobi_sn(1,m)
4125 (ftake '%elliptic_kc m))
4126 ((and (eq $triginverses '$all)
4127 (listp u)
4128 (eq (caar u) '%jacobi_sd)
4129 (alike1 (third u) m))
4130 ;; inverse_jacobi_sd(sd(u)) = u
4131 (second u))
4133 ;; Nothing to do
4134 (give-up))))
4136 ;; inverse_jacobi_cs(x)
4138 ;; Let u = inverse_jacobi_cs(x). Then jacobi_cs(u) = x or
4139 ;; 1/x = 1/jacobi_cs(u) = jacobi_sc(u)
4141 ;; u = inverse_sc(1/x)
4143 (defprop %inverse_jacobi_cs
4144 ((x m)
4145 ;; Whittaker and Watson, example in 22.122
4146 ;; inverse_jacobi_cs(u,m) = integrate(1/sqrt(t^2+1)/sqrt(t^2+(1-m)), t, u, inf)
4147 ;; -> -1/sqrt(x^2+1)/sqrt(x^2+(1-m))
4148 ((mtimes) -1
4149 ((mexpt) ((mplus) 1 ((mexpt simp ratsimp) x 2))
4150 ((rat) -1 2))
4151 ((mexpt) ((mplus) 1
4152 ((mtimes simp ratsimp) -1 m)
4153 ((mexpt simp ratsimp) x 2))
4154 ((rat) -1 2)))
4155 ;; wrt m
4156 ; ((%derivative) ((%inverse_jacobi_cs) x m) m 1)
4157 nil)
4158 grad)
4160 (def-simplifier inverse_jacobi_cs (u m)
4161 (cond ((or (float-numerical-eval-p u m)
4162 (complex-float-numerical-eval-p u m)
4163 (bigfloat-numerical-eval-p u m)
4164 (complex-bigfloat-numerical-eval-p u m))
4165 (ftake '%inverse_jacobi_sc ($rectform (div 1 u)) m))
4166 ((zerop1 u)
4167 (ftake '%elliptic_kc m))
4169 ;; Nothing to do
4170 (give-up))))
4172 ;; inverse_jacobi_cd(x)
4174 ;; Let u = inverse_jacobi_cd(x). Then jacobi_cd(u) = x or
4175 ;; x = jacobi_cn(u)/jacobi_dn(u)
4177 ;; x^2 = cn^2/dn^2
4178 ;; = (1-sn^2)/(1-m*sn^2)
4180 ;; or
4182 ;; sn^2 = (1-x^2)/(1-m*x^2)
4184 ;; sn(u) = sqrt(1-x^2)/sqrt(1-m*x^2)
4186 ;; u = inverse_sn(sqrt(1-x^2)/sqrt(1-m*x^2))
4188 (defprop %inverse_jacobi_cd
4189 ((x m)
4190 ;; Whittaker and Watson, example in 22.122
4191 ;; inverse_jacobi_cd(u,m) = integrate(1/sqrt(1-t^2)/sqrt(1-m*t^2), t, u, 1)
4192 ;; -> -1/sqrt(1-x^2)/sqrt(1-m*x^2)
4193 ((mtimes) -1
4194 ((mexpt)
4195 ((mplus) 1 ((mtimes) -1 ((mexpt) x 2)))
4196 ((rat) -1 2))
4197 ((mexpt)
4198 ((mplus) 1 ((mtimes) -1 m ((mexpt) x 2)))
4199 ((rat) -1 2)))
4200 ;; wrt m
4201 ; ((%derivative) ((%inverse_jacobi_cd) x m) m 1)
4202 nil)
4203 grad)
4205 (def-simplifier inverse_jacobi_cd (u m)
4206 (cond ((or (complex-float-numerical-eval-p u m)
4207 (complex-bigfloat-numerical-eval-p u m))
4208 (let (($numer t))
4209 (ftake '%inverse_jacobi_sn
4210 ($rectform (div (power (mul (sub 1 u) (add 1 u)) 1//2)
4211 (power (sub 1 (mul m (mul u u))) 1//2)))
4212 m)))
4213 ((onep1 u)
4215 ((zerop1 u)
4216 (ftake '%elliptic_kc m))
4217 ((and (eq $triginverses '$all)
4218 (listp u)
4219 (eq (caar u) '%jacobi_cd)
4220 (alike1 (third u) m))
4221 ;; inverse_jacobi_cd(cd(u)) = u
4222 (second u))
4224 ;; Nothing to do
4225 (give-up))))
4227 ;; inverse_jacobi_ds(x)
4229 ;; Let u = inverse_jacobi_ds(x). Then jacobi_ds(u) = x or
4230 ;; 1/x = 1/jacobi_ds(u) = jacobi_sd(u)
4232 ;; u = inverse_sd(1/x)
4234 (defprop %inverse_jacobi_ds
4235 ((x m)
4236 ;; Whittaker and Watson, example in 22.122
4237 ;; inverse_jacobi_ds(u,m) = integrate(1/sqrt(t^2-(1-m))/sqrt(t^2+m), t, u, inf)
4238 ;; -> -1/sqrt(x^2-(1-m))/sqrt(x^2+m)
4239 ((mtimes) -1
4240 ((mexpt)
4241 ((mplus) -1 m ((mexpt simp ratsimp) x 2))
4242 ((rat) -1 2))
4243 ((mexpt)
4244 ((mplus) m ((mexpt simp ratsimp) x 2))
4245 ((rat) -1 2)))
4246 ;; wrt m
4247 ; ((%derivative) ((%inverse_jacobi_ds) x m) m 1)
4248 nil)
4249 grad)
4251 (def-simplifier inverse_jacobi_ds (u m)
4252 (cond ((or (float-numerical-eval-p u m)
4253 (complex-float-numerical-eval-p u m)
4254 (bigfloat-numerical-eval-p u m)
4255 (complex-bigfloat-numerical-eval-p u m))
4256 (ftake '%inverse_jacobi_sd ($rectform (div 1 u)) m))
4257 ((and $trigsign (mminusp* u))
4258 (neg (ftake* '%inverse_jacobi_ds (neg u) m)))
4259 ((eql 0 ($ratsimp (sub u (power (sub 1 m) 1//2))))
4260 ;; inverse_jacobi_ds(sqrt(1-m),m) = elliptic_kc(m)
4262 ;; Since inverse_jacobi_ds(sqrt(1-m), m) =
4263 ;; inverse_jacobi_sd(1/sqrt(1-m),m). And we know from
4264 ;; above that this is elliptic_kc(m)
4265 (ftake '%elliptic_kc m))
4266 ((and (eq $triginverses '$all)
4267 (listp u)
4268 (eq (caar u) '%jacobi_ds)
4269 (alike1 (third u) m))
4270 ;; inverse_jacobi_ds(ds(u)) = u
4271 (second u))
4273 ;; Nothing to do
4274 (give-up))))
4277 ;; inverse_jacobi_dc(x)
4279 ;; Let u = inverse_jacobi_dc(x). Then jacobi_dc(u) = x or
4280 ;; 1/x = 1/jacobi_dc(u) = jacobi_cd(u)
4282 ;; u = inverse_cd(1/x)
4284 (defprop %inverse_jacobi_dc
4285 ((x m)
4286 ;; Note: Whittaker and Watson, example in 22.122 says
4287 ;; inverse_jacobi_dc(u,m) = integrate(1/sqrt(t^2-1)/sqrt(t^2-m),
4288 ;; t, u, 1) but that seems wrong. A&S 17.4.47 says
4289 ;; integrate(1/sqrt(t^2-1)/sqrt(t^2-m), t, a, u) =
4290 ;; inverse_jacobi_cd(x,m). Lawden 3.2.8 says the same.
4291 ;; functions.wolfram.com says the derivative is
4292 ;; 1/sqrt(t^2-1)/sqrt(t^2-m).
4293 ((mtimes)
4294 ((mexpt)
4295 ((mplus) -1 ((mexpt simp ratsimp) x 2))
4296 ((rat) -1 2))
4297 ((mexpt)
4298 ((mplus)
4299 ((mtimes simp ratsimp) -1 m)
4300 ((mexpt simp ratsimp) x 2))
4301 ((rat) -1 2)))
4302 ;; wrt m
4303 ; ((%derivative) ((%inverse_jacobi_dc) x m) m 1)
4304 nil)
4305 grad)
4307 (def-simplifier inverse_jacobi_dc (u m)
4308 (cond ((or (complex-float-numerical-eval-p u m)
4309 (complex-bigfloat-numerical-eval-p u m))
4310 (ftake '%inverse_jacobi_cd ($rectform (div 1 u)) m))
4311 ((onep1 u)
4313 ((and (eq $triginverses '$all)
4314 (listp u)
4315 (eq (caar u) '%jacobi_dc)
4316 (alike1 (third u) m))
4317 ;; inverse_jacobi_dc(dc(u)) = u
4318 (second u))
4320 ;; Nothing to do
4321 (give-up))))
4323 ;; Convert an inverse Jacobian function into the equivalent elliptic
4324 ;; integral F.
4326 ;; See A&S 17.4.41-17.4.52.
4327 (defun make-elliptic-f (e)
4328 (cond ((atom e)
4330 ((member (caar e) '(%inverse_jacobi_sc %inverse_jacobi_cs
4331 %inverse_jacobi_nd %inverse_jacobi_dn
4332 %inverse_jacobi_sn %inverse_jacobi_cd
4333 %inverse_jacobi_dc %inverse_jacobi_ns
4334 %inverse_jacobi_nc %inverse_jacobi_ds
4335 %inverse_jacobi_sd %inverse_jacobi_cn))
4336 ;; We have some inverse Jacobi function. Convert it to the F form.
4337 (destructuring-bind ((fn &rest ops) u m)
4339 (declare (ignore ops))
4340 (ecase fn
4341 (%inverse_jacobi_sc
4342 ;; A&S 17.4.41
4343 (ftake '%elliptic_f (ftake '%atan u) m))
4344 (%inverse_jacobi_cs
4345 ;; A&S 17.4.42
4346 (ftake '%elliptic_f (ftake '%atan (div 1 u)) m))
4347 (%inverse_jacobi_nd
4348 ;; A&S 17.4.43
4349 (ftake '%elliptic_f
4350 (ftake '%asin
4351 (mul (power m -1//2)
4352 (div 1 u)
4353 (power (add -1 (mul u u))
4354 1//2)))
4356 (%inverse_jacobi_dn
4357 ;; A&S 17.4.44
4358 (ftake '%elliptic_f
4359 (ftake '%asin (mul
4360 (power m -1//2)
4361 (power (sub 1 (power u 2)) 1//2)))
4363 (%inverse_jacobi_sn
4364 ;; A&S 17.4.45
4365 (ftake '%elliptic_f (ftake '%asin u) m))
4366 (%inverse_jacobi_cd
4367 ;; A&S 17.4.46
4368 (ftake '%elliptic_f
4369 (ftake '%asin
4370 (power (mul (sub 1 (mul u u))
4371 (sub 1 (mul m u u)))
4372 1//2))
4374 (%inverse_jacobi_dc
4375 ;; A&S 17.4.47
4376 (ftake '%elliptic_f
4377 (ftake '%asin
4378 (power (mul (sub (mul u u) 1)
4379 (sub (mul u u) m))
4380 1//2))
4382 (%inverse_jacobi_ns
4383 ;; A&S 17.4.48
4384 (ftake '%elliptic_f (ftake '%asin (div 1 u)) m))
4385 (%inverse_jacobi_nc
4386 ;; A&S 17.4.49
4387 (ftake '%elliptic_f (ftake '%acos (div 1 u)) m))
4388 (%inverse_jacobi_ds
4389 ;; A&S 17.4.50
4390 (ftake '%elliptic_f
4391 (ftake '%asin
4392 (power (add m (mul u u))
4393 1//2))
4395 (%inverse_jacobi_sd
4396 ;; A&S 17.4.51
4397 (ftake '%elliptic_f
4398 (ftake '%asin
4399 (div u
4400 (power (add 1 (mul m u u))
4401 1//2)))
4403 (%inverse_jacobi_cn
4404 ;; A&S 17.4.52
4405 (ftake '%elliptic_f (ftake '%acos u) m)))))
4407 (recur-apply #'make-elliptic-f e))))
4409 (defmfun $make_elliptic_f (e)
4410 (if (atom e)
4412 (simplify (make-elliptic-f e))))
4414 (defun make-elliptic-e (e)
4415 (cond ((atom e) e)
4416 ((eq (caar e) '$elliptic_eu)
4417 (destructuring-bind ((ffun &rest ops) u m) e
4418 (declare (ignore ffun ops))
4419 (ftake '%elliptic_e (ftake '%asin (ftake '%jacobi_sn u m)) m)))
4421 (recur-apply #'make-elliptic-e e))))
4423 (defmfun $make_elliptic_e (e)
4424 (if (atom e)
4426 (simplify (make-elliptic-e e))))
4429 ;; Eu(u,m) = integrate(jacobi_dn(v,m)^2,v,0,u)
4430 ;; = integrate(sqrt((1-m*t^2)/(1-t^2)),t,0,jacobi_sn(u,m))
4432 ;; Eu(u,m) = E(am(u),m)
4434 ;; where E(u,m) is elliptic-e above.
4436 ;; Checks.
4437 ;; Lawden gives the following relationships
4439 ;; E(u+v) = E(u) + E(v) - m*sn(u)*sn(v)*sn(u+v)
4440 ;; E(u,0) = u, E(u,1) = tanh u
4442 ;; E(i*u,k) = i*sc(u,k')*dn(u,k') - i*E(u,k') + i*u
4444 ;; E(2*i*K') = 2*i*(K'-E')
4446 ;; E(u + 2*i*K') = E(u) + 2*i*(K' - E')
4448 ;; E(u+K) = E(u) + E - k^2*sn(u)*cd(u)
4449 (defun elliptic-eu (u m)
4450 (cond ((realp u)
4451 ;; E(u + 2*n*K) = E(u) + 2*n*E
4452 (let ((ell-k (to (elliptic-k m)))
4453 (ell-e (elliptic-ec m)))
4454 (multiple-value-bind (n u-rem)
4455 (floor u (* 2 ell-k))
4456 ;; 0 <= u-rem < 2*K
4457 (+ (* 2 n ell-e)
4458 (cond ((>= u-rem ell-k)
4459 ;; 0 <= u-rem < K so
4460 ;; E(u + K) = E(u) + E - m*sn(u)*cd(u)
4461 (let ((u-k (- u ell-k)))
4462 (- (+ (elliptic-e (cl:asin (bigfloat::sn u-k m)) m)
4463 ell-e)
4464 (/ (* m (bigfloat::sn u-k m) (bigfloat::cn u-k m))
4465 (bigfloat::dn u-k m)))))
4467 (elliptic-e (cl:asin (bigfloat::sn u m)) m)))))))
4468 ((complexp u)
4469 ;; From Lawden:
4471 ;; E(u+i*v, m) = E(u,m) -i*E(v,m') + i*v + i*sc(v,m')*dn(v,m')
4472 ;; -i*m*sn(u,m)*sc(v,m')*sn(u+i*v,m)
4474 (let ((u-r (realpart u))
4475 (u-i (imagpart u))
4476 (m1 (- 1 m)))
4477 (+ (elliptic-eu u-r m)
4478 (* #c(0 1)
4479 (- (+ u-i
4480 (/ (* (bigfloat::sn u-i m1) (bigfloat::dn u-i m1))
4481 (bigfloat::cn u-i m1)))
4482 (+ (elliptic-eu u-i m1)
4483 (/ (* m (bigfloat::sn u-r m) (bigfloat::sn u-i m1) (bigfloat::sn u m))
4484 (bigfloat::cn u-i m1))))))))))
4486 (defprop $elliptic_eu
4487 ((u m)
4488 ((mexpt) ((%jacobi_dn) u m) 2)
4489 ;; wrt m
4491 grad)
4493 (def-simplifier elliptic_eu (u m)
4494 (cond
4495 ;; as it stands, ELLIPTIC-EU can't handle bigfloats or complex bigfloats,
4496 ;; so handle only floats and complex floats here.
4497 ((float-numerical-eval-p u m)
4498 (elliptic-eu ($float u) ($float m)))
4499 ((complex-float-numerical-eval-p u m)
4500 (let ((u-r ($realpart u))
4501 (u-i ($imagpart u))
4502 (m ($float m)))
4503 (complexify (elliptic-eu (complex u-r u-i) m))))
4505 (give-up))))
4507 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4508 ;; Integrals. At present with respect to first argument only.
4509 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4511 ;; A&S 16.24.1: integrate(jacobi_sn(u,m),u)
4512 ;; = log(jacobi_dn(u,m)-sqrt(m)*jacobi_cn(u,m))/sqrt(m)
4513 (defprop %jacobi_sn
4514 ((u m)
4515 ((mtimes simp) ((mexpt simp) m ((rat simp) -1 2))
4516 ((%log simp)
4517 ((mplus simp)
4518 ((mtimes simp) -1 ((mexpt simp) m ((rat simp) 1 2))
4519 ((%jacobi_cn simp) u m))
4520 ((%jacobi_dn simp) u m))))
4521 nil)
4522 integral)
4524 ;; A&S 16.24.2: integrate(jacobi_cn(u,m),u) = acos(jacobi_dn(u,m))/sqrt(m)
4525 (defprop %jacobi_cn
4526 ((u m)
4527 ((mtimes simp) ((mexpt simp) m ((rat simp) -1 2))
4528 ((%acos simp) ((%jacobi_dn simp) u m)))
4529 nil)
4530 integral)
4532 ;; A&S 16.24.3: integrate(jacobi_dn(u,m),u) = asin(jacobi_sn(u,m))
4533 (defprop %jacobi_dn
4534 ((u m)
4535 ((%asin simp) ((%jacobi_sn simp) u m))
4536 nil)
4537 integral)
4539 ;; A&S 16.24.4: integrate(jacobi_cd(u,m),u)
4540 ;; = log(jacobi_nd(u,m)+sqrt(m)*jacobi_sd(u,m))/sqrt(m)
4541 (defprop %jacobi_cd
4542 ((u m)
4543 ((mtimes simp) ((mexpt simp) m ((rat simp) -1 2))
4544 ((%log simp)
4545 ((mplus simp) ((%jacobi_nd simp) u m)
4546 ((mtimes simp) ((mexpt simp) m ((rat simp) 1 2))
4547 ((%jacobi_sd simp) u m)))))
4548 nil)
4549 integral)
4551 ;; integrate(jacobi_sd(u,m),u)
4553 ;; A&S 16.24.5 gives
4554 ;; asin(-sqrt(m)*jacobi_cd(u,m))/sqrt(m*m_1), where m + m_1 = 1
4555 ;; but this does not pass some simple tests.
4557 ;; functions.wolfram.com 09.35.21.001.01 gives
4558 ;; -asin(sqrt(m)*jacobi_cd(u,m))*sqrt(1-m*jacobi_cd(u,m)^2)*jacobi_dn(u,m)/((1-m)*sqrt(m))
4559 ;; and this does pass.
4560 (defprop %jacobi_sd
4561 ((u m)
4562 ((mtimes simp) -1
4563 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
4564 ((mexpt simp) m ((rat simp) -1 2))
4565 ((mexpt simp)
4566 ((mplus simp) 1
4567 ((mtimes simp) -1 $m ((mexpt simp) ((%jacobi_cd simp) u m) 2)))
4568 ((rat simp) 1 2))
4569 ((%jacobi_dn simp) u m)
4570 ((%asin simp)
4571 ((mtimes simp) ((mexpt simp) m ((rat simp) 1 2))
4572 ((%jacobi_cd simp) u m))))
4573 nil)
4574 integral)
4576 ;; integrate(jacobi_nd(u,m),u)
4578 ;; A&S 16.24.6 gives
4579 ;; acos(jacobi_cd(u,m))/sqrt(m_1), where m + m_1 = 1
4580 ;; but this does not pass some simple tests.
4582 ;; functions.wolfram.com 09.32.21.0001.01 gives
4583 ;; sqrt(1-jacobi_cd(u,m)^2)*acos(jacobi_cd(u,m))/((1-m)*jacobi_sd(u,m))
4584 ;; and this does pass.
4585 (defprop %jacobi_nd
4586 ((u m)
4587 ((mtimes simp) ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m)) -1)
4588 ((mexpt simp)
4589 ((mplus simp) 1
4590 ((mtimes simp) -1 ((mexpt simp) ((%jacobi_cd simp) u m) 2)))
4591 ((rat simp) 1 2))
4592 ((mexpt simp) ((%jacobi_sd simp) u m) -1)
4593 ((%acos simp) ((%jacobi_cd simp) u m)))
4594 nil)
4595 integral)
4597 ;; A&S 16.24.7: integrate(jacobi_dc(u,m),u) = log(jacobi_nc(u,m)+jacobi_sc(u,m))
4598 (defprop %jacobi_dc
4599 ((u m)
4600 ((%log simp) ((mplus simp) ((%jacobi_nc simp) u m) ((%jacobi_sc simp) u m)))
4601 nil)
4602 integral)
4604 ;; A&S 16.24.8: integrate(jacobi_nc(u,m),u)
4605 ;; = log(jacobi_dc(u,m)+sqrt(m_1)*jacobi_sc(u,m))/sqrt(m_1), where m + m_1 = 1
4606 (defprop %jacobi_nc
4607 ((u m)
4608 ((mtimes simp)
4609 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m))
4610 ((rat simp) -1 2))
4611 ((%log simp)
4612 ((mplus simp) ((%jacobi_dc simp) u m)
4613 ((mtimes simp)
4614 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m))
4615 ((rat simp) 1 2))
4616 ((%jacobi_sc simp) u m)))))
4617 nil)
4618 integral)
4620 ;; A&S 16.24.9: integrate(jacobi_sc(u,m),u)
4621 ;; = log(jacobi_dc(u,m)+sqrt(m_1)*jacobi_nc(u,m))/sqrt(m_1), where m + m_1 = 1
4622 (defprop %jacobi_sc
4623 ((u m)
4624 ((mtimes simp)
4625 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m))
4626 ((rat simp) -1 2))
4627 ((%log simp)
4628 ((mplus simp) ((%jacobi_dc simp) u m)
4629 ((mtimes simp)
4630 ((mexpt simp) ((mplus simp) 1 ((mtimes simp) -1 m))
4631 ((rat simp) 1 2))
4632 ((%jacobi_nc simp) u m)))))
4633 nil)
4634 integral)
4636 ;; A&S 16.24.10: integrate(jacobi_ns(u,m),u)
4637 ;; = log(jacobi_ds(u,m)-jacobi_cs(u,m))
4638 (defprop %jacobi_ns
4639 ((u m)
4640 ((%log simp)
4641 ((mplus simp) ((mtimes simp) -1 ((%jacobi_cs simp) u m))
4642 ((%jacobi_ds simp) u m)))
4643 nil)
4644 integral)
4646 ;; integrate(jacobi_ds(u,m),u)
4648 ;; A&S 16.24.11 gives
4649 ;; log(jacobi_ds(u,m)-jacobi_cs(u,m))
4650 ;; but this does not pass some simple tests.
4652 ;; functions.wolfram.com 09.30.21.0001.01 gives
4653 ;; log((1-jacobi_cn(u,m))/jacobi_sn(u,m))
4655 (defprop %jacobi_ds
4656 ((u m)
4657 ((%log simp)
4658 ((mtimes simp)
4659 ((mplus simp) 1 ((mtimes simp) -1 ((%jacobi_cn simp) u m)))
4660 ((mexpt simp) ((%jacobi_sn simp) u m) -1)))
4661 nil)
4662 integral)
4664 ;; A&S 16.24.12: integrate(jacobi_cs(u,m),u) = log(jacobi_ns(u,m)-jacobi_ds(u,m))
4665 (defprop %jacobi_cs
4666 ((u m)
4667 ((%log simp)
4668 ((mplus simp) ((mtimes simp) -1 ((%jacobi_ds simp) u m))
4669 ((%jacobi_ns simp) u m)))
4670 nil)
4671 integral)
4673 ;; functions.wolfram.com 09.48.21.0001.01
4674 ;; integrate(inverse_jacobi_sn(u,m),u) =
4675 ;; inverse_jacobi_sn(u,m)*u
4676 ;; - log( jacobi_dn(inverse_jacobi_sn(u,m),m)
4677 ;; -sqrt(m)*jacobi_cn(inverse_jacobi_sn(u,m),m)) / sqrt(m)
4678 (defprop %inverse_jacobi_sn
4679 ((u m)
4680 ((mplus simp) ((mtimes simp) u ((%inverse_jacobi_sn simp) u m))
4681 ((mtimes simp) -1 ((mexpt simp) m ((rat simp) -1 2))
4682 ((%log simp)
4683 ((mplus simp)
4684 ((mtimes simp) -1 ((mexpt simp) m ((rat simp) 1 2))
4685 ((%jacobi_cn simp) ((%inverse_jacobi_sn simp) u m) m))
4686 ((%jacobi_dn simp) ((%inverse_jacobi_sn simp) u m) m)))))
4687 nil)
4688 integral)
4690 ;; functions.wolfram.com 09.38.21.0001.01
4691 ;; integrate(inverse_jacobi_cn(u,m),u) =
4692 ;; u*inverse_jacobi_cn(u,m)
4693 ;; -%i*log(%i*jacobi_dn(inverse_jacobi_cn(u,m),m)/sqrt(m)
4694 ;; -jacobi_sn(inverse_jacobi_cn(u,m),m))
4695 ;; /sqrt(m)
4696 (defprop %inverse_jacobi_cn
4697 ((u m)
4698 ((mplus simp) ((mtimes simp) u ((%inverse_jacobi_cn simp) u m))
4699 ((mtimes simp) -1 $%i ((mexpt simp) m ((rat simp) -1 2))
4700 ((%log simp)
4701 ((mplus simp)
4702 ((mtimes simp) $%i ((mexpt simp) m ((rat simp) -1 2))
4703 ((%jacobi_dn simp) ((%inverse_jacobi_cn simp) u m) m))
4704 ((mtimes simp) -1
4705 ((%jacobi_sn simp) ((%inverse_jacobi_cn simp) u m) m))))))
4706 nil)
4707 integral)
4709 ;; functions.wolfram.com 09.41.21.0001.01
4710 ;; integrate(inverse_jacobi_dn(u,m),u) =
4711 ;; u*inverse_jacobi_dn(u,m)
4712 ;; - %i*log(%i*jacobi_cn(inverse_jacobi_dn(u,m),m)
4713 ;; +jacobi_sn(inverse_jacobi_dn(u,m),m))
4714 (defprop %inverse_jacobi_dn
4715 ((u m)
4716 ((mplus simp) ((mtimes simp) u ((%inverse_jacobi_dn simp) u m))
4717 ((mtimes simp) -1 $%i
4718 ((%log simp)
4719 ((mplus simp)
4720 ((mtimes simp) $%i
4721 ((%jacobi_cn simp) ((%inverse_jacobi_dn simp) u m) m))
4722 ((%jacobi_sn simp) ((%inverse_jacobi_dn simp) u m) m)))))
4723 nil)
4724 integral)
4727 ;; Real and imaginary part for Jacobi elliptic functions.
4728 (defprop %jacobi_sn risplit-sn-cn-dn risplit-function)
4729 (defprop %jacobi_cn risplit-sn-cn-dn risplit-function)
4730 (defprop %jacobi_dn risplit-sn-cn-dn risplit-function)
4732 (defun risplit-sn-cn-dn (expr)
4733 (let* ((arg (second expr))
4734 (param (third expr)))
4735 ;; We only split on the argument, not the order
4736 (destructuring-bind (arg-r . arg-i)
4737 (risplit arg)
4738 (cond ((=0 arg-i)
4739 ;; Pure real
4740 (cons (take (first expr) arg-r param)
4743 (let* ((s (ftake '%jacobi_sn arg-r param))
4744 (c (ftake '%jacobi_cn arg-r param))
4745 (d (ftake '%jacobi_dn arg-r param))
4746 (s1 (ftake '%jacobi_sn arg-i (sub 1 param)))
4747 (c1 (ftake '%jacobi_cn arg-i (sub 1 param)))
4748 (d1 (ftake '%jacobi_dn arg-i (sub 1 param)))
4749 (den (add (mul c1 c1)
4750 (mul param
4751 (mul (mul s s)
4752 (mul s1 s1))))))
4753 ;; Let s = jacobi_sn(x,m)
4754 ;; c = jacobi_cn(x,m)
4755 ;; d = jacobi_dn(x,m)
4756 ;; s1 = jacobi_sn(y,1-m)
4757 ;; c1 = jacobi_cn(y,1-m)
4758 ;; d1 = jacobi_dn(y,1-m)
4759 (case (caar expr)
4760 (%jacobi_sn
4761 ;; A&S 16.21.1
4762 ;; jacobi_sn(x+%i*y,m) =
4764 ;; s*d1 + %i*c*d*s1*c1
4765 ;; -------------------
4766 ;; c1^2+m*s^2*s1^2
4768 (cons (div (mul s d1) den)
4769 (div (mul c (mul d (mul s1 c1)))
4770 den)))
4771 (%jacobi_cn
4772 ;; A&S 16.21.2
4774 ;; cn(x+%i_y, m) =
4776 ;; c*c1 - %i*s*d*s1*d1
4777 ;; -------------------
4778 ;; c1^2+m*s^2*s1^2
4779 (cons (div (mul c c1) den)
4780 (div (mul -1
4781 (mul s (mul d (mul s1 d1))))
4782 den)))
4783 (%jacobi_dn
4784 ;; A&S 16.21.3
4786 ;; dn(x+%i_y, m) =
4788 ;; d*c1*d1 - %i*m*s*c*s1
4789 ;; ---------------------
4790 ;; c1^2+m*s^2*s1^2
4791 (cons (div (mul d (mul c1 d1))
4792 den)
4793 (div (mul -1 (mul param (mul s (mul c s1))))
4794 den))))))))))
4797 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4798 ;; Jacobi amplitude function.
4799 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4801 (in-package #:bigfloat)
4803 ;; Arithmetic-Geometric Mean algorithm for real or complex numbers.
4804 ;; See https://dlmf.nist.gov/22.20.ii.
4806 ;; Do not use this for computing jacobi sn. It loses some 7 digits of
4807 ;; accuracy for sn(1+%i,0.7).
4808 (let ((an (make-array 100 :fill-pointer 0))
4809 (bn (make-array 100 :fill-pointer 0))
4810 (cn (make-array 100 :fill-pointer 0)))
4811 ;; Instead of allocating these array anew each time, we'll reuse
4812 ;; them and allow them to grow as needed.
4813 (defun agm (a0 b0 c0 tol)
4814 "Arithmetic-Geometric Mean algorithm for real or complex a0, b0, c0.
4815 Algorithm continues until |c[n]| <= tol."
4817 ;; DLMF (https://dlmf.nist.gov/22.20.ii) says for any real or
4818 ;; complex a0 and b0, b0/a0 must not be real and negative. Let's
4819 ;; check that.
4820 (let ((q (/ b0 a0)))
4821 (when (and (= (imagpart q) 0)
4822 (minusp (realpart q)))
4823 (error "Invalid arguments for AGM: ~A ~A~%" a0 b0)))
4824 (let ((nd (max (* 2 (ceiling (log (- (log tol 2))))) 8)))
4825 ;; DLMF (https://dlmf.nist.gov/22.20.ii) says that |c[n]| <=
4826 ;; C*2^(-2^n), for some constant C. Solve C*2^(-2^n) = tol to
4827 ;; get n = log(log(C/tol)/log(2))/log(2). Arbitrarily assume C
4828 ;; is one to get n = log(-(log(tol)/log(2)))/log(2). Thus, the
4829 ;; approximate number of term needed is n =
4830 ;; 1.44*log(-(1.44*log(tol))). Round to 2*log(-log2(tol)).
4831 (setf (fill-pointer an) 0
4832 (fill-pointer bn) 0
4833 (fill-pointer cn) 0)
4834 (vector-push-extend a0 an)
4835 (vector-push-extend b0 bn)
4836 (vector-push-extend c0 cn)
4838 (do ((k 0 (1+ k)))
4839 ((or (<= (abs (aref cn k)) tol)
4840 (>= k nd))
4841 (if (>= k nd)
4842 (error "Failed to converge")
4843 (values k an bn cn)))
4844 (vector-push-extend (/ (+ (aref an k) (aref bn k)) 2) an)
4845 ;; DLMF (https://dlmf.nist.gov/22.20.ii) has conditions on how
4846 ;; to choose the square root depending on the phase of a[n-1]
4847 ;; and b[n-1]. We don't check for that here.
4848 (vector-push-extend (sqrt (* (aref an k) (aref bn k))) bn)
4849 (vector-push-extend (/ (- (aref an k) (aref bn k)) 2) cn)))))
4851 (defun jacobi-am-agm (u m tol)
4852 "Evaluate the jacobi_am function from real u and m with |m| <= 1. This
4853 uses the AGM method until a tolerance of TOL is reached for the
4854 error."
4855 (multiple-value-bind (n an bn cn)
4856 (agm 1 (sqrt (- 1 m)) (sqrt m) tol)
4857 (declare (ignore bn))
4858 ;; See DLMF (https://dlmf.nist.gov/22.20.ii) for the algorithm.
4859 (let ((phi (* u (aref an n) (expt 2 n))))
4860 (loop for k from n downto 1
4862 (setf phi (/ (+ phi (asin (* (/ (aref cn k)
4863 (aref an k))
4864 (sin phi))))
4865 2)))
4866 phi)))
4868 ;; Compute Jacobi am for real or complex values of U and M. The args
4869 ;; must be floats or bigfloat::bigfloats. TOL is the tolerance used
4870 ;; by the AGM algorithm. It is ignored if the AGM algorithm is not
4871 ;; used.
4872 (defun bf-jacobi-am (u m tol)
4873 (cond ((and (realp u) (realp m) (<= (abs m) 1))
4874 ;; The case of real u and m with |m| <= 1. We can use AGM to
4875 ;; compute the result.
4876 (jacobi-am-agm (to u)
4877 (to m)
4878 tol))
4880 ;; Otherwise, use the formula am(u,m) = asin(jacobi_sn(u,m)).
4881 ;; (See DLMF https://dlmf.nist.gov/22.16.E1). This appears
4882 ;; to be what functions.wolfram.com is using in this case.
4883 (asin (sn (to u) (to m))))))
4885 (in-package :maxima)
4886 (def-simplifier jacobi_am (u m)
4887 (let (args)
4888 (cond
4889 ((zerop1 u)
4890 ;; am(0,m) = 0
4892 ((zerop1 m)
4893 ;; See https://dlmf.nist.gov/22.16.E4
4895 ;; am(u,0) = u
4897 ((eql m 1)
4898 ;; See https://dlmf.nist.gov/22.16.E5. This is equivalent to
4899 ;; the Gudermannian function.
4901 ;; am(u,1) = 2*atan(exp(u))-%pi/2
4902 (sub (mul 2 (ftake '%atan (ftake '%exp u)))
4903 (div '$%pi 2)))
4904 ((float-numerical-eval-p u m)
4905 (to (bigfloat::bf-jacobi-am ($float u)
4906 ($float m)
4907 double-float-epsilon)))
4908 ((setf args (complex-float-numerical-eval-p u m))
4909 (destructuring-bind (u m)
4910 args
4911 (to (bigfloat::bf-jacobi-am (bigfloat:to ($float u))
4912 (bigfloat:to ($float m))
4913 double-float-epsilon))))
4914 ((bigfloat-numerical-eval-p u m)
4915 (to (bigfloat::bf-jacobi-am (bigfloat:to ($bfloat u))
4916 (bigfloat:to ($bfloat m))
4917 (expt 2 (- fpprec)))))
4918 ((setf args (complex-bigfloat-numerical-eval-p u m))
4919 (destructuring-bind (u m)
4920 args
4921 (to (bigfloat::bf-jacobi-am (bigfloat:to ($bfloat u))
4922 (bigfloat:to ($bfloat m))
4923 (expt 2 (- fpprec))))))
4925 ;; Nothing to do
4926 (give-up)))))
4928 ;; Derivative of jacobi_am wrt z and m.
4929 (defprop %jacobi_am
4930 ((z m)
4931 ;; WRT z. From http://functions.wolfram.com/09.24.20.0001.01
4932 ;; jacobi_dn(z,m)
4933 ((%jacobi_dn) $z $m)
4934 ;; WRT m. From http://functions.wolfram.com/09.24.20.0003.01.
4935 ;; There are 5 different formulas listed; we chose the first,
4936 ;; arbitrarily.
4938 ;; (((m-1)*z+elliptic_e(jacobi_am(z,m),m))*jacobi_dn(z,m)
4939 ;; - m*jacobi_cn(z,m)*jacobi_sn(z,m))/(2*m*(m-1))
4940 ((mtimes) ((rat) 1 2) ((mexpt) ((mplus) -1 $m) -1)
4941 ((mexpt) $m -1)
4942 ((mplus)
4943 ((mtimes) -1 $m ((%jacobi_cn) $z $m) ((%jacobi_sn) $z $m))
4944 ((mtimes) ((%jacobi_dn) $z $m)
4945 ((mplus) ((mtimes) ((mplus) -1 $m) $z)
4946 ((%elliptic_e) ((%jacobi_am) $z $m) $m)))))
4947 nil)
4948 grad)