ADD: new track message, Entity class and Position class
This commit is contained in:
Henry Winkel
281
libs/geographiclib/maxima/ellint.mac
Normal file
281
libs/geographiclib/maxima/ellint.mac
Normal file
@@ -0,0 +1,281 @@
|
||||
/*
|
||||
Implementation of methods given in
|
||||
B. C. Carlson
|
||||
Computation of elliptic integrals
|
||||
Numerical Algorithms 10, 13-26 (1995)
|
||||
|
||||
Copyright (c) Charles Karney (2009-2013) <charles@karney.com> and
|
||||
licensed under the MIT/X11 License. For more information, see
|
||||
https://geographiclib.sourceforge.io/
|
||||
*/
|
||||
|
||||
/* fpprec:120$ Should be set outside */
|
||||
etol:0.1b0^fpprec$ /* For Carlson */
|
||||
tolRF : (3 * etol)^(1/8b0)$
|
||||
tolRD : (etol/5)^(1/8b0)$
|
||||
tolRG0 : 2.7b0 * sqrt(etol)$
|
||||
tolJAC:sqrt(etol)$ /* For Bulirsch */
|
||||
pi:bfloat(%pi)$
|
||||
atan2x(y,x) := -atan2(-y, x)$ /* fix atan2(0b0,-1b0) = -pi */
|
||||
rf(x,y,z) := block([a0:(x+y+z)/3, q,x0:x,y0:y,z0:z,
|
||||
an,ln,xx,yy,zz,e2,e3,mul:1b0],
|
||||
q:max(abs(a0-x),abs(a0-y),abs(a0-z))/tolRF,
|
||||
an:a0,
|
||||
while q >= mul * abs(an) do (
|
||||
ln:sqrt(x0)*sqrt(y0)+sqrt(y0)*sqrt(z0)+sqrt(z0)*sqrt(x0),
|
||||
an:(an+ln)/4,
|
||||
x0:(x0+ln)/4,
|
||||
y0:(y0+ln)/4,
|
||||
z0:(z0+ln)/4,
|
||||
mul:mul*4),
|
||||
xx:(a0-x)/(mul*an),
|
||||
yy:(a0-y)/(mul*an),
|
||||
zz:-xx-yy,
|
||||
e2:xx*yy-zz^2,
|
||||
e3:xx*yy*zz,
|
||||
(e3 * (6930 * e3 + e2 * (15015 * e2 - 16380) + 17160) +
|
||||
e2 * ((10010 - 5775 * e2) * e2 - 24024) + 240240) /
|
||||
(240240 * sqrt(an)))$
|
||||
rd(x,y,z) := block([a0:(x+y+3*z)/5, q,x0:x,y0:y,z0:z,
|
||||
an,ln,xx,yy,zz,e2,e3,e4,e5,s:0b0,mul:1b0],
|
||||
q:max(abs(a0-x),abs(a0-y),abs(a0-z))/tolRD,
|
||||
an:a0,
|
||||
while q >= mul*abs(an) do (
|
||||
ln:sqrt(x0)*sqrt(y0)+sqrt(y0)*sqrt(z0)+sqrt(z0)*sqrt(x0),
|
||||
s:s+1/(mul*sqrt(z0)*(z0+ln)),
|
||||
an:(an+ln)/4,
|
||||
x0:(x0+ln)/4,
|
||||
y0:(y0+ln)/4,
|
||||
z0:(z0+ln)/4,
|
||||
mul:4*mul),
|
||||
xx:(a0-x)/(mul*an),
|
||||
yy:(a0-y)/(mul*an),
|
||||
zz:-(xx+yy)/3,
|
||||
e2:xx*yy-6*zz^2,
|
||||
e3:(3*xx*yy-8*zz^2)*zz,
|
||||
e4:3*(xx*yy-zz^2)*zz^2,
|
||||
e5:xx*yy*zz^3,
|
||||
((471240 - 540540 * e2) * e5 +
|
||||
(612612 * e2 - 540540 * e3 - 556920) * e4 +
|
||||
e3 * (306306 * e3 + e2 * (675675 * e2 - 706860) + 680680) +
|
||||
e2 * ((417690 - 255255 * e2) * e2 - 875160) + 4084080) /
|
||||
(4084080 * mul * an * sqrt(an)) + 3 * s)$
|
||||
|
||||
/* R_G(x,y,0) */
|
||||
rg0(x,y) := block([x0:sqrt(max(x,y)),y0:sqrt(min(x,y)),xn,yn,
|
||||
t,s:0b0,mul:0.25b0],
|
||||
xn:x0,
|
||||
yn:y0,
|
||||
while abs(xn-yn) > tolRG0 * xn do (
|
||||
t:(xn+yn)/2,
|
||||
yn:sqrt(xn*yn),
|
||||
xn:t,
|
||||
mul : 2*mul,
|
||||
s:s+mul*(xn-yn)^2),
|
||||
((x0+y0)^2/4 - s)*pi/(2*(xn+yn)) )$
|
||||
|
||||
rg(x, y, z) := (
|
||||
if z = 0b0 then (z:y, y:0b0),
|
||||
(z * rf(x, y, z) - (x-z) * (y-z) * rd(x, y, z) / 3
|
||||
+ sqrt(x * y / z)) / 2)$
|
||||
|
||||
rj(x, y, z, p) := block([A0:(x + y + z + 2*p)/5,An,delta:(p-x) * (p-y) * (p-z),
|
||||
Q,x0:x,y0:y,z0:z,p0:p,mul:1b0,mul3:1b0,s:0b0,X,Y,Z,P,E2,E3,E4,E5],
|
||||
An : A0,
|
||||
Q : max(abs(A0-x), abs(A0-y), abs(A0-z), abs(A0-p)) / tolRD,
|
||||
while Q >= mul * abs(An) do block([lam,d0,e0],
|
||||
lam : sqrt(x0)*sqrt(y0) + sqrt(y0)*sqrt(z0) + sqrt(z0)*sqrt(x0),
|
||||
d0 : (sqrt(p0)+sqrt(x0)) * (sqrt(p0)+sqrt(y0)) * (sqrt(p0)+sqrt(z0)),
|
||||
e0 : delta/(mul3 * d0^2),
|
||||
s : s + rc(1b0, 1b0 + e0)/(mul * d0),
|
||||
An : (An + lam)/4,
|
||||
x0 : (x0 + lam)/4,
|
||||
y0 : (y0 + lam)/4,
|
||||
z0 : (z0 + lam)/4,
|
||||
p0 : (p0 + lam)/4,
|
||||
mul : 4*mul,
|
||||
mul3 : 64*mul3),
|
||||
X : (A0 - x) / (mul * An),
|
||||
Y : (A0 - y) / (mul * An),
|
||||
Z : (A0 - z) / (mul * An),
|
||||
P : -(X + Y + Z) / 2,
|
||||
E2 : X*Y + X*Z + Y*Z - 3*P*P,
|
||||
E3 : X*Y*Z + 2*P * (E2 + 2*P*P),
|
||||
E4 : (2*X*Y*Z + P * (E2 + 3*P*P)) * P,
|
||||
E5 : X*Y*Z*P*P,
|
||||
((471240 - 540540 * E2) * E5 +
|
||||
(612612 * E2 - 540540 * E3 - 556920) * E4 +
|
||||
E3 * (306306 * E3 + E2 * (675675 * E2 - 706860) + 680680) +
|
||||
E2 * ((417690 - 255255 * E2) * E2 - 875160) + 4084080) /
|
||||
(4084080 * mul * An * sqrt(An)) + 6 * s)$
|
||||
|
||||
rd(x, y, z) := block([A0:(x + y + 3*z)/5,An,Q,x0:x,y0:y,z0:z,
|
||||
mul:1b0,s:0b0,X,Y,Z,E2,E3,E4,E5],
|
||||
An : A0,
|
||||
Q : max(abs(A0-x), abs(A0-y), abs(A0-z)) / tolRD,
|
||||
while Q >= mul * abs(An) do block([lam],
|
||||
lam : sqrt(x0)*sqrt(y0) + sqrt(y0)*sqrt(z0) + sqrt(z0)*sqrt(x0),
|
||||
s : s + 1/(mul * sqrt(z0) * (z0 + lam)),
|
||||
An : (An + lam)/4,
|
||||
x0 : (x0 + lam)/4,
|
||||
y0 : (y0 + lam)/4,
|
||||
z0 : (z0 + lam)/4,
|
||||
mul : 4*mul),
|
||||
X : (A0 - x) / (mul * An),
|
||||
Y : (A0 - y) / (mul * An),
|
||||
Z : -(X + Y) / 3,
|
||||
E2 : X*Y - 6*Z*Z,
|
||||
E3 : (3*X*Y - 8*Z*Z)*Z,
|
||||
E4 : 3 * (X*Y - Z*Z) * Z*Z,
|
||||
E5 : X*Y*Z*Z*Z,
|
||||
((471240 - 540540 * E2) * E5 +
|
||||
(612612 * E2 - 540540 * E3 - 556920) * E4 +
|
||||
E3 * (306306 * E3 + E2 * (675675 * E2 - 706860) + 680680) +
|
||||
E2 * ((417690 - 255255 * E2) * E2 - 875160) + 4084080) /
|
||||
(4084080 * mul * An * sqrt(An)) + 3 * s)$
|
||||
|
||||
rc(x, y):=if x < y then atan(sqrt((y - x) / x)) / sqrt(y - x)
|
||||
else ( if x = y and y > 0b0 then 1 / sqrt(y) else
|
||||
atanh( if y > 0b0 then sqrt((x - y) / x)
|
||||
else sqrt(x / (x - y)) ) / sqrt(x - y) )$
|
||||
|
||||
/* k^2 = m */
|
||||
ec(k2):=2*rg0(1b0-k2,1b0)$
|
||||
kc(k2):=rf(0b0,1b0-k2,1b0)$
|
||||
dc(k2):=rd(0b0,1b0-k2,1b0)/3$
|
||||
pic(k2,alpha2):=if alpha2 # 0b0 then
|
||||
kc(k2)+alpha2*rj(0b0,1b0-k2,1b0,1b0-alpha2)/3
|
||||
else kc(k2)$
|
||||
gc(k2,alpha2):=if alpha2 # 0b0 then (if k2 # 1b0 then
|
||||
kc(k2) + (alpha2-k2)*rj(0b0,1b0-k2,1b0,1b0-alpha2)/3
|
||||
else rc(1b0,1b0-alpha2))
|
||||
else ec(k2)$
|
||||
hc(k2,alpha2):=if alpha2 # 0b0 then (if k2 # 1b0 then
|
||||
kc(k2) - (1b0-alpha2)*rj(0b0,1b0-k2,1b0,1b0-alpha2)/3
|
||||
else rc(1b0,1b0-alpha2))
|
||||
else kc(k2) - dc(k2)$
|
||||
|
||||
/* Implementation of methods given in
|
||||
|
||||
Roland Bulirsch
|
||||
Numerical Calculation of Elliptic Integrals and Elliptic Functions
|
||||
Numericshe Mathematik 7, 78-90 (1965)
|
||||
|
||||
*/
|
||||
|
||||
sncndn(x,mc):=block([bo, a, b, c, d, l, sn, cn, dn, m, n],
|
||||
local(m, n),
|
||||
if mc # 0 then (
|
||||
bo:is(mc < 0b0),
|
||||
if bo then (
|
||||
d:1-mc,
|
||||
mc:-mc/d,
|
||||
d:sqrt(d),
|
||||
x:d*x),
|
||||
dn:a:1,
|
||||
for i:0 thru 12 do (
|
||||
l:i,
|
||||
m[i]:a,
|
||||
n[i]:mc:sqrt(mc),
|
||||
c:(a+mc)/2,
|
||||
if abs(a-mc)<=tolJAC*a then return(false),
|
||||
mc:a*mc,
|
||||
a:c
|
||||
),
|
||||
x:c*x,
|
||||
sn:sin(x),
|
||||
cn:cos(x),
|
||||
if sn#0b0 then (
|
||||
a:cn/sn,
|
||||
c:a*c,
|
||||
for i:l step -1 thru 0 do (
|
||||
b:m[i],
|
||||
a:c*a,
|
||||
c:dn*c,
|
||||
dn:(n[i]+a)/(b+a),
|
||||
a:c/b
|
||||
),
|
||||
a:1/sqrt(c*c+1b0),
|
||||
sn:if sn<0b0 then -a else a,
|
||||
cn:c*sn
|
||||
),
|
||||
if bo then (
|
||||
a:dn,
|
||||
dn:cn,
|
||||
cn:a,
|
||||
sn:sn/d
|
||||
)
|
||||
) else /* mc = 0 */ (
|
||||
sn:tanh(x),
|
||||
dn:cn:sech(x)
|
||||
/* d:exp(x), a:1/d, b:a+d, cn:dn:2/b,
|
||||
if x < 0.3b0 then (
|
||||
d:x*x*x*x,
|
||||
d:(d*(d*(d*(d+93024b0)+3047466240b0)+24135932620800b0)+
|
||||
20274183401472000b0)/60822550204416000b0,
|
||||
sn:cn*(x*x*x*d+sin(x))
|
||||
) else
|
||||
sn:(d-a)/b */
|
||||
),
|
||||
[sn,cn,dn]
|
||||
)$
|
||||
|
||||
Delta(sn, k2):=sqrt(1 - k2 * sn*sn)$
|
||||
|
||||
/* Versions of incomplete functions in terms of Jacobi elliptic function
|
||||
with u = am(phi) real and in [0,K(k2)] */
|
||||
|
||||
eirx(sn,cn,dn,k2,ec):=block([t,cn2:cn*cn,dn2:dn*dn,sn2:sn*sn,ei,kp2:1b0-k2],
|
||||
ei : (if k2 <= 0b0 then
|
||||
rf(cn2, dn2, 1b0) - k2 * sn2 * rd(cn2, dn2, 1b0) / 3 else
|
||||
(if kp2 >= 0b0 then
|
||||
kp2 * rf(cn2, dn2, 1b0) +
|
||||
k2 * kp2 * sn2 * rd(cn2, 1b0, dn2) / 3 +
|
||||
k2 * abs(cn) / dn else
|
||||
- kp2 * sn2 * rd(dn2, 1b0, cn2) / 3 + dn / abs(cn) ) ),
|
||||
ei : ei * abs(sn),
|
||||
if cn < 0b0 then ei : 2 * ec - ei,
|
||||
if sn < 0 then ei : -ei,
|
||||
ei)$
|
||||
|
||||
dirx(sn, cn, dn, k2, dc):=block(
|
||||
[di:abs(sn) * sn*sn * rd(cn*cn, dn*dn, 1b0) / 3],
|
||||
if cn < 0b0 then di : 2 * dc - di,
|
||||
if sn < 0b0 then di : -di,
|
||||
di)$
|
||||
|
||||
hirx(sn, cn, dn, k2, alpha2, hc):=block(
|
||||
[cn2 : cn*cn, dn2 : dn*dn, sn2 : sn*sn, hi, alphap2:1b0-alpha2],
|
||||
hi : abs(sn) * (rf(cn2, dn2, 1b0) -
|
||||
alphap2 * sn2 *
|
||||
rj(cn2, dn2, 1b0, cn2 + alphap2 * sn2) / 3),
|
||||
if cn < 0 then hi : 2 * hc - hi,
|
||||
if sn < 0 then hi : -hi,
|
||||
hi)$
|
||||
|
||||
deltae(sn, cn, dn, k2, ec):=(
|
||||
if cn < 0 then (cn : -cn, sn : -sn),
|
||||
eirx(sn, cn, dn, k2, ec) * (pi/2) / ec - atan2x(sn, cn))$
|
||||
deltad(sn, cn, dn, k2, dc):=(
|
||||
if cn < 0 then (cn : -cn, sn : -sn),
|
||||
dirx(sn, cn, dn, k2, ec) * (pi/2) / dc - atan2x(sn, cn))$
|
||||
deltah(sn, cn, dn, k2, alpha2, hc):=(
|
||||
if cn < 0 then (cn : -cn, sn : -sn),
|
||||
hirx(sn, cn, dn, k2, alpha2, hc) * (pi/2) / hc - atan2x(sn, cn))$
|
||||
|
||||
einv(x, k2, ec):=block(
|
||||
[n : floor(x / (2 * ec) + 0.5b0), phi, eps : k2/(sqrt(1b0-k2) + 1b0)^2,
|
||||
err:1b0],
|
||||
x : x - 2 * ec * n,
|
||||
phi : pi * x / (2 * ec),
|
||||
phi : phi - eps * sin(2 * phi) / 2,
|
||||
while abs(err) > tolJAC do block([sn:sin(phi), cn:cos(phi), dn],
|
||||
dn : Delta(sn, k2),
|
||||
err : (eirx(sn, cn, dn, k2, ec) - x)/dn,
|
||||
phi : phi - err),
|
||||
n * pi + phi)$
|
||||
|
||||
deltaeinv(stau, ctau, k2, ec) := block([tau],
|
||||
if ctau < 0 then (ctau : -ctau, stau : -stau),
|
||||
tau : atan2x(stau, ctau),
|
||||
einv(tau * ec / (pi/2), k2, ec) - tau)$
|
||||
Reference in New Issue
Block a user