Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I have a 5x5 matrix function H[kx]

H[kx_]:={{T1, kx T8, -I T6, kx T9, -I kx T10}, 
 {kx T8, T2, -I kx T11, kx T12, I kx T13}, 
 {I T6, I kx T11, T3, -I kx T14, kx T15}, 
 {kx T9, kx T12, I kx T14, T4, -I T7}, 
 {I kx T10, -I kx T13, kx T15, I T7, T5}
}

with real parameters T1 to T15, and I have data as follow

dat={{-0.005, -0.418971, 1.24115, 2.6321, 3.07757, 4.40013}, 
 {-0.004, -0.418735, 1.24086, 2.63201, 3.07785, 4.40028}, 
 {-0.003, -0.418551, 1.24063, 2.63194, 3.07806, 4.4004}, 
 {-0.002, -0.41842, 1.24047, 2.63189, 3.07822, 4.40048}, 
 {-0.001, -0.418342, 1.24038, 2.63185, 3.07831, 4.40053}, 
 {0., -0.418316, 1.24034, 2.63184, 3.07834, 4.40055}, 
 {0.001, -0.418342, 1.24038, 2.63185, 3.07831, 4.40053}, 
 {0.002, -0.41842, 1.24047, 2.63189, 3.07822, 4.40048}, 
 {0.003, -0.418548, 1.24063, 2.63194, 3.07807, 4.4004}, 
 {0.004, -0.418728, 1.24085, 2.63201, 3.07785, 4.40028}, 
 {0.005, -0.418959, 1.24114, 2.63211, 3.07758, 4.40012}
}

For each i, kx=dat[[i,1]], and dat[[i,2;;6]] are the eigenvalues (from small to big) which will be fitted by H[kx].

The aim is to find all the parameters T1 to T15 which best produce the eigenvalues given by dat for all kx. How can I achieve this?

share|improve this question
1  
The easy approach : define a measure of the deviation, for instance expr = Total[ Flatten[(ev[#[[1]]] - Reverse[SortBy[#[[2 ;;]], Abs]])^2 & /@ dat]]; and then try to NMinimize it turns out to be unusably slow. –  b.gatessucks Jan 17 '13 at 14:16
    
I did this, using an object function to describe the total deviation between the calculated eigenvalues and the data. And then using NMinimize or FindMinimum. However, the result is far from reasonable. –  goodluck Jan 18 '13 at 0:34

1 Answer 1

Not having good starting values at hand, nor sufficient time to spare with your problem, here was the best I could do:

{mv, am} = 
 Quiet @ NMinimize[Norm[Norm[
   Map[Function[x, With[{kx = First[#]}, CharacteristicPolynomial[H[kx], x]] // Evaluate],
       Rest[#]]] & /@ dat],
                {T1, T2, T3, T4, T5, T6, T7, T8, T9, T10, T11, T12, T13, T14, T15},
                Method -> {"NelderMead", RandomSeed -> 4}]
   {0.020097 + 0. I,
    {T1 -> 1.61337, T2 -> -0.418315, T3 -> 2.70502, T4 -> 3.47363,
     T5 -> 3.55875, T6 -> 0.73906, T7 -> 0.883149, T8 -> -5.58534,
     T9 -> 2.15443, T10 -> -1.25767, T11 -> 3.13062, T12 -> -1.82002,
     T13 -> 1.77503, T14 -> -0.694595, T15 -> -0.768617}}

Even this feeble attempt yields something usable:

mf[kx_] = H[kx] /. am;
Eigenvalues[mf[First[#]]] - Sort[Rest[#], GreaterEqual] & /@ dat

gives

{{0.00027062, 0.000618862, -0.00025875, -0.000162659, 4.80406*10^-6},
 {0.000107527, 0.000256957, -0.000105524, -0.0000752058, 3.12297*10^-6},
 {-0.0000226674, -0.0000167649, 0.0000136659, -2.74297*10^-6, 1.38639*10^-6},
 {-0.000109957, -0.00022229, 0.0000988083, 0.0000447379, 5.78009*10^-7},
 {-0.000164336, -0.000339608, 0.000159896, 0.0000672356, 6.90641*10^-7},
 {-0.000185798, -0.000378715, 0.000176925, 0.0000847389, 7.26231*10^-7},
 {-0.000164334, -0.000339608, 0.000159897, 0.000067227, 6.95853*10^-7},
 {-0.000109939, -0.00022229, 0.0000988172, 0.0000446694, 6.19705*10^-7},
 {-0.0000226064, -0.0000267654, 0.0000136958, -2.97409*10^-6, -1.47291*10^-6},
 {0.000107672, 0.000256956, -0.000105453, -0.0000657536, -3.5436*10^-6},
 {0.000280902, 0.00060886, -0.000268611, -0.000153729, -6.54493*10^-6}}

Someone with more time to play around with the Method option of NMinimize[] should be able to find better results than mine...

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.