天津大学张琪昌等编的<分岔与混沌理论及应用>中Mathematica程序1

wy19830711 · 发表于 2006-11-9 11:27

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？我要加入

x

一维:

aa = Table[a[i, j], {i, remainder}, {j, 2, korder}];
hx = Table[0, {remainder}];
Do[hx[] = Sum[a[i, j]
x[1]^j, {j, 2, korder}] + O[x[1]]^(korder + 1), {i, 1, remainder}];
my = Table[0, {remainder}];
Do[y = hx[], {i, 1, remainder}];
Do[nx = D[hx[], x[1]] dx[1] - dy == 0; my[] = LogicalExpand[nx], {i,
1, remainder}];
myok = Flatten[my];
aij1 = Flatten[aa];
my2 = Solve[myok, aij1];
my2 = Flatten[my2];
dx[1] = Simplify[dx[1] /. my2];
dx[1] = Normal[dx[1]];
centermaniford = {}
Do[dx[jj] = dx[jj];
dx[jj] = Expand[dx[jj]];
len = Length[dx[jj]];
eff = Table[0, {len}];
Do[item = dx[jj][];
ee = 0; Do[
eii = Exponent[item, x[ii]];
ee = ee + eii;
, {ii, 1, centerdimension}];
If[ee > korder, eff[] = eff[], eff[] = eff[] + item];
, {i, 1, len}];
dx[jj] = 0;
len1 = Length[eff];
Do[
dx[jj] = dx[jj] + eff[];
, {i, 1, len1}];
centermaniford = Join[{dx[jj]}, centermaniford];
, {jj, 1, centerdimension}]
centermaniford = Reverse[centermaniford]
centermaniford = Simplify[centermaniford]

复制代码

wy19830711 · 发表于 2006-11-9 11:29

remainder = total - centerdimension;
ahij2 = {};
Do[
Do[
Do[
i = l - j; ahij2 = Join[{a[h, i, j]}, ahij2]
, {j, 0, l}]
, {l, 2, korder}]
, {h, 1, remainder}];
Do[
hyx = 0;
Sum[Do[i = l - j; hyx = hyx + a[h, i, j] x[1]^i x[2]^
j, {j, 0, l}], {l, 2, korder}];
y[h] = hyx
, {h, 1, remainder}];
nx = Table[0, {remainder}];
coe = {};
Do[
nx[[h]] = Sum[D[y[h], x[ii]] dx[ii], {ii, 1, centerdimension}] - dy[h]
, {h, 1, remainder}];
Do[
Do[
Do[
i = ip - j;
mycoe = Coefficient[nx[[h]], x[1], i];
mycoe = Coefficient[mycoe, x[2], j] /. {x[1] -> 0, x[2] -> 0};
coe = Join[{mycoe == 0}, coe]
, {j, 0, ip}]
, {ip, 2, korder}]
, {h, 1, remainder}];
me = Solve[coe, ahij2];
me = Flatten[me];
Do[
y = y /. me
, {i, 1, remainder}];
centermaniford = {}
Do[
dx[jj] = dx[jj];
dx[jj] = Expand[dx[jj]];
len = Length[dx[jj]];
eff = Table[0, {len}];
Do[
item = dx[jj][];
ee = 0;
Do[
eii = Exponent[item, x[ii]];
ee = ee + eii;
, {ii, 1, centerdimension}];
If[ee > korder, eff[] = eff[], eff[] = eff[] + item];
, {i, 1, len}];
dx[jj] = 0;
len1 = Length[eff];
Do[
dx[jj] = dx[jj] + eff[];
, {i, 1, len1}];
centermaniford = Join[{dx[jj]}, centermaniford];
, {jj, 1, centerdimension}]
centermaniford = Reverse[centermaniford]
centermaniford = Simplify[centermaniford]

复制代码

wy19830711 · 发表于 2006-11-9 11:29

remainder = total - centerdimension;
ahij2 = {};
Do[
Do[
Do[
i = l - j; ahij2 = Join[{a[h, i, j]}, ahij2]
, {j, 0, l}]
, {l, 2, korder}]
, {h, 1, remainder}];
Do[
hyx = 0;
Sum[Do[i = l - j; hyx = hyx + a[h, i, j] x[1]^i x[2]^
j, {j, 0, l}], {l, 2, korder}];
y[h] = hyx
, {h, 1, remainder}];
nx = Table[0, {remainder}];
coe = {};
Do[
nx[[h]] = Sum[D[y[h], x[ii]] dx[ii], {ii, 1, centerdimension}] - dy[h]
, {h, 1, remainder}];
Do[
Do[
Do[
i = ip - j;
mycoe = Coefficient[nx[[h]], x[1], i];
mycoe = Coefficient[mycoe, x[2], j] /. {x[1] -> 0, x[2] -> 0};
coe = Join[{mycoe == 0}, coe]
, {j, 0, ip}]
, {ip, 2, korder}]
, {h, 1, remainder}];
me = Solve[coe, ahij2];
me = Flatten[me];
Do[
y = y /. me
, {i, 1, remainder}];
centermaniford = {}
Do[
dx[jj] = dx[jj];
dx[jj] = Expand[dx[jj]];
len = Length[dx[jj]];
eff = Table[0, {len}];
Do[
item = dx[jj][];
ee = 0;
Do[
eii = Exponent[item, x[ii]];
ee = ee + eii;
, {ii, 1, centerdimension}];
If[ee > korder, eff[] = eff[], eff[] = eff[] + item];
, {i, 1, len}];
dx[jj] = 0;
len1 = Length[eff];
Do[
dx[jj] = dx[jj] + eff[];
, {i, 1, len1}];
centermaniford = Join[{dx[jj]}, centermaniford];
, {jj, 1, centerdimension}]
centermaniford = Reverse[centermaniford]
centermaniford = Simplify[centermaniford]

复制代码

wy19830711 · 发表于 2006-11-9 11:31

remainder = total - centerdimension;
ahij2 = {};
Do[
Do[
Do[
i = l - j; ahij2 = Join[{a[h, i, j]}, ahij2]
, {j, 0, l}]
, {l, 2, korder}]
, {h, 1, remainder}];
Do[
hyx = 0;
Sum[Do[i = l - j; hyx = hyx + a[h, i, j] x[1]^i x[2]^
j, {j, 0, l}], {l, 2, korder}];
y[h] = hyx
, {h, 1, remainder}];
nx = Table[0, {remainder}];
coe = {};
Do[
nx[[h]] = Sum[D[y[h], x[ii]] dx[ii], {ii, 1, centerdimension}] - dy[h]
, {h, 1, remainder}];
Do[
Do[
Do[
i = ip - j;
mycoe = Coefficient[nx[[h]], x[1], i];
mycoe = Coefficient[mycoe, x[2], j] /. {x[1] -> 0, x[2] -> 0};
coe = Join[{mycoe == 0}, coe]
, {j, 0, ip}]
, {ip, 2, korder}]
, {h, 1, remainder}];
me = Solve[coe, ahij2];
me = Flatten[me];
Do[
y = y /. me
, {i, 1, remainder}];
centermaniford = {}
Do[
dx[jj] = dx[jj];
dx[jj] = Expand[dx[jj]];
len = Length[dx[jj]];
eff = Table[0, {len}];
Do[
item = dx[jj][];
ee = 0;
Do[
eii = Exponent[item, x[ii]];
ee = ee + eii;
, {ii, 1, centerdimension}];
If[ee > korder, eff[] = eff[], eff[] = eff[] + item];
, {i, 1, len}];
dx[jj] = 0;
len1 = Length[eff];
Do[
dx[jj] = dx[jj] + eff[];
, {i, 1, len1}];
centermaniford = Join[{dx[jj]}, centermaniford];
, {jj, 1, centerdimension}]
centermaniford = Reverse[centermaniford]
centermaniford = Simplify[centermaniford]

复制代码

ieluxinhua · 发表于 2006-11-14 15:54

能不能介绍一下这三个程序？

gghhjj · 发表于 2006-11-15 07:10

原帖由 ieluxinhua 于 2006-11-14 15:54 发表
能不能介绍一下这三个程序？

自己找《分岔与混沌理论及应用》对照看一下就行了

yzsldj · 发表于 2006-11-18 11:05

将这个程序用来计算实际问题时，无法得到正确结果，我试过几个"centerdimension=2"的例子，不知是何原因。

看来这个程序只能计算张琪昌<分岔与混沌理论及应用>书中的例4.4.1，输出正确的结果，其它问题的计算均报错。

wy19830711 · 发表于 2006-11-18 16:58

应该不会吧,我都试过啊

gghhjj · 发表于 2006-11-19 07:39

原帖由 yzsldj 于 2006-11-18 11:05 发表
将这个程序用来计算实际问题时，无法得到正确结果，我试过几个"centerdimension=2"的例子，不知是何原因。

看来这个程序只能计算张琪昌<分岔与混沌理论及应用>书中的例4.4.1，输出正确的结果， ...

可以把你的例子给一下，大家看看

yzsldj · 发表于 2006-11-19 08:32

我的问题是：

centerdimension=3;
dx[1]=y[1]+x[1]*z[1];
dy[1]=-x[1]+y[1]*z[1]-x[1]*w[1];
dz[1]=0;
dw[1]=-w[1]+alpha*x[1]^2;
korder=5;
total1=4;

要么出错，要么无输出结果。
我把代码也附上，请大家看看问题出在哪里。

This program is to compute the centermaniford
ReadList["e:\center1.txt"]
remainder=total1-centerdimension
"******************************"
"To compute the zero space of the stable maniford and y[i]"
"******************************"
If [centerdimension==1,
aa=Table[a[i,j],{i,remainder},{j,2,korder}];
hx=Table[0,{remainder}];
Do[
hx[[i]]=Sum[a[i,j] x[1]^j,{j,2,korder}]+O[x[1]]^(korder+1),{i,1, remainder }];
my=Table[0,{remainder}];
Do[
y[i]=hx[[i]],{i,1,remainder}];
Do[
nx=D[hx[[i]],x[1]] dx[1]-dy[i]==0;
my[[i]]=LogicalExpand[nx]
,{i,1,remainder}];
myok=Flatten[my];
aij1=Flatten[aa];
my2=Solve[myok,aij1];
my2= Flatten [my2];
dx[1]=Simplify[dx[1]/.my2];
dx[1]=Normal[dx[1]];
]
If[centerdimension==2,
ahij2={};
Do[
Do[
Do[
i=l-j; ahij2=Join[{a[h,i,j]},ahij2]
,{j,0,l}]
,{l,2,korder}]
,{h,1,remainder}];
Do[
hyx=0;
Sum[Do[i=l-j;hyx=hyx+a[h,i,j] x[1]^i x[2]^j,{j,0,l}],{l,2,korder}];
y[h]=hyx
,{h,1,remainder}] ;
nx=Table[0,{remainder}] ;
coe={};
Do[
nx[[h]]=Sum[D[y[h],x[ii]] dx[ii],{ii,1,centerdimension}]-dy[h]
,{h,1,remainder}];
Do[
Do[
Do[
i=ip-j;
mycoe=Coefficient[nx[[h]],x[1],i];
mycoe=Coefficient[mycoe,x[2],j]/.{x[1]->0,x[2]->0} ;
coe=Join[{mycoe==0},coe]
,{j,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}];
me=Solve[coe,ahij2];
me=Flatten[me];
Do[
y[i]=y[i]/.me
,{i,1,remainder}];
]
If[centerdimension==3,
ahijp3={};
Do[
Do[
Do[
Do[
p=ip-i-j;
ahijp3=Join[{a[h,i,j,p]},ahijp3]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}];
Do[
hyx=0;
Do[
Do[
Do[
p=ip-i-j;
hyx=hyx+a[h,i,j,p] x[1]^i x[2]^j x[3]^p
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}];
y[h]=hyx;
,{h,1,remainder}];
nx=Table[0,{remainder}];
coe={};
Do[
nx[[h]]=Sum[D[y[h],x[ii]] dx[ii],{ii,1,centerdimension}]-dy[h]
,{h,1,remainder}];
Do[
Do[
Do[
Do[
p=ip-i-j ;
mycoe=Coefficient[nx[[h]],x[1],i];
mycoe=Coefficient[mycoe,x[2],j] ;
mycoe=Coefficient[mycoe,x[3],p]/.{x[1]->0,x[2]->0,x[3]->0};
coe=Join[{mycoe==0},coe]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}];
me=Solve[coe,ahijp3];
me=Flatten[me];
Do[y[i]=y[i]/.me,{i,1,remainder}];
]
If[centerdimension==4,
ahijpl4={};
Do[
Do[
Do[
Do[
Do[
l=ip-i-j-p;
ahijp14=Join[{a[h,i,j,p,l]},ahijpl4]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}];
Do[
hyx=0;
Do[
Do[
Do[
Do[
l=ip-i-j-p;
hyx=hyx+a[h,i,j,p,l] x[1]^i x[2]^j x[3]^p x[4]^l;
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}];
y[h]=hyx;
,{h,1,remainder}];
nx=Table[0,{remainder}] ;
coe={} ;
Do[
nx[[h]]=Sum[D[y[h],x[ii]] dx[ii],{ii,1,centerdimension}]-dy[h]
,{h,1,remainder}] ;
Do[
Do[
Do[
Do[
Do[
l=ip-i-j-p;
mycoe=Coefficient[nx[[h]],x[1],i];
mycoe=Coefficient[mycoe,x[2],j] ;
mycoe=Coefficient[mycoe,x[3],p] ;
mycoe=Coefficient[mycoe,x[4],l]/.{x[1]->0,x[2]->0,x[3]->0,x[4]->0};
coe=Join[{mycoe==0},coe]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}] ;
me=Solve[coe,ahijpl4] ;
me=Flatten[me];
Do[
y[i]=y[i]/.me
,{i,1,remainder}];
]
If[centerdimension==5,
ahijplm5={};
Do[
Do[
Do[
Do[
Do[
Do[
m=ip-i-j-p-l;
ahijplm5=Join[{a[h,i,j,p,l,m]},ahijplm5]
,{l,0,ip-i-j-p}]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}];
Do[
hyx=0;
Do[
Do[
Do[
Do[
Do[
m=ip-i-j-p-l;
hyx=hyx+a[h,i,j,p,l,m] x[1]^i x[2]^j x[3]^p x[4]^l x[5]^m;
,{l,0,ip-i-j-p}]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}];
y[h]=hyx;
,{h,1,remainder}];
nx=Table[0,{remainder}] ;
coe={} ;
Do[
nx[[h]]=Sum[D[y[h],x[ii]] dx[ii],{ii,1,centerdimension}]-dy[h]
,{h,1,remainder}] ;
Do[
Do[
Do[
Do[
Do[
Do[
m=ip-i-j-p-l;
mycoe=Coefficient[nx[[h]],x[1],i];
mycoe=Coefficient[mycoe,x[2],j] ;
mycoe=Coefficient[mycoe,x[3],p] ;
mycoe=Coefficient[mycoe,x[4],l] ;
mycoe=Coefficient[mycoe,x[5],m]/.{x[1]->0,x[2]->0,x[3]->0,x[4]->0,x[5]->0} ;
coe=Join[{mycoe==0},coe]
,{l,0,ip-i-j-p}]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}] ;
Print[ "To solve the equation"];
me=Solve[coe,ahijplm5] ;
me=Flatten[me];
Print[me]
Do[
y[i]=y[i]/.me,
{i,1,remainder}];
]
If[centerdimension==6,
ahijplmn6={};
Do[
Do[
Do[
Do[
Do[
Do[
Do[
n=ip-i-j-p-l-m;
ahijplmn6=Join[{a[h,i,j,p,l,m,n]},ahijplmn6];
,{m,0,ip-i-j-p-l}]
,{l,0,ip-i-j-p}]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}];
Do[
hyx=0;
Do[
Do[
Do[
Do[
Do[
Do[
n=ip-i-j-p-l-m;
hyx=hyx+a[h,i,j,p,l,m,n] x[1]^i x[2]^j x[3]^p x[4]^l x[5]^m x[6]^n;
,{m,0,ip-i-j-p-l}]
,{l,0,ip-i-j-p}]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}];
y[h]=hyx;
,{h,1,remainder}];
nx=Table[0,{remainder}] ;
coe={} ;
Do[
nx[[h]]=Sum[D[y[h],x[ii]] dx[ii],{ii,1,centerdimension}]-dy[h]
,{h,1,remainder}] ;
Do[
Do[
Do[
Do[
Do[
Do[
Do[
n=ip-i-j-p-l-m;
mycoe=Coefficient[nx[[h]],x[1],i];
mycoe=Coefficient[mycoe,x[2],j] ;
mycoe=Coefficient[mycoe,x[3],p] ;
mycoe=Coefficient[mycoe,x[4],l] ;
mycoe=Coefficient[mycoe,x[5],m] ;
mycoe=Coefficient[mycoe,x[6],n]/.{x[1]->0,x[2]->0,x[3]->0,x[4]->0,x[5]->0,x[6]->0} ;
coe=Join[{mycoe==0},coe]
,{m,0,ip-i-j-p-l}]
,{l,0,ip-i-j-p}]
,{p,0,ip-i-j}]
,{j,0,ip-i}]
,{i,0,ip}]
,{ip,2,korder}]
,{h,1,remainder}] ;
Print[ "To solve the equation "];
me=Solve[coe,ahijplmn6] ;
me=Flatten[me];
Print[me]
Do[
y[i]=y[i]/.me,{i,1,remainder}];
]
"******************************"
"To compute the centermaniford and crop the higher order items"
"******************************"
centermaniford={}
Do[
dx[jj]=dx[jj];
dx[jj]=Expand[dx[jj]];
len=Length[dx[jj]];
eff=Table[0,{len}];
Do[
item=dx[jj][[i]];
ee=0;
Do[
eii=Exponent[item,x[ii]];
ee=ee+eii;
,{ii,1,centerdimension}];
If[ee>korder,eff[[i]]=eff[[i]],eff[[i]]=eff[[i]]+item];
,{i,1,len}];
dx[jj]=0;
len1=Length[eff];
Do[
dx[jj]=dx[jj]+eff[[i]];
,{i,1,len1}];
centermaniford=Join[{dx[jj]},centermaniford];
,{jj,1,centerdimension}]
centermaniford=Reverse[centermaniford]>>e:\center.out
centermaniford=Simplify[centermaniford]
Print["This is the end of the program"]

复制代码

无水1324 · 发表于 2007-6-14 21:35

一个不错的东西，顶上来！希望需要的人参考。程序中确实存在问题。有兴趣的可以一起研究一下！

octopussheng · 发表于 2007-6-28 12:01

这本书我看了一两遍了，后面的程序还没有算过，我还打算用这些程序出点结果呢，不会真的有问题吧，我也拿例子试试看！

无水1324 · 发表于 2007-6-28 12:34

试一下，才知道真正的问题在那里

octopussheng · 发表于 2007-6-28 21:05

我算了一下书上的例4.4.1，为什么出来的结果是这样子的啊？

gghhjj · 发表于 2007-6-29 04:31

原帖由 octopussheng 于 2007-6-28 21:05 发表

 登录/注册后可看大图

我算了一下书上的例4.4.1，为什么出来的结果是这样子的啊？

没有这本书，能够把详细内容贴一下？

账号		自动登录	找回密码
密码			我要加入

[分形与混沌] 天津大学张琪昌等编的<分岔与混沌理论及应用>中Mathematica程序1

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

天津大学张琪昌等编的<分岔与混沌理论及应用>中Mathematica程序2

天津大学张琪昌等编的<分岔与混沌理论及应用>中Mathematica程序3

天津大学张琪昌等编的<分岔与混沌理论及应用>中Mathematica程序规范形

评分