void expm(gsl_matrix_complex * L, gsl_complex t, gsl_matrix * m)
{
int i,j,s;
gsl_vector_complex *eval = gsl_vector_complex_alloc(4);
gsl_matrix_complex *evec = gsl_matrix_complex_alloc(4, 4);
gsl_eigen_nonsymmv_workspace * w = gsl_eigen_nonsymmv_alloc(4);
gsl_matrix_complex *evalmat = gsl_matrix_complex_alloc(4, 4);
gsl_matrix_complex *vd = gsl_matrix_complex_alloc(4, 4);
gsl_complex one = gsl_complex_rect(1, 0);
gsl_complex zero = gsl_complex_rect(0, 0);
gsl_matrix_complex *K = gsl_matrix_complex_alloc(4, 4);
gsl_permutation *p = gsl_permutation_alloc(4);
gsl_vector_complex *x = gsl_vector_complex_alloc(4);
gsl_vector_complex_view bp;
gsl_complex z;
gsl_eigen_nonsymmv(m, eval, evec, w);
gsl_eigen_nonsymmv_sort(eval, evec, GSL_EIGEN_SORT_ABS_DESC);
gsl_eigen_nonsymmv_free(w); // clear workspace
for (i = 0; i < 4; i++)
{
gsl_complex eval_i = gsl_vector_complex_get(eval, i);
gsl_complex expeval = gsl_complex_mul(eval_i,t);
expeval = gsl_complex_exp(expeval);
gsl_matrix_complex_set(evalmat, i, i, expeval);
}
gsl_vector_complex_free(eval); // clear vector for eigenvalues
// v'L'=De'v'
gsl_blas_zgemm(CblasTrans, CblasTrans, one, evalmat, evec, zero, vd);
gsl_matrix_complex_transpose(evec);//transpose v
gsl_matrix_complex_memcpy(K,evec);
for (i = 0; i < 4; i++)
{
bp = gsl_matrix_complex_column(vd, i);
gsl_linalg_complex_LU_decomp(evec, p, &s);
gsl_linalg_complex_LU_solve(evec, p, &bp.vector, x);
for (j = 0; j < 4; j++)
{
z = gsl_vector_complex_get(x, j);
gsl_matrix_complex_set(L,i,j,z); //'through the looking glass' transpose
}
gsl_matrix_complex_memcpy(evec,K);
}
gsl_permutation_free(p);
gsl_vector_complex_free(x);
gsl_matrix_complex_free(vd);
gsl_matrix_complex_free(evec);
gsl_matrix_complex_free(evalmat);
gsl_matrix_complex_free(K);
}
void
test_eigen_herm_matrix(const gsl_matrix_complex * m, size_t count,
const char * desc)
{
const size_t N = m->size1;
gsl_matrix_complex * A = gsl_matrix_complex_alloc(N, N);
gsl_vector * eval = gsl_vector_alloc(N);
gsl_vector * evalv = gsl_vector_alloc(N);
gsl_vector * x = gsl_vector_alloc(N);
gsl_vector * y = gsl_vector_alloc(N);
gsl_matrix_complex * evec = gsl_matrix_complex_alloc(N, N);
gsl_eigen_herm_workspace * w = gsl_eigen_herm_alloc(N);
gsl_eigen_hermv_workspace * wv = gsl_eigen_hermv_alloc(N);
gsl_matrix_complex_memcpy(A, m);
gsl_eigen_hermv(A, evalv, evec, wv);
test_eigen_herm_results(m, evalv, evec, count, desc, "unsorted");
gsl_matrix_complex_memcpy(A, m);
gsl_eigen_herm(A, eval, w);
/* sort eval and evalv */
gsl_vector_memcpy(x, eval);
gsl_vector_memcpy(y, evalv);
gsl_sort_vector(x);
gsl_sort_vector(y);
test_eigenvalues_real(y, x, desc, "unsorted");
gsl_eigen_hermv_sort(evalv, evec, GSL_EIGEN_SORT_VAL_ASC);
test_eigen_herm_results(m, evalv, evec, count, desc, "val/asc");
gsl_eigen_hermv_sort(evalv, evec, GSL_EIGEN_SORT_VAL_DESC);
test_eigen_herm_results(m, evalv, evec, count, desc, "val/desc");
gsl_eigen_hermv_sort(evalv, evec, GSL_EIGEN_SORT_ABS_ASC);
test_eigen_herm_results(m, evalv, evec, count, desc, "abs/asc");
gsl_eigen_hermv_sort(evalv, evec, GSL_EIGEN_SORT_ABS_DESC);
test_eigen_herm_results(m, evalv, evec, count, desc, "abs/desc");
gsl_matrix_complex_free(A);
gsl_vector_free(eval);
gsl_vector_free(evalv);
gsl_vector_free(x);
gsl_vector_free(y);
gsl_matrix_complex_free(evec);
gsl_eigen_herm_free(w);
gsl_eigen_hermv_free(wv);
} /* test_eigen_herm_matrix() */
static VALUE rb_gsl_linalg_complex_LU_svx(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix_complex *m = NULL, *mtmp = NULL;
gsl_permutation *p = NULL;
gsl_vector_complex *x = NULL;
int flagm = 0, itmp, signum;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
CHECK_MATRIX(argv[0]);
Data_Get_Struct(argv[0], gsl_matrix_complex, m);
if (CLASS_OF(argv[0]) != cgsl_matrix_complex_LU) {
flagm = 1;
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
} else {
mtmp = m;
}
itmp = 1;
break;
default:
Data_Get_Struct(obj, gsl_matrix_complex, m);
if (CLASS_OF(obj) != cgsl_matrix_complex_LU) {
flagm = 1;
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
} else {
mtmp = m;
}
itmp = 0;
}
if (flagm == 1) {
if (itmp != argc-1) rb_raise(rb_eArgError, "Usage: m.LU_solve(b)");
Data_Get_Struct(argv[itmp], gsl_vector_complex, x);
p = gsl_permutation_alloc(x->size);
gsl_linalg_complex_LU_decomp(mtmp, p, &signum);
} else {
Data_Get_Struct(argv[itmp], gsl_permutation, p);
itmp++;
Data_Get_Struct(argv[itmp], gsl_vector_complex, x);
itmp++;
}
gsl_linalg_complex_LU_svx(mtmp, p, x);
if (flagm == 1) {
gsl_matrix_complex_free(mtmp);
gsl_permutation_free(p);
}
return argv[argc-1];
}
void
qpb_sun_project(qpb_link *u, int n)
{
gsl_eigen_hermv_workspace *gsl_work = gsl_eigen_hermv_alloc(NC);
gsl_matrix_complex *B = gsl_matrix_complex_alloc(NC, NC);
gsl_matrix_complex *A = gsl_matrix_complex_alloc(NC, NC);
gsl_matrix_complex *V = gsl_matrix_complex_alloc(NC, NC);
gsl_matrix_complex *U = gsl_matrix_complex_alloc(NC, NC);
gsl_matrix_complex *D = gsl_matrix_complex_alloc(NC, NC);
gsl_vector *S = gsl_vector_alloc(NC);
gsl_permutation *perm = gsl_permutation_alloc(NC);
for(int k=0; k<n; k++){
qpb_complex *a = (qpb_complex *)(u + k);
for(int i=0; i<NC; i++)
for(int j=0; j<NC; j++)
gsl_matrix_complex_set(A, i, j, gsl_complex_rect(a[j + i*NC].re, a[j + i*NC].im));
gsl_matrix_complex_memcpy(U, A);
int sgn;
gsl_linalg_complex_LU_decomp(U, perm, &sgn);
gsl_complex det_A = gsl_linalg_complex_LU_det(U, sgn);
qpb_double phi = gsl_complex_arg(det_A);
gsl_complex one = gsl_complex_rect(1., 0.);
gsl_complex zero = gsl_complex_rect(0., 0.);
gsl_matrix_complex_memcpy(U, A);
svd(U, V, S);
get_theta_matrix(D, S, phi);
gsl_blas_zgemm(CblasNoTrans, CblasNoTrans, one, U, D, zero, B);
gsl_blas_zgemm(CblasNoTrans, CblasConjTrans, one, B, V, zero, A);
for(int i=0; i<NC; i++)
for(int j=0; j<NC; j++){
a[j + i*NC].re = GSL_REAL(gsl_matrix_complex_get(A, i, j));
a[j + i*NC].im = GSL_IMAG(gsl_matrix_complex_get(A, i, j));
}
}
gsl_matrix_complex_free(A);
gsl_matrix_complex_free(B);
gsl_matrix_complex_free(V);
gsl_matrix_complex_free(U);
gsl_matrix_complex_free(D);
gsl_permutation_free(perm);
gsl_vector_free(S);
gsl_eigen_hermv_free(gsl_work);
return;
}
static VALUE rb_gsl_linalg_complex_LU_sgndet(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix_complex *m = NULL, *mtmp = NULL;
gsl_permutation *p = NULL;
gsl_complex *z = NULL;
VALUE vz;
int flagm = 0, signum, itmp;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
CHECK_MATRIX_COMPLEX(argv[0]);
Data_Get_Struct(argv[0], gsl_matrix_complex, m);
if (CLASS_OF(argv[0]) != cgsl_matrix_complex_LU) {
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
flagm = 1;
} else {
mtmp = m;
}
itmp = 1;
break;
default:
Data_Get_Struct(obj, gsl_matrix_complex, m);
if (CLASS_OF(obj) != cgsl_matrix_complex_LU) {
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
flagm = 1;
} else {
mtmp = m;
}
itmp = 0;
}
if (flagm == 1) {
p = gsl_permutation_alloc(m->size1);
gsl_linalg_complex_LU_decomp(mtmp, p, &signum);
} else {
if (itmp != argc-1) rb_raise(rb_eArgError, "signum not given");
signum = NUM2DBL(argv[itmp]);
}
vz = Data_Make_Struct(cgsl_complex, gsl_complex, 0, free, z);
*z = gsl_linalg_complex_LU_sgndet(mtmp, signum);
if (flagm == 1) {
gsl_matrix_complex_free(mtmp);
gsl_permutation_free(p);
}
return vz;
}
static int
mc_qr(lua_State *L) /* (-1,+2,e) */
{
mMatComplex *m = qlua_checkMatComplex(L, 1);
mMatComplex *qr = qlua_newMatComplex(L, m->l_size, m->r_size);
mMatComplex *q = qlua_newMatComplex(L, m->l_size, m->l_size);
mMatComplex *r = qlua_newMatComplex(L, m->l_size, m->r_size);
int nm = m->l_size < m->r_size? m->l_size: m->r_size;
gsl_vector_complex *tau;
gsl_matrix_complex_memcpy(qr->m, m->m);
tau = gsl_vector_complex_alloc(nm);
if (tau == 0) {
lua_gc(L, LUA_GCCOLLECT, 0);
tau = gsl_vector_complex_alloc(nm);
if (tau == 0)
luaL_error(L, "not enough memory");
}
if (gsl_linalg_complex_QR_decomp(qr->m, tau))
luaL_error(L, "matrix:qr() failed");
if (gsl_linalg_complex_QR_unpack(qr->m, tau, q->m, r->m))
luaL_error(L, "matrix:qr() failed");
gsl_vector_complex_free(tau);
return 2;
}
static int
mc_det(lua_State *L)
{
mMatComplex *m = qlua_checkMatComplex(L, 1);
mMatComplex *lu;
mMatComplex *r;
gsl_permutation *p;
int signum;
gsl_complex d;
QLA_D_Complex *z;
if (m->l_size != m->r_size)
return luaL_error(L, "square matrix expected");
p = new_permutation(L, m->l_size);
lu = qlua_newMatComplex(L, m->l_size, m->l_size);
r = qlua_newMatComplex(L, m->l_size, m->l_size);
gsl_matrix_complex_memcpy(lu->m, m->m);
gsl_linalg_complex_LU_decomp(lu->m, p, &signum);
d = gsl_linalg_complex_LU_det(lu->m, signum);
gsl_permutation_free(p);
z = qlua_newComplex(L);
QLA_real(*z) = GSL_REAL(d);
QLA_imag(*z) = GSL_IMAG(d);
return 1;
}
static bool matrix_determinant(CMATRIX *m, COMPLEX_VALUE *det)
{
int sign = 0;
int size = WIDTH(m);
if (size != HEIGHT(m))
return TRUE;
gsl_permutation *p = gsl_permutation_calloc(size);
if (COMPLEX(m))
{
gsl_matrix_complex *tmp = gsl_matrix_complex_alloc(size, size);
gsl_matrix_complex_memcpy(tmp, CMAT(m));
gsl_linalg_complex_LU_decomp(tmp, p, &sign);
det->z = gsl_linalg_complex_LU_det(tmp, sign);
gsl_matrix_complex_free(tmp);
}
else
{
gsl_matrix *tmp = gsl_matrix_alloc(size, size);
gsl_matrix_memcpy(tmp, MAT(m));
gsl_linalg_LU_decomp(tmp, p, &sign);
det->x = gsl_linalg_LU_det(tmp, sign);
det->z.dat[1] = 0;
gsl_matrix_free(tmp);
}
gsl_permutation_free(p);
return FALSE;
}
static VALUE rb_gsl_blas_ztrsm2(VALUE obj, VALUE s, VALUE u, VALUE ta,
VALUE d, VALUE a, VALUE aa, VALUE bb)
{
gsl_matrix_complex *A = NULL, *B = NULL, *Bnew = NULL;
gsl_complex *pa = NULL;
CBLAS_SIDE_t Side;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t TransA;
CBLAS_DIAG_t Diag;
CHECK_FIXNUM(s); CHECK_FIXNUM(u); CHECK_FIXNUM(ta); CHECK_FIXNUM(d);
CHECK_COMPLEX(a);
CHECK_MATRIX_COMPLEX(aa);
CHECK_MATRIX_COMPLEX(bb);
Side = FIX2INT(s);
Uplo = FIX2INT(u);
TransA = FIX2INT(ta);
Diag = FIX2INT(d);
Data_Get_Struct(a, gsl_complex, pa);
Data_Get_Struct(aa, gsl_matrix_complex, A);
Data_Get_Struct(bb, gsl_matrix_complex, B);
Bnew = gsl_matrix_complex_alloc(B->size1, B->size2);
gsl_matrix_complex_memcpy(Bnew, B);
gsl_blas_ztrsm(Side, Uplo, TransA, Diag, *pa, A, Bnew);
return Data_Wrap_Struct(cgsl_matrix_complex, 0, gsl_matrix_complex_free, Bnew);
}
/*
* Calculate the matrix exponent of A and store in eA.
* Algorithm: Truncated Talyor series.
*
* WARNING: Large errors possible and it's slow.
*/
int
gsl_ext_expm_complex(gsl_matrix_complex *A, gsl_matrix_complex *eA)
{
int i;
gsl_complex alpha, beta, z;
gsl_matrix_complex *I, *T;
I = gsl_matrix_complex_alloc(A->size1, A->size2);
T = gsl_matrix_complex_alloc(A->size1, A->size2);
GSL_SET_COMPLEX(&alpha, 1.0, 0.0);
GSL_SET_COMPLEX(&beta, 0.0, 0.0);
gsl_matrix_complex_set_identity(I);
gsl_matrix_complex_set_identity(eA);
for (i = 50; i > 0; i--)
{
GSL_SET_COMPLEX(&z, 1.0 / i, 0.0);
gsl_matrix_complex_scale(eA, z);
gsl_blas_zgemm(CblasNoTrans, CblasNoTrans, alpha, eA, A, beta, T);
gsl_matrix_complex_add(T, I);
gsl_matrix_complex_memcpy(eA, T);
}
return 0;
}
static int
mc_solve(lua_State *L)
{
mMatComplex *m = qlua_checkMatComplex(L, 1);
mVecComplex *v = qlua_checkVecComplex(L, 2);
mMatComplex *lu;
mVecComplex *x;
gsl_permutation *p;
/* XXX assume GSL and QLA_D_Complex use compatible layout */
gsl_vector_complex_view vb = gsl_vector_complex_view_array((void *)&v->val[0], v->size);
gsl_vector_complex_view vx;
int signum;
if (m->l_size != m->r_size)
return luaL_error(L, "square matrix expected");
if (m->l_size != v->size)
return luaL_error(L, "vector dim mismatch matrix size");
p = new_permutation(L, m->l_size);
lu = qlua_newMatComplex(L, m->l_size, m->l_size);
x = qlua_newVecComplex(L, m->l_size);
/* XXX assume GSL and QLA_D_Complex use compatible layout */
vx = gsl_vector_complex_view_array((void *)&x->val[0], x->size);
gsl_matrix_complex_memcpy(lu->m, m->m);
gsl_linalg_complex_LU_decomp(lu->m, p, &signum);
if (gsl_linalg_complex_LU_solve(lu->m, p, &vb.vector, &vx.vector))
luaL_error(L, "matrix:solve() failed");
gsl_permutation_free(p);
return 1;
}
static VALUE rb_gsl_linalg_complex_LU_invert(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix_complex *m = NULL, *mtmp = NULL, *inverse = NULL;
gsl_permutation *p = NULL;
int flagm = 0, signum, itmp;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
CHECK_MATRIX_COMPLEX(argv[0]);
Data_Get_Struct(argv[0], gsl_matrix_complex, m);
if (CLASS_OF(argv[0]) != cgsl_matrix_complex_LU) {
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
flagm = 1;
} else {
mtmp = m;
}
itmp = 1;
break;
default:
Data_Get_Struct(obj, gsl_matrix_complex, m);
if (CLASS_OF(obj) != cgsl_matrix_complex_LU) {
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
flagm = 1;
} else {
mtmp = m;
}
itmp = 0;
}
if (flagm == 1) {
p = gsl_permutation_alloc(m->size1);
gsl_linalg_complex_LU_decomp(mtmp, p, &signum);
} else {
Data_Get_Struct(argv[itmp], gsl_permutation, p);
}
inverse = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_linalg_complex_LU_invert(mtmp, p, inverse);
if (flagm == 1) {
gsl_matrix_complex_free(mtmp);
gsl_permutation_free(p);
}
return Data_Wrap_Struct(cgsl_matrix_complex, 0, gsl_matrix_complex_free, inverse);
}
static CMATRIX *MATRIX_copy(CMATRIX *_object)
{
CMATRIX *copy = MATRIX_create(WIDTH(THIS), HEIGHT(THIS), COMPLEX(THIS), FALSE);
if (COMPLEX(THIS))
gsl_matrix_complex_memcpy(CMAT(copy), CMAT(THIS));
else
gsl_matrix_memcpy(MAT(copy), MAT(THIS));
return copy;
}
void
qdpack_matrix_memcpy(qdpack_matrix_t *dst, qdpack_matrix_t *src)
{
if (src == NULL || dst == NULL)
return;
dst->n = src->n;
dst->m = src->m;
gsl_matrix_complex_memcpy(dst->data, src->data);
}
static VALUE rb_gsl_linalg_complex_LU_lndet(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix_complex *m = NULL, *mtmp = NULL;
gsl_permutation *p = NULL;
double lndet;
int flagm = 0, signum;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
CHECK_MATRIX_COMPLEX(argv[0]);
Data_Get_Struct(argv[0], gsl_matrix_complex, m);
if (CLASS_OF(argv[0]) != cgsl_matrix_complex_LU) {
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
flagm = 1;
} else {
mtmp = m;
}
break;
default:
Data_Get_Struct(obj, gsl_matrix_complex, m);
if (CLASS_OF(obj) != cgsl_matrix_complex_LU) {
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
flagm = 1;
} else {
mtmp = m;
}
}
if (flagm == 1) {
p = gsl_permutation_alloc(m->size1);
gsl_linalg_complex_LU_decomp(mtmp, p, &signum);
}
lndet = gsl_linalg_complex_LU_lndet(mtmp);
if (flagm == 1) {
gsl_matrix_complex_free(mtmp);
gsl_permutation_free(p);
}
return rb_float_new(lndet);
}
static int
do_ccmul(lua_State *L, mMatComplex *a, double b_re, double b_im)
{
mMatComplex *r = qlua_newMatComplex(L, a->l_size, a->r_size);
gsl_complex z;
gsl_matrix_complex_memcpy(r->m, a->m);
GSL_SET_COMPLEX(&z, b_re, b_im);
gsl_matrix_complex_scale(r->m, z);
return 1;
}
void gsl_matrix_complex_change_basis_UCMU(gsl_matrix_complex* U, gsl_matrix_complex* M){
unsigned int numneu = U->size1;
gsl_matrix_complex *U1 = gsl_matrix_complex_alloc(numneu,numneu);
gsl_matrix_complex *U2 = gsl_matrix_complex_alloc(numneu,numneu);
gsl_matrix_complex_memcpy(U1,U);
gsl_matrix_complex_memcpy(U2,U);
gsl_matrix_complex *T1 = gsl_matrix_complex_alloc(numneu,numneu);
// doing : U M U^dagger
gsl_blas_zgemm(CblasNoTrans,CblasNoTrans,
gsl_complex_rect(1.0,0.0),M,
U1,gsl_complex_rect(0.0,0.0),T1);
gsl_blas_zgemm(CblasConjTrans,CblasNoTrans,
gsl_complex_rect(1.0,0.0),U2,
T1,gsl_complex_rect(0.0,0.0),M);
// now H_current is in the interaction basis of the mass basis
gsl_matrix_complex_free(U1);
gsl_matrix_complex_free(U2);
gsl_matrix_complex_free(T1);
}
static int
cm_sub_cm(lua_State *L)
{
mMatComplex *a = qlua_checkMatComplex(L, 1);
mMatComplex *b = qlua_checkMatComplex(L, 2);
int al = a->l_size;
int ar = a->r_size;
mMatComplex *r = qlua_newMatComplex(L, al, ar);
if ((al != b->l_size) || (ar != b->r_size))
return luaL_error(L, "matrix sizes mismatch in m + m");
gsl_matrix_complex_memcpy(r->m, a->m);
gsl_matrix_complex_sub(r->m, b->m);
return 1;
}
bool Matrix_Inverse(gsl_matrix_complex *A, gsl_matrix_complex *B){
int s;
gsl_matrix_complex *T;
gsl_permutation *p;
T=gsl_matrix_complex_alloc(B->size1,B->size2);
gsl_matrix_complex_memcpy(T, B);
p=gsl_permutation_alloc (T->size1);
gsl_linalg_complex_LU_decomp (T, p, &s);
gsl_linalg_complex_LU_invert (T, p,A);
gsl_permutation_free(p);
gsl_matrix_complex_free(T);
return true;
}
VALUE rb_gsl_linalg_complex_LU_decomp2(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix_complex *m = NULL, *mnew = NULL;
gsl_permutation *p = NULL;
int signum, itmp;
size_t size;
VALUE objm, obj2;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
if (argc != 1) rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)",
argc);
CHECK_MATRIX_COMPLEX(argv[0]);
Data_Get_Struct(argv[0], gsl_matrix_complex, m);
itmp = 1;
break;
default:
CHECK_MATRIX_COMPLEX(obj);
Data_Get_Struct(obj, gsl_matrix_complex, m);
itmp = 0;
}
size = m->size1;
mnew = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mnew, m);
objm = Data_Wrap_Struct(cgsl_matrix_complex_LU, 0, gsl_matrix_complex_free, mnew);
switch (argc-itmp) {
case 0:
p = gsl_permutation_alloc(size);
gsl_linalg_complex_LU_decomp(mnew, p, &signum);
obj2 = Data_Wrap_Struct(cgsl_permutation, 0, gsl_permutation_free, p);
return rb_ary_new3(3, objm ,obj2, INT2FIX(signum));
break;
case 1: /* when a permutation object is given */
CHECK_PERMUTATION(argv[itmp]);
Data_Get_Struct(argv[itmp], gsl_permutation, p);
gsl_linalg_complex_LU_decomp(m, p, &signum);
return rb_ary_new3(3, objm , argv[itmp], INT2FIX(signum));
break;
default:
rb_raise(rb_eArgError, "Usage: LU_decomp!() or LU_decomp!(permutation)");
}
}
static void *matrix_invert(void *m, bool complex)
{
int sign = 0;
int size = ((gsl_matrix *)m)->size1;
void *result;
if (size != ((gsl_matrix *)m)->size2)
return NULL;
gsl_permutation *p = gsl_permutation_calloc(size);
if (!complex)
{
gsl_matrix *tmp = gsl_matrix_alloc(size, size);
result = gsl_matrix_alloc(size, size);
gsl_matrix_memcpy(tmp, (gsl_matrix *)m);
gsl_linalg_LU_decomp(tmp, p, &sign);
if (gsl_linalg_LU_invert(tmp, p, (gsl_matrix *)result) != GSL_SUCCESS)
{
gsl_matrix_free(result);
return NULL;
}
gsl_matrix_free(tmp);
}
else
{
gsl_matrix_complex *tmp = gsl_matrix_complex_alloc(size, size);
result = gsl_matrix_complex_alloc(size, size);
gsl_matrix_complex_memcpy(tmp, (gsl_matrix_complex *)m);
gsl_linalg_complex_LU_decomp(tmp, p, &sign);
if (gsl_linalg_complex_LU_invert(tmp, p, (gsl_matrix_complex *)result) != GSL_SUCCESS)
{
gsl_matrix_complex_free(result);
return NULL;
}
gsl_matrix_complex_free(tmp);
}
gsl_permutation_free(p);
return result;
}
static VALUE rb_gsl_blas_zsyrk2(VALUE obj, VALUE u, VALUE t, VALUE a, VALUE aa,
VALUE b, VALUE cc)
{
gsl_matrix_complex *A = NULL, *C = NULL, *Cnew = NULL;
gsl_complex *pa = NULL, *pb = NULL;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t Trans;
CHECK_FIXNUM(u); CHECK_FIXNUM(t);
CHECK_COMPLEX(a); CHECK_COMPLEX(b);
CHECK_MATRIX_COMPLEX(aa); CHECK_MATRIX_COMPLEX(cc);
Uplo = FIX2INT(u);
Trans = FIX2INT(t);
Data_Get_Struct(a, gsl_complex, pa);
Data_Get_Struct(b, gsl_complex, pb);
Data_Get_Struct(aa, gsl_matrix_complex, A);
Data_Get_Struct(cc, gsl_matrix_complex, C);
Cnew = gsl_matrix_complex_alloc(C->size1, C->size2);
gsl_matrix_complex_memcpy(Cnew, C);
gsl_blas_zsyrk(Uplo, Trans, *pa, A, *pb, Cnew);
return Data_Wrap_Struct(cgsl_matrix_complex, 0, gsl_matrix_complex_free, Cnew);
}
static VALUE rb_gsl_blas_zherk2(VALUE obj, VALUE u, VALUE t, VALUE a, VALUE aa,
VALUE b, VALUE cc)
{
gsl_matrix_complex *A = NULL, *C = NULL, *Cnew = NULL;
double alpha, beta;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t Trans;
CHECK_FIXNUM(u); CHECK_FIXNUM(t);
Need_Float(a); Need_Float(b);
CHECK_MATRIX_COMPLEX(aa); CHECK_MATRIX_COMPLEX(cc);
Uplo = FIX2INT(u);
Trans = FIX2INT(t);
alpha = NUM2DBL(a);
beta = NUM2DBL(b);
Data_Get_Struct(aa, gsl_matrix_complex, A);
Data_Get_Struct(cc, gsl_matrix_complex, C);
Cnew = gsl_matrix_complex_alloc(C->size1, C->size2);
gsl_matrix_complex_memcpy(Cnew, C);
gsl_blas_zherk(Uplo, Trans, alpha, A, beta, Cnew);
return Data_Wrap_Struct(cgsl_matrix_complex, 0, gsl_matrix_complex_free, Cnew);
}
static int
mc_inverse(lua_State *L)
{
mMatComplex *m = qlua_checkMatComplex(L, 1);
mMatComplex *lu;
mMatComplex *r;
gsl_permutation *p;
int signum;
if (m->l_size != m->r_size)
return luaL_error(L, "square matrix expected");
p = new_permutation(L, m->l_size);
lu = qlua_newMatComplex(L, m->l_size, m->l_size);
r = qlua_newMatComplex(L, m->l_size, m->l_size);
gsl_matrix_complex_memcpy(lu->m, m->m);
gsl_linalg_complex_LU_decomp(lu->m, p, &signum);
if (gsl_linalg_complex_LU_invert(lu->m, p, r->m))
luaL_error(L, "matrix:inverse() failed");
gsl_permutation_free(p);
return 1;
}
/*
computes the svd of a complex matrix. Missing in gsl.
*/
int
svd(gsl_matrix_complex *A, gsl_matrix_complex *V, gsl_vector *S)
{
int n = A->size1;
gsl_eigen_hermv_workspace *gsl_work = gsl_eigen_hermv_alloc(n);
gsl_matrix_complex *Asq = gsl_matrix_complex_alloc(n, n);
gsl_complex zero = gsl_complex_rect(0., 0.);
gsl_complex one = gsl_complex_rect(1., 0.);
gsl_vector *e = gsl_vector_alloc(n);
gsl_matrix_complex *U = gsl_matrix_complex_alloc(n, n);
gsl_blas_zgemm(CblasNoTrans, CblasConjTrans, one, A, A, zero, Asq);
gsl_eigen_hermv(Asq, e, U, gsl_work);
gsl_eigen_hermv_sort(e, U, GSL_EIGEN_SORT_VAL_DESC);
gsl_blas_zgemm(CblasConjTrans, CblasNoTrans, one, A, A, zero, Asq);
gsl_eigen_hermv(Asq, e, V, gsl_work);
gsl_eigen_hermv_sort(e, V, GSL_EIGEN_SORT_VAL_DESC);
gsl_blas_zgemm(CblasNoTrans, CblasNoTrans, one, A, V, zero, Asq);
gsl_blas_zgemm(CblasConjTrans, CblasNoTrans, one, U, Asq, zero, A);
for(int i=0; i<n; i++){
gsl_complex x = gsl_matrix_complex_get(A, i, i);
double phase = gsl_complex_arg(gsl_complex_mul_real(x, 1./sqrt(e->data[i])));
gsl_vector_complex_view U_col = gsl_matrix_complex_column(U, i);
gsl_vector_complex_scale(&U_col.vector, gsl_complex_polar(1., phase));
gsl_vector_set(S, i, sqrt(gsl_vector_get(e, i)));
}
gsl_matrix_complex_memcpy(A, U);
gsl_vector_free(e);
gsl_matrix_complex_free(U);
gsl_matrix_complex_free(Asq);
gsl_eigen_hermv_free(gsl_work);
return 0;
}
static int
mc_eigen(lua_State *L) /* (-1,+2,e) */
{
mMatComplex *m = qlua_checkMatComplex(L, 1);
gsl_matrix_complex_view mx;
gsl_eigen_hermv_workspace *w;
gsl_vector *ev;
mVecReal *lambda;
mMatComplex *trans;
mMatComplex *tmp;
int n;
int i;
int lo, hi;
switch (lua_gettop(L)) {
case 1:
if (m->l_size != m->r_size)
return luaL_error(L, "matrix:eigen() expects square matrix");
lo = 0;
hi = m->l_size;
break;
case 2:
lo = 0;
hi = luaL_checkint(L, 2);
if ((hi > m->l_size) || (hi > m->r_size))
return slice_out(L);
break;
case 3:
lo = luaL_checkint(L, 2);
hi = luaL_checkint(L, 3);
if ((lo >= hi) ||
(lo > m->l_size) || (lo > m->r_size) ||
(hi > m->l_size) || (hi > m->r_size))
return slice_out(L);
break;
default:
return luaL_error(L, "matrix:eigen(): illegal arguments");
}
n = hi - lo;
mx = gsl_matrix_complex_submatrix(m->m, lo, lo, n, n);
tmp = qlua_newMatComplex(L, n, n);
gsl_matrix_complex_memcpy(tmp->m, &mx.matrix);
lambda = qlua_newVecReal(L, n);
trans = qlua_newMatComplex(L, n, n);
ev = new_gsl_vector(L, n);
w = gsl_eigen_hermv_alloc(n);
if (w == 0) {
lua_gc(L, LUA_GCCOLLECT, 0);
w = gsl_eigen_hermv_alloc(n);
if (w == 0)
luaL_error(L, "not enough memory");
}
if (gsl_eigen_hermv(tmp->m, ev, trans->m, w))
luaL_error(L, "matrix:eigen() failed");
if (gsl_eigen_hermv_sort(ev, trans->m, GSL_EIGEN_SORT_VAL_ASC))
luaL_error(L, "matrix:eigen() eigenvalue ordering failed");
for (i = 0; i < n; i++)
lambda->val[i] = gsl_vector_get(ev, i);
gsl_vector_free(ev);
gsl_eigen_hermv_free(w);
return 2;
}
void
test_eigen_genherm(void)
{
size_t N_max = 20;
size_t n, i;
gsl_rng *r = gsl_rng_alloc(gsl_rng_default);
for (n = 1; n <= N_max; ++n)
{
gsl_matrix_complex * A = gsl_matrix_complex_alloc(n, n);
gsl_matrix_complex * B = gsl_matrix_complex_alloc(n, n);
gsl_matrix_complex * ma = gsl_matrix_complex_alloc(n, n);
gsl_matrix_complex * mb = gsl_matrix_complex_alloc(n, n);
gsl_vector * eval = gsl_vector_alloc(n);
gsl_vector * evalv = gsl_vector_alloc(n);
gsl_vector * x = gsl_vector_alloc(n);
gsl_vector * y = gsl_vector_alloc(n);
gsl_vector_complex * work = gsl_vector_complex_alloc(n);
gsl_matrix_complex * evec = gsl_matrix_complex_alloc(n, n);
gsl_eigen_genherm_workspace * w = gsl_eigen_genherm_alloc(n);
gsl_eigen_genhermv_workspace * wv = gsl_eigen_genhermv_alloc(n);
for (i = 0; i < 5; ++i)
{
create_random_herm_matrix(A, r, -10, 10);
create_random_complex_posdef_matrix(B, r, work);
gsl_matrix_complex_memcpy(ma, A);
gsl_matrix_complex_memcpy(mb, B);
gsl_eigen_genhermv(ma, mb, evalv, evec, wv);
test_eigen_genherm_results(A, B, evalv, evec, i, "random", "unsorted");
gsl_matrix_complex_memcpy(ma, A);
gsl_matrix_complex_memcpy(mb, B);
gsl_eigen_genherm(ma, mb, eval, w);
/* eval and evalv have to be sorted? not sure why */
gsl_vector_memcpy(x, eval);
gsl_vector_memcpy(y, evalv);
gsl_sort_vector(x);
gsl_sort_vector(y);
test_eigenvalues_real(y, x, "genherm, random", "unsorted");
gsl_eigen_genhermv_sort(evalv, evec, GSL_EIGEN_SORT_VAL_ASC);
test_eigen_genherm_results(A, B, evalv, evec, i, "random", "val/asc");
gsl_eigen_genhermv_sort(evalv, evec, GSL_EIGEN_SORT_VAL_DESC);
test_eigen_genherm_results(A, B, evalv, evec, i, "random", "val/desc");
gsl_eigen_genhermv_sort(evalv, evec, GSL_EIGEN_SORT_ABS_ASC);
test_eigen_genherm_results(A, B, evalv, evec, i, "random", "abs/asc");
gsl_eigen_genhermv_sort(evalv, evec, GSL_EIGEN_SORT_ABS_DESC);
test_eigen_genherm_results(A, B, evalv, evec, i, "random", "abs/desc");
}
gsl_matrix_complex_free(A);
gsl_matrix_complex_free(B);
gsl_matrix_complex_free(ma);
gsl_matrix_complex_free(mb);
gsl_vector_free(eval);
gsl_vector_free(evalv);
gsl_vector_free(x);
gsl_vector_free(y);
gsl_vector_complex_free(work);
gsl_matrix_complex_free(evec);
gsl_eigen_genherm_free(w);
gsl_eigen_genhermv_free(wv);
}
gsl_rng_free(r);
} /* test_eigen_genherm() */
static VALUE rb_gsl_linalg_complex_LU_solve(int argc, VALUE *argv, VALUE obj)
{
gsl_matrix_complex *m = NULL, *mtmp = NULL;
gsl_permutation *p = NULL;
gsl_vector_complex *b = NULL, *x = NULL;
int flagm = 0, flagx = 0, itmp, signum;
switch (TYPE(obj)) {
case T_MODULE:
case T_CLASS:
case T_OBJECT:
if (argc < 2 || argc > 4)
rb_raise(rb_eArgError, "Usage: solve(m, b), solve(m, b, x), solve(lu, p, b), solve(lu, p, b, x)");
CHECK_MATRIX(argv[0]);
Data_Get_Struct(argv[0], gsl_matrix_complex, m);
if (CLASS_OF(argv[0]) != cgsl_matrix_complex_LU) {
flagm = 1;
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
} else {
mtmp = m;
}
itmp = 1;
break;
default:
if (argc < 1 || argc > 3)
rb_raise(rb_eArgError, "Usage: LU_solve(b), LU_solve(p, b), LU_solve(b, x), solve(p, b, x)");
Data_Get_Struct(obj, gsl_matrix_complex, m);
if (CLASS_OF(obj) != cgsl_matrix_complex_LU) {
flagm = 1;
mtmp = gsl_matrix_complex_alloc(m->size1, m->size2);
gsl_matrix_complex_memcpy(mtmp, m);
} else {
mtmp = m;
}
itmp = 0;
}
if (flagm == 1) {
if (itmp != argc-1) rb_raise(rb_eArgError, "Usage: m.LU_solve(b)");
Data_Get_Struct(argv[itmp], gsl_vector_complex, b);
x = gsl_vector_complex_alloc(b->size);
p = gsl_permutation_alloc(b->size);
gsl_linalg_complex_LU_decomp(mtmp, p, &signum);
} else {
Data_Get_Struct(argv[itmp], gsl_permutation, p);
itmp++;
Data_Get_Struct(argv[itmp], gsl_vector_complex, b);
itmp++;
if (itmp == argc-1) {
Data_Get_Struct(argv[itmp], gsl_vector_complex, x);
flagx = 1;
} else {
x = gsl_vector_complex_alloc(m->size1);
}
}
gsl_linalg_complex_LU_solve(mtmp, p, b, x);
if (flagm == 1) {
gsl_matrix_complex_free(mtmp);
gsl_permutation_free(p);
}
if (flagx == 0) return Data_Wrap_Struct(cgsl_vector_complex, 0, gsl_vector_complex_free, x);
else return argv[argc-1];
}
bool Matrix_Copy(gsl_matrix_complex *A, gsl_matrix_complex *B){
gsl_matrix_complex_memcpy(A,B);
return true;
}
/** ----------------------------------------------------------------------------
* Sort eigenvectors
*/
int
gsl_ext_eigen_sort(gsl_matrix_complex *evec, gsl_vector_complex *eval, int sort_order)
{
gsl_complex z;
gsl_matrix_complex *evec_copy;
gsl_vector_complex *eval_copy;
int *idx_map, i, j, idx_temp;
double p1, p2;
if ((evec->size1 != evec->size2) || (evec->size1 != eval->size))
{
return -1;
}
evec_copy = gsl_matrix_complex_alloc(evec->size1, evec->size2);
eval_copy = gsl_vector_complex_alloc(eval->size);
idx_map = (int *)malloc(sizeof(int) * eval->size);
gsl_matrix_complex_memcpy(evec_copy, evec);
gsl_vector_complex_memcpy(eval_copy, eval);
// calculate new eigenvalue order
for (i = 0; i < eval->size; i++)
{
idx_map[i] = i;
}
for (i = 0; i < eval->size - 1; i++)
{
for (j = i+1; j < eval->size; j++)
{
idx_temp = -1;
if (sort_order == GSL_EXT_EIGEN_SORT_ABS)
{
p1 = gsl_complex_abs(gsl_vector_complex_get(eval, idx_map[i]));
p2 = gsl_complex_abs(gsl_vector_complex_get(eval, idx_map[j]));
if (p1 > p2)
{
idx_temp = idx_map[i];
}
}
if (sort_order == GSL_EXT_EIGEN_SORT_PHASE)
{
p1 = gsl_complex_arg(gsl_vector_complex_get(eval, idx_map[i]));
p2 = gsl_complex_arg(gsl_vector_complex_get(eval, idx_map[j]));
if (p1 > M_PI) p1 -= 2*M_PI;
if (p1 <= -M_PI) p1 += 2*M_PI;
if (p2 > M_PI) p2 -= 2*M_PI;
if (p2 <= -M_PI) p2 += 2*M_PI;
//if (((p2 < p1) && (p1 - p2 < M_PI)) || )
if (p2 < p1)
{
idx_temp = idx_map[i];
}
}
if (idx_temp != -1)
{
// swap
//idx_temp = idx_map[i];
idx_map[i] = idx_map[j];
idx_map[j] = idx_temp;
}
}
}
// reshuffle the eigenvectors and eigenvalues
for (i = 0; i < eval->size; i++)
{
for (j = 0; j < eval->size; j++)
{
z = gsl_matrix_complex_get(evec_copy, idx_map[i], j);
gsl_matrix_complex_set(evec, i, j, z);
//z = gsl_matrix_complex_get(evec_copy, i, idx_map[j]);
//gsl_matrix_complex_set(evec, i, j, z);
}
z = gsl_vector_complex_get(eval_copy, idx_map[i]);
gsl_vector_complex_set(eval, i, z);
}
gsl_matrix_complex_free(evec_copy);
gsl_vector_complex_free(eval_copy);
free(idx_map);
return 0;
}
