diff options
Diffstat (limited to 'texmf-dist/scripts/ketcindy/ketlib/maximaL')
4 files changed, 0 insertions, 477 deletions
diff --git a/texmf-dist/scripts/ketcindy/ketlib/maximaL/fourier_sec.max b/texmf-dist/scripts/ketcindy/ketlib/maximaL/fourier_sec.max deleted file mode 100644 index c70f7f46..00000000 --- a/texmf-dist/scripts/ketcindy/ketlib/maximaL/fourier_sec.max +++ /dev/null @@ -1,260 +0,0 @@ -/* -Package fourier_sec, to study piecewise defined functions -(sectionally defined, hence the name). - -Author: Jose A. Vallejo - Faculty of Sciences - Universidad Autonoma de San Luis Potosi (Mexico) - http://galia.fc.uaslp.mx/~jvallejo - -It is assumed that the functions are defined using the format - if ... then ... else ... -as, for example, -(%i1) absolute(x):=if (x<=0) then -x elseif (x>0) then x$ -(it will not work with 'abs'). -It provides three functions: -1. 'paritycheck', to check if a given piecewise defined - function is even or odd (or none). For instance, - (%i2) paritycheck(absolute(x),x); - (%o2) 0 - A '0' means 'even', '1' is 'odd', and '-1' is 'none' -2. 'fourier_sec_coeff', to compute the Fourier sine and cosine - coefficients. The function must have compact support.For - instance, for the unit step we have: - (%i3) h(x):=if (-%pi<=x and x<0) then 0 elseif (0<=x and x<=%pi) then 1$ - (%i4) fourier_sec_coeff(h(x),x); - (%o4) [1/2,0,-((-1)^n-1)/(%pi*n)] -3. 'fourier_sec_series', to compute the Fourier series, truncated - or not. The series for the unit step to the 10th order: - (%i5) fourier_sec_series(h(x),x,10); - (%o5) (2*sin(9*x))/(9*%pi)+(2*sin(7*x))/(7*%pi)+(2*sin(5*x))/(5*%pi)+(2*sin(3*x))/(3*%pi)+(2*sin(x))/%pi+1/2 - and the whole Fourier series - (%i6) fourier_sec_series(h(x),x,inf); - (%o6) (sum(((1/n-(-1)^n/n)*sin(n*x))/%pi,n,1,inf))+1/2 -*/ - - -load(fourie)$ - -load(simplify_sum)$ - -paritycheck(funvar,x):=block([subintervals,subvalues,tmp1,tmp2,token1,token0,tmp3, - subvalues_list,subintervals_list,icentral:0,middle,minusmiddle,token2, - side_subintervals_list,L,side_subvalues_list, - zero_subintervals,tmp4,tmp5,non_zero_side_subvalues_list, - non_zero_side_subintervals_list,LL,token3,expr1,expr2], - local(M,N,P,Q,count1,count2,count3,count4), - subintervals:makelist(part(funvar,i),i,makelist(2*k-1,k,1,(length(funvar)-2)/2)), - subvalues:makelist(part(funvar,i),i,makelist(2*k,k,1,(length(funvar)-2)/2)), - for j:1 thru length(subintervals) do (if operatorp(subintervals[j],["<",">","<=",">="]) then tmp1[j]:1 else tmp1[j]:0), - tmp1:makelist(tmp1[j],j,1,length(subintervals)), - tmp2:sublist_indices(tmp1,lambda([x],x=1)), - - /* if length(tmp2)=0 all the subintervals in the domain of funvar are bounded! */ - - if is(equal(length(tmp2),0)) then - ( - subvalues_list:copylist(subvalues), - tmp3:copylist(subintervals), - for j:1 thru length(tmp3) do - ( - M[j]:makelist(part(tmp3[j],k),k,1,length(tmp3[j])), - for m:1 thru 2 do N[j,m]:makelist(part(M[j],m,n),n,1,length(M[j])), - P[j]:append(N[j,1],N[j,2]),Q[j]:sort(delete(x,P[j]),"<") - ), - subintervals_list:makelist(Q[j],j,1,length(tmp3)), - for i:1 thru length(subintervals_list) do (if is(lmin(subintervals_list[i])*lmax(subintervals_list[i])<0) then icentral:i), - if is(icentral>0) then middle:subvalues_list[icentral], - if is(icentral>0) then - (if evenfunp(middle,x) then token2:0 elseif oddfunp(middle,x) then token2:1 else return(-1)) - else - - /* now we analyze what happens if icentral=0, so there are only side intervals */ - - ( - /* as before, there must be an even number of symmetric intervals, otherwise -1 */ - side_subintervals_list:copylist(subintervals_list), - if not(evenp(length(side_subintervals_list))) then return(-1), - L:length(side_subintervals_list)/2, - for k:1 thru L do count1[k]:charfun(is(equal(side_subintervals_list[k],reverse(map("-",side_subintervals_list[2*L+1-k]))))), - if sum(count1[j],j,1,L)#L then return(-1), - side_subvalues_list:copylist(subvalues_list), - for k:1 thru L do count2[k]:charfun(is(equalp(side_subvalues_list[k],ratsubst(-x,x,side_subvalues_list[2*L+1-k])))), - if is(equal(sum(count2[j],j,1,L),L)) then token3:0, - for k:1 thru L do count3[k]:charfun(is(equalp(side_subvalues_list[k],-ratsubst(-x,x,side_subvalues_list[2*L+1-k])))), - if is(equal(sum(count3[j],j,1,L),L)) then token3:1, - if is(not(equalp(token3,0)) and not(equalp(token3,1))) then return(-1) , - return(token3) - ), - - /* and what happens if icentral#0 */ - - side_subintervals_list:delete(subintervals_list[icentral],subintervals_list), - if is(equal(length(side_subintervals_list),0)) then (if is(equal(token1,token2)) then return(token1*token2) else return(-1)), - if not(evenp(length(side_subintervals_list))) then return(-1), - L:length(side_subintervals_list)/2, - for k:1 thru L do count1[k]:charfun(is(equal(side_subintervals_list[k],reverse(map("-",side_subintervals_list[2*L+1-k]))))), - if sum(count1[j],j,1,L)#L then return(-1), - side_subvalues_list:delete(subvalues_list[icentral],subvalues_list), - - /* remove those subintervals in which funvar vanishes */ - - zero_subintervals:sublist_indices(side_subvalues_list,lambda([x],x=0)), - tmp4:copylist(side_subintervals_list), - for j:1 thru length(zero_subintervals) do - (tmp4:delete(side_subintervals_list[zero_subintervals[j]],tmp4)), - non_zero_side_subintervals_list:tmp4, - tmp5:copylist(side_subvalues_list), - for j:1 thru length(zero_subintervals) do - (tmp5:delete(side_subvalues_list[zero_subintervals[j]],tmp5)), - non_zero_side_subvalues_list:tmp5, - - /* if length(non_zero_side_subintervals_list)=0 then we are done just with token2 */ - - if is(equal(length(non_zero_side_subintervals_list),0)) then return(token2), - - /* otherwise, we must also take into account token3 */ - LL:length(non_zero_side_subintervals_list)/2, - for k:1 thru LL do count2[k]:charfun(is(equalp(non_zero_side_subvalues_list[k],ratsubst(-x,x,non_zero_side_subvalues_list[2*LL+1-k])))), - if is(equal(sum(count2[j],j,1,LL),LL)) then token3:0, - for k:1 thru LL do count3[k]:charfun(is(equalp(non_zero_side_subvalues_list[k],-ratsubst(-x,x,non_zero_side_subvalues_list[2*LL+1-k])))), - if is(equal(sum(count3[j],j,1,LL),LL)) then token3:1, - if is(not(equal(token3,0) or equal(token3,1))) then return(-1) elseif - is(token2#token3) then return(-1) - elseif is(equal(token2,0)) then return(0) - elseif is(equal(token2,1)) then return(1) - - ), - - /* we continue here with unbounded intervals */ - - expr1:subvalues[tmp2[1]], - expr2:ratsubst(-x,x,subvalues[tmp2[2]]), - if is(equalp(expr1,expr2)) then token1:0 - elseif is(equalp(expr1,-expr2)) then token1:1 - else return(-1), - - /* the problem when defining token1 is that if the asymptotic value is 0, then it is always token1:0 */ - /* although the function could be odd. To cope with this, we define token0 below */ - - tmp3:makelist(subintervals[i],i,sublist_indices(tmp1,lambda([x],x=0))), - if is(equal(length(tmp3),0)) then return(token1), - subvalues_list:makelist(subvalues[i],i,sublist_indices(tmp1,lambda([x],x=0))), - token0:if member(0,makelist(subvalues[i],i,tmp2)) then 0 else 7, - for j:1 thru length(tmp3) do - ( - M[j]:makelist(part(tmp3[j],k),k,1,length(tmp3[j])), - for m:1 thru 2 do N[j,m]:makelist(part(M[j],m,n),n,1,length(M[j])), - P[j]:append(N[j,1],N[j,2]),Q[j]:sort(delete(x,P[j]),"<") - ), - subintervals_list:makelist(Q[j],j,1,length(tmp3)), - for i:1 thru length(subintervals_list) do (if is(lmin(subintervals_list[i])*lmax(subintervals_list[i])<0) then icentral:i), - if is(icentral>0) then middle:subvalues_list[icentral], - if is(icentral>0) then - (if evenfunp(middle,x) then token2:0 elseif oddfunp(middle,x) then token2:1 else return(-1)) - else - - /* now we analyze what happens if icentral=0, so there are only non-bounded intervals and side intervals */ - - ( - /* as before, there must be an even number of symmetric intervals, otherwise -1 */ - side_subintervals_list:copylist(subintervals_list), - if not(evenp(length(side_subintervals_list))) then return(-1), - L:length(side_subintervals_list)/2, - for k:1 thru L do count1[k]:charfun(is(equal(side_subintervals_list[k],reverse(map("-",side_subintervals_list[2*L+1-k]))))), - if sum(count1[j],j,1,L)#L then return(-1), - side_subvalues_list:copylist(subvalues_list), - for k:1 thru L do count2[k]:charfun(is(equalp(side_subvalues_list[k],ratsubst(-x,x,side_subvalues_list[2*L+1-k])))), - if is(equal(sum(count2[j],j,1,L),L)) then token3:0, - for k:1 thru L do count3[k]:charfun(is(equalp(side_subvalues_list[k],-ratsubst(-x,x,side_subvalues_list[2*L+1-k])))), - if is(equal(sum(count3[j],j,1,L),L)) then token3:1, - if is(not(equal(token3,0)) and not(equal(token3,1))) then return(-1) elseif - is(not(equal(token1,token3)) and not(equal(token0,0))) then return(-1) - elseif is( equal(token0,0) and equal(token3,0)) then return(0) - elseif is( equal(token0,0) and equal(token3,1)) then return(1) - elseif is(not(equal(token0,0)) and equal(token1,token3)) then return(token3) - elseif is(not(equal(token0,0)) and not(equal(token1,token3))) then return(-1) - ), - - /* and what happens if icentral#0 */ - - side_subintervals_list:delete(subintervals_list[icentral],subintervals_list), - if is(equal(length(side_subintervals_list),0)) then (if is(equal(token1,token2)) then return(token1*token2) else return(-1)), - if not(evenp(length(side_subintervals_list))) then return(-1), - L:length(side_subintervals_list)/2, - for k:1 thru L do count1[k]:charfun(is(equal(side_subintervals_list[k],reverse(map("-",side_subintervals_list[2*L+1-k]))))), - if sum(count1[j],j,1,L)#L then return(-1), - side_subvalues_list:delete(subvalues_list[icentral],subvalues_list), - - /* remove those subintervals in which funvar vanishes */ - - zero_subintervals:sublist_indices(side_subvalues_list,lambda([x],x=0)), - tmp4:copylist(side_subintervals_list), - for j:1 thru length(zero_subintervals) do - (tmp4:delete(side_subintervals_list[zero_subintervals[j]],tmp4)), - non_zero_side_subintervals_list:tmp4, - tmp5:copylist(side_subvalues_list), - for j:1 thru length(zero_subintervals) do - (tmp5:delete(side_subvalues_list[zero_subintervals[j]],tmp5)), - non_zero_side_subvalues_list:tmp5, - - /* if length(non_zero_side_subintervals_list)=0 then we are done just with token1 and token2 */ - - if is(equal(length(non_zero_side_subintervals_list),0)) then (if is(equal(token1,token2)) then return(token1*token2) else return(-1)), - - /* otherwise, we must also take into account token3 */ - LL:length(non_zero_side_subintervals_list)/2, - for k:1 thru LL do count2[k]:charfun(is(equalp(non_zero_side_subvalues_list[k],ratsubst(-x,x,non_zero_side_subvalues_list[2*LL+1-k])))), - if is(equal(sum(count2[j],j,1,LL),LL)) then token3:0, - for k:1 thru LL do count3[k]:charfun(is(equalp(non_zero_side_subvalues_list[k],-ratsubst(-x,x,non_zero_side_subvalues_list[2*LL+1-k])))), - if is(equal(sum(count3[j],j,1,LL),LL)) then token3:1, - if is(not(equal(token0,0)) and is(not(equal(token1,token2)) or not(equal(token1,token3)) or not(equal(token2,token3))) ) then return(-1) - elseif is(not(equal(token0,0)) and is(equal(token1,0)) ) then return(0) - elseif is(not(equal(token0,0)) and is(equal(token1,1)) ) then return(1) - elseif is( equal(token0,0) and equal(token3,0) and equal(token2,0)) then return(0) - elseif is( equal(token0,0) and equal(token3,1) and equal(token2,1)) then return(1) - else return(-1) - -)$ - -fourier_sec_coeff(fuvar,x):= -block([pp,LL,lm,a0,coeff], - local(a,b,n,MM,NN,PP,QQ), - declare(n,integer), - pp:((length(fuvar)/2)-1), - LL:makelist(part(fuvar,i),i,makelist(2*s-1,s,1,pp)), - for j:1 thru length(LL) step 1 do - ( - MM[j]:makelist(part(LL[j],r),r,1,length(LL[j])), - for r:1 thru 2 do NN(j,r):=makelist(part(MM[j],r,k),k,1,length(MM[j])), - PP[j]:append(NN(j,1),NN(j,2)),QQ[j]:delete(x,PP[j]) - ), - for i:1 thru pp step 1 do partsums[i]:sort(QQ[i],"<"), - for i:1 thru pp step 1 do partfunc[i]:part(fuvar,2*i), - lm:lmax(unique(flatten(makelist(QQ[q],q,1,length(LL))))), - a0:(1/(2*lm))*sum(integrate(partfunc[i],x,partsums[i][1],partsums[i][2]),i,1,pp), - if is(equal(paritycheck(fuvar,x),1)) then a(n):=0 else a(n):=(1/lm)*sum(adefint(partfunc[i]*cos(%pi*n*x/lm),x,partsums[i][1],partsums[i][2]),i,1,pp), - if is(equal(paritycheck(fuvar,x),0)) then b(n):=0 else b(n):=(1/lm)*sum(adefint(partfunc[i]*sin(%pi*n*x/lm),x,partsums[i][1],partsums[i][2]),i,1,pp), - coeff:[a0,simplify_sum(a(n)),simplify_sum(b(n))], - factor(ratsimp(coeff)) -)$ - -fourier_sec_series(fuvar,x,u):= -block([pp,LL,lm,a0,coeff], - local(a,b,n,MM,NN,PP,QQ), - declare(n,integer), - pp:((length(fuvar)/2)-1), - LL:makelist(part(fuvar,i),i,makelist(2*s-1,s,1,pp)), - for j:1 thru length(LL) step 1 do - ( - MM[j]:makelist(part(LL[j],r),r,1,length(LL[j])), - for r:1 thru 2 do NN(j,r):=makelist(part(MM[j],r,k),k,1,length(MM[j])), - PP[j]:append(NN(j,1),NN(j,2)),QQ[j]:delete(x,PP[j]) - ), - for i:1 thru pp step 1 do partsums[i]:sort(QQ[i],"<"), - for i:1 thru pp step 1 do partfunc[i]:part(fuvar,2*i), - lm:lmax(unique(flatten(makelist(QQ[q],q,1,length(LL))))), - a0:(1/(2*lm))*sum(integrate(partfunc[i],x,partsums[i][1],partsums[i][2]),i,1,pp), - if is(equal(paritycheck(fuvar,x),1)) then a(n):=0 else a(n):=(1/lm)*sum(adefint(partfunc[i]*cos(%pi*n*x/lm),x,partsums[i][1],partsums[i][2]),i,1,pp), - if is(equal(paritycheck(fuvar,x),0)) then b(n):=0 else b(n):=(1/lm)*sum(adefint(partfunc[i]*sin(%pi*n*x/lm),x,partsums[i][1],partsums[i][2]),i,1,pp), - a0+intosum(sum(a(n)*cos(%pi*n*x/lm),n,1,u))+intosum(sum(b(n)*sin(%pi*n*x/lm),n,1,u)))$
\ No newline at end of file diff --git a/texmf-dist/scripts/ketcindy/ketlib/maximaL/matoperation.max b/texmf-dist/scripts/ketcindy/ketlib/maximaL/matoperation.max deleted file mode 100644 index 512a9ffb..00000000 --- a/texmf-dist/scripts/ketcindy/ketlib/maximaL/matoperation.max +++ /dev/null @@ -1,47 +0,0 @@ -/* Maxima tips http://www.cymric.jp/maxima/tips.html */ - -rowmult(X, n, c) := block([M], - M:matrix(), - for i:1 thru length(X) do - if i=n then M:addrow(M, c*row(X, i)) - else M:addrow(M, row(X, i)), - M -); -rowadd(X, n, m, c) := block([M], - M:matrix(), - for i:1 thru length(X) do - if i=n then M:addrow(M, c * row(X, m) + row(X, i)) - else M:addrow(M, row(X, i)), - M -); -rowch(X, m, n) := block([M], - M:matrix(), - for i:1 thru length(X) do - if i=m then M:addrow(M, row(X, n)) - else if i=n then M:addrow(M, row(X, m)) - else M:addrow(M, row(X, i)), - M -); - -colmult(X, n, c) := block([M], - M:matrix(), - for i:1 thru length(transpose(X)) do - if i=n then M:addcol(M, c*col(X, i)) - else M:addcol(M, col(X, i)), - M -); -coladd(X, n, m, c) := block([M], - M:matrix(), - for i:1 thru length(transpose(X)) do - if i=n then M:addcol(M, c * col(X, m) + col(X, i)) - else M:addcol(M, col(X, i)), - M -); -colch(X, m, n) := block([M], - M:matrix(), - for i:1 thru length(transpose(X)) do - if i=m then M:addcol(M, col(X, n)) - else if i=n then M:addcol(M, col(X, m)) - else M:addcol(M, col(X, i)), - M -); diff --git a/texmf-dist/scripts/ketcindy/ketlib/maximaL/poincare.mac b/texmf-dist/scripts/ketcindy/ketlib/maximaL/poincare.mac deleted file mode 100644 index aefab3a2..00000000 --- a/texmf-dist/scripts/ketcindy/ketlib/maximaL/poincare.mac +++ /dev/null @@ -1,71 +0,0 @@ -/* Poincare.mac is a set of routines for the computation -of Poincare surfaces of sections of Hamiltonian systems */ - -/* Author: Jose A Vallejo -Universidad Autonoma de San Luis Potosi (Mexico) -josanv@gmail.com */ - -/* To avoid messages when loading draw, execute -with_stdout("/dev/null",load(draw))$ (in Linux) -with_stdout("NUL",load(draw))$ (in Windows) */ - -/* Poincare.mac requires a compiled version of -rkfun.lisp, a LISP implementation of the RK4 -algorithm due to Richard Fateman. The original -code can be downloaded from -https://people.eecs.berkeley.edu/~fateman/lisp/rkfun.lisp */ - -/*load("rkfun.fasl");*/ -/*load("rkfun.lisp");*/ - - -hameqs(H,name):=block( -[vv,t,tvv,n,Q,P,eqq,eqp,eqs], -vv:args(lhs(apply(fundef,[H]))), -tvv:cons(t,vv), -n:length(vv)/2, -Q:makelist(vv[2*j-1],j,1,n), -P:makelist(vv[2*k],k,1,n), -eqq:makelist(float(diff(apply(H,vv),P[j])),j,1,n), -eqp:makelist(float(-diff(apply(H,vv),Q[j])),j,1,n), -eqs:join(eqq,eqp), -for j:1 thru 2*n do define(funmake(concat(name,j),tvv),block([],mode_identity(float,vv),eqs[j])), -apply(compile,makelist(concat(name,j),j,1,2*n)), -[makelist(apply(concat(name,j),tvv),j,1,2*n),vv,makelist(concat(name,j),j,1,2*n)] -)$ - -lextract(ll,n):=block([l,a,b], -l:length(ll), -a:rest(ll,n), -b:rest(ll,n-l-1), -append(b,a) -)$ - -poincare3d(H,name,inicond,timestep,coord):=block( -[heq,vars,tvars,hfuns,c,sol], -heq:hameqs(H,name), -vars:heq[2], -tvars:cons(t,vars), -hfuns:heq[3], -c:first(sublist_indices(vars,lambda([x],x=coord))), -sol:rkfun(hfuns,tvars,float(inicond),timestep), -map(lambda([x],lextract(x,c)),map(lambda([x],rest(x)),sol)) -)$ - -poincare2d(H,name,inicond,timestep,scene):=block( -[heq,vars,tvars,hfuns,solu,c,soluc,sola,solb,subind,sol,e,f], -heq:hameqs(H,name), -vars:heq[2], -tvars:cons(t,vars), -hfuns:heq[3], -solu:rkfun(hfuns,tvars,float(inicond),timestep), -c:first(sublist_indices(vars,lambda([x],x=first(scene)))), -soluc:map(lambda([x],x[c+1]),solu), -sola:rest(soluc,-1)-second(scene), -solb:rest(soluc)-second(scene), -subind:sublist_indices(sola*solb,lambda([x],is(x < 0))), -sol:makelist(solu[k],k,subind), -e:first(sublist_indices(vars,lambda([x],x=third(scene))))+1, -f:first(sublist_indices(vars,lambda([x],x=fourth(scene))))+1, -makelist([j[e],j[f]],j,sol) -)$
\ No newline at end of file diff --git a/texmf-dist/scripts/ketcindy/ketlib/maximaL/rkfun.lisp b/texmf-dist/scripts/ketcindy/ketlib/maximaL/rkfun.lisp deleted file mode 100644 index 70aafc7f..00000000 --- a/texmf-dist/scripts/ketcindy/ketlib/maximaL/rkfun.lisp +++ /dev/null @@ -1,99 +0,0 @@ -;; variation on runge-kutta (rk) routine in complex_dynamics.lisp by villate@fe.up.pt -;; this one with changed by fateman@berkeley.edu - -#| rkfun may be much faster than rk because it calls compiled programs. - rkfun (this file) should also be compiled to speed it up. - how to use: - - - first, read and understand the documentation for rk(). - next, define the ODE right hand sides as functions as shown below - -fun1(y,x,x0):= x0$ -fun2(y,x,x0):= block([], mode_declare([y, x0,x],float),(1-x^2)*x0-x); -compile(fun1)$ -compile(fun2)$ -showtime:all$ - -last(rkfun([fun1,fun2],[x,xdot],[0.0,0.6],[t,0,50,0.01])); - -/* which is, in one test, 18 times faster than */ - -last(rk([xdot,(1-x^2)*xdot -x],[x,xdot],[0.0,0.6],[t,0,50,0.01])); - -|# - -(defun $rkfun (funs vars initial domain ;; taken from complex_dynamics.lisp - &aux d u funlist k1 k2 k3 k4 r1 r2 r3 traj r - (it (mapcar #'coerce-float (cddr domain)))) - (unless ($listp funs) (setq funs `((mlist) ,funs))) - (unless ($listp initial) (setq initial `((mlist) ,initial))) - (unless ($listp vars) (setq vars `((mlist) ,vars))) - (dolist (var (cdr vars)) - (unless (symbolp var) - (merror (intl:gettext "rk: variable name expected; found: ~M") var))) - (unless (symbolp (cadr domain)) - (merror (intl:gettext "rk: variable name expected; found: ~M") - (cadr domain))) - (setq vars (append '((mlist)) (list (cadr domain)) (cdr vars))) - (setq r (append `(,(car it)) (mapcar #'coerce-float (cdr initial)))) - (setq funlist (cdr funs)) - - (setq d (/ (- (cadr it) (car it)) (caddr it))) - (setq traj (list (cons '(mlist) r))) - (do ((m 1 (1+ m))) ((> m d)) - (progn ;;; was ignore-errors - (setq k1 (mapcar #'(lambda (x) (apply x r)) funlist)) - (setq r1 (map 'list #'+ (cdr r) (mapcar #'(lambda (x) (* 0.5d0 (caddr it) x)) k1))) - (push (+ (car r) (/ (caddr it) 2)) r1) - (setq k2 (mapcar #'(lambda (x) (apply x r1)) funlist)) - (setq r2 (map 'list #'+ (cdr r) (mapcar #'(lambda (x) (* 0.5d0(caddr it) x)) k2))) - (push (+ (car r) (/ (caddr it) 2)) r2) - (setq k3 (mapcar #'(lambda (x) (apply x r2)) funlist)) - (setq r3 (map 'list #'+ (cdr r) (mapcar #'(lambda (x) (* (caddr it) x)) k3))) - (push (+ (car r) (caddr it)) r3) - (setq k4 (mapcar #'(lambda (x) (apply x r3)) funlist)) - (setq u (map 'list #'+ - (mapcar #'(lambda (x) (* #.(/ 1.0 6.0d0) x)) k1) - (mapcar #'(lambda (x) (* #.(/ 1.0 3.0d0) x)) k2) - (mapcar #'(lambda (x) (* #.(/ 1.0 3.0d0) x)) k3) - (mapcar #'(lambda (x) (* #.(/ 1.0 6.0d0) x)) k4))) - (setq r - (append - `(,(+ (car it) (* m (caddr it)))) - (map 'list #'+ (cdr r) (mapcar #'(lambda (x) (* (caddr it) x)) u)))) - (push (cons '(mlist) r) traj))) - (when (< (car r) (cadr it)) - (let ((s (- (cadr it) (car r))) ) - (declare(double-float s)(special s)(optimize (speed 3)(safety 0))) - (progn ;; was ignore-errors - (setq k1 (mapcar #'(lambda (x) (mapply x r nil)) funlist)) - (setq r1 (map 'list #'+ (cdr r) (mapcar #'(lambda (x) - (declare(double-float x)) - (* s 0.5d0 x)) k1))) - (push (+ (car r) (* 0.5d0 s)) r1) - (setq k2 (mapcar #'(lambda (x) (mapply x r1 nil)) funlist)) - (setq r2 (map 'list #'+ (cdr r) (mapcar #'(lambda (x)(declare(double-float x)) - (* s 0.5d0 x)) k2))) - (push (+ (car r) (* 0.5d0 s)) r2) - (setq k3 (mapcar #'(lambda (x) (mapply x r2 nil)) funlist)) - (setq r3 (map 'list #'+ (cdr r) (mapcar #'(lambda (x)(declare(double-float x)) - (* s x)) k3))) - (push (+ (car r) s) r3) - (setq k4 (mapcar #'(lambda (x) (mapply x r3 nil)) funlist)) - (setq u (map 'list #'+ - (mapcar #'(lambda (x)(declare(double-float x)) - (* #.(/ 1.0d0 6.0d0) x)) k1) - (mapcar #'(lambda (x)(declare(double-float x)) - (* #.(/ 1.0d0 3.0d0) x)) k2) - (mapcar #'(lambda (x) (declare(double-float x)) - (* #.(/ 1.0d0 3.0d0) x)) k3) - (mapcar #'(lambda (x)(declare(double-float x)) - (* #.(/ 1.0d0 6.0d0) x)) k4))) - (setq r - (append - `(,(cadr it)) - (map 'list #'+ (cdr r) (mapcar #'(lambda (x)(declare(double-float x)) - (* s x)) u)))) - (push (cons '(mlist) r) traj)))) - (cons '(mlist) (nreverse traj)))
\ No newline at end of file |