Re: Re: Solve[] doesn't
- To: mathgroup at smc.vnet.net
- Subject: [mg90655] Re: [mg90636] Re: Solve[] doesn't
- From: DrMajorBob <drmajorbob at att.net>
- Date: Fri, 18 Jul 2008 04:00:46 -0400 (EDT)
- References: <g5kil1$8lf$1@smc.vnet.net>
- Reply-to: drmajorbob at longhorns.com
> (* Now solve for sijkl - if you dare! *)
In what equation(s)?
In terms of what other variables or constants?
Bobby
On Thu, 17 Jul 2008 04:34:27 -0500, Hauke Reddmann
<fc3a501 at uni-hamburg.de> wrote:
> Addendum - "Faked Example" of course means exactly that -
> my problem looks *like* the one I gave (of course
> Mathematica solves THAT :-) in general structure.
> It's hard to come up with actual code because I work
> "on the fly" and so I won't exclude sheer stupidity
> or a typo on my side.
>
> I can give my basic code, though, it's just state model
> knot theory work:
>
> ClearAll["Global`*"];
> (*Set Dimension*) n=3;fl=Floor[n/2];ce=Floor[(n-1)/2];
> (*Define Closure*) cl[x_]:=Simplify[pc.x.qc/oo];
> (*Define Convert1*) mt[x_]:=Nest[Partition[#,n]&,Flatten[x],3];
> (*Define Convert2*) tm[x_]:=Partition[Flatten[x],n*n];
> (*Define Rotation*) ro[x_]:=tm[Transpose[p.mt[x].q,{3,1,4,2}]];
> (*Define Tidy Up*)
> ti[x_]:=x//Flatten//Together//Numerator//Factor//Sort//Union;
>
> (*Actual Example*)
> (*Set Cup and Cap*) q={{1/2,1,1},{-1,-1,0},{1,0,0}};
> p=Inverse[q];
> (*Set S Matrix *) s={
> {s1111,s1112,s1113,s1121,s1122,s1123,s1131,s1132,s1133},
> {s1211,s1212,s1213,s1221,s1222,s1223,s1231,s1232,s1233},
> {s1311,s1312,s1313,s1321,s1322,s1323,s1331,s1332,s1333},
> {s2111,s2112,s2113,s2121,s2122,s2123,s2131,s2132,s2133},
> {s2211,s2212,s2213,s2221,s2222,s2223,s2231,s2232,s2233},
> {s2311,s2312,s2313,s2321,s2322,s2323,s2331,s2332,s2333},
> {s3111,s3112,s3113,s3121,s3122,s3123,s3131,s3132,s3133},
> {s3211,s3212,s3213,s3221,s3222,s3223,s3231,s3232,s3233},
> {s3311,s3312,s3313,s3321,s3322,s3323,s3331,s3332,s3333}};
>
> (*Define R Matrix via Whirl 1*) r=ro[s];
> (*Whirl 2*) nul1=Flatten[s-ro[r]];
> (*Cap as Vector*) pc=Flatten[p];
> (*Cup as Vector*) qc=Flatten[q];
> (*Twist*) nul2a=Flatten[pc.s-pc*f];
> (*Twist*) nul2b=Flatten[pc.r-pc/f];
> (*Id*) kr=IdentityMatrix[n^2];
> (*Poke*) nul3=Flatten[s.r-kr];
> (*Id*) id=IdentityMatrix[n];
> (*S x Id*)
> s1=Partition[Flatten[Transpose[Outer[Times,s,id],{1,3,2,4}]],n^3];
> (*Id x S*)
> s2=Partition[Flatten[Transpose[Outer[Times,id,s],{1,3,2,4}]],n^3];
> (*Slide*) nul4=Flatten[s1.s2.s1-s2.s1.s2];
>
> (* Now solve for sijkl - if you dare! *)
> (* nul1 and nul2a/b are linear, try them first. *)
>
> g=(Sqrt[5]+1)/2;
> f=I*(2*g+1);
> S=I*{
> {g-1,0,-g/2,0,g/2,g/2,-g/2,-g/2,-g/4},
> {0,g-1,-g,0,g,g,-g,-g,-g/2},
> {0,0,-1,0,g,g,-g,-g,-g/2},
> {0,0,g,g-1,-g,-g,g,g,g/2},
> {0,0,g,0,-1,-g,g,g,g/2},
> {0,0,0,0,0,g-1,0,0,0},
> {0,0,-g,0,g,g,-1,-g,-g/2},
> {0,0,0,0,0,0,0,g-1,0},
> {0,0,0,0,0,0,0,0,g-1}};
> (* s=S is a solution I know but sometimes not find. *)
>
> HTH.
> --
> Hauke Reddmann <:-EX8 fc3a501 at uni-hamburg.de
> Er-a svo gott sem gott kveða
> öl alda sonum, því að færra veit
> er fleira drekkur síns til geðs gumi.
>
>
--
DrMajorBob at longhorns.com