23 #if (AE_COMPILER==AE_MSVC) 24 #pragma warning(disable:4100) 25 #pragma warning(disable:4127) 26 #pragma warning(disable:4702) 27 #pragma warning(disable:4996) 202 alglib_impl::cmatrixrank1(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, const_cast<alglib_impl::ae_vector*>(u.
c_ptr()), iu, const_cast<alglib_impl::ae_vector*>(v.
c_ptr()), iv, &_alglib_env_state);
232 alglib_impl::rmatrixrank1(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, const_cast<alglib_impl::ae_vector*>(u.
c_ptr()), iu, const_cast<alglib_impl::ae_vector*>(v.
c_ptr()), iv, &_alglib_env_state);
280 alglib_impl::cmatrixmv(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, opa, const_cast<alglib_impl::ae_vector*>(x.
c_ptr()), ix, const_cast<alglib_impl::ae_vector*>(y.
c_ptr()), iy, &_alglib_env_state);
325 alglib_impl::rmatrixmv(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, opa, const_cast<alglib_impl::ae_vector*>(x.
c_ptr()), ix, const_cast<alglib_impl::ae_vector*>(y.
c_ptr()), iy, &_alglib_env_state);
338 void cmatrixrighttrsm(
const ae_int_t m,
const ae_int_t n,
const complex_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const complex_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
344 alglib_impl::cmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
355 void smp_cmatrixrighttrsm(
const ae_int_t m,
const ae_int_t n,
const complex_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const complex_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
361 alglib_impl::_pexec_cmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
374 void cmatrixlefttrsm(
const ae_int_t m,
const ae_int_t n,
const complex_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const complex_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
380 alglib_impl::cmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
391 void smp_cmatrixlefttrsm(
const ae_int_t m,
const ae_int_t n,
const complex_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const complex_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
397 alglib_impl::_pexec_cmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
410 void rmatrixrighttrsm(
const ae_int_t m,
const ae_int_t n,
const real_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const real_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
416 alglib_impl::rmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
427 void smp_rmatrixrighttrsm(
const ae_int_t m,
const ae_int_t n,
const real_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const real_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
433 alglib_impl::_pexec_rmatrixrighttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
446 void rmatrixlefttrsm(
const ae_int_t m,
const ae_int_t n,
const real_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const real_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
452 alglib_impl::rmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
463 void smp_rmatrixlefttrsm(
const ae_int_t m,
const ae_int_t n,
const real_2d_array &
a,
const ae_int_t i1,
const ae_int_t j1,
const bool isupper,
const bool isunit,
const ae_int_t optype,
const real_2d_array &
x,
const ae_int_t i2,
const ae_int_t j2)
469 alglib_impl::_pexec_rmatrixlefttrsm(m, n, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), i1, j1, isupper, isunit, optype, const_cast<alglib_impl::ae_matrix*>(x.
c_ptr()), i2, j2, &_alglib_env_state);
482 void cmatrixsyrk(
const ae_int_t n,
const ae_int_t k,
const double alpha,
const complex_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const double beta,
const complex_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc,
const bool isupper)
488 alglib_impl::cmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ic, jc, isupper, &_alglib_env_state);
499 void smp_cmatrixsyrk(
const ae_int_t n,
const ae_int_t k,
const double alpha,
const complex_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const double beta,
const complex_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc,
const bool isupper)
505 alglib_impl::_pexec_cmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ic, jc, isupper, &_alglib_env_state);
518 void rmatrixsyrk(
const ae_int_t n,
const ae_int_t k,
const double alpha,
const real_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const double beta,
const real_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc,
const bool isupper)
524 alglib_impl::rmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ic, jc, isupper, &_alglib_env_state);
535 void smp_rmatrixsyrk(
const ae_int_t n,
const ae_int_t k,
const double alpha,
const real_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const double beta,
const real_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc,
const bool isupper)
541 alglib_impl::_pexec_rmatrixsyrk(n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, optypea, beta, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ic, jc, isupper, &_alglib_env_state);
554 void cmatrixgemm(
const ae_int_t m,
const ae_int_t n,
const ae_int_t k,
const alglib::complex alpha,
const complex_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const complex_2d_array &
b,
const ae_int_t ib,
const ae_int_t jb,
const ae_int_t optypeb,
const alglib::complex beta,
const complex_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc)
560 alglib_impl::cmatrixgemm(m, n, k, *alpha.
c_ptr(),
const_cast<alglib_impl::ae_matrix*
>(a.
c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), ib, jb, optypeb, *beta.
c_ptr(),
const_cast<alglib_impl::ae_matrix*
>(c.
c_ptr()), ic, jc, &_alglib_env_state);
571 void smp_cmatrixgemm(
const ae_int_t m,
const ae_int_t n,
const ae_int_t k,
const alglib::complex alpha,
const complex_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const complex_2d_array &
b,
const ae_int_t ib,
const ae_int_t jb,
const ae_int_t optypeb,
const alglib::complex beta,
const complex_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc)
577 alglib_impl::_pexec_cmatrixgemm(m, n, k, *alpha.
c_ptr(),
const_cast<alglib_impl::ae_matrix*
>(a.
c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), ib, jb, optypeb, *beta.
c_ptr(),
const_cast<alglib_impl::ae_matrix*
>(c.
c_ptr()), ic, jc, &_alglib_env_state);
590 void rmatrixgemm(
const ae_int_t m,
const ae_int_t n,
const ae_int_t k,
const double alpha,
const real_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const real_2d_array &
b,
const ae_int_t ib,
const ae_int_t jb,
const ae_int_t optypeb,
const double beta,
const real_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc)
596 alglib_impl::rmatrixgemm(m, n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), ib, jb, optypeb, beta, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ic, jc, &_alglib_env_state);
607 void smp_rmatrixgemm(
const ae_int_t m,
const ae_int_t n,
const ae_int_t k,
const double alpha,
const real_2d_array &
a,
const ae_int_t ia,
const ae_int_t ja,
const ae_int_t optypea,
const real_2d_array &
b,
const ae_int_t ib,
const ae_int_t jb,
const ae_int_t optypeb,
const double beta,
const real_2d_array &
c,
const ae_int_t ic,
const ae_int_t jc)
613 alglib_impl::_pexec_rmatrixgemm(m, n, k, alpha, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), ia, ja, optypea, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), ib, jb, optypeb, beta, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ic, jc, &_alglib_env_state);
1138 alglib_impl::rmatrixbd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tauq.
c_ptr()), const_cast<alglib_impl::ae_vector*>(taup.
c_ptr()), &_alglib_env_state);
1222 alglib_impl::rmatrixbdmultiplybyq(const_cast<alglib_impl::ae_matrix*>(qp.
c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(tauq.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), zrows, zcolumns, fromtheright, dotranspose, &_alglib_env_state);
1306 alglib_impl::rmatrixbdmultiplybyp(const_cast<alglib_impl::ae_matrix*>(qp.
c_ptr()), m, n, const_cast<alglib_impl::ae_vector*>(taup.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), zrows, zcolumns, fromtheright, dotranspose, &_alglib_env_state);
1543 alglib_impl::smatrixtd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, isupper, const_cast<alglib_impl::ae_vector*>(tau.
c_ptr()), const_cast<alglib_impl::ae_vector*>(d.
c_ptr()), const_cast<alglib_impl::ae_vector*>(e.
c_ptr()), &_alglib_env_state);
1661 alglib_impl::hmatrixtd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, isupper, const_cast<alglib_impl::ae_vector*>(tau.
c_ptr()), const_cast<alglib_impl::ae_vector*>(d.
c_ptr()), const_cast<alglib_impl::ae_vector*>(e.
c_ptr()), &_alglib_env_state);
1783 bool rmatrixbdsvd(
real_1d_array &
d,
const real_1d_array &e,
const ae_int_t n,
const bool isupper,
const bool isfractionalaccuracyrequired,
real_2d_array &
u,
const ae_int_t nru,
real_2d_array &
c,
const ae_int_t ncc,
real_2d_array &vt,
const ae_int_t ncvt)
1789 ae_bool result =
alglib_impl::rmatrixbdsvd(const_cast<alglib_impl::ae_vector*>(d.
c_ptr()), const_cast<alglib_impl::ae_vector*>(e.
c_ptr()), n, isupper, isfractionalaccuracyrequired, const_cast<alglib_impl::ae_matrix*>(u.
c_ptr()), nru, const_cast<alglib_impl::ae_matrix*>(c.
c_ptr()), ncc, const_cast<alglib_impl::ae_matrix*>(vt.
c_ptr()), ncvt, &_alglib_env_state);
1791 return *(
reinterpret_cast<bool*
>(&result));
1857 ae_bool result =
alglib_impl::rmatrixsvd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), m, n, uneeded, vtneeded, additionalmemory, const_cast<alglib_impl::ae_vector*>(w.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(u.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(vt.
c_ptr()), &_alglib_env_state);
1859 return *(
reinterpret_cast<bool*
>(&result));
1906 ae_bool result =
alglib_impl::smatrixevd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, zneeded, isupper, const_cast<alglib_impl::ae_vector*>(d.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
1908 return *(
reinterpret_cast<bool*
>(&result));
1962 ae_bool result =
alglib_impl::smatrixevdr(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, zneeded, isupper, b1, b2, &m, const_cast<alglib_impl::ae_vector*>(w.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
1964 return *(
reinterpret_cast<bool*
>(&result));
2015 ae_bool result =
alglib_impl::smatrixevdi(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, zneeded, isupper, i1, i2, const_cast<alglib_impl::ae_vector*>(w.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
2017 return *(
reinterpret_cast<bool*
>(&result));
2068 ae_bool result =
alglib_impl::hmatrixevd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, zneeded, isupper, const_cast<alglib_impl::ae_vector*>(d.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
2070 return *(
reinterpret_cast<bool*
>(&result));
2129 ae_bool result =
alglib_impl::hmatrixevdr(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, zneeded, isupper, b1, b2, &m, const_cast<alglib_impl::ae_vector*>(w.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
2131 return *(
reinterpret_cast<bool*
>(&result));
2188 ae_bool result =
alglib_impl::hmatrixevdi(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, zneeded, isupper, i1, i2, const_cast<alglib_impl::ae_vector*>(w.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
2190 return *(
reinterpret_cast<bool*
>(&result));
2255 return *(
reinterpret_cast<bool*
>(&result));
2324 return *(
reinterpret_cast<bool*
>(&result));
2393 return *(
reinterpret_cast<bool*
>(&result));
2474 ae_bool result =
alglib_impl::rmatrixevd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, vneeded, const_cast<alglib_impl::ae_vector*>(wr.
c_ptr()), const_cast<alglib_impl::ae_vector*>(wi.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(vl.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(vr.
c_ptr()), &_alglib_env_state);
2476 return *(
reinterpret_cast<bool*
>(&result));
3042 return *(
reinterpret_cast<bool*
>(&result));
3087 return *(
reinterpret_cast<bool*
>(&result));
3120 return *(
reinterpret_cast<double*
>(&result));
3153 return *(
reinterpret_cast<double*
>(&result));
3196 return *(
reinterpret_cast<double*
>(&result));
3231 return *(
reinterpret_cast<double*
>(&result));
3266 return *(
reinterpret_cast<double*
>(&result));
3309 return *(
reinterpret_cast<double*
>(&result));
3342 return *(
reinterpret_cast<double*
>(&result));
3375 return *(
reinterpret_cast<double*
>(&result));
3409 return *(
reinterpret_cast<double*
>(&result));
3444 return *(
reinterpret_cast<double*
>(&result));
3483 return *(
reinterpret_cast<double*
>(&result));
3522 return *(
reinterpret_cast<double*
>(&result));
3556 return *(
reinterpret_cast<double*
>(&result));
3591 return *(
reinterpret_cast<double*
>(&result));
3626 return *(
reinterpret_cast<double*
>(&result));
3661 return *(
reinterpret_cast<double*
>(&result));
3674 _matinvreport_owner::_matinvreport_owner()
3677 if( p_struct==NULL )
3678 throw ap_error(
"ALGLIB: malloc error");
3680 throw ap_error(
"ALGLIB: malloc error");
3686 if( p_struct==NULL )
3687 throw ap_error(
"ALGLIB: malloc error");
3689 throw ap_error(
"ALGLIB: malloc error");
3698 throw ap_error(
"ALGLIB: malloc error");
3702 _matinvreport_owner::~_matinvreport_owner()
3826 throw ap_error(
"Error while calling 'rmatrixluinverse': looks like one of arguments has wrong size");
3909 throw ap_error(
"Error while calling 'rmatrixinverse': looks like one of arguments has wrong size");
3992 throw ap_error(
"Error while calling 'cmatrixluinverse': looks like one of arguments has wrong size");
4067 throw ap_error(
"Error while calling 'cmatrixinverse': looks like one of arguments has wrong size");
4167 throw ap_error(
"Error while calling 'spdmatrixcholeskyinverse': looks like one of arguments has wrong size");
4274 throw ap_error(
"Error while calling 'spdmatrixinverse': looks like one of arguments has wrong size");
4276 throw ap_error(
"'a' parameter is not symmetric matrix");
4284 throw ap_error(
"Internal error while forcing symmetricity of 'a' parameter");
4378 throw ap_error(
"Error while calling 'hpdmatrixcholeskyinverse': looks like one of arguments has wrong size");
4485 throw ap_error(
"Error while calling 'hpdmatrixinverse': looks like one of arguments has wrong size");
4487 throw ap_error(
"'a' parameter is not Hermitian matrix");
4495 throw ap_error(
"Internal error while forcing Hermitian properties of 'a' parameter");
4603 throw ap_error(
"Error while calling 'rmatrixtrinverse': looks like one of arguments has wrong size");
4718 throw ap_error(
"Error while calling 'cmatrixtrinverse': looks like one of arguments has wrong size");
4745 throw ap_error(
"ALGLIB: malloc error");
4747 throw ap_error(
"ALGLIB: malloc error");
4754 throw ap_error(
"ALGLIB: malloc error");
4756 throw ap_error(
"ALGLIB: malloc error");
4765 throw ap_error(
"ALGLIB: malloc error");
5209 return *(
reinterpret_cast<double*
>(&result));
5244 return *(
reinterpret_cast<double*
>(&result));
5316 alglib_impl::sparsemv(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), const_cast<alglib_impl::ae_vector*>(x.
c_ptr()), const_cast<alglib_impl::ae_vector*>(y.
c_ptr()), &_alglib_env_state);
5356 alglib_impl::sparsemtv(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), const_cast<alglib_impl::ae_vector*>(x.
c_ptr()), const_cast<alglib_impl::ae_vector*>(y.
c_ptr()), &_alglib_env_state);
5402 alglib_impl::sparsemv2(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), const_cast<alglib_impl::ae_vector*>(x.
c_ptr()), const_cast<alglib_impl::ae_vector*>(y0.
c_ptr()), const_cast<alglib_impl::ae_vector*>(y1.
c_ptr()), &_alglib_env_state);
5449 alglib_impl::sparsesmv(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), isupper, const_cast<alglib_impl::ae_vector*>(x.
c_ptr()), const_cast<alglib_impl::ae_vector*>(y.
c_ptr()), &_alglib_env_state);
5490 alglib_impl::sparsemm(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), &_alglib_env_state);
5531 alglib_impl::sparsemtm(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), &_alglib_env_state);
5578 alglib_impl::sparsemm2(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b0.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(b1.
c_ptr()), &_alglib_env_state);
5626 alglib_impl::sparsesmm(const_cast<alglib_impl::sparsematrix*>(s.
c_ptr()), isupper, const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), k, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), &_alglib_env_state);
5704 return *(
reinterpret_cast<bool*
>(&result));
5745 return *(
reinterpret_cast<bool*
>(&result));
5909 return *(
reinterpret_cast<ae_int_t*
>(&result));
5939 return *(
reinterpret_cast<bool*
>(&result));
5969 return *(
reinterpret_cast<bool*
>(&result));
6019 return *(
reinterpret_cast<ae_int_t*
>(&result));
6043 return *(
reinterpret_cast<ae_int_t*
>(&result));
6062 throw ap_error(
"ALGLIB: malloc error");
6064 throw ap_error(
"ALGLIB: malloc error");
6071 throw ap_error(
"ALGLIB: malloc error");
6073 throw ap_error(
"ALGLIB: malloc error");
6082 throw ap_error(
"ALGLIB: malloc error");
6288 return *(
reinterpret_cast<double*
>(&result));
6321 throw ap_error(
"Error while calling 'rmatrixludet': looks like one of arguments has wrong size");
6329 return *(
reinterpret_cast<double*
>(&result));
6361 return *(
reinterpret_cast<double*
>(&result));
6390 throw ap_error(
"Error while calling 'rmatrixdet': looks like one of arguments has wrong size");
6398 return *(
reinterpret_cast<double*
>(&result));
6467 throw ap_error(
"Error while calling 'cmatrixludet': looks like one of arguments has wrong size");
6536 throw ap_error(
"Error while calling 'cmatrixdet': looks like one of arguments has wrong size");
6582 return *(
reinterpret_cast<double*
>(&result));
6617 throw ap_error(
"Error while calling 'spdmatrixcholeskydet': looks like one of arguments has wrong size");
6625 return *(
reinterpret_cast<double*
>(&result));
6668 return *(
reinterpret_cast<double*
>(&result));
6709 throw ap_error(
"Error while calling 'spdmatrixdet': looks like one of arguments has wrong size");
6711 throw ap_error(
"'a' parameter is not symmetric matrix");
6720 return *(
reinterpret_cast<double*
>(&result));
6784 ae_bool result =
alglib_impl::smatrixgevd(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, isuppera, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), isupperb, zneeded, problemtype, const_cast<alglib_impl::ae_vector*>(d.
c_ptr()), const_cast<alglib_impl::ae_matrix*>(z.
c_ptr()), &_alglib_env_state);
6786 return *(
reinterpret_cast<bool*
>(&result));
6852 ae_bool result =
alglib_impl::smatrixgevdreduce(const_cast<alglib_impl::ae_matrix*>(a.
c_ptr()), n, isuppera, const_cast<alglib_impl::ae_matrix*>(b.
c_ptr()), isupperb, problemtype, const_cast<alglib_impl::ae_matrix*>(r.
c_ptr()), &isupperr, &_alglib_env_state);
6854 return *(
reinterpret_cast<bool*
>(&result));
7058 return *(
reinterpret_cast<bool*
>(&result));
7074 static ae_int_t ablas_rgemmparallelsize = 64;
7075 static ae_int_t ablas_cgemmparallelsize = 64;
7076 static void ablas_ablasinternalsplitlength(
ae_int_t n,
7081 static void ablas_cmatrixrighttrsm2(
ae_int_t m,
7093 static void ablas_cmatrixlefttrsm2(
ae_int_t m,
7105 static void ablas_rmatrixrighttrsm2(
ae_int_t m,
7117 static void ablas_rmatrixlefttrsm2(
ae_int_t m,
7129 static void ablas_cmatrixsyrk2(
ae_int_t n,
7142 static void ablas_rmatrixsyrk2(
ae_int_t n,
7157 static void ortfac_cmatrixqrbasecase(
ae_matrix* a,
7164 static void ortfac_cmatrixlqbasecase(
ae_matrix* a,
7171 static void ortfac_rmatrixblockreflector(
ae_matrix* a,
7179 static void ortfac_cmatrixblockreflector(
ae_matrix* a,
7193 ae_bool isfractionalaccuracyrequired,
7204 static double bdsvd_extsignbdsqr(
double a,
double b,
ae_state *_state);
7205 static void bdsvd_svd2x2(
double f,
7211 static void bdsvd_svdv2x2(
double f,
7231 static void evd_tdevde2(
double a,
7237 static void evd_tdevdev2(
double a,
7245 static double evd_tdevdpythag(
double a,
double b,
ae_state *_state);
7246 static double evd_tdevdextsign(
double a,
double b,
ae_state *_state);
7264 static void evd_internaldstein(
ae_int_t n,
7275 static void evd_tdininternaldlagtf(
ae_int_t n,
7285 static void evd_tdininternaldlagts(
ae_int_t n,
7295 static void evd_internaldlaebz(
ae_int_t ijob,
7315 static void evd_internaltrevc(
ae_matrix* t,
7325 static void evd_internalhsevdlaln2(
ae_bool ltrans,
7346 static void evd_internalhsevdladiv(
double a,
7361 static void evd_toupperhessenberg(
ae_matrix* a,
7365 static void evd_unpackqfromupperhessenberg(
ae_matrix* a,
7374 static void trfac_cmatrixluprec(
ae_matrix* a,
7381 static void trfac_rmatrixluprec(
ae_matrix* a,
7388 static void trfac_cmatrixplurec(
ae_matrix* a,
7395 static void trfac_rmatrixplurec(
ae_matrix* a,
7402 static void trfac_cmatrixlup2(
ae_matrix* a,
7409 static void trfac_rmatrixlup2(
ae_matrix* a,
7416 static void trfac_cmatrixplu2(
ae_matrix* a,
7423 static void trfac_rmatrixplu2(
ae_matrix* a,
7450 static void rcond_rmatrixrcondtrinternal(
ae_matrix* a,
7458 static void rcond_cmatrixrcondtrinternal(
ae_matrix* a,
7466 static void rcond_spdmatrixrcondcholeskyinternal(
ae_matrix* cha,
7473 static void rcond_hpdmatrixrcondcholeskyinternal(
ae_matrix* cha,
7480 static void rcond_rmatrixrcondluinternal(
ae_matrix* lua,
7487 static void rcond_cmatrixrcondluinternal(
ae_matrix* lua,
7494 static void rcond_rmatrixestimatenorm(
ae_int_t n,
7501 static void rcond_cmatrixestimatenorm(
ae_int_t n,
7509 static double rcond_internalcomplexrcondscsum1(
ae_vector* x,
7515 static void rcond_internalcomplexrcondsaveall(
ae_vector* isave,
7527 static void rcond_internalcomplexrcondloadall(
ae_vector* isave,
7541 static void matinv_rmatrixtrinverserec(
ae_matrix* a,
7550 static void matinv_cmatrixtrinverserec(
ae_matrix* a,
7559 static void matinv_rmatrixluinverserec(
ae_matrix* a,
7566 static void matinv_cmatrixluinverserec(
ae_matrix* a,
7573 static void matinv_spdmatrixcholeskyinverserec(
ae_matrix* a,
7579 static void matinv_hpdmatrixcholeskyinverserec(
ae_matrix* a,
7587 static double sparse_desiredloadfactor = 0.66;
7588 static double sparse_maxloadfactor = 0.75;
7589 static double sparse_growfactor = 2.00;
7590 static ae_int_t sparse_additional = 10;
7591 static ae_int_t sparse_linalgswitch = 16;
7645 ablas_ablasinternalsplitlength(n,
ablasblocksize(a, _state), n1, n2, _state);
7774 for(i=0; i<=m-1; i++)
7835 for(i=0; i<=m-1; i++)
7883 for(i=0; i<=n-1; i++)
7885 for(j=i+1; j<=n-1; j++)
7893 for(i=0; i<=n-1; i++)
7895 for(j=i+1; j<=n-1; j++)
7934 for(i=0; i<=m-1; i++)
7971 for(i=0; i<=m-1; i++)
8015 for(i=0; i<=m-1; i++)
8060 for(i=0; i<=m-1; i++)
8122 for(i=0; i<=m-1; i++)
8128 if(
cmatrixmvf(m, n, a, ia, ja, opa, x, ix, y, iy, _state) )
8138 for(i=0; i<=m-1; i++)
8151 for(i=0; i<=m-1; i++)
8155 for(i=0; i<=n-1; i++)
8168 for(i=0; i<=m-1; i++)
8172 for(i=0; i<=n-1; i++)
8233 for(i=0; i<=m-1; i++)
8239 if(
rmatrixmvf(m, n, a, ia, ja, opa, x, ix, y, iy, _state) )
8249 for(i=0; i<=m-1; i++)
8262 for(i=0; i<=m-1; i++)
8266 for(i=0; i<=n-1; i++)
8297 ablas_cmatrixrighttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8307 cmatrixrighttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8308 cmatrixrighttrsm(s2, n, a, i1, j1, isupper, isunit, optype, x, i2+s1, j2, _state);
8324 if( isupper&&optype==0 )
8332 cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8333 cmatrixgemm(m, s2, s1,
ae_complex_from_d(-1.0), x, i2, j2, 0, a, i1, j1+s1, 0,
ae_complex_from_d(1.0), x, i2, j2+s1, _state);
8334 cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8337 if( isupper&&optype!=0 )
8345 cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8346 cmatrixgemm(m, s1, s2,
ae_complex_from_d(-1.0), x, i2, j2+s1, 0, a, i1, j1+s1, optype,
ae_complex_from_d(1.0), x, i2, j2, _state);
8347 cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8350 if( !isupper&&optype==0 )
8358 cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8359 cmatrixgemm(m, s1, s2,
ae_complex_from_d(-1.0), x, i2, j2+s1, 0, a, i1+s1, j1, 0,
ae_complex_from_d(1.0), x, i2, j2, _state);
8360 cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8363 if( !isupper&&optype!=0 )
8371 cmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8372 cmatrixgemm(m, s2, s1,
ae_complex_from_d(-1.0), x, i2, j2, 0, a, i1+s1, j1, optype,
ae_complex_from_d(1.0), x, i2, j2+s1, _state);
8373 cmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8395 cmatrixrighttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8420 ablas_cmatrixlefttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8430 cmatrixlefttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8431 cmatrixlefttrsm(m, s2, a, i1, j1, isupper, isunit, optype, x, i2, j2+s1, _state);
8441 if( isupper&&optype==0 )
8449 cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8450 cmatrixgemm(s1, n, s2,
ae_complex_from_d(-1.0), a, i1, j1+s1, 0, x, i2+s1, j2, 0,
ae_complex_from_d(1.0), x, i2, j2, _state);
8451 cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8454 if( isupper&&optype!=0 )
8462 cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8463 cmatrixgemm(s2, n, s1,
ae_complex_from_d(-1.0), a, i1, j1+s1, optype, x, i2, j2, 0,
ae_complex_from_d(1.0), x, i2+s1, j2, _state);
8464 cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8467 if( !isupper&&optype==0 )
8475 cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8476 cmatrixgemm(s2, n, s1,
ae_complex_from_d(-1.0), a, i1+s1, j1, 0, x, i2, j2, 0,
ae_complex_from_d(1.0), x, i2+s1, j2, _state);
8477 cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8480 if( !isupper&&optype!=0 )
8488 cmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8489 cmatrixgemm(s1, n, s2,
ae_complex_from_d(-1.0), a, i1+s1, j1, optype, x, i2+s1, j2, 0,
ae_complex_from_d(1.0), x, i2, j2, _state);
8490 cmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8512 cmatrixlefttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8537 ablas_rmatrixrighttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8547 rmatrixrighttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8548 rmatrixrighttrsm(s2, n, a, i1, j1, isupper, isunit, optype, x, i2+s1, j2, _state);
8564 if( isupper&&optype==0 )
8572 rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8573 rmatrixgemm(m, s2, s1, -1.0, x, i2, j2, 0, a, i1, j1+s1, 0, 1.0, x, i2, j2+s1, _state);
8574 rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8577 if( isupper&&optype!=0 )
8585 rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8586 rmatrixgemm(m, s1, s2, -1.0, x, i2, j2+s1, 0, a, i1, j1+s1, optype, 1.0, x, i2, j2, _state);
8587 rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8590 if( !isupper&&optype==0 )
8598 rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8599 rmatrixgemm(m, s1, s2, -1.0, x, i2, j2+s1, 0, a, i1+s1, j1, 0, 1.0, x, i2, j2, _state);
8600 rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8603 if( !isupper&&optype!=0 )
8611 rmatrixrighttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8612 rmatrixgemm(m, s2, s1, -1.0, x, i2, j2, 0, a, i1+s1, j1, optype, 1.0, x, i2, j2+s1, _state);
8613 rmatrixrighttrsm(m, s2, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2, j2+s1, _state);
8635 rmatrixrighttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8660 ablas_rmatrixlefttrsm2(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8670 rmatrixlefttrsm(m, s1, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8671 rmatrixlefttrsm(m, s2, a, i1, j1, isupper, isunit, optype, x, i2, j2+s1, _state);
8680 if( isupper&&optype==0 )
8688 rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8689 rmatrixgemm(s1, n, s2, -1.0, a, i1, j1+s1, 0, x, i2+s1, j2, 0, 1.0, x, i2, j2, _state);
8690 rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8693 if( isupper&&optype!=0 )
8701 rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8702 rmatrixgemm(s2, n, s1, -1.0, a, i1, j1+s1, optype, x, i2, j2, 0, 1.0, x, i2+s1, j2, _state);
8703 rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8706 if( !isupper&&optype==0 )
8714 rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8715 rmatrixgemm(s2, n, s1, -1.0, a, i1+s1, j1, 0, x, i2, j2, 0, 1.0, x, i2+s1, j2, _state);
8716 rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8719 if( !isupper&&optype!=0 )
8727 rmatrixlefttrsm(s2, n, a, i1+s1, j1+s1, isupper, isunit, optype, x, i2+s1, j2, _state);
8728 rmatrixgemm(s1, n, s2, -1.0, a, i1+s1, j1, optype, x, i2+s1, j2, 0, 1.0, x, i2, j2, _state);
8729 rmatrixlefttrsm(s1, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state);
8751 rmatrixlefttrsm(m,n,a,i1,j1,isupper,isunit,optype,x,i2,j2, _state);
8777 ablas_cmatrixsyrk2(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8789 cmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8790 cmatrixsyrk(n, s2, alpha, a, ia, ja+s1, optypea, 1.0, c, ic, jc, isupper, _state);
8794 cmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8795 cmatrixsyrk(n, s2, alpha, a, ia+s1, ja, optypea, 1.0, c, ic, jc, isupper, _state);
8805 if( optypea==0&&isupper )
8807 cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8808 cmatrixgemm(s1, s2, k,
ae_complex_from_d(alpha), a, ia, ja, 0, a, ia+s1, ja, 2,
ae_complex_from_d(beta), c, ic, jc+s1, _state);
8809 cmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8812 if( optypea==0&&!isupper )
8814 cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8815 cmatrixgemm(s2, s1, k,
ae_complex_from_d(alpha), a, ia+s1, ja, 0, a, ia, ja, 2,
ae_complex_from_d(beta), c, ic+s1, jc, _state);
8816 cmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8819 if( optypea!=0&&isupper )
8821 cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8822 cmatrixgemm(s1, s2, k,
ae_complex_from_d(alpha), a, ia, ja, 2, a, ia, ja+s1, 0,
ae_complex_from_d(beta), c, ic, jc+s1, _state);
8823 cmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8826 if( optypea!=0&&!isupper )
8828 cmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8829 cmatrixgemm(s2, s1, k,
ae_complex_from_d(alpha), a, ia, ja+s1, 2, a, ia, ja, 0,
ae_complex_from_d(beta), c, ic+s1, jc, _state);
8830 cmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8853 cmatrixsyrk(n,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isupper, _state);
8881 if(
rmatrixsyrkmkl(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state) )
8887 ablas_rmatrixsyrk2(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8903 rmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8904 rmatrixsyrk(n, s2, alpha, a, ia, ja+s1, optypea, 1.0, c, ic, jc, isupper, _state);
8908 rmatrixsyrk(n, s1, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8909 rmatrixsyrk(n, s2, alpha, a, ia+s1, ja, optypea, 1.0, c, ic, jc, isupper, _state);
8919 if( optypea==0&&isupper )
8921 rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8922 rmatrixgemm(s1, s2, k, alpha, a, ia, ja, 0, a, ia+s1, ja, 1, beta, c, ic, jc+s1, _state);
8923 rmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8926 if( optypea==0&&!isupper )
8928 rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8929 rmatrixgemm(s2, s1, k, alpha, a, ia+s1, ja, 0, a, ia, ja, 1, beta, c, ic+s1, jc, _state);
8930 rmatrixsyrk(s2, k, alpha, a, ia+s1, ja, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8933 if( optypea!=0&&isupper )
8935 rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8936 rmatrixgemm(s1, s2, k, alpha, a, ia, ja, 1, a, ia, ja+s1, 0, beta, c, ic, jc+s1, _state);
8937 rmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8940 if( optypea!=0&&!isupper )
8942 rmatrixsyrk(s1, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state);
8943 rmatrixgemm(s2, s1, k, alpha, a, ia, ja+s1, 1, a, ia, ja, 0, beta, c, ic+s1, jc, _state);
8944 rmatrixsyrk(s2, k, alpha, a, ia, ja+s1, optypea, beta, c, ic+s1, jc+s1, isupper, _state);
8967 rmatrixsyrk(n,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isupper, _state);
8995 if( (m<=bs&&n<=bs)&&k<=bs )
8997 cmatrixgemmk(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9017 cmatrixgemm(s1, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9020 cmatrixgemm(s2, n, k, alpha, a, ia+s1, ja, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9024 cmatrixgemm(s2, n, k, alpha, a, ia, ja+s1, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9037 cmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9038 cmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib, jb+s1, optypeb, beta, c, ic, jc+s1, _state);
9042 cmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9043 cmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib+s1, jb, optypeb, beta, c, ic, jc+s1, _state);
9056 if( optypea==0&&optypeb==0 )
9058 cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9059 cmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib+s1, jb, optypeb,
ae_complex_from_d(1.0), c, ic, jc, _state);
9061 if( optypea==0&&optypeb!=0 )
9063 cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9064 cmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib, jb+s1, optypeb,
ae_complex_from_d(1.0), c, ic, jc, _state);
9066 if( optypea!=0&&optypeb==0 )
9068 cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9069 cmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib+s1, jb, optypeb,
ae_complex_from_d(1.0), c, ic, jc, _state);
9071 if( optypea!=0&&optypeb!=0 )
9073 cmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9074 cmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib, jb+s1, optypeb,
ae_complex_from_d(1.0), c, ic, jc, _state);
9100 cmatrixgemm(m,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc, _state);
9132 ae_assert(optypea==0||optypea==1,
"RMatrixGEMM: incorrect OpTypeA (must be 0 or 1)", _state);
9133 ae_assert(optypeb==0||optypeb==1,
"RMatrixGEMM: incorrect OpTypeB (must be 0 or 1)", _state);
9134 ae_assert(ic+m<=c->rows,
"RMatrixGEMM: incorect size of output matrix C", _state);
9135 ae_assert(jc+n<=c->cols,
"RMatrixGEMM: incorect size of output matrix C", _state);
9140 if(
rmatrixgemmmkl(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state) )
9144 if( (m<=bs&&n<=bs)&&k<=bs )
9146 rmatrixgemmk(m, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9168 rmatrixgemm(s1, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9169 rmatrixgemm(s2, n, k, alpha, a, ia+s1, ja, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9173 rmatrixgemm(s1, n, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9174 rmatrixgemm(s2, n, k, alpha, a, ia, ja+s1, optypea, b, ib, jb, optypeb, beta, c, ic+s1, jc, _state);
9187 rmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9188 rmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib, jb+s1, optypeb, beta, c, ic, jc+s1, _state);
9192 rmatrixgemm(m, s1, k, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9193 rmatrixgemm(m, s2, k, alpha, a, ia, ja, optypea, b, ib+s1, jb, optypeb, beta, c, ic, jc+s1, _state);
9206 if( optypea==0&&optypeb==0 )
9208 rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9209 rmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib+s1, jb, optypeb, 1.0, c, ic, jc, _state);
9211 if( optypea==0&&optypeb!=0 )
9213 rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9214 rmatrixgemm(m, n, s2, alpha, a, ia, ja+s1, optypea, b, ib, jb+s1, optypeb, 1.0, c, ic, jc, _state);
9216 if( optypea!=0&&optypeb==0 )
9218 rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9219 rmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib+s1, jb, optypeb, 1.0, c, ic, jc, _state);
9221 if( optypea!=0&&optypeb!=0 )
9223 rmatrixgemm(m, n, s1, alpha, a, ia, ja, optypea, b, ib, jb, optypeb, beta, c, ic, jc, _state);
9224 rmatrixgemm(m, n, s2, alpha, a, ia+s1, ja, optypea, b, ib, jb+s1, optypeb, 1.0, c, ic, jc, _state);
9250 rmatrixgemm(m,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc, _state);
9261 static void ablas_ablasinternalsplitlength(
ae_int_t n,
9319 static void ablas_cmatrixrighttrsm2(
ae_int_t m,
9350 if(
cmatrixrighttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9370 for(i=0; i<=m-1; i++)
9372 for(j=0; j<=n-1; j++)
9398 for(i=0; i<=m-1; i++)
9400 for(j=n-1; j>=0; j--)
9423 for(i=0; i<=m-1; i++)
9425 for(j=n-1; j>=0; j--)
9455 for(i=0; i<=m-1; i++)
9457 for(j=n-1; j>=0; j--)
9483 for(i=0; i<=m-1; i++)
9485 for(j=0; j<=n-1; j++)
9508 for(i=0; i<=m-1; i++)
9510 for(j=0; j<=n-1; j++)
9534 static void ablas_cmatrixlefttrsm2(
ae_int_t m,
9565 if(
cmatrixlefttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9585 for(i=m-1; i>=0; i--)
9587 for(j=i+1; j<=m-1; j++)
9606 for(i=0; i<=m-1; i++)
9617 for(j=i+1; j<=m-1; j++)
9631 for(i=0; i<=m-1; i++)
9642 for(j=i+1; j<=m-1; j++)
9663 for(i=0; i<=m-1; i++)
9665 for(j=0; j<=i-1; j++)
9688 for(i=m-1; i>=0; i--)
9699 for(j=i-1; j>=0; j--)
9713 for(i=m-1; i>=0; i--)
9724 for(j=i-1; j>=0; j--)
9743 static void ablas_rmatrixrighttrsm2(
ae_int_t m,
9774 if(
rmatrixrighttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9794 for(i=0; i<=m-1; i++)
9796 for(j=0; j<=n-1; j++)
9822 for(i=0; i<=m-1; i++)
9824 for(j=n-1; j>=0; j--)
9854 for(i=0; i<=m-1; i++)
9856 for(j=n-1; j>=0; j--)
9882 for(i=0; i<=m-1; i++)
9884 for(j=0; j<=n-1; j++)
9908 static void ablas_rmatrixlefttrsm2(
ae_int_t m,
9939 if(
rmatrixlefttrsmf(m, n, a, i1, j1, isupper, isunit, optype, x, i2, j2, _state) )
9959 for(i=m-1; i>=0; i--)
9961 for(j=i+1; j<=m-1; j++)
9980 for(i=0; i<=m-1; i++)
9991 for(j=i+1; j<=m-1; j++)
10012 for(i=0; i<=m-1; i++)
10014 for(j=0; j<=i-1; j++)
10037 for(i=m-1; i>=0; i--)
10048 for(j=i-1; j>=0; j--)
10063 static void ablas_cmatrixsyrk2(
ae_int_t n,
10096 if(
cmatrixsyrkf(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state) )
10110 for(i=0; i<=n-1; i++)
10122 for(j=j1; j<=j2; j++)
10150 for(i=0; i<=n-1; i++)
10164 for(j=j1; j<=j2; j++)
10174 for(i=0; i<=k-1; i++)
10176 for(j=0; j<=n-1; j++)
10200 static void ablas_rmatrixsyrk2(
ae_int_t n,
10233 if(
rmatrixsyrkf(n, k, alpha, a, ia, ja, optypea, beta, c, ic, jc, isupper, _state) )
10247 for(i=0; i<=n-1; i++)
10259 for(j=j1; j<=j2; j++)
10287 for(i=0; i<=n-1; i++)
10301 for(j=j1; j<=j2; j++)
10311 for(i=0; i<=k-1; i++)
10313 for(j=0; j<=n-1; j++)
10417 while(blockstart!=minmn)
10423 blocksize = minmn-blockstart;
10428 rowscount = m-blockstart;
10436 rmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10438 rmatrixcopy(rowscount, blocksize, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10448 if( blockstart+blocksize<=n-1 )
10456 ortfac_rmatrixblockreflector(&tmpa, &taubuf,
ae_true, rowscount, blocksize, &tmpt, &work, _state);
10464 rmatrixgemm(blocksize, n-blockstart-blocksize, rowscount, 1.0, &tmpa, 0, 0, 1, a, blockstart, blockstart+blocksize, 0, 0.0, &tmpr, 0, 0, _state);
10465 rmatrixgemm(blocksize, n-blockstart-blocksize, blocksize, 1.0, &tmpt, 0, 0, 1, &tmpr, 0, 0, 0, 0.0, &tmpr, blocksize, 0, _state);
10466 rmatrixgemm(rowscount, n-blockstart-blocksize, blocksize, 1.0, &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, 1.0, a, blockstart, blockstart+blocksize, _state);
10474 for(i=0; i<=blocksize-1; i++)
10486 blockstart = blockstart+blocksize;
10573 while(blockstart!=minmn)
10579 blocksize = minmn-blockstart;
10584 columnscount = n-blockstart;
10592 rmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10594 rmatrixcopy(blocksize, columnscount, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10604 if( blockstart+blocksize<=m-1 )
10612 ortfac_rmatrixblockreflector(&tmpa, &taubuf,
ae_false, columnscount, blocksize, &tmpt, &work, _state);
10619 rmatrixgemm(m-blockstart-blocksize, blocksize, columnscount, 1.0, a, blockstart+blocksize, blockstart, 0, &tmpa, 0, 0, 1, 0.0, &tmpr, 0, 0, _state);
10620 rmatrixgemm(m-blockstart-blocksize, blocksize, blocksize, 1.0, &tmpr, 0, 0, 0, &tmpt, 0, 0, 0, 0.0, &tmpr, 0, blocksize, _state);
10621 rmatrixgemm(m-blockstart-blocksize, columnscount, blocksize, 1.0, &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, 1.0, a, blockstart+blocksize, blockstart, _state);
10629 for(i=0; i<=blocksize-1; i++)
10641 blockstart = blockstart+blocksize;
10714 while(blockstart!=minmn)
10720 blocksize = minmn-blockstart;
10725 rowscount = m-blockstart;
10733 cmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10734 ortfac_cmatrixqrbasecase(&tmpa, rowscount, blocksize, &work, &t, &taubuf, _state);
10735 cmatrixcopy(rowscount, blocksize, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10745 if( blockstart+blocksize<=n-1 )
10753 ortfac_cmatrixblockreflector(&tmpa, &taubuf,
ae_true, rowscount, blocksize, &tmpt, &work, _state);
10761 cmatrixgemm(blocksize, n-blockstart-blocksize, rowscount,
ae_complex_from_d(1.0), &tmpa, 0, 0, 2, a, blockstart, blockstart+blocksize, 0,
ae_complex_from_d(0.0), &tmpr, 0, 0, _state);
10762 cmatrixgemm(blocksize, n-blockstart-blocksize, blocksize,
ae_complex_from_d(1.0), &tmpt, 0, 0, 2, &tmpr, 0, 0, 0,
ae_complex_from_d(0.0), &tmpr, blocksize, 0, _state);
10763 cmatrixgemm(rowscount, n-blockstart-blocksize, blocksize,
ae_complex_from_d(1.0), &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0,
ae_complex_from_d(1.0), a, blockstart, blockstart+blocksize, _state);
10771 for(i=0; i<=blocksize-1; i++)
10783 blockstart = blockstart+blocksize;
10856 while(blockstart!=minmn)
10862 blocksize = minmn-blockstart;
10867 columnscount = n-blockstart;
10875 cmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state);
10876 ortfac_cmatrixlqbasecase(&tmpa, blocksize, columnscount, &work, &t, &taubuf, _state);
10877 cmatrixcopy(blocksize, columnscount, &tmpa, 0, 0, a, blockstart, blockstart, _state);
10887 if( blockstart+blocksize<=m-1 )
10895 ortfac_cmatrixblockreflector(&tmpa, &taubuf,
ae_false, columnscount, blocksize, &tmpt, &work, _state);
10902 cmatrixgemm(m-blockstart-blocksize, blocksize, columnscount,
ae_complex_from_d(1.0), a, blockstart+blocksize, blockstart, 0, &tmpa, 0, 0, 2,
ae_complex_from_d(0.0), &tmpr, 0, 0, _state);
10903 cmatrixgemm(m-blockstart-blocksize, blocksize, blocksize,
ae_complex_from_d(1.0), &tmpr, 0, 0, 0, &tmpt, 0, 0, 0,
ae_complex_from_d(0.0), &tmpr, 0, blocksize, _state);
10904 cmatrixgemm(m-blockstart-blocksize, columnscount, blocksize,
ae_complex_from_d(1.0), &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0,
ae_complex_from_d(1.0), a, blockstart+blocksize, blockstart, _state);
10912 for(i=0; i<=blocksize-1; i++)
10924 blockstart = blockstart+blocksize;
10983 ae_assert(qcolumns<=m, "UnpackQFromQR: QColumns>M!
", _state); 10984 if( (m<=0||n<=0)||qcolumns<=0 ) 10986 ae_frame_leave(_state); 10993 minmn = ae_minint(m, n, _state); 10994 refcnt = ae_minint(minmn, qcolumns, _state); 10995 ae_matrix_set_length(q, m, qcolumns, _state); 10996 for(i=0; i<=m-1; i++) 10998 for(j=0; j<=qcolumns-1; j++) 11002 q->ptr.pp_double[i][j] = 1; 11006 q->ptr.pp_double[i][j] = 0; 11010 ae_vector_set_length(&work, ae_maxint(m, qcolumns, _state)+1, _state); 11011 ae_vector_set_length(&t, ae_maxint(m, qcolumns, _state)+1, _state); 11012 ae_vector_set_length(&taubuf, minmn, _state); 11013 ae_matrix_set_length(&tmpa, m, ablasblocksize(a, _state), _state); 11014 ae_matrix_set_length(&tmpt, ablasblocksize(a, _state), 2*ablasblocksize(a, _state), _state); 11015 ae_matrix_set_length(&tmpr, 2*ablasblocksize(a, _state), qcolumns, _state); 11020 blockstart = ablasblocksize(a, _state)*(refcnt/ablasblocksize(a, _state)); 11021 blocksize = refcnt-blockstart; 11022 while(blockstart>=0) 11024 rowscount = m-blockstart; 11029 * Copy current block 11031 rmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state); 11032 ae_v_move(&taubuf.ptr.p_double[0], 1, &tau->ptr.p_double[blockstart], 1, ae_v_len(0,blocksize-1)); 11035 * Update, choose between: 11036 * a) Level 2 algorithm (when the rest of the matrix is small enough) 11037 * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY 11038 * representation for products of Householder transformations', 11039 * by R. Schreiber and C. Van Loan. 11041 if( qcolumns>=2*ablasblocksize(a, _state) ) 11045 * Prepare block reflector 11047 ortfac_rmatrixblockreflector(&tmpa, &taubuf, ae_true, rowscount, blocksize, &tmpt, &work, _state); 11050 * Multiply matrix by Q. 11052 * Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA' 11054 rmatrixgemm(blocksize, qcolumns, rowscount, 1.0, &tmpa, 0, 0, 1, q, blockstart, 0, 0, 0.0, &tmpr, 0, 0, _state); 11055 rmatrixgemm(blocksize, qcolumns, blocksize, 1.0, &tmpt, 0, 0, 0, &tmpr, 0, 0, 0, 0.0, &tmpr, blocksize, 0, _state); 11056 rmatrixgemm(rowscount, qcolumns, blocksize, 1.0, &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, 1.0, q, blockstart, 0, _state); 11062 * Level 2 algorithm 11064 for(i=blocksize-1; i>=0; i--) 11066 ae_v_move(&t.ptr.p_double[1], 1, &tmpa.ptr.pp_double[i][i], tmpa.stride, ae_v_len(1,rowscount-i)); 11067 t.ptr.p_double[1] = 1; 11068 applyreflectionfromtheleft(q, taubuf.ptr.p_double[i], &t, blockstart+i, m-1, 0, qcolumns-1, &work, _state); 11076 blockstart = blockstart-ablasblocksize(a, _state); 11077 blocksize = ablasblocksize(a, _state); 11079 ae_frame_leave(_state); 11083 /************************************************************************* 11084 Unpacking of matrix R from the QR decomposition of a matrix A 11087 A - matrices Q and R in compact form. 11088 Output of RMatrixQR subroutine. 11089 M - number of rows in given matrix A. M>=0. 11090 N - number of columns in given matrix A. N>=0. 11093 R - matrix R, array[0..M-1, 0..N-1]. 11095 -- ALGLIB routine -- 11098 *************************************************************************/ 11099 void rmatrixqrunpackr(/* Real */ ae_matrix* a, 11102 /* Real */ ae_matrix* r, 11108 ae_matrix_clear(r); 11114 k = ae_minint(m, n, _state); 11115 ae_matrix_set_length(r, m, n, _state); 11116 for(i=0; i<=n-1; i++) 11118 r->ptr.pp_double[0][i] = 0; 11120 for(i=1; i<=m-1; i++) 11122 ae_v_move(&r->ptr.pp_double[i][0], 1, &r->ptr.pp_double[0][0], 1, ae_v_len(0,n-1)); 11124 for(i=0; i<=k-1; i++) 11126 ae_v_move(&r->ptr.pp_double[i][i], 1, &a->ptr.pp_double[i][i], 1, ae_v_len(i,n-1)); 11131 /************************************************************************* 11132 Partial unpacking of matrix Q from the LQ decomposition of a matrix A 11135 A - matrices L and Q in compact form. 11136 Output of RMatrixLQ subroutine. 11137 M - number of rows in given matrix A. M>=0. 11138 N - number of columns in given matrix A. N>=0. 11139 Tau - scalar factors which are used to form Q. 11140 Output of the RMatrixLQ subroutine. 11141 QRows - required number of rows in matrix Q. N>=QRows>=0. 11144 Q - first QRows rows of matrix Q. Array whose indexes range 11145 within [0..QRows-1, 0..N-1]. If QRows=0, the array remains 11148 -- ALGLIB routine -- 11151 *************************************************************************/ 11152 void rmatrixlqunpackq(/* Real */ ae_matrix* a, 11155 /* Real */ ae_vector* tau, 11157 /* Real */ ae_matrix* q, 11160 ae_frame _frame_block; 11169 ae_int_t blockstart; 11170 ae_int_t blocksize; 11171 ae_int_t columnscount; 11175 ae_frame_make(_state, &_frame_block); 11176 ae_matrix_clear(q); 11177 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 11178 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 11179 ae_vector_init(&taubuf, 0, DT_REAL, _state, ae_true); 11180 ae_matrix_init(&tmpa, 0, 0, DT_REAL, _state, ae_true); 11181 ae_matrix_init(&tmpt, 0, 0, DT_REAL, _state, ae_true); 11182 ae_matrix_init(&tmpr, 0, 0, DT_REAL, _state, ae_true); 11184 ae_assert(qrows<=n, "RMatrixLQUnpackQ: QRows>N!
", _state); 11185 if( (m<=0||n<=0)||qrows<=0 ) 11187 ae_frame_leave(_state); 11194 minmn = ae_minint(m, n, _state); 11195 refcnt = ae_minint(minmn, qrows, _state); 11196 ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state); 11197 ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state); 11198 ae_vector_set_length(&taubuf, minmn, _state); 11199 ae_matrix_set_length(&tmpa, ablasblocksize(a, _state), n, _state); 11200 ae_matrix_set_length(&tmpt, ablasblocksize(a, _state), 2*ablasblocksize(a, _state), _state); 11201 ae_matrix_set_length(&tmpr, qrows, 2*ablasblocksize(a, _state), _state); 11202 ae_matrix_set_length(q, qrows, n, _state); 11203 for(i=0; i<=qrows-1; i++) 11205 for(j=0; j<=n-1; j++) 11209 q->ptr.pp_double[i][j] = 1; 11213 q->ptr.pp_double[i][j] = 0; 11221 blockstart = ablasblocksize(a, _state)*(refcnt/ablasblocksize(a, _state)); 11222 blocksize = refcnt-blockstart; 11223 while(blockstart>=0) 11225 columnscount = n-blockstart; 11232 rmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state); 11233 ae_v_move(&taubuf.ptr.p_double[0], 1, &tau->ptr.p_double[blockstart], 1, ae_v_len(0,blocksize-1)); 11236 * Update matrix, choose between: 11237 * a) Level 2 algorithm (when the rest of the matrix is small enough) 11238 * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY 11239 * representation for products of Householder transformations', 11240 * by R. Schreiber and C. Van Loan. 11242 if( qrows>=2*ablasblocksize(a, _state) ) 11246 * Prepare block reflector 11248 ortfac_rmatrixblockreflector(&tmpa, &taubuf, ae_false, columnscount, blocksize, &tmpt, &work, _state); 11251 * Multiply the rest of A by Q'. 11253 * Q' = E + Y*T'*Y' = E + TmpA'*TmpT'*TmpA 11255 rmatrixgemm(qrows, blocksize, columnscount, 1.0, q, 0, blockstart, 0, &tmpa, 0, 0, 1, 0.0, &tmpr, 0, 0, _state); 11256 rmatrixgemm(qrows, blocksize, blocksize, 1.0, &tmpr, 0, 0, 0, &tmpt, 0, 0, 1, 0.0, &tmpr, 0, blocksize, _state); 11257 rmatrixgemm(qrows, columnscount, blocksize, 1.0, &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, 1.0, q, 0, blockstart, _state); 11263 * Level 2 algorithm 11265 for(i=blocksize-1; i>=0; i--) 11267 ae_v_move(&t.ptr.p_double[1], 1, &tmpa.ptr.pp_double[i][i], 1, ae_v_len(1,columnscount-i)); 11268 t.ptr.p_double[1] = 1; 11269 applyreflectionfromtheright(q, taubuf.ptr.p_double[i], &t, 0, qrows-1, blockstart+i, n-1, &work, _state); 11277 blockstart = blockstart-ablasblocksize(a, _state); 11278 blocksize = ablasblocksize(a, _state); 11280 ae_frame_leave(_state); 11284 /************************************************************************* 11285 Unpacking of matrix L from the LQ decomposition of a matrix A 11288 A - matrices Q and L in compact form. 11289 Output of RMatrixLQ subroutine. 11290 M - number of rows in given matrix A. M>=0. 11291 N - number of columns in given matrix A. N>=0. 11294 L - matrix L, array[0..M-1, 0..N-1]. 11296 -- ALGLIB routine -- 11299 *************************************************************************/ 11300 void rmatrixlqunpackl(/* Real */ ae_matrix* a, 11303 /* Real */ ae_matrix* l, 11309 ae_matrix_clear(l); 11315 ae_matrix_set_length(l, m, n, _state); 11316 for(i=0; i<=n-1; i++) 11318 l->ptr.pp_double[0][i] = 0; 11320 for(i=1; i<=m-1; i++) 11322 ae_v_move(&l->ptr.pp_double[i][0], 1, &l->ptr.pp_double[0][0], 1, ae_v_len(0,n-1)); 11324 for(i=0; i<=m-1; i++) 11326 k = ae_minint(i, n-1, _state); 11327 ae_v_move(&l->ptr.pp_double[i][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k)); 11332 /************************************************************************* 11333 Partial unpacking of matrix Q from QR decomposition of a complex matrix A. 11336 A - matrices Q and R in compact form. 11337 Output of CMatrixQR subroutine . 11338 M - number of rows in matrix A. M>=0. 11339 N - number of columns in matrix A. N>=0. 11340 Tau - scalar factors which are used to form Q. 11341 Output of CMatrixQR subroutine . 11342 QColumns - required number of columns in matrix Q. M>=QColumns>=0. 11345 Q - first QColumns columns of matrix Q. 11346 Array whose index ranges within [0..M-1, 0..QColumns-1]. 11347 If QColumns=0, array isn't changed. 11349 -- ALGLIB routine -- 11352 *************************************************************************/ 11353 void cmatrixqrunpackq(/* Complex */ ae_matrix* a, 11356 /* Complex */ ae_vector* tau, 11358 /* Complex */ ae_matrix* q, 11361 ae_frame _frame_block; 11370 ae_int_t blockstart; 11371 ae_int_t blocksize; 11372 ae_int_t rowscount; 11376 ae_frame_make(_state, &_frame_block); 11377 ae_matrix_clear(q); 11378 ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true); 11379 ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true); 11380 ae_vector_init(&taubuf, 0, DT_COMPLEX, _state, ae_true); 11381 ae_matrix_init(&tmpa, 0, 0, DT_COMPLEX, _state, ae_true); 11382 ae_matrix_init(&tmpt, 0, 0, DT_COMPLEX, _state, ae_true); 11383 ae_matrix_init(&tmpr, 0, 0, DT_COMPLEX, _state, ae_true); 11385 ae_assert(qcolumns<=m, "UnpackQFromQR: QColumns>M!
", _state); 11388 ae_frame_leave(_state); 11395 minmn = ae_minint(m, n, _state); 11396 refcnt = ae_minint(minmn, qcolumns, _state); 11397 ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state); 11398 ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state); 11399 ae_vector_set_length(&taubuf, minmn, _state); 11400 ae_matrix_set_length(&tmpa, m, ablascomplexblocksize(a, _state), _state); 11401 ae_matrix_set_length(&tmpt, ablascomplexblocksize(a, _state), ablascomplexblocksize(a, _state), _state); 11402 ae_matrix_set_length(&tmpr, 2*ablascomplexblocksize(a, _state), qcolumns, _state); 11403 ae_matrix_set_length(q, m, qcolumns, _state); 11404 for(i=0; i<=m-1; i++) 11406 for(j=0; j<=qcolumns-1; j++) 11410 q->ptr.pp_complex[i][j] = ae_complex_from_d(1); 11414 q->ptr.pp_complex[i][j] = ae_complex_from_d(0); 11422 blockstart = ablascomplexblocksize(a, _state)*(refcnt/ablascomplexblocksize(a, _state)); 11423 blocksize = refcnt-blockstart; 11424 while(blockstart>=0) 11426 rowscount = m-blockstart; 11431 * QR decomposition of submatrix. 11432 * Matrix is copied to temporary storage to solve 11433 * some TLB issues arising from non-contiguous memory 11436 cmatrixcopy(rowscount, blocksize, a, blockstart, blockstart, &tmpa, 0, 0, _state); 11437 ae_v_cmove(&taubuf.ptr.p_complex[0], 1, &tau->ptr.p_complex[blockstart], 1, "N
", ae_v_len(0,blocksize-1)); 11440 * Update matrix, choose between: 11441 * a) Level 2 algorithm (when the rest of the matrix is small enough) 11442 * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY 11443 * representation for products of Householder transformations', 11444 * by R. Schreiber and C. Van Loan. 11446 if( qcolumns>=2*ablascomplexblocksize(a, _state) ) 11450 * Prepare block reflector 11452 ortfac_cmatrixblockreflector(&tmpa, &taubuf, ae_true, rowscount, blocksize, &tmpt, &work, _state); 11455 * Multiply the rest of A by Q. 11457 * Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA' 11459 cmatrixgemm(blocksize, qcolumns, rowscount, ae_complex_from_d(1.0), &tmpa, 0, 0, 2, q, blockstart, 0, 0, ae_complex_from_d(0.0), &tmpr, 0, 0, _state); 11460 cmatrixgemm(blocksize, qcolumns, blocksize, ae_complex_from_d(1.0), &tmpt, 0, 0, 0, &tmpr, 0, 0, 0, ae_complex_from_d(0.0), &tmpr, blocksize, 0, _state); 11461 cmatrixgemm(rowscount, qcolumns, blocksize, ae_complex_from_d(1.0), &tmpa, 0, 0, 0, &tmpr, blocksize, 0, 0, ae_complex_from_d(1.0), q, blockstart, 0, _state); 11467 * Level 2 algorithm 11469 for(i=blocksize-1; i>=0; i--) 11471 ae_v_cmove(&t.ptr.p_complex[1], 1, &tmpa.ptr.pp_complex[i][i], tmpa.stride, "N
", ae_v_len(1,rowscount-i)); 11472 t.ptr.p_complex[1] = ae_complex_from_d(1); 11473 complexapplyreflectionfromtheleft(q, taubuf.ptr.p_complex[i], &t, blockstart+i, m-1, 0, qcolumns-1, &work, _state); 11481 blockstart = blockstart-ablascomplexblocksize(a, _state); 11482 blocksize = ablascomplexblocksize(a, _state); 11484 ae_frame_leave(_state); 11488 /************************************************************************* 11489 Unpacking of matrix R from the QR decomposition of a matrix A 11492 A - matrices Q and R in compact form. 11493 Output of CMatrixQR subroutine. 11494 M - number of rows in given matrix A. M>=0. 11495 N - number of columns in given matrix A. N>=0. 11498 R - matrix R, array[0..M-1, 0..N-1]. 11500 -- ALGLIB routine -- 11503 *************************************************************************/ 11504 void cmatrixqrunpackr(/* Complex */ ae_matrix* a, 11507 /* Complex */ ae_matrix* r, 11513 ae_matrix_clear(r); 11519 k = ae_minint(m, n, _state); 11520 ae_matrix_set_length(r, m, n, _state); 11521 for(i=0; i<=n-1; i++) 11523 r->ptr.pp_complex[0][i] = ae_complex_from_d(0); 11525 for(i=1; i<=m-1; i++) 11527 ae_v_cmove(&r->ptr.pp_complex[i][0], 1, &r->ptr.pp_complex[0][0], 1, "N
", ae_v_len(0,n-1)); 11529 for(i=0; i<=k-1; i++) 11531 ae_v_cmove(&r->ptr.pp_complex[i][i], 1, &a->ptr.pp_complex[i][i], 1, "N
", ae_v_len(i,n-1)); 11536 /************************************************************************* 11537 Partial unpacking of matrix Q from LQ decomposition of a complex matrix A. 11540 A - matrices Q and R in compact form. 11541 Output of CMatrixLQ subroutine . 11542 M - number of rows in matrix A. M>=0. 11543 N - number of columns in matrix A. N>=0. 11544 Tau - scalar factors which are used to form Q. 11545 Output of CMatrixLQ subroutine . 11546 QRows - required number of rows in matrix Q. N>=QColumns>=0. 11549 Q - first QRows rows of matrix Q. 11550 Array whose index ranges within [0..QRows-1, 0..N-1]. 11551 If QRows=0, array isn't changed. 11553 -- ALGLIB routine -- 11556 *************************************************************************/ 11557 void cmatrixlqunpackq(/* Complex */ ae_matrix* a, 11560 /* Complex */ ae_vector* tau, 11562 /* Complex */ ae_matrix* q, 11565 ae_frame _frame_block; 11574 ae_int_t blockstart; 11575 ae_int_t blocksize; 11576 ae_int_t columnscount; 11580 ae_frame_make(_state, &_frame_block); 11581 ae_matrix_clear(q); 11582 ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true); 11583 ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true); 11584 ae_vector_init(&taubuf, 0, DT_COMPLEX, _state, ae_true); 11585 ae_matrix_init(&tmpa, 0, 0, DT_COMPLEX, _state, ae_true); 11586 ae_matrix_init(&tmpt, 0, 0, DT_COMPLEX, _state, ae_true); 11587 ae_matrix_init(&tmpr, 0, 0, DT_COMPLEX, _state, ae_true); 11591 ae_frame_leave(_state); 11598 minmn = ae_minint(m, n, _state); 11599 refcnt = ae_minint(minmn, qrows, _state); 11600 ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state); 11601 ae_vector_set_length(&t, ae_maxint(m, n, _state)+1, _state); 11602 ae_vector_set_length(&taubuf, minmn, _state); 11603 ae_matrix_set_length(&tmpa, ablascomplexblocksize(a, _state), n, _state); 11604 ae_matrix_set_length(&tmpt, ablascomplexblocksize(a, _state), ablascomplexblocksize(a, _state), _state); 11605 ae_matrix_set_length(&tmpr, qrows, 2*ablascomplexblocksize(a, _state), _state); 11606 ae_matrix_set_length(q, qrows, n, _state); 11607 for(i=0; i<=qrows-1; i++) 11609 for(j=0; j<=n-1; j++) 11613 q->ptr.pp_complex[i][j] = ae_complex_from_d(1); 11617 q->ptr.pp_complex[i][j] = ae_complex_from_d(0); 11625 blockstart = ablascomplexblocksize(a, _state)*(refcnt/ablascomplexblocksize(a, _state)); 11626 blocksize = refcnt-blockstart; 11627 while(blockstart>=0) 11629 columnscount = n-blockstart; 11634 * LQ decomposition of submatrix. 11635 * Matrix is copied to temporary storage to solve 11636 * some TLB issues arising from non-contiguous memory 11639 cmatrixcopy(blocksize, columnscount, a, blockstart, blockstart, &tmpa, 0, 0, _state); 11640 ae_v_cmove(&taubuf.ptr.p_complex[0], 1, &tau->ptr.p_complex[blockstart], 1, "N
", ae_v_len(0,blocksize-1)); 11643 * Update matrix, choose between: 11644 * a) Level 2 algorithm (when the rest of the matrix is small enough) 11645 * b) blocked algorithm, see algorithm 5 from 'A storage efficient WY 11646 * representation for products of Householder transformations', 11647 * by R. Schreiber and C. Van Loan. 11649 if( qrows>=2*ablascomplexblocksize(a, _state) ) 11653 * Prepare block reflector 11655 ortfac_cmatrixblockreflector(&tmpa, &taubuf, ae_false, columnscount, blocksize, &tmpt, &work, _state); 11658 * Multiply the rest of A by Q'. 11660 * Q' = E + Y*T'*Y' = E + TmpA'*TmpT'*TmpA 11662 cmatrixgemm(qrows, blocksize, columnscount, ae_complex_from_d(1.0), q, 0, blockstart, 0, &tmpa, 0, 0, 2, ae_complex_from_d(0.0), &tmpr, 0, 0, _state); 11663 cmatrixgemm(qrows, blocksize, blocksize, ae_complex_from_d(1.0), &tmpr, 0, 0, 0, &tmpt, 0, 0, 2, ae_complex_from_d(0.0), &tmpr, 0, blocksize, _state); 11664 cmatrixgemm(qrows, columnscount, blocksize, ae_complex_from_d(1.0), &tmpr, 0, blocksize, 0, &tmpa, 0, 0, 0, ae_complex_from_d(1.0), q, 0, blockstart, _state); 11670 * Level 2 algorithm 11672 for(i=blocksize-1; i>=0; i--) 11674 ae_v_cmove(&t.ptr.p_complex[1], 1, &tmpa.ptr.pp_complex[i][i], 1, "Conj
", ae_v_len(1,columnscount-i)); 11675 t.ptr.p_complex[1] = ae_complex_from_d(1); 11676 complexapplyreflectionfromtheright(q, ae_c_conj(taubuf.ptr.p_complex[i], _state), &t, 0, qrows-1, blockstart+i, n-1, &work, _state); 11684 blockstart = blockstart-ablascomplexblocksize(a, _state); 11685 blocksize = ablascomplexblocksize(a, _state); 11687 ae_frame_leave(_state); 11691 /************************************************************************* 11692 Unpacking of matrix L from the LQ decomposition of a matrix A 11695 A - matrices Q and L in compact form. 11696 Output of CMatrixLQ subroutine. 11697 M - number of rows in given matrix A. M>=0. 11698 N - number of columns in given matrix A. N>=0. 11701 L - matrix L, array[0..M-1, 0..N-1]. 11703 -- ALGLIB routine -- 11706 *************************************************************************/ 11707 void cmatrixlqunpackl(/* Complex */ ae_matrix* a, 11710 /* Complex */ ae_matrix* l, 11716 ae_matrix_clear(l); 11722 ae_matrix_set_length(l, m, n, _state); 11723 for(i=0; i<=n-1; i++) 11725 l->ptr.pp_complex[0][i] = ae_complex_from_d(0); 11727 for(i=1; i<=m-1; i++) 11729 ae_v_cmove(&l->ptr.pp_complex[i][0], 1, &l->ptr.pp_complex[0][0], 1, "N
", ae_v_len(0,n-1)); 11731 for(i=0; i<=m-1; i++) 11733 k = ae_minint(i, n-1, _state); 11734 ae_v_cmove(&l->ptr.pp_complex[i][0], 1, &a->ptr.pp_complex[i][0], 1, "N
", ae_v_len(0,k)); 11739 /************************************************************************* 11740 Base case for real QR 11742 -- LAPACK routine (version 3.0) -- 11743 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 11744 Courant Institute, Argonne National Lab, and Rice University 11745 September 30, 1994. 11746 Sergey Bochkanov, ALGLIB project, translation from FORTRAN to 11747 pseudocode, 2007-2010. 11748 *************************************************************************/ 11749 void rmatrixqrbasecase(/* Real */ ae_matrix* a, 11752 /* Real */ ae_vector* work, 11753 /* Real */ ae_vector* t, 11754 /* Real */ ae_vector* tau, 11763 minmn = ae_minint(m, n, _state); 11766 * Test the input arguments 11769 for(i=0; i<=k-1; i++) 11773 * Generate elementary reflector H(i) to annihilate A(i+1:m,i) 11775 ae_v_move(&t->ptr.p_double[1], 1, &a->ptr.pp_double[i][i], a->stride, ae_v_len(1,m-i)); 11776 generatereflection(t, m-i, &tmp, _state); 11777 tau->ptr.p_double[i] = tmp; 11778 ae_v_move(&a->ptr.pp_double[i][i], a->stride, &t->ptr.p_double[1], 1, ae_v_len(i,m-1)); 11779 t->ptr.p_double[1] = 1; 11784 * Apply H(i) to A(i:m-1,i+1:n-1) from the left 11786 applyreflectionfromtheleft(a, tau->ptr.p_double[i], t, i, m-1, i+1, n-1, work, _state); 11792 /************************************************************************* 11793 Base case for real LQ 11795 -- LAPACK routine (version 3.0) -- 11796 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 11797 Courant Institute, Argonne National Lab, and Rice University 11798 September 30, 1994. 11799 Sergey Bochkanov, ALGLIB project, translation from FORTRAN to 11800 pseudocode, 2007-2010. 11801 *************************************************************************/ 11802 void rmatrixlqbasecase(/* Real */ ae_matrix* a, 11805 /* Real */ ae_vector* work, 11806 /* Real */ ae_vector* t, 11807 /* Real */ ae_vector* tau, 11815 k = ae_minint(m, n, _state); 11816 for(i=0; i<=k-1; i++) 11820 * Generate elementary reflector H(i) to annihilate A(i,i+1:n-1) 11822 ae_v_move(&t->ptr.p_double[1], 1, &a->ptr.pp_double[i][i], 1, ae_v_len(1,n-i)); 11823 generatereflection(t, n-i, &tmp, _state); 11824 tau->ptr.p_double[i] = tmp; 11825 ae_v_move(&a->ptr.pp_double[i][i], 1, &t->ptr.p_double[1], 1, ae_v_len(i,n-1)); 11826 t->ptr.p_double[1] = 1; 11831 * Apply H(i) to A(i+1:m,i:n) from the right 11833 applyreflectionfromtheright(a, tau->ptr.p_double[i], t, i+1, m-1, i, n-1, work, _state); 11839 /************************************************************************* 11840 Reduction of a rectangular matrix to bidiagonal form 11842 The algorithm reduces the rectangular matrix A to bidiagonal form by 11843 orthogonal transformations P and Q: A = Q*B*P. 11846 A - source matrix. array[0..M-1, 0..N-1] 11847 M - number of rows in matrix A. 11848 N - number of columns in matrix A. 11851 A - matrices Q, B, P in compact form (see below). 11852 TauQ - scalar factors which are used to form matrix Q. 11853 TauP - scalar factors which are used to form matrix P. 11855 The main diagonal and one of the secondary diagonals of matrix A are 11856 replaced with bidiagonal matrix B. Other elements contain elementary 11857 reflections which form MxM matrix Q and NxN matrix P, respectively. 11859 If M>=N, B is the upper bidiagonal MxN matrix and is stored in the 11860 corresponding elements of matrix A. Matrix Q is represented as a 11861 product of elementary reflections Q = H(0)*H(1)*...*H(n-1), where 11862 H(i) = 1-tau*v*v'. Here tau is a scalar which is stored in TauQ[i], and 11863 vector v has the following structure: v(0:i-1)=0, v(i)=1, v(i+1:m-1) is 11864 stored in elements A(i+1:m-1,i). Matrix P is as follows: P = 11865 G(0)*G(1)*...*G(n-2), where G(i) = 1 - tau*u*u'. Tau is stored in TauP[i], 11866 u(0:i)=0, u(i+1)=1, u(i+2:n-1) is stored in elements A(i,i+2:n-1). 11868 If M<N, B is the lower bidiagonal MxN matrix and is stored in the 11869 corresponding elements of matrix A. Q = H(0)*H(1)*...*H(m-2), where 11870 H(i) = 1 - tau*v*v', tau is stored in TauQ, v(0:i)=0, v(i+1)=1, v(i+2:m-1) 11871 is stored in elements A(i+2:m-1,i). P = G(0)*G(1)*...*G(m-1), 11872 G(i) = 1-tau*u*u', tau is stored in TauP, u(0:i-1)=0, u(i)=1, u(i+1:n-1) 11873 is stored in A(i,i+1:n-1). 11877 m=6, n=5 (m > n): m=5, n=6 (m < n): 11879 ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) 11880 ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) 11881 ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) 11882 ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) 11883 ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) 11886 Here vi and ui are vectors which form H(i) and G(i), and d and e - 11887 are the diagonal and off-diagonal elements of matrix B. 11889 -- LAPACK routine (version 3.0) -- 11890 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 11891 Courant Institute, Argonne National Lab, and Rice University 11892 September 30, 1994. 11893 Sergey Bochkanov, ALGLIB project, translation from FORTRAN to 11894 pseudocode, 2007-2010. 11895 *************************************************************************/ 11896 void rmatrixbd(/* Real */ ae_matrix* a, 11899 /* Real */ ae_vector* tauq, 11900 /* Real */ ae_vector* taup, 11903 ae_frame _frame_block; 11910 ae_frame_make(_state, &_frame_block); 11911 ae_vector_clear(tauq); 11912 ae_vector_clear(taup); 11913 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 11914 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 11922 ae_frame_leave(_state); 11925 maxmn = ae_maxint(m, n, _state); 11926 ae_vector_set_length(&work, maxmn+1, _state); 11927 ae_vector_set_length(&t, maxmn+1, _state); 11930 ae_vector_set_length(tauq, n, _state); 11931 ae_vector_set_length(taup, n, _state); 11935 ae_vector_set_length(tauq, m, _state); 11936 ae_vector_set_length(taup, m, _state); 11942 * Reduce to upper bidiagonal form 11944 for(i=0; i<=n-1; i++) 11948 * Generate elementary reflector H(i) to annihilate A(i+1:m-1,i) 11950 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i][i], a->stride, ae_v_len(1,m-i)); 11951 generatereflection(&t, m-i, <au, _state); 11952 tauq->ptr.p_double[i] = ltau; 11953 ae_v_move(&a->ptr.pp_double[i][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i,m-1)); 11954 t.ptr.p_double[1] = 1; 11957 * Apply H(i) to A(i:m-1,i+1:n-1) from the left 11959 applyreflectionfromtheleft(a, ltau, &t, i, m-1, i+1, n-1, &work, _state); 11964 * Generate elementary reflector G(i) to annihilate 11967 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i][i+1], 1, ae_v_len(1,n-i-1)); 11968 generatereflection(&t, n-1-i, <au, _state); 11969 taup->ptr.p_double[i] = ltau; 11970 ae_v_move(&a->ptr.pp_double[i][i+1], 1, &t.ptr.p_double[1], 1, ae_v_len(i+1,n-1)); 11971 t.ptr.p_double[1] = 1; 11974 * Apply G(i) to A(i+1:m-1,i+1:n-1) from the right 11976 applyreflectionfromtheright(a, ltau, &t, i+1, m-1, i+1, n-1, &work, _state); 11980 taup->ptr.p_double[i] = 0; 11988 * Reduce to lower bidiagonal form 11990 for(i=0; i<=m-1; i++) 11994 * Generate elementary reflector G(i) to annihilate A(i,i+1:n-1) 11996 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i][i], 1, ae_v_len(1,n-i)); 11997 generatereflection(&t, n-i, <au, _state); 11998 taup->ptr.p_double[i] = ltau; 11999 ae_v_move(&a->ptr.pp_double[i][i], 1, &t.ptr.p_double[1], 1, ae_v_len(i,n-1)); 12000 t.ptr.p_double[1] = 1; 12003 * Apply G(i) to A(i+1:m-1,i:n-1) from the right 12005 applyreflectionfromtheright(a, ltau, &t, i+1, m-1, i, n-1, &work, _state); 12010 * Generate elementary reflector H(i) to annihilate 12013 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,m-1-i)); 12014 generatereflection(&t, m-1-i, <au, _state); 12015 tauq->ptr.p_double[i] = ltau; 12016 ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i+1,m-1)); 12017 t.ptr.p_double[1] = 1; 12020 * Apply H(i) to A(i+1:m-1,i+1:n-1) from the left 12022 applyreflectionfromtheleft(a, ltau, &t, i+1, m-1, i+1, n-1, &work, _state); 12026 tauq->ptr.p_double[i] = 0; 12030 ae_frame_leave(_state); 12034 /************************************************************************* 12035 Unpacking matrix Q which reduces a matrix to bidiagonal form. 12038 QP - matrices Q and P in compact form. 12039 Output of ToBidiagonal subroutine. 12040 M - number of rows in matrix A. 12041 N - number of columns in matrix A. 12042 TAUQ - scalar factors which are used to form Q. 12043 Output of ToBidiagonal subroutine. 12044 QColumns - required number of columns in matrix Q. 12048 Q - first QColumns columns of matrix Q. 12049 Array[0..M-1, 0..QColumns-1] 12050 If QColumns=0, the array is not modified. 12055 *************************************************************************/ 12056 void rmatrixbdunpackq(/* Real */ ae_matrix* qp, 12059 /* Real */ ae_vector* tauq, 12061 /* Real */ ae_matrix* q, 12067 ae_matrix_clear(q); 12069 ae_assert(qcolumns<=m, "RMatrixBDUnpackQ: QColumns>M!
", _state); 12070 ae_assert(qcolumns>=0, "RMatrixBDUnpackQ: QColumns<0!
", _state); 12071 if( (m==0||n==0)||qcolumns==0 ) 12079 ae_matrix_set_length(q, m, qcolumns, _state); 12080 for(i=0; i<=m-1; i++) 12082 for(j=0; j<=qcolumns-1; j++) 12086 q->ptr.pp_double[i][j] = 1; 12090 q->ptr.pp_double[i][j] = 0; 12098 rmatrixbdmultiplybyq(qp, m, n, tauq, q, m, qcolumns, ae_false, ae_false, _state); 12102 /************************************************************************* 12103 Multiplication by matrix Q which reduces matrix A to bidiagonal form. 12105 The algorithm allows pre- or post-multiply by Q or Q'. 12108 QP - matrices Q and P in compact form. 12109 Output of ToBidiagonal subroutine. 12110 M - number of rows in matrix A. 12111 N - number of columns in matrix A. 12112 TAUQ - scalar factors which are used to form Q. 12113 Output of ToBidiagonal subroutine. 12114 Z - multiplied matrix. 12115 array[0..ZRows-1,0..ZColumns-1] 12116 ZRows - number of rows in matrix Z. If FromTheRight=False, 12117 ZRows=M, otherwise ZRows can be arbitrary. 12118 ZColumns - number of columns in matrix Z. If FromTheRight=True, 12119 ZColumns=M, otherwise ZColumns can be arbitrary. 12120 FromTheRight - pre- or post-multiply. 12121 DoTranspose - multiply by Q or Q'. 12124 Z - product of Z and Q. 12125 Array[0..ZRows-1,0..ZColumns-1] 12126 If ZRows=0 or ZColumns=0, the array is not modified. 12131 *************************************************************************/ 12132 void rmatrixbdmultiplybyq(/* Real */ ae_matrix* qp, 12135 /* Real */ ae_vector* tauq, 12136 /* Real */ ae_matrix* z, 12139 ae_bool fromtheright, 12140 ae_bool dotranspose, 12143 ae_frame _frame_block; 12152 ae_frame_make(_state, &_frame_block); 12153 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 12154 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 12156 if( ((m<=0||n<=0)||zrows<=0)||zcolumns<=0 ) 12158 ae_frame_leave(_state); 12161 ae_assert((fromtheright&&zcolumns==m)||(!fromtheright&&zrows==m), "RMatrixBDMultiplyByQ: incorrect Z size!
", _state); 12166 mx = ae_maxint(m, n, _state); 12167 mx = ae_maxint(mx, zrows, _state); 12168 mx = ae_maxint(mx, zcolumns, _state); 12169 ae_vector_set_length(&v, mx+1, _state); 12170 ae_vector_set_length(&work, mx+1, _state); 12203 ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i][i], qp->stride, ae_v_len(1,m-i)); 12204 v.ptr.p_double[1] = 1; 12207 applyreflectionfromtheright(z, tauq->ptr.p_double[i], &v, 0, zrows-1, i, m-1, &work, _state); 12211 applyreflectionfromtheleft(z, tauq->ptr.p_double[i], &v, i, m-1, 0, zcolumns-1, &work, _state); 12215 while(i!=i2+istep); 12251 ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i+1][i], qp->stride, ae_v_len(1,m-i-1)); 12252 v.ptr.p_double[1] = 1; 12255 applyreflectionfromtheright(z, tauq->ptr.p_double[i], &v, 0, zrows-1, i+1, m-1, &work, _state); 12259 applyreflectionfromtheleft(z, tauq->ptr.p_double[i], &v, i+1, m-1, 0, zcolumns-1, &work, _state); 12263 while(i!=i2+istep); 12266 ae_frame_leave(_state); 12270 /************************************************************************* 12271 Unpacking matrix P which reduces matrix A to bidiagonal form. 12272 The subroutine returns transposed matrix P. 12275 QP - matrices Q and P in compact form. 12276 Output of ToBidiagonal subroutine. 12277 M - number of rows in matrix A. 12278 N - number of columns in matrix A. 12279 TAUP - scalar factors which are used to form P. 12280 Output of ToBidiagonal subroutine. 12281 PTRows - required number of rows of matrix P^T. N >= PTRows >= 0. 12284 PT - first PTRows columns of matrix P^T 12285 Array[0..PTRows-1, 0..N-1] 12286 If PTRows=0, the array is not modified. 12291 *************************************************************************/ 12292 void rmatrixbdunpackpt(/* Real */ ae_matrix* qp, 12295 /* Real */ ae_vector* taup, 12297 /* Real */ ae_matrix* pt, 12303 ae_matrix_clear(pt); 12305 ae_assert(ptrows<=n, "RMatrixBDUnpackPT: PTRows>N!
", _state); 12306 ae_assert(ptrows>=0, "RMatrixBDUnpackPT: PTRows<0!
", _state); 12307 if( (m==0||n==0)||ptrows==0 ) 12315 ae_matrix_set_length(pt, ptrows, n, _state); 12316 for(i=0; i<=ptrows-1; i++) 12318 for(j=0; j<=n-1; j++) 12322 pt->ptr.pp_double[i][j] = 1; 12326 pt->ptr.pp_double[i][j] = 0; 12334 rmatrixbdmultiplybyp(qp, m, n, taup, pt, ptrows, n, ae_true, ae_true, _state); 12338 /************************************************************************* 12339 Multiplication by matrix P which reduces matrix A to bidiagonal form. 12341 The algorithm allows pre- or post-multiply by P or P'. 12344 QP - matrices Q and P in compact form. 12345 Output of RMatrixBD subroutine. 12346 M - number of rows in matrix A. 12347 N - number of columns in matrix A. 12348 TAUP - scalar factors which are used to form P. 12349 Output of RMatrixBD subroutine. 12350 Z - multiplied matrix. 12351 Array whose indexes range within [0..ZRows-1,0..ZColumns-1]. 12352 ZRows - number of rows in matrix Z. If FromTheRight=False, 12353 ZRows=N, otherwise ZRows can be arbitrary. 12354 ZColumns - number of columns in matrix Z. If FromTheRight=True, 12355 ZColumns=N, otherwise ZColumns can be arbitrary. 12356 FromTheRight - pre- or post-multiply. 12357 DoTranspose - multiply by P or P'. 12360 Z - product of Z and P. 12361 Array whose indexes range within [0..ZRows-1,0..ZColumns-1]. 12362 If ZRows=0 or ZColumns=0, the array is not modified. 12367 *************************************************************************/ 12368 void rmatrixbdmultiplybyp(/* Real */ ae_matrix* qp, 12371 /* Real */ ae_vector* taup, 12372 /* Real */ ae_matrix* z, 12375 ae_bool fromtheright, 12376 ae_bool dotranspose, 12379 ae_frame _frame_block; 12388 ae_frame_make(_state, &_frame_block); 12389 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 12390 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 12392 if( ((m<=0||n<=0)||zrows<=0)||zcolumns<=0 ) 12394 ae_frame_leave(_state); 12397 ae_assert((fromtheright&&zcolumns==n)||(!fromtheright&&zrows==n), "RMatrixBDMultiplyByP: incorrect Z size!
", _state); 12402 mx = ae_maxint(m, n, _state); 12403 mx = ae_maxint(mx, zrows, _state); 12404 mx = ae_maxint(mx, zcolumns, _state); 12405 ae_vector_set_length(&v, mx+1, _state); 12406 ae_vector_set_length(&work, mx+1, _state); 12441 ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i][i+1], 1, ae_v_len(1,n-1-i)); 12442 v.ptr.p_double[1] = 1; 12445 applyreflectionfromtheright(z, taup->ptr.p_double[i], &v, 0, zrows-1, i+1, n-1, &work, _state); 12449 applyreflectionfromtheleft(z, taup->ptr.p_double[i], &v, i+1, n-1, 0, zcolumns-1, &work, _state); 12453 while(i!=i2+istep); 12488 ae_v_move(&v.ptr.p_double[1], 1, &qp->ptr.pp_double[i][i], 1, ae_v_len(1,n-i)); 12489 v.ptr.p_double[1] = 1; 12492 applyreflectionfromtheright(z, taup->ptr.p_double[i], &v, 0, zrows-1, i, n-1, &work, _state); 12496 applyreflectionfromtheleft(z, taup->ptr.p_double[i], &v, i, n-1, 0, zcolumns-1, &work, _state); 12500 while(i!=i2+istep); 12502 ae_frame_leave(_state); 12506 /************************************************************************* 12507 Unpacking of the main and secondary diagonals of bidiagonal decomposition 12511 B - output of RMatrixBD subroutine. 12512 M - number of rows in matrix B. 12513 N - number of columns in matrix B. 12516 IsUpper - True, if the matrix is upper bidiagonal. 12517 otherwise IsUpper is False. 12518 D - the main diagonal. 12519 Array whose index ranges within [0..Min(M,N)-1]. 12520 E - the secondary diagonal (upper or lower, depending on 12521 the value of IsUpper). 12522 Array index ranges within [0..Min(M,N)-1], the last 12523 element is not used. 12528 *************************************************************************/ 12529 void rmatrixbdunpackdiagonals(/* Real */ ae_matrix* b, 12533 /* Real */ ae_vector* d, 12534 /* Real */ ae_vector* e, 12539 *isupper = ae_false; 12540 ae_vector_clear(d); 12541 ae_vector_clear(e); 12550 ae_vector_set_length(d, n, _state); 12551 ae_vector_set_length(e, n, _state); 12552 for(i=0; i<=n-2; i++) 12554 d->ptr.p_double[i] = b->ptr.pp_double[i][i]; 12555 e->ptr.p_double[i] = b->ptr.pp_double[i][i+1]; 12557 d->ptr.p_double[n-1] = b->ptr.pp_double[n-1][n-1]; 12561 ae_vector_set_length(d, m, _state); 12562 ae_vector_set_length(e, m, _state); 12563 for(i=0; i<=m-2; i++) 12565 d->ptr.p_double[i] = b->ptr.pp_double[i][i]; 12566 e->ptr.p_double[i] = b->ptr.pp_double[i+1][i]; 12568 d->ptr.p_double[m-1] = b->ptr.pp_double[m-1][m-1]; 12573 /************************************************************************* 12574 Reduction of a square matrix to upper Hessenberg form: Q'*A*Q = H, 12575 where Q is an orthogonal matrix, H - Hessenberg matrix. 12578 A - matrix A with elements [0..N-1, 0..N-1] 12579 N - size of matrix A. 12582 A - matrices Q and P in compact form (see below). 12583 Tau - array of scalar factors which are used to form matrix Q. 12584 Array whose index ranges within [0..N-2] 12586 Matrix H is located on the main diagonal, on the lower secondary diagonal 12587 and above the main diagonal of matrix A. The elements which are used to 12588 form matrix Q are situated in array Tau and below the lower secondary 12589 diagonal of matrix A as follows: 12591 Matrix Q is represented as a product of elementary reflections 12593 Q = H(0)*H(2)*...*H(n-2), 12595 where each H(i) is given by 12597 H(i) = 1 - tau * v * (v^T) 12599 where tau is a scalar stored in Tau[I]; v - is a real vector, 12600 so that v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) stored in A(i+2:n-1,i). 12602 -- LAPACK routine (version 3.0) -- 12603 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 12604 Courant Institute, Argonne National Lab, and Rice University 12606 *************************************************************************/ 12607 void rmatrixhessenberg(/* Real */ ae_matrix* a, 12609 /* Real */ ae_vector* tau, 12612 ae_frame _frame_block; 12618 ae_frame_make(_state, &_frame_block); 12619 ae_vector_clear(tau); 12620 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 12621 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 12623 ae_assert(n>=0, "RMatrixHessenberg: incorrect N!
", _state); 12626 * Quick return if possible 12630 ae_frame_leave(_state); 12633 ae_vector_set_length(tau, n-2+1, _state); 12634 ae_vector_set_length(&t, n+1, _state); 12635 ae_vector_set_length(&work, n-1+1, _state); 12636 for(i=0; i<=n-2; i++) 12640 * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) 12642 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1)); 12643 generatereflection(&t, n-i-1, &v, _state); 12644 ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i+1,n-1)); 12645 tau->ptr.p_double[i] = v; 12646 t.ptr.p_double[1] = 1; 12649 * Apply H(i) to A(1:ihi,i+1:ihi) from the right 12651 applyreflectionfromtheright(a, v, &t, 0, n-1, i+1, n-1, &work, _state); 12654 * Apply H(i) to A(i+1:ihi,i+1:n) from the left 12656 applyreflectionfromtheleft(a, v, &t, i+1, n-1, i+1, n-1, &work, _state); 12658 ae_frame_leave(_state); 12662 /************************************************************************* 12663 Unpacking matrix Q which reduces matrix A to upper Hessenberg form 12666 A - output of RMatrixHessenberg subroutine. 12667 N - size of matrix A. 12668 Tau - scalar factors which are used to form Q. 12669 Output of RMatrixHessenberg subroutine. 12673 Array whose indexes range within [0..N-1, 0..N-1]. 12678 *************************************************************************/ 12679 void rmatrixhessenbergunpackq(/* Real */ ae_matrix* a, 12681 /* Real */ ae_vector* tau, 12682 /* Real */ ae_matrix* q, 12685 ae_frame _frame_block; 12691 ae_frame_make(_state, &_frame_block); 12692 ae_matrix_clear(q); 12693 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 12694 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 12698 ae_frame_leave(_state); 12705 ae_matrix_set_length(q, n-1+1, n-1+1, _state); 12706 ae_vector_set_length(&v, n-1+1, _state); 12707 ae_vector_set_length(&work, n-1+1, _state); 12708 for(i=0; i<=n-1; i++) 12710 for(j=0; j<=n-1; j++) 12714 q->ptr.pp_double[i][j] = 1; 12718 q->ptr.pp_double[i][j] = 0; 12726 for(i=0; i<=n-2; i++) 12732 ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1)); 12733 v.ptr.p_double[1] = 1; 12734 applyreflectionfromtheright(q, tau->ptr.p_double[i], &v, 0, n-1, i+1, n-1, &work, _state); 12736 ae_frame_leave(_state); 12740 /************************************************************************* 12741 Unpacking matrix H (the result of matrix A reduction to upper Hessenberg form) 12744 A - output of RMatrixHessenberg subroutine. 12745 N - size of matrix A. 12748 H - matrix H. Array whose indexes range within [0..N-1, 0..N-1]. 12753 *************************************************************************/ 12754 void rmatrixhessenbergunpackh(/* Real */ ae_matrix* a, 12756 /* Real */ ae_matrix* h, 12759 ae_frame _frame_block; 12765 ae_frame_make(_state, &_frame_block); 12766 ae_matrix_clear(h); 12767 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 12768 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 12772 ae_frame_leave(_state); 12775 ae_matrix_set_length(h, n-1+1, n-1+1, _state); 12776 for(i=0; i<=n-1; i++) 12778 for(j=0; j<=i-2; j++) 12780 h->ptr.pp_double[i][j] = 0; 12782 j = ae_maxint(0, i-1, _state); 12783 ae_v_move(&h->ptr.pp_double[i][j], 1, &a->ptr.pp_double[i][j], 1, ae_v_len(j,n-1)); 12785 ae_frame_leave(_state); 12789 /************************************************************************* 12790 Reduction of a symmetric matrix which is given by its higher or lower 12791 triangular part to a tridiagonal matrix using orthogonal similarity 12792 transformation: Q'*A*Q=T. 12795 A - matrix to be transformed 12796 array with elements [0..N-1, 0..N-1]. 12797 N - size of matrix A. 12798 IsUpper - storage format. If IsUpper = True, then matrix A is given 12799 by its upper triangle, and the lower triangle is not used 12800 and not modified by the algorithm, and vice versa 12801 if IsUpper = False. 12804 A - matrices T and Q in compact form (see lower) 12805 Tau - array of factors which are forming matrices H(i) 12806 array with elements [0..N-2]. 12807 D - main diagonal of symmetric matrix T. 12808 array with elements [0..N-1]. 12809 E - secondary diagonal of symmetric matrix T. 12810 array with elements [0..N-2]. 12813 If IsUpper=True, the matrix Q is represented as a product of elementary 12816 Q = H(n-2) . . . H(2) H(0). 12818 Each H(i) has the form 12820 H(i) = I - tau * v * v' 12822 where tau is a real scalar, and v is a real vector with 12823 v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in 12824 A(0:i-1,i+1), and tau in TAU(i). 12826 If IsUpper=False, the matrix Q is represented as a product of elementary 12829 Q = H(0) H(2) . . . H(n-2). 12831 Each H(i) has the form 12833 H(i) = I - tau * v * v' 12835 where tau is a real scalar, and v is a real vector with 12836 v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in A(i+2:n-1,i), 12839 The contents of A on exit are illustrated by the following examples 12842 if UPLO = 'U': if UPLO = 'L': 12844 ( d e v1 v2 v3 ) ( d ) 12845 ( d e v2 v3 ) ( e d ) 12846 ( d e v3 ) ( v0 e d ) 12847 ( d e ) ( v0 v1 e d ) 12848 ( d ) ( v0 v1 v2 e d ) 12850 where d and e denote diagonal and off-diagonal elements of T, and vi 12851 denotes an element of the vector defining H(i). 12853 -- LAPACK routine (version 3.0) -- 12854 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 12855 Courant Institute, Argonne National Lab, and Rice University 12857 *************************************************************************/ 12858 void smatrixtd(/* Real */ ae_matrix* a, 12861 /* Real */ ae_vector* tau, 12862 /* Real */ ae_vector* d, 12863 /* Real */ ae_vector* e, 12866 ae_frame _frame_block; 12875 ae_frame_make(_state, &_frame_block); 12876 ae_vector_clear(tau); 12877 ae_vector_clear(d); 12878 ae_vector_clear(e); 12879 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 12880 ae_vector_init(&t2, 0, DT_REAL, _state, ae_true); 12881 ae_vector_init(&t3, 0, DT_REAL, _state, ae_true); 12885 ae_frame_leave(_state); 12888 ae_vector_set_length(&t, n+1, _state); 12889 ae_vector_set_length(&t2, n+1, _state); 12890 ae_vector_set_length(&t3, n+1, _state); 12893 ae_vector_set_length(tau, n-2+1, _state); 12895 ae_vector_set_length(d, n-1+1, _state); 12898 ae_vector_set_length(e, n-2+1, _state); 12904 * Reduce the upper triangle of A 12906 for(i=n-2; i>=0; i--) 12910 * Generate elementary reflector H() = E - tau * v * v' 12914 ae_v_move(&t.ptr.p_double[2], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(2,i+1)); 12916 t.ptr.p_double[1] = a->ptr.pp_double[i][i+1]; 12917 generatereflection(&t, i+1, &taui, _state); 12920 ae_v_move(&a->ptr.pp_double[0][i+1], a->stride, &t.ptr.p_double[2], 1, ae_v_len(0,i-1)); 12922 a->ptr.pp_double[i][i+1] = t.ptr.p_double[1]; 12923 e->ptr.p_double[i] = a->ptr.pp_double[i][i+1]; 12924 if( ae_fp_neq(taui,0) ) 12928 * Apply H from both sides to A 12930 a->ptr.pp_double[i][i+1] = 1; 12933 * Compute x := tau * A * v storing x in TAU 12935 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(1,i+1)); 12936 symmetricmatrixvectormultiply(a, isupper, 0, i, &t, taui, &t3, _state); 12937 ae_v_move(&tau->ptr.p_double[0], 1, &t3.ptr.p_double[1], 1, ae_v_len(0,i)); 12940 * Compute w := x - 1/2 * tau * (x'*v) * v 12942 v = ae_v_dotproduct(&tau->ptr.p_double[0], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(0,i)); 12943 alpha = -0.5*taui*v; 12944 ae_v_addd(&tau->ptr.p_double[0], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(0,i), alpha); 12947 * Apply the transformation as a rank-2 update: 12948 * A := A - v * w' - w * v' 12950 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(1,i+1)); 12951 ae_v_move(&t3.ptr.p_double[1], 1, &tau->ptr.p_double[0], 1, ae_v_len(1,i+1)); 12952 symmetricrank2update(a, isupper, 0, i, &t, &t3, &t2, -1, _state); 12953 a->ptr.pp_double[i][i+1] = e->ptr.p_double[i]; 12955 d->ptr.p_double[i+1] = a->ptr.pp_double[i+1][i+1]; 12956 tau->ptr.p_double[i] = taui; 12958 d->ptr.p_double[0] = a->ptr.pp_double[0][0]; 12964 * Reduce the lower triangle of A 12966 for(i=0; i<=n-2; i++) 12970 * Generate elementary reflector H = E - tau * v * v' 12972 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1)); 12973 generatereflection(&t, n-i-1, &taui, _state); 12974 ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(i+1,n-1)); 12975 e->ptr.p_double[i] = a->ptr.pp_double[i+1][i]; 12976 if( ae_fp_neq(taui,0) ) 12980 * Apply H from both sides to A 12982 a->ptr.pp_double[i+1][i] = 1; 12985 * Compute x := tau * A * v storing y in TAU 12987 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1)); 12988 symmetricmatrixvectormultiply(a, isupper, i+1, n-1, &t, taui, &t2, _state); 12989 ae_v_move(&tau->ptr.p_double[i], 1, &t2.ptr.p_double[1], 1, ae_v_len(i,n-2)); 12992 * Compute w := x - 1/2 * tau * (x'*v) * v 12994 v = ae_v_dotproduct(&tau->ptr.p_double[i], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(i,n-2)); 12995 alpha = -0.5*taui*v; 12996 ae_v_addd(&tau->ptr.p_double[i], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(i,n-2), alpha); 12999 * Apply the transformation as a rank-2 update: 13000 * A := A - v * w' - w * v' 13003 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1)); 13004 ae_v_move(&t2.ptr.p_double[1], 1, &tau->ptr.p_double[i], 1, ae_v_len(1,n-i-1)); 13005 symmetricrank2update(a, isupper, i+1, n-1, &t, &t2, &t3, -1, _state); 13006 a->ptr.pp_double[i+1][i] = e->ptr.p_double[i]; 13008 d->ptr.p_double[i] = a->ptr.pp_double[i][i]; 13009 tau->ptr.p_double[i] = taui; 13011 d->ptr.p_double[n-1] = a->ptr.pp_double[n-1][n-1]; 13013 ae_frame_leave(_state); 13017 /************************************************************************* 13018 Unpacking matrix Q which reduces symmetric matrix to a tridiagonal 13022 A - the result of a SMatrixTD subroutine 13023 N - size of matrix A. 13024 IsUpper - storage format (a parameter of SMatrixTD subroutine) 13025 Tau - the result of a SMatrixTD subroutine 13028 Q - transformation matrix. 13029 array with elements [0..N-1, 0..N-1]. 13032 Copyright 2005-2010 by Bochkanov Sergey 13033 *************************************************************************/ 13034 void smatrixtdunpackq(/* Real */ ae_matrix* a, 13037 /* Real */ ae_vector* tau, 13038 /* Real */ ae_matrix* q, 13041 ae_frame _frame_block; 13047 ae_frame_make(_state, &_frame_block); 13048 ae_matrix_clear(q); 13049 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 13050 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 13054 ae_frame_leave(_state); 13061 ae_matrix_set_length(q, n-1+1, n-1+1, _state); 13062 ae_vector_set_length(&v, n+1, _state); 13063 ae_vector_set_length(&work, n-1+1, _state); 13064 for(i=0; i<=n-1; i++) 13066 for(j=0; j<=n-1; j++) 13070 q->ptr.pp_double[i][j] = 1; 13074 q->ptr.pp_double[i][j] = 0; 13084 for(i=0; i<=n-2; i++) 13090 ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[0][i+1], a->stride, ae_v_len(1,i+1)); 13091 v.ptr.p_double[i+1] = 1; 13092 applyreflectionfromtheleft(q, tau->ptr.p_double[i], &v, 0, i, 0, n-1, &work, _state); 13097 for(i=n-2; i>=0; i--) 13103 ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[i+1][i], a->stride, ae_v_len(1,n-i-1)); 13104 v.ptr.p_double[1] = 1; 13105 applyreflectionfromtheleft(q, tau->ptr.p_double[i], &v, i+1, n-1, 0, n-1, &work, _state); 13108 ae_frame_leave(_state); 13112 /************************************************************************* 13113 Reduction of a Hermitian matrix which is given by its higher or lower 13114 triangular part to a real tridiagonal matrix using unitary similarity 13115 transformation: Q'*A*Q = T. 13118 A - matrix to be transformed 13119 array with elements [0..N-1, 0..N-1]. 13120 N - size of matrix A. 13121 IsUpper - storage format. If IsUpper = True, then matrix A is given 13122 by its upper triangle, and the lower triangle is not used 13123 and not modified by the algorithm, and vice versa 13124 if IsUpper = False. 13127 A - matrices T and Q in compact form (see lower) 13128 Tau - array of factors which are forming matrices H(i) 13129 array with elements [0..N-2]. 13130 D - main diagonal of real symmetric matrix T. 13131 array with elements [0..N-1]. 13132 E - secondary diagonal of real symmetric matrix T. 13133 array with elements [0..N-2]. 13136 If IsUpper=True, the matrix Q is represented as a product of elementary 13139 Q = H(n-2) . . . H(2) H(0). 13141 Each H(i) has the form 13143 H(i) = I - tau * v * v' 13145 where tau is a complex scalar, and v is a complex vector with 13146 v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in 13147 A(0:i-1,i+1), and tau in TAU(i). 13149 If IsUpper=False, the matrix Q is represented as a product of elementary 13152 Q = H(0) H(2) . . . H(n-2). 13154 Each H(i) has the form 13156 H(i) = I - tau * v * v' 13158 where tau is a complex scalar, and v is a complex vector with 13159 v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in A(i+2:n-1,i), 13162 The contents of A on exit are illustrated by the following examples 13165 if UPLO = 'U': if UPLO = 'L': 13167 ( d e v1 v2 v3 ) ( d ) 13168 ( d e v2 v3 ) ( e d ) 13169 ( d e v3 ) ( v0 e d ) 13170 ( d e ) ( v0 v1 e d ) 13171 ( d ) ( v0 v1 v2 e d ) 13173 where d and e denote diagonal and off-diagonal elements of T, and vi 13174 denotes an element of the vector defining H(i). 13176 -- LAPACK routine (version 3.0) -- 13177 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 13178 Courant Institute, Argonne National Lab, and Rice University 13180 *************************************************************************/ 13181 void hmatrixtd(/* Complex */ ae_matrix* a, 13184 /* Complex */ ae_vector* tau, 13185 /* Real */ ae_vector* d, 13186 /* Real */ ae_vector* e, 13189 ae_frame _frame_block; 13198 ae_frame_make(_state, &_frame_block); 13199 ae_vector_clear(tau); 13200 ae_vector_clear(d); 13201 ae_vector_clear(e); 13202 ae_vector_init(&t, 0, DT_COMPLEX, _state, ae_true); 13203 ae_vector_init(&t2, 0, DT_COMPLEX, _state, ae_true); 13204 ae_vector_init(&t3, 0, DT_COMPLEX, _state, ae_true); 13208 ae_frame_leave(_state); 13211 for(i=0; i<=n-1; i++) 13213 ae_assert(ae_fp_eq(a->ptr.pp_complex[i][i].y,0), "Assertion failed
", _state); 13217 ae_vector_set_length(tau, n-2+1, _state); 13218 ae_vector_set_length(e, n-2+1, _state); 13220 ae_vector_set_length(d, n-1+1, _state); 13221 ae_vector_set_length(&t, n-1+1, _state); 13222 ae_vector_set_length(&t2, n-1+1, _state); 13223 ae_vector_set_length(&t3, n-1+1, _state); 13228 * Reduce the upper triangle of A 13230 a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(a->ptr.pp_complex[n-1][n-1].x); 13231 for(i=n-2; i>=0; i--) 13235 * Generate elementary reflector H = I+1 - tau * v * v' 13237 alpha = a->ptr.pp_complex[i][i+1]; 13238 t.ptr.p_complex[1] = alpha; 13241 ae_v_cmove(&t.ptr.p_complex[2], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N
", ae_v_len(2,i+1)); 13243 complexgeneratereflection(&t, i+1, &taui, _state); 13246 ae_v_cmove(&a->ptr.pp_complex[0][i+1], a->stride, &t.ptr.p_complex[2], 1, "N
", ae_v_len(0,i-1)); 13248 alpha = t.ptr.p_complex[1]; 13249 e->ptr.p_double[i] = alpha.x; 13250 if( ae_c_neq_d(taui,0) ) 13254 * Apply H(I+1) from both sides to A 13256 a->ptr.pp_complex[i][i+1] = ae_complex_from_d(1); 13259 * Compute x := tau * A * v storing x in TAU 13261 ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N
", ae_v_len(1,i+1)); 13262 hermitianmatrixvectormultiply(a, isupper, 0, i, &t, taui, &t2, _state); 13263 ae_v_cmove(&tau->ptr.p_complex[0], 1, &t2.ptr.p_complex[1], 1, "N
", ae_v_len(0,i)); 13266 * Compute w := x - 1/2 * tau * (x'*v) * v 13268 v = ae_v_cdotproduct(&tau->ptr.p_complex[0], 1, "Conj
", &a->ptr.pp_complex[0][i+1], a->stride, "N
", ae_v_len(0,i)); 13269 alpha = ae_c_neg(ae_c_mul(ae_c_mul_d(taui,0.5),v)); 13270 ae_v_caddc(&tau->ptr.p_complex[0], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N
", ae_v_len(0,i), alpha); 13273 * Apply the transformation as a rank-2 update: 13274 * A := A - v * w' - w * v' 13276 ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N
", ae_v_len(1,i+1)); 13277 ae_v_cmove(&t3.ptr.p_complex[1], 1, &tau->ptr.p_complex[0], 1, "N
", ae_v_len(1,i+1)); 13278 hermitianrank2update(a, isupper, 0, i, &t, &t3, &t2, ae_complex_from_d(-1), _state); 13282 a->ptr.pp_complex[i][i] = ae_complex_from_d(a->ptr.pp_complex[i][i].x); 13284 a->ptr.pp_complex[i][i+1] = ae_complex_from_d(e->ptr.p_double[i]); 13285 d->ptr.p_double[i+1] = a->ptr.pp_complex[i+1][i+1].x; 13286 tau->ptr.p_complex[i] = taui; 13288 d->ptr.p_double[0] = a->ptr.pp_complex[0][0].x; 13294 * Reduce the lower triangle of A 13296 a->ptr.pp_complex[0][0] = ae_complex_from_d(a->ptr.pp_complex[0][0].x); 13297 for(i=0; i<=n-2; i++) 13301 * Generate elementary reflector H = I - tau * v * v' 13303 ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N
", ae_v_len(1,n-i-1)); 13304 complexgeneratereflection(&t, n-i-1, &taui, _state); 13305 ae_v_cmove(&a->ptr.pp_complex[i+1][i], a->stride, &t.ptr.p_complex[1], 1, "N
", ae_v_len(i+1,n-1)); 13306 e->ptr.p_double[i] = a->ptr.pp_complex[i+1][i].x; 13307 if( ae_c_neq_d(taui,0) ) 13311 * Apply H(i) from both sides to A(i+1:n,i+1:n) 13313 a->ptr.pp_complex[i+1][i] = ae_complex_from_d(1); 13316 * Compute x := tau * A * v storing y in TAU 13318 ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N
", ae_v_len(1,n-i-1)); 13319 hermitianmatrixvectormultiply(a, isupper, i+1, n-1, &t, taui, &t2, _state); 13320 ae_v_cmove(&tau->ptr.p_complex[i], 1, &t2.ptr.p_complex[1], 1, "N
", ae_v_len(i,n-2)); 13323 * Compute w := x - 1/2 * tau * (x'*v) * v 13325 v = ae_v_cdotproduct(&tau->ptr.p_complex[i], 1, "Conj
", &a->ptr.pp_complex[i+1][i], a->stride, "N
", ae_v_len(i,n-2)); 13326 alpha = ae_c_neg(ae_c_mul(ae_c_mul_d(taui,0.5),v)); 13327 ae_v_caddc(&tau->ptr.p_complex[i], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N
", ae_v_len(i,n-2), alpha); 13330 * Apply the transformation as a rank-2 update: 13331 * A := A - v * w' - w * v' 13333 ae_v_cmove(&t.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N
", ae_v_len(1,n-i-1)); 13334 ae_v_cmove(&t2.ptr.p_complex[1], 1, &tau->ptr.p_complex[i], 1, "N
", ae_v_len(1,n-i-1)); 13335 hermitianrank2update(a, isupper, i+1, n-1, &t, &t2, &t3, ae_complex_from_d(-1), _state); 13339 a->ptr.pp_complex[i+1][i+1] = ae_complex_from_d(a->ptr.pp_complex[i+1][i+1].x); 13341 a->ptr.pp_complex[i+1][i] = ae_complex_from_d(e->ptr.p_double[i]); 13342 d->ptr.p_double[i] = a->ptr.pp_complex[i][i].x; 13343 tau->ptr.p_complex[i] = taui; 13345 d->ptr.p_double[n-1] = a->ptr.pp_complex[n-1][n-1].x; 13347 ae_frame_leave(_state); 13351 /************************************************************************* 13352 Unpacking matrix Q which reduces a Hermitian matrix to a real tridiagonal 13356 A - the result of a HMatrixTD subroutine 13357 N - size of matrix A. 13358 IsUpper - storage format (a parameter of HMatrixTD subroutine) 13359 Tau - the result of a HMatrixTD subroutine 13362 Q - transformation matrix. 13363 array with elements [0..N-1, 0..N-1]. 13366 Copyright 2005-2010 by Bochkanov Sergey 13367 *************************************************************************/ 13368 void hmatrixtdunpackq(/* Complex */ ae_matrix* a, 13371 /* Complex */ ae_vector* tau, 13372 /* Complex */ ae_matrix* q, 13375 ae_frame _frame_block; 13381 ae_frame_make(_state, &_frame_block); 13382 ae_matrix_clear(q); 13383 ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true); 13384 ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true); 13388 ae_frame_leave(_state); 13395 ae_matrix_set_length(q, n-1+1, n-1+1, _state); 13396 ae_vector_set_length(&v, n+1, _state); 13397 ae_vector_set_length(&work, n-1+1, _state); 13398 for(i=0; i<=n-1; i++) 13400 for(j=0; j<=n-1; j++) 13404 q->ptr.pp_complex[i][j] = ae_complex_from_d(1); 13408 q->ptr.pp_complex[i][j] = ae_complex_from_d(0); 13418 for(i=0; i<=n-2; i++) 13424 ae_v_cmove(&v.ptr.p_complex[1], 1, &a->ptr.pp_complex[0][i+1], a->stride, "N
", ae_v_len(1,i+1)); 13425 v.ptr.p_complex[i+1] = ae_complex_from_d(1); 13426 complexapplyreflectionfromtheleft(q, tau->ptr.p_complex[i], &v, 0, i, 0, n-1, &work, _state); 13431 for(i=n-2; i>=0; i--) 13437 ae_v_cmove(&v.ptr.p_complex[1], 1, &a->ptr.pp_complex[i+1][i], a->stride, "N
", ae_v_len(1,n-i-1)); 13438 v.ptr.p_complex[1] = ae_complex_from_d(1); 13439 complexapplyreflectionfromtheleft(q, tau->ptr.p_complex[i], &v, i+1, n-1, 0, n-1, &work, _state); 13442 ae_frame_leave(_state); 13446 /************************************************************************* 13447 Base case for complex QR 13449 -- LAPACK routine (version 3.0) -- 13450 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 13451 Courant Institute, Argonne National Lab, and Rice University 13452 September 30, 1994. 13453 Sergey Bochkanov, ALGLIB project, translation from FORTRAN to 13454 pseudocode, 2007-2010. 13455 *************************************************************************/ 13456 static void ortfac_cmatrixqrbasecase(/* Complex */ ae_matrix* a, 13459 /* Complex */ ae_vector* work, 13460 /* Complex */ ae_vector* t, 13461 /* Complex */ ae_vector* tau, 13471 minmn = ae_minint(m, n, _state); 13478 * Test the input arguments 13480 k = ae_minint(m, n, _state); 13481 for(i=0; i<=k-1; i++) 13485 * Generate elementary reflector H(i) to annihilate A(i+1:m,i) 13488 ae_v_cmove(&t->ptr.p_complex[1], 1, &a->ptr.pp_complex[i][i], a->stride, "N
", ae_v_len(1,mmi)); 13489 complexgeneratereflection(t, mmi, &tmp, _state); 13490 tau->ptr.p_complex[i] = tmp; 13491 ae_v_cmove(&a->ptr.pp_complex[i][i], a->stride, &t->ptr.p_complex[1], 1, "N
", ae_v_len(i,m-1)); 13492 t->ptr.p_complex[1] = ae_complex_from_d(1); 13497 * Apply H'(i) to A(i:m,i+1:n) from the left 13499 complexapplyreflectionfromtheleft(a, ae_c_conj(tau->ptr.p_complex[i], _state), t, i, m-1, i+1, n-1, work, _state); 13505 /************************************************************************* 13506 Base case for complex LQ 13508 -- LAPACK routine (version 3.0) -- 13509 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 13510 Courant Institute, Argonne National Lab, and Rice University 13511 September 30, 1994. 13512 Sergey Bochkanov, ALGLIB project, translation from FORTRAN to 13513 pseudocode, 2007-2010. 13514 *************************************************************************/ 13515 static void ortfac_cmatrixlqbasecase(/* Complex */ ae_matrix* a, 13518 /* Complex */ ae_vector* work, 13519 /* Complex */ ae_vector* t, 13520 /* Complex */ ae_vector* tau, 13528 minmn = ae_minint(m, n, _state); 13535 * Test the input arguments 13537 for(i=0; i<=minmn-1; i++) 13541 * Generate elementary reflector H(i) 13543 * NOTE: ComplexGenerateReflection() generates left reflector, 13544 * i.e. H which reduces x by applyiong from the left, but we 13545 * need RIGHT reflector. So we replace H=E-tau*v*v' by H^H, 13546 * which changes v to conj(v). 13548 ae_v_cmove(&t->ptr.p_complex[1], 1, &a->ptr.pp_complex[i][i], 1, "Conj
", ae_v_len(1,n-i)); 13549 complexgeneratereflection(t, n-i, &tmp, _state); 13550 tau->ptr.p_complex[i] = tmp; 13551 ae_v_cmove(&a->ptr.pp_complex[i][i], 1, &t->ptr.p_complex[1], 1, "Conj
", ae_v_len(i,n-1)); 13552 t->ptr.p_complex[1] = ae_complex_from_d(1); 13559 complexapplyreflectionfromtheright(a, tau->ptr.p_complex[i], t, i+1, m-1, i, n-1, work, _state); 13565 /************************************************************************* 13566 Generate block reflector: 13567 * fill unused parts of reflectors matrix by zeros 13568 * fill diagonal of reflectors matrix by ones 13569 * generate triangular factor T 13572 A - either LengthA*BlockSize (if ColumnwiseA) or 13573 BlockSize*LengthA (if not ColumnwiseA) matrix of 13574 elementary reflectors. 13576 Tau - scalar factors 13577 ColumnwiseA - reflectors are stored in rows or in columns 13578 LengthA - length of largest reflector 13579 BlockSize - number of reflectors 13580 T - array[BlockSize,2*BlockSize]. Left BlockSize*BlockSize 13581 submatrix stores triangular factor on exit. 13582 WORK - array[BlockSize] 13584 -- ALGLIB routine -- 13587 *************************************************************************/ 13588 static void ortfac_rmatrixblockreflector(/* Real */ ae_matrix* a, 13589 /* Real */ ae_vector* tau, 13590 ae_bool columnwisea, 13592 ae_int_t blocksize, 13593 /* Real */ ae_matrix* t, 13594 /* Real */ ae_vector* work, 13605 * fill beginning of new column with zeros, 13606 * load 1.0 in the first non-zero element 13608 for(k=0; k<=blocksize-1; k++) 13612 for(i=0; i<=k-1; i++) 13614 a->ptr.pp_double[i][k] = 0; 13619 for(i=0; i<=k-1; i++) 13621 a->ptr.pp_double[k][i] = 0; 13624 a->ptr.pp_double[k][k] = 1; 13628 * Calculate Gram matrix of A 13630 for(i=0; i<=blocksize-1; i++) 13632 for(j=0; j<=blocksize-1; j++) 13634 t->ptr.pp_double[i][blocksize+j] = 0; 13637 for(k=0; k<=lengtha-1; k++) 13639 for(j=1; j<=blocksize-1; j++) 13643 v = a->ptr.pp_double[k][j]; 13644 if( ae_fp_neq(v,0) ) 13646 ae_v_addd(&t->ptr.pp_double[j][blocksize], 1, &a->ptr.pp_double[k][0], 1, ae_v_len(blocksize,blocksize+j-1), v); 13651 v = a->ptr.pp_double[j][k]; 13652 if( ae_fp_neq(v,0) ) 13654 ae_v_addd(&t->ptr.pp_double[j][blocksize], 1, &a->ptr.pp_double[0][k], a->stride, ae_v_len(blocksize,blocksize+j-1), v); 13661 * Prepare Y (stored in TmpA) and T (stored in TmpT) 13663 for(k=0; k<=blocksize-1; k++) 13667 * fill non-zero part of T, use pre-calculated Gram matrix 13669 ae_v_move(&work->ptr.p_double[0], 1, &t->ptr.pp_double[k][blocksize], 1, ae_v_len(0,k-1)); 13670 for(i=0; i<=k-1; i++) 13672 v = ae_v_dotproduct(&t->ptr.pp_double[i][i], 1, &work->ptr.p_double[i], 1, ae_v_len(i,k-1)); 13673 t->ptr.pp_double[i][k] = -tau->ptr.p_double[k]*v; 13675 t->ptr.pp_double[k][k] = -tau->ptr.p_double[k]; 13678 * Rest of T is filled by zeros 13680 for(i=k+1; i<=blocksize-1; i++) 13682 t->ptr.pp_double[i][k] = 0; 13688 /************************************************************************* 13689 Generate block reflector (complex): 13690 * fill unused parts of reflectors matrix by zeros 13691 * fill diagonal of reflectors matrix by ones 13692 * generate triangular factor T 13695 -- ALGLIB routine -- 13698 *************************************************************************/ 13699 static void ortfac_cmatrixblockreflector(/* Complex */ ae_matrix* a, 13700 /* Complex */ ae_vector* tau, 13701 ae_bool columnwisea, 13703 ae_int_t blocksize, 13704 /* Complex */ ae_matrix* t, 13705 /* Complex */ ae_vector* work, 13715 * Prepare Y (stored in TmpA) and T (stored in TmpT) 13717 for(k=0; k<=blocksize-1; k++) 13721 * fill beginning of new column with zeros, 13722 * load 1.0 in the first non-zero element 13726 for(i=0; i<=k-1; i++) 13728 a->ptr.pp_complex[i][k] = ae_complex_from_d(0); 13733 for(i=0; i<=k-1; i++) 13735 a->ptr.pp_complex[k][i] = ae_complex_from_d(0); 13738 a->ptr.pp_complex[k][k] = ae_complex_from_d(1); 13741 * fill non-zero part of T, 13743 for(i=0; i<=k-1; i++) 13747 v = ae_v_cdotproduct(&a->ptr.pp_complex[k][i], a->stride, "Conj
", &a->ptr.pp_complex[k][k], a->stride, "N
", ae_v_len(k,lengtha-1)); 13751 v = ae_v_cdotproduct(&a->ptr.pp_complex[i][k], 1, "N
", &a->ptr.pp_complex[k][k], 1, "Conj
", ae_v_len(k,lengtha-1)); 13753 work->ptr.p_complex[i] = v; 13755 for(i=0; i<=k-1; i++) 13757 v = ae_v_cdotproduct(&t->ptr.pp_complex[i][i], 1, "N
", &work->ptr.p_complex[i], 1, "N
", ae_v_len(i,k-1)); 13758 t->ptr.pp_complex[i][k] = ae_c_neg(ae_c_mul(tau->ptr.p_complex[k],v)); 13760 t->ptr.pp_complex[k][k] = ae_c_neg(tau->ptr.p_complex[k]); 13763 * Rest of T is filled by zeros 13765 for(i=k+1; i<=blocksize-1; i++) 13767 t->ptr.pp_complex[i][k] = ae_complex_from_d(0); 13775 /************************************************************************* 13776 Singular value decomposition of a bidiagonal matrix (extended algorithm) 13778 The algorithm performs the singular value decomposition of a bidiagonal 13779 matrix B (upper or lower) representing it as B = Q*S*P^T, where Q and P - 13780 orthogonal matrices, S - diagonal matrix with non-negative elements on the 13781 main diagonal, in descending order. 13783 The algorithm finds singular values. In addition, the algorithm can 13784 calculate matrices Q and P (more precisely, not the matrices, but their 13785 product with given matrices U and VT - U*Q and (P^T)*VT)). Of course, 13786 matrices U and VT can be of any type, including identity. Furthermore, the 13787 algorithm can calculate Q'*C (this product is calculated more effectively 13788 than U*Q, because this calculation operates with rows instead of matrix 13791 The feature of the algorithm is its ability to find all singular values 13792 including those which are arbitrarily close to 0 with relative accuracy 13793 close to machine precision. If the parameter IsFractionalAccuracyRequired 13794 is set to True, all singular values will have high relative accuracy close 13795 to machine precision. If the parameter is set to False, only the biggest 13796 singular value will have relative accuracy close to machine precision. 13797 The absolute error of other singular values is equal to the absolute error 13798 of the biggest singular value. 13801 D - main diagonal of matrix B. 13802 Array whose index ranges within [0..N-1]. 13803 E - superdiagonal (or subdiagonal) of matrix B. 13804 Array whose index ranges within [0..N-2]. 13805 N - size of matrix B. 13806 IsUpper - True, if the matrix is upper bidiagonal. 13807 IsFractionalAccuracyRequired - 13808 THIS PARAMETER IS IGNORED SINCE ALGLIB 3.5.0 13809 SINGULAR VALUES ARE ALWAYS SEARCHED WITH HIGH ACCURACY. 13810 U - matrix to be multiplied by Q. 13811 Array whose indexes range within [0..NRU-1, 0..N-1]. 13812 The matrix can be bigger, in that case only the submatrix 13813 [0..NRU-1, 0..N-1] will be multiplied by Q. 13814 NRU - number of rows in matrix U. 13815 C - matrix to be multiplied by Q'. 13816 Array whose indexes range within [0..N-1, 0..NCC-1]. 13817 The matrix can be bigger, in that case only the submatrix 13818 [0..N-1, 0..NCC-1] will be multiplied by Q'. 13819 NCC - number of columns in matrix C. 13820 VT - matrix to be multiplied by P^T. 13821 Array whose indexes range within [0..N-1, 0..NCVT-1]. 13822 The matrix can be bigger, in that case only the submatrix 13823 [0..N-1, 0..NCVT-1] will be multiplied by P^T. 13824 NCVT - number of columns in matrix VT. 13827 D - singular values of matrix B in descending order. 13828 U - if NRU>0, contains matrix U*Q. 13829 VT - if NCVT>0, contains matrix (P^T)*VT. 13830 C - if NCC>0, contains matrix Q'*C. 13833 True, if the algorithm has converged. 13834 False, if the algorithm hasn't converged (rare case). 13836 Additional information: 13837 The type of convergence is controlled by the internal parameter TOL. 13838 If the parameter is greater than 0, the singular values will have 13839 relative accuracy TOL. If TOL<0, the singular values will have 13840 absolute accuracy ABS(TOL)*norm(B). 13841 By default, |TOL| falls within the range of 10*Epsilon and 100*Epsilon, 13842 where Epsilon is the machine precision. It is not recommended to use 13843 TOL less than 10*Epsilon since this will considerably slow down the 13844 algorithm and may not lead to error decreasing. 13847 changed MAXITR from 6 to 12. 13849 -- LAPACK routine (version 3.0) -- 13850 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 13851 Courant Institute, Argonne National Lab, and Rice University 13853 *************************************************************************/ 13854 ae_bool rmatrixbdsvd(/* Real */ ae_vector* d, 13855 /* Real */ ae_vector* e, 13858 ae_bool isfractionalaccuracyrequired, 13859 /* Real */ ae_matrix* u, 13861 /* Real */ ae_matrix* c, 13863 /* Real */ ae_matrix* vt, 13867 ae_frame _frame_block; 13873 ae_frame_make(_state, &_frame_block); 13874 ae_vector_init_copy(&_e, e, _state, ae_true); 13876 ae_vector_init(&d1, 0, DT_REAL, _state, ae_true); 13877 ae_vector_init(&e1, 0, DT_REAL, _state, ae_true); 13879 ae_vector_set_length(&d1, n+1, _state); 13880 ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n)); 13883 ae_vector_set_length(&e1, n-1+1, _state); 13884 ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1)); 13886 result = bdsvd_bidiagonalsvddecompositioninternal(&d1, &e1, n, isupper, isfractionalaccuracyrequired, u, 0, nru, c, 0, ncc, vt, 0, ncvt, _state); 13887 ae_v_move(&d->ptr.p_double[0], 1, &d1.ptr.p_double[1], 1, ae_v_len(0,n-1)); 13888 ae_frame_leave(_state); 13893 ae_bool bidiagonalsvddecomposition(/* Real */ ae_vector* d, 13894 /* Real */ ae_vector* e, 13897 ae_bool isfractionalaccuracyrequired, 13898 /* Real */ ae_matrix* u, 13900 /* Real */ ae_matrix* c, 13902 /* Real */ ae_matrix* vt, 13906 ae_frame _frame_block; 13910 ae_frame_make(_state, &_frame_block); 13911 ae_vector_init_copy(&_e, e, _state, ae_true); 13914 result = bdsvd_bidiagonalsvddecompositioninternal(d, e, n, isupper, isfractionalaccuracyrequired, u, 1, nru, c, 1, ncc, vt, 1, ncvt, _state); 13915 ae_frame_leave(_state); 13920 /************************************************************************* 13921 Internal working subroutine for bidiagonal decomposition 13922 *************************************************************************/ 13923 static ae_bool bdsvd_bidiagonalsvddecompositioninternal(/* Real */ ae_vector* d, 13924 /* Real */ ae_vector* e, 13927 ae_bool isfractionalaccuracyrequired, 13928 /* Real */ ae_matrix* u, 13931 /* Real */ ae_matrix* c, 13934 /* Real */ ae_matrix* vt, 13939 ae_frame _frame_block; 13985 ae_bool matrixsplitflag; 13995 ae_bool bchangedir; 14001 ae_frame_make(_state, &_frame_block); 14002 ae_vector_init_copy(&_e, e, _state, ae_true); 14004 ae_vector_init(&work0, 0, DT_REAL, _state, ae_true); 14005 ae_vector_init(&work1, 0, DT_REAL, _state, ae_true); 14006 ae_vector_init(&work2, 0, DT_REAL, _state, ae_true); 14007 ae_vector_init(&work3, 0, DT_REAL, _state, ae_true); 14008 ae_vector_init(&utemp, 0, DT_REAL, _state, ae_true); 14009 ae_vector_init(&vttemp, 0, DT_REAL, _state, ae_true); 14010 ae_vector_init(&ctemp, 0, DT_REAL, _state, ae_true); 14011 ae_vector_init(&etemp, 0, DT_REAL, _state, ae_true); 14016 ae_frame_leave(_state); 14021 if( ae_fp_less(d->ptr.p_double[1],0) ) 14023 d->ptr.p_double[1] = -d->ptr.p_double[1]; 14026 ae_v_muld(&vt->ptr.pp_double[vstart][vstart], 1, ae_v_len(vstart,vstart+ncvt-1), -1); 14029 ae_frame_leave(_state); 14034 * these initializers are not really necessary, 14035 * but without them compiler complains about uninitialized locals 14043 ae_vector_set_length(&work0, n-1+1, _state); 14044 ae_vector_set_length(&work1, n-1+1, _state); 14045 ae_vector_set_length(&work2, n-1+1, _state); 14046 ae_vector_set_length(&work3, n-1+1, _state); 14047 uend = ustart+ae_maxint(nru-1, 0, _state); 14048 vend = vstart+ae_maxint(ncvt-1, 0, _state); 14049 cend = cstart+ae_maxint(ncc-1, 0, _state); 14050 ae_vector_set_length(&utemp, uend+1, _state); 14051 ae_vector_set_length(&vttemp, vend+1, _state); 14052 ae_vector_set_length(&ctemp, cend+1, _state); 14057 * resize E from N-1 to N 14059 ae_vector_set_length(&etemp, n+1, _state); 14060 for(i=1; i<=n-1; i++) 14062 etemp.ptr.p_double[i] = e->ptr.p_double[i]; 14064 ae_vector_set_length(e, n+1, _state); 14065 for(i=1; i<=n-1; i++) 14067 e->ptr.p_double[i] = etemp.ptr.p_double[i]; 14069 e->ptr.p_double[n] = 0; 14073 * Get machine constants 14075 eps = ae_machineepsilon; 14076 unfl = ae_minrealnumber; 14079 * If matrix lower bidiagonal, rotate to be upper bidiagonal 14080 * by applying Givens rotations on the left 14084 for(i=1; i<=n-1; i++) 14086 generaterotation(d->ptr.p_double[i], e->ptr.p_double[i], &cs, &sn, &r, _state); 14087 d->ptr.p_double[i] = r; 14088 e->ptr.p_double[i] = sn*d->ptr.p_double[i+1]; 14089 d->ptr.p_double[i+1] = cs*d->ptr.p_double[i+1]; 14090 work0.ptr.p_double[i] = cs; 14091 work1.ptr.p_double[i] = sn; 14095 * Update singular vectors if desired 14099 applyrotationsfromtheright(fwddir, ustart, uend, 1+ustart-1, n+ustart-1, &work0, &work1, u, &utemp, _state); 14103 applyrotationsfromtheleft(fwddir, 1+cstart-1, n+cstart-1, cstart, cend, &work0, &work1, c, &ctemp, _state); 14108 * Compute singular values to relative accuracy TOL 14109 * (By setting TOL to be negative, algorithm will compute 14110 * singular values to absolute accuracy ABS(TOL)*norm(input matrix)) 14112 tolmul = ae_maxreal(10, ae_minreal(100, ae_pow(eps, -0.125, _state), _state), _state); 14116 * Compute approximate maximum, minimum singular values 14119 for(i=1; i<=n; i++) 14121 smax = ae_maxreal(smax, ae_fabs(d->ptr.p_double[i], _state), _state); 14123 for(i=1; i<=n-1; i++) 14125 smax = ae_maxreal(smax, ae_fabs(e->ptr.p_double[i], _state), _state); 14128 if( ae_fp_greater_eq(tol,0) ) 14132 * Relative accuracy desired 14134 sminoa = ae_fabs(d->ptr.p_double[1], _state); 14135 if( ae_fp_neq(sminoa,0) ) 14138 for(i=2; i<=n; i++) 14140 mu = ae_fabs(d->ptr.p_double[i], _state)*(mu/(mu+ae_fabs(e->ptr.p_double[i-1], _state))); 14141 sminoa = ae_minreal(sminoa, mu, _state); 14142 if( ae_fp_eq(sminoa,0) ) 14148 sminoa = sminoa/ae_sqrt(n, _state); 14149 thresh = ae_maxreal(tol*sminoa, maxitr*n*n*unfl, _state); 14155 * Absolute accuracy desired 14157 thresh = ae_maxreal(ae_fabs(tol, _state)*smax, maxitr*n*n*unfl, _state); 14161 * Prepare for main iteration loop for the singular values 14162 * (MAXIT is the maximum number of passes through the inner 14163 * loop permitted before nonconvergence signalled.) 14165 maxit = maxitr*n*n; 14171 * M points to last element of unconverged part of matrix 14176 * Begin main iteration loop 14182 * Check for convergence or exceeding iteration count 14191 ae_frame_leave(_state); 14196 * Find diagonal block of matrix to work on 14198 if( ae_fp_less(tol,0)&&ae_fp_less_eq(ae_fabs(d->ptr.p_double[m], _state),thresh) ) 14200 d->ptr.p_double[m] = 0; 14202 smax = ae_fabs(d->ptr.p_double[m], _state); 14204 matrixsplitflag = ae_false; 14205 for(lll=1; lll<=m-1; lll++) 14208 abss = ae_fabs(d->ptr.p_double[ll], _state); 14209 abse = ae_fabs(e->ptr.p_double[ll], _state); 14210 if( ae_fp_less(tol,0)&&ae_fp_less_eq(abss,thresh) ) 14212 d->ptr.p_double[ll] = 0; 14214 if( ae_fp_less_eq(abse,thresh) ) 14216 matrixsplitflag = ae_true; 14219 smin = ae_minreal(smin, abss, _state); 14220 smax = ae_maxreal(smax, ae_maxreal(abss, abse, _state), _state); 14222 if( !matrixsplitflag ) 14230 * Matrix splits since E(LL) = 0 14232 e->ptr.p_double[ll] = 0; 14237 * Convergence of bottom singular value, return to top of loop 14246 * E(LL) through E(M-1) are nonzero, E(LL-1) is zero 14252 * 2 by 2 block, handle separately 14254 bdsvd_svdv2x2(d->ptr.p_double[m-1], e->ptr.p_double[m-1], d->ptr.p_double[m], &sigmn, &sigmx, &sinr, &cosr, &sinl, &cosl, _state); 14255 d->ptr.p_double[m-1] = sigmx; 14256 e->ptr.p_double[m-1] = 0; 14257 d->ptr.p_double[m] = sigmn; 14260 * Compute singular vectors, if desired 14264 mm0 = m+(vstart-1); 14265 mm1 = m-1+(vstart-1); 14266 ae_v_moved(&vttemp.ptr.p_double[vstart], 1, &vt->ptr.pp_double[mm1][vstart], 1, ae_v_len(vstart,vend), cosr); 14267 ae_v_addd(&vttemp.ptr.p_double[vstart], 1, &vt->ptr.pp_double[mm0][vstart], 1, ae_v_len(vstart,vend), sinr); 14268 ae_v_muld(&vt->ptr.pp_double[mm0][vstart], 1, ae_v_len(vstart,vend), cosr); 14269 ae_v_subd(&vt->ptr.pp_double[mm0][vstart], 1, &vt->ptr.pp_double[mm1][vstart], 1, ae_v_len(vstart,vend), sinr); 14270 ae_v_move(&vt->ptr.pp_double[mm1][vstart], 1, &vttemp.ptr.p_double[vstart], 1, ae_v_len(vstart,vend)); 14275 mm1 = m-1+ustart-1; 14276 ae_v_moved(&utemp.ptr.p_double[ustart], 1, &u->ptr.pp_double[ustart][mm1], u->stride, ae_v_len(ustart,uend), cosl); 14277 ae_v_addd(&utemp.ptr.p_double[ustart], 1, &u->ptr.pp_double[ustart][mm0], u->stride, ae_v_len(ustart,uend), sinl); 14278 ae_v_muld(&u->ptr.pp_double[ustart][mm0], u->stride, ae_v_len(ustart,uend), cosl); 14279 ae_v_subd(&u->ptr.pp_double[ustart][mm0], u->stride, &u->ptr.pp_double[ustart][mm1], u->stride, ae_v_len(ustart,uend), sinl); 14280 ae_v_move(&u->ptr.pp_double[ustart][mm1], u->stride, &utemp.ptr.p_double[ustart], 1, ae_v_len(ustart,uend)); 14285 mm1 = m-1+cstart-1; 14286 ae_v_moved(&ctemp.ptr.p_double[cstart], 1, &c->ptr.pp_double[mm1][cstart], 1, ae_v_len(cstart,cend), cosl); 14287 ae_v_addd(&ctemp.ptr.p_double[cstart], 1, &c->ptr.pp_double[mm0][cstart], 1, ae_v_len(cstart,cend), sinl); 14288 ae_v_muld(&c->ptr.pp_double[mm0][cstart], 1, ae_v_len(cstart,cend), cosl); 14289 ae_v_subd(&c->ptr.pp_double[mm0][cstart], 1, &c->ptr.pp_double[mm1][cstart], 1, ae_v_len(cstart,cend), sinl); 14290 ae_v_move(&c->ptr.pp_double[mm1][cstart], 1, &ctemp.ptr.p_double[cstart], 1, ae_v_len(cstart,cend)); 14297 * If working on new submatrix, choose shift direction 14298 * (from larger end diagonal element towards smaller) 14301 * "if (LL>OLDM)
or (M<OLDLL) then
" 14302 * fixed thanks to Michael Rolle < m@rolle.name > 14303 * Very strange that LAPACK still contains it. 14305 bchangedir = ae_false; 14306 if( idir==1&&ae_fp_less(ae_fabs(d->ptr.p_double[ll], _state),1.0E-3*ae_fabs(d->ptr.p_double[m], _state)) ) 14308 bchangedir = ae_true; 14310 if( idir==2&&ae_fp_less(ae_fabs(d->ptr.p_double[m], _state),1.0E-3*ae_fabs(d->ptr.p_double[ll], _state)) ) 14312 bchangedir = ae_true; 14314 if( (ll!=oldll||m!=oldm)||bchangedir ) 14316 if( ae_fp_greater_eq(ae_fabs(d->ptr.p_double[ll], _state),ae_fabs(d->ptr.p_double[m], _state)) ) 14320 * Chase bulge from top (big end) to bottom (small end) 14328 * Chase bulge from bottom (big end) to top (small end) 14335 * Apply convergence tests 14341 * Run convergence test in forward direction 14342 * First apply standard test to bottom of matrix 14344 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),ae_fabs(tol, _state)*ae_fabs(d->ptr.p_double[m], _state))||(ae_fp_less(tol,0)&&ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),thresh)) ) 14346 e->ptr.p_double[m-1] = 0; 14349 if( ae_fp_greater_eq(tol,0) ) 14353 * If relative accuracy desired, 14354 * apply convergence criterion forward 14356 mu = ae_fabs(d->ptr.p_double[ll], _state); 14358 iterflag = ae_false; 14359 for(lll=ll; lll<=m-1; lll++) 14361 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[lll], _state),tol*mu) ) 14363 e->ptr.p_double[lll] = 0; 14364 iterflag = ae_true; 14367 mu = ae_fabs(d->ptr.p_double[lll+1], _state)*(mu/(mu+ae_fabs(e->ptr.p_double[lll], _state))); 14368 sminl = ae_minreal(sminl, mu, _state); 14380 * Run convergence test in backward direction 14381 * First apply standard test to top of matrix 14383 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),ae_fabs(tol, _state)*ae_fabs(d->ptr.p_double[ll], _state))||(ae_fp_less(tol,0)&&ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),thresh)) ) 14385 e->ptr.p_double[ll] = 0; 14388 if( ae_fp_greater_eq(tol,0) ) 14392 * If relative accuracy desired, 14393 * apply convergence criterion backward 14395 mu = ae_fabs(d->ptr.p_double[m], _state); 14397 iterflag = ae_false; 14398 for(lll=m-1; lll>=ll; lll--) 14400 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[lll], _state),tol*mu) ) 14402 e->ptr.p_double[lll] = 0; 14403 iterflag = ae_true; 14406 mu = ae_fabs(d->ptr.p_double[lll], _state)*(mu/(mu+ae_fabs(e->ptr.p_double[lll], _state))); 14407 sminl = ae_minreal(sminl, mu, _state); 14419 * Compute shift. First, test if shifting would ruin relative 14420 * accuracy, and if so set the shift to zero. 14422 if( ae_fp_greater_eq(tol,0)&&ae_fp_less_eq(n*tol*(sminl/smax),ae_maxreal(eps, 0.01*tol, _state)) ) 14426 * Use a zero shift to avoid loss of relative accuracy 14434 * Compute the shift from 2-by-2 block at end of matrix 14438 sll = ae_fabs(d->ptr.p_double[ll], _state); 14439 bdsvd_svd2x2(d->ptr.p_double[m-1], e->ptr.p_double[m-1], d->ptr.p_double[m], &shift, &r, _state); 14443 sll = ae_fabs(d->ptr.p_double[m], _state); 14444 bdsvd_svd2x2(d->ptr.p_double[ll], e->ptr.p_double[ll], d->ptr.p_double[ll+1], &shift, &r, _state); 14448 * Test if shift negligible, and if so set to zero 14450 if( ae_fp_greater(sll,0) ) 14452 if( ae_fp_less(ae_sqr(shift/sll, _state),eps) ) 14460 * Increment iteration count 14465 * If SHIFT = 0, do simplified QR iteration 14467 if( ae_fp_eq(shift,0) ) 14473 * Chase bulge from top to bottom 14474 * Save cosines and sines for later singular vector updates 14478 for(i=ll; i<=m-1; i++) 14480 generaterotation(d->ptr.p_double[i]*cs, e->ptr.p_double[i], &cs, &sn, &r, _state); 14483 e->ptr.p_double[i-1] = oldsn*r; 14485 generaterotation(oldcs*r, d->ptr.p_double[i+1]*sn, &oldcs, &oldsn, &tmp, _state); 14486 d->ptr.p_double[i] = tmp; 14487 work0.ptr.p_double[i-ll+1] = cs; 14488 work1.ptr.p_double[i-ll+1] = sn; 14489 work2.ptr.p_double[i-ll+1] = oldcs; 14490 work3.ptr.p_double[i-ll+1] = oldsn; 14492 h = d->ptr.p_double[m]*cs; 14493 d->ptr.p_double[m] = h*oldcs; 14494 e->ptr.p_double[m-1] = h*oldsn; 14497 * Update singular vectors 14501 applyrotationsfromtheleft(fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work0, &work1, vt, &vttemp, _state); 14505 applyrotationsfromtheright(fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work2, &work3, u, &utemp, _state); 14509 applyrotationsfromtheleft(fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work2, &work3, c, &ctemp, _state); 14515 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),thresh) ) 14517 e->ptr.p_double[m-1] = 0; 14524 * Chase bulge from bottom to top 14525 * Save cosines and sines for later singular vector updates 14529 for(i=m; i>=ll+1; i--) 14531 generaterotation(d->ptr.p_double[i]*cs, e->ptr.p_double[i-1], &cs, &sn, &r, _state); 14534 e->ptr.p_double[i] = oldsn*r; 14536 generaterotation(oldcs*r, d->ptr.p_double[i-1]*sn, &oldcs, &oldsn, &tmp, _state); 14537 d->ptr.p_double[i] = tmp; 14538 work0.ptr.p_double[i-ll] = cs; 14539 work1.ptr.p_double[i-ll] = -sn; 14540 work2.ptr.p_double[i-ll] = oldcs; 14541 work3.ptr.p_double[i-ll] = -oldsn; 14543 h = d->ptr.p_double[ll]*cs; 14544 d->ptr.p_double[ll] = h*oldcs; 14545 e->ptr.p_double[ll] = h*oldsn; 14548 * Update singular vectors 14552 applyrotationsfromtheleft(!fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work2, &work3, vt, &vttemp, _state); 14556 applyrotationsfromtheright(!fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work0, &work1, u, &utemp, _state); 14560 applyrotationsfromtheleft(!fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work0, &work1, c, &ctemp, _state); 14566 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),thresh) ) 14568 e->ptr.p_double[ll] = 0; 14576 * Use nonzero shift 14582 * Chase bulge from top to bottom 14583 * Save cosines and sines for later singular vector updates 14585 f = (ae_fabs(d->ptr.p_double[ll], _state)-shift)*(bdsvd_extsignbdsqr(1, d->ptr.p_double[ll], _state)+shift/d->ptr.p_double[ll]); 14586 g = e->ptr.p_double[ll]; 14587 for(i=ll; i<=m-1; i++) 14589 generaterotation(f, g, &cosr, &sinr, &r, _state); 14592 e->ptr.p_double[i-1] = r; 14594 f = cosr*d->ptr.p_double[i]+sinr*e->ptr.p_double[i]; 14595 e->ptr.p_double[i] = cosr*e->ptr.p_double[i]-sinr*d->ptr.p_double[i]; 14596 g = sinr*d->ptr.p_double[i+1]; 14597 d->ptr.p_double[i+1] = cosr*d->ptr.p_double[i+1]; 14598 generaterotation(f, g, &cosl, &sinl, &r, _state); 14599 d->ptr.p_double[i] = r; 14600 f = cosl*e->ptr.p_double[i]+sinl*d->ptr.p_double[i+1]; 14601 d->ptr.p_double[i+1] = cosl*d->ptr.p_double[i+1]-sinl*e->ptr.p_double[i]; 14604 g = sinl*e->ptr.p_double[i+1]; 14605 e->ptr.p_double[i+1] = cosl*e->ptr.p_double[i+1]; 14607 work0.ptr.p_double[i-ll+1] = cosr; 14608 work1.ptr.p_double[i-ll+1] = sinr; 14609 work2.ptr.p_double[i-ll+1] = cosl; 14610 work3.ptr.p_double[i-ll+1] = sinl; 14612 e->ptr.p_double[m-1] = f; 14615 * Update singular vectors 14619 applyrotationsfromtheleft(fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work0, &work1, vt, &vttemp, _state); 14623 applyrotationsfromtheright(fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work2, &work3, u, &utemp, _state); 14627 applyrotationsfromtheleft(fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work2, &work3, c, &ctemp, _state); 14633 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[m-1], _state),thresh) ) 14635 e->ptr.p_double[m-1] = 0; 14642 * Chase bulge from bottom to top 14643 * Save cosines and sines for later singular vector updates 14645 f = (ae_fabs(d->ptr.p_double[m], _state)-shift)*(bdsvd_extsignbdsqr(1, d->ptr.p_double[m], _state)+shift/d->ptr.p_double[m]); 14646 g = e->ptr.p_double[m-1]; 14647 for(i=m; i>=ll+1; i--) 14649 generaterotation(f, g, &cosr, &sinr, &r, _state); 14652 e->ptr.p_double[i] = r; 14654 f = cosr*d->ptr.p_double[i]+sinr*e->ptr.p_double[i-1]; 14655 e->ptr.p_double[i-1] = cosr*e->ptr.p_double[i-1]-sinr*d->ptr.p_double[i]; 14656 g = sinr*d->ptr.p_double[i-1]; 14657 d->ptr.p_double[i-1] = cosr*d->ptr.p_double[i-1]; 14658 generaterotation(f, g, &cosl, &sinl, &r, _state); 14659 d->ptr.p_double[i] = r; 14660 f = cosl*e->ptr.p_double[i-1]+sinl*d->ptr.p_double[i-1]; 14661 d->ptr.p_double[i-1] = cosl*d->ptr.p_double[i-1]-sinl*e->ptr.p_double[i-1]; 14664 g = sinl*e->ptr.p_double[i-2]; 14665 e->ptr.p_double[i-2] = cosl*e->ptr.p_double[i-2]; 14667 work0.ptr.p_double[i-ll] = cosr; 14668 work1.ptr.p_double[i-ll] = -sinr; 14669 work2.ptr.p_double[i-ll] = cosl; 14670 work3.ptr.p_double[i-ll] = -sinl; 14672 e->ptr.p_double[ll] = f; 14677 if( ae_fp_less_eq(ae_fabs(e->ptr.p_double[ll], _state),thresh) ) 14679 e->ptr.p_double[ll] = 0; 14683 * Update singular vectors if desired 14687 applyrotationsfromtheleft(!fwddir, ll+vstart-1, m+vstart-1, vstart, vend, &work2, &work3, vt, &vttemp, _state); 14691 applyrotationsfromtheright(!fwddir, ustart, uend, ll+ustart-1, m+ustart-1, &work0, &work1, u, &utemp, _state); 14695 applyrotationsfromtheleft(!fwddir, ll+cstart-1, m+cstart-1, cstart, cend, &work0, &work1, c, &ctemp, _state); 14701 * QR iteration finished, go back and check convergence 14707 * All singular values converged, so make them positive 14709 for(i=1; i<=n; i++) 14711 if( ae_fp_less(d->ptr.p_double[i],0) ) 14713 d->ptr.p_double[i] = -d->ptr.p_double[i]; 14716 * Change sign of singular vectors, if desired 14720 ae_v_muld(&vt->ptr.pp_double[i+vstart-1][vstart], 1, ae_v_len(vstart,vend), -1); 14726 * Sort the singular values into decreasing order (insertion sort on 14727 * singular values, but only one transposition per singular vector) 14729 for(i=1; i<=n-1; i++) 14733 * Scan for smallest D(I) 14736 smin = d->ptr.p_double[1]; 14737 for(j=2; j<=n+1-i; j++) 14739 if( ae_fp_less_eq(d->ptr.p_double[j],smin) ) 14742 smin = d->ptr.p_double[j]; 14749 * Swap singular values and vectors 14751 d->ptr.p_double[isub] = d->ptr.p_double[n+1-i]; 14752 d->ptr.p_double[n+1-i] = smin; 14756 ae_v_move(&vttemp.ptr.p_double[vstart], 1, &vt->ptr.pp_double[isub+vstart-1][vstart], 1, ae_v_len(vstart,vend)); 14757 ae_v_move(&vt->ptr.pp_double[isub+vstart-1][vstart], 1, &vt->ptr.pp_double[j+vstart-1][vstart], 1, ae_v_len(vstart,vend)); 14758 ae_v_move(&vt->ptr.pp_double[j+vstart-1][vstart], 1, &vttemp.ptr.p_double[vstart], 1, ae_v_len(vstart,vend)); 14763 ae_v_move(&utemp.ptr.p_double[ustart], 1, &u->ptr.pp_double[ustart][isub+ustart-1], u->stride, ae_v_len(ustart,uend)); 14764 ae_v_move(&u->ptr.pp_double[ustart][isub+ustart-1], u->stride, &u->ptr.pp_double[ustart][j+ustart-1], u->stride, ae_v_len(ustart,uend)); 14765 ae_v_move(&u->ptr.pp_double[ustart][j+ustart-1], u->stride, &utemp.ptr.p_double[ustart], 1, ae_v_len(ustart,uend)); 14770 ae_v_move(&ctemp.ptr.p_double[cstart], 1, &c->ptr.pp_double[isub+cstart-1][cstart], 1, ae_v_len(cstart,cend)); 14771 ae_v_move(&c->ptr.pp_double[isub+cstart-1][cstart], 1, &c->ptr.pp_double[j+cstart-1][cstart], 1, ae_v_len(cstart,cend)); 14772 ae_v_move(&c->ptr.pp_double[j+cstart-1][cstart], 1, &ctemp.ptr.p_double[cstart], 1, ae_v_len(cstart,cend)); 14776 ae_frame_leave(_state); 14781 static double bdsvd_extsignbdsqr(double a, double b, ae_state *_state) 14786 if( ae_fp_greater_eq(b,0) ) 14788 result = ae_fabs(a, _state); 14792 result = -ae_fabs(a, _state); 14798 static void bdsvd_svd2x2(double f, 14818 fa = ae_fabs(f, _state); 14819 ga = ae_fabs(g, _state); 14820 ha = ae_fabs(h, _state); 14821 fhmn = ae_minreal(fa, ha, _state); 14822 fhmx = ae_maxreal(fa, ha, _state); 14823 if( ae_fp_eq(fhmn,0) ) 14826 if( ae_fp_eq(fhmx,0) ) 14832 *ssmax = ae_maxreal(fhmx, ga, _state)*ae_sqrt(1+ae_sqr(ae_minreal(fhmx, ga, _state)/ae_maxreal(fhmx, ga, _state), _state), _state); 14837 if( ae_fp_less(ga,fhmx) ) 14840 at = (fhmx-fhmn)/fhmx; 14841 au = ae_sqr(ga/fhmx, _state); 14842 c = 2/(ae_sqrt(aas*aas+au, _state)+ae_sqrt(at*at+au, _state)); 14849 if( ae_fp_eq(au,0) ) 14853 * Avoid possible harmful underflow if exponent range 14854 * asymmetric (true SSMIN may not underflow even if 14857 *ssmin = fhmn*fhmx/ga; 14863 at = (fhmx-fhmn)/fhmx; 14864 c = 1/(ae_sqrt(1+ae_sqr(aas*au, _state), _state)+ae_sqrt(1+ae_sqr(at*au, _state), _state)); 14865 *ssmin = fhmn*c*au; 14866 *ssmin = *ssmin+(*ssmin); 14874 static void bdsvd_svdv2x2(double f, 14919 fa = ae_fabs(ft, _state); 14921 ha = ae_fabs(h, _state); 14924 * these initializers are not really necessary, 14925 * but without them compiler complains about uninitialized locals 14934 * PMAX points to the maximum absolute element of matrix 14935 * PMAX = 1 if F largest in absolute values 14936 * PMAX = 2 if G largest in absolute values 14937 * PMAX = 3 if H largest in absolute values 14940 swp = ae_fp_greater(ha,fa); 14956 ga = ae_fabs(gt, _state); 14957 if( ae_fp_eq(ga,0) ) 14973 if( ae_fp_greater(ga,fa) ) 14976 if( ae_fp_less(fa/ga,ae_machineepsilon) ) 14980 * Case of very large GA 14984 if( ae_fp_greater(ha,1) ) 15007 if( ae_fp_eq(d,fa) ) 15019 s = ae_sqrt(tt+mm, _state); 15020 if( ae_fp_eq(l,0) ) 15022 r = ae_fabs(m, _state); 15026 r = ae_sqrt(l*l+mm, _state); 15031 if( ae_fp_eq(mm,0) ) 15035 * Note that M is very tiny 15037 if( ae_fp_eq(l,0) ) 15039 t = bdsvd_extsignbdsqr(2, ft, _state)*bdsvd_extsignbdsqr(1, gt, _state); 15043 t = gt/bdsvd_extsignbdsqr(d, ft, _state)+m/t; 15048 t = (m/(s+t)+m/(r+l))*(1+a); 15050 l = ae_sqrt(t*t+4, _state); 15053 clt = (crt+srt*m)/a; 15074 * Correct signs of SSMAX and SSMIN 15078 tsign = bdsvd_extsignbdsqr(1, *csr, _state)*bdsvd_extsignbdsqr(1, *csl, _state)*bdsvd_extsignbdsqr(1, f, _state); 15082 tsign = bdsvd_extsignbdsqr(1, *snr, _state)*bdsvd_extsignbdsqr(1, *csl, _state)*bdsvd_extsignbdsqr(1, g, _state); 15086 tsign = bdsvd_extsignbdsqr(1, *snr, _state)*bdsvd_extsignbdsqr(1, *snl, _state)*bdsvd_extsignbdsqr(1, h, _state); 15088 *ssmax = bdsvd_extsignbdsqr(*ssmax, tsign, _state); 15089 *ssmin = bdsvd_extsignbdsqr(*ssmin, tsign*bdsvd_extsignbdsqr(1, f, _state)*bdsvd_extsignbdsqr(1, h, _state), _state); 15095 /************************************************************************* 15096 Singular value decomposition of a rectangular matrix. 15098 The algorithm calculates the singular value decomposition of a matrix of 15099 size MxN: A = U * S * V^T 15101 The algorithm finds the singular values and, optionally, matrices U and V^T. 15102 The algorithm can find both first min(M,N) columns of matrix U and rows of 15103 matrix V^T (singular vectors), and matrices U and V^T wholly (of sizes MxM 15104 and NxN respectively). 15106 Take into account that the subroutine does not return matrix V but V^T. 15109 A - matrix to be decomposed. 15110 Array whose indexes range within [0..M-1, 0..N-1]. 15111 M - number of rows in matrix A. 15112 N - number of columns in matrix A. 15113 UNeeded - 0, 1 or 2. See the description of the parameter U. 15114 VTNeeded - 0, 1 or 2. See the description of the parameter VT. 15117 * equals 0, the algorithm doesn’t use additional 15118 memory (lower requirements, lower performance). 15119 * equals 1, the algorithm uses additional 15120 memory of size min(M,N)*min(M,N) of real numbers. 15121 It often speeds up the algorithm. 15122 * equals 2, the algorithm uses additional 15123 memory of size M*min(M,N) of real numbers. 15124 It allows to get a maximum performance. 15125 The recommended value of the parameter is 2. 15128 W - contains singular values in descending order. 15129 U - if UNeeded=0, U isn't changed, the left singular vectors 15130 are not calculated. 15131 if Uneeded=1, U contains left singular vectors (first 15132 min(M,N) columns of matrix U). Array whose indexes range 15133 within [0..M-1, 0..Min(M,N)-1]. 15134 if UNeeded=2, U contains matrix U wholly. Array whose 15135 indexes range within [0..M-1, 0..M-1]. 15136 VT - if VTNeeded=0, VT isn’t changed, the right singular vectors 15137 are not calculated. 15138 if VTNeeded=1, VT contains right singular vectors (first 15139 min(M,N) rows of matrix V^T). Array whose indexes range 15140 within [0..min(M,N)-1, 0..N-1]. 15141 if VTNeeded=2, VT contains matrix V^T wholly. Array whose 15142 indexes range within [0..N-1, 0..N-1]. 15145 Copyright 2005 by Bochkanov Sergey 15146 *************************************************************************/ 15147 ae_bool rmatrixsvd(/* Real */ ae_matrix* a, 15152 ae_int_t additionalmemory, 15153 /* Real */ ae_vector* w, 15154 /* Real */ ae_matrix* u, 15155 /* Real */ ae_matrix* vt, 15158 ae_frame _frame_block; 15176 ae_frame_make(_state, &_frame_block); 15177 ae_matrix_init_copy(&_a, a, _state, ae_true); 15179 ae_vector_clear(w); 15180 ae_matrix_clear(u); 15181 ae_matrix_clear(vt); 15182 ae_vector_init(&tauq, 0, DT_REAL, _state, ae_true); 15183 ae_vector_init(&taup, 0, DT_REAL, _state, ae_true); 15184 ae_vector_init(&tau, 0, DT_REAL, _state, ae_true); 15185 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 15186 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 15187 ae_matrix_init(&t2, 0, 0, DT_REAL, _state, ae_true); 15192 ae_frame_leave(_state); 15195 ae_assert(uneeded>=0&&uneeded<=2, "SVDDecomposition: wrong parameters!
", _state); 15196 ae_assert(vtneeded>=0&&vtneeded<=2, "SVDDecomposition: wrong parameters!
", _state); 15197 ae_assert(additionalmemory>=0&&additionalmemory<=2, "SVDDecomposition: wrong parameters!
", _state); 15202 minmn = ae_minint(m, n, _state); 15203 ae_vector_set_length(w, minmn+1, _state); 15210 ae_matrix_set_length(u, nru-1+1, ncu-1+1, _state); 15216 ae_matrix_set_length(u, nru-1+1, ncu-1+1, _state); 15224 ae_matrix_set_length(vt, nrvt-1+1, ncvt-1+1, _state); 15230 ae_matrix_set_length(vt, nrvt-1+1, ncvt-1+1, _state); 15234 * M much larger than N 15235 * Use bidiagonal reduction with QR-decomposition 15237 if( ae_fp_greater(m,1.6*n) ) 15243 * No left singular vectors to be computed 15245 rmatrixqr(a, m, n, &tau, _state); 15246 for(i=0; i<=n-1; i++) 15248 for(j=0; j<=i-1; j++) 15250 a->ptr.pp_double[i][j] = 0; 15253 rmatrixbd(a, n, n, &tauq, &taup, _state); 15254 rmatrixbdunpackpt(a, n, n, &taup, nrvt, vt, _state); 15255 rmatrixbdunpackdiagonals(a, n, n, &isupper, w, &e, _state); 15256 result = rmatrixbdsvd(w, &e, n, isupper, ae_false, u, 0, a, 0, vt, ncvt, _state); 15257 ae_frame_leave(_state); 15264 * Left singular vectors (may be full matrix U) to be computed 15266 rmatrixqr(a, m, n, &tau, _state); 15267 rmatrixqrunpackq(a, m, n, &tau, ncu, u, _state); 15268 for(i=0; i<=n-1; i++) 15270 for(j=0; j<=i-1; j++) 15272 a->ptr.pp_double[i][j] = 0; 15275 rmatrixbd(a, n, n, &tauq, &taup, _state); 15276 rmatrixbdunpackpt(a, n, n, &taup, nrvt, vt, _state); 15277 rmatrixbdunpackdiagonals(a, n, n, &isupper, w, &e, _state); 15278 if( additionalmemory<1 ) 15282 * No additional memory can be used 15284 rmatrixbdmultiplybyq(a, n, n, &tauq, u, m, n, ae_true, ae_false, _state); 15285 result = rmatrixbdsvd(w, &e, n, isupper, ae_false, u, m, a, 0, vt, ncvt, _state); 15291 * Large U. Transforming intermediate matrix T2 15293 ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state); 15294 rmatrixbdunpackq(a, n, n, &tauq, n, &t2, _state); 15295 copymatrix(u, 0, m-1, 0, n-1, a, 0, m-1, 0, n-1, _state); 15296 inplacetranspose(&t2, 0, n-1, 0, n-1, &work, _state); 15297 result = rmatrixbdsvd(w, &e, n, isupper, ae_false, u, 0, &t2, n, vt, ncvt, _state); 15298 matrixmatrixmultiply(a, 0, m-1, 0, n-1, ae_false, &t2, 0, n-1, 0, n-1, ae_true, 1.0, u, 0, m-1, 0, n-1, 0.0, &work, _state); 15300 ae_frame_leave(_state); 15306 * N much larger than M 15307 * Use bidiagonal reduction with LQ-decomposition 15309 if( ae_fp_greater(n,1.6*m) ) 15315 * No right singular vectors to be computed 15317 rmatrixlq(a, m, n, &tau, _state); 15318 for(i=0; i<=m-1; i++) 15320 for(j=i+1; j<=m-1; j++) 15322 a->ptr.pp_double[i][j] = 0; 15325 rmatrixbd(a, m, m, &tauq, &taup, _state); 15326 rmatrixbdunpackq(a, m, m, &tauq, ncu, u, _state); 15327 rmatrixbdunpackdiagonals(a, m, m, &isupper, w, &e, _state); 15328 ae_vector_set_length(&work, m+1, _state); 15329 inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state); 15330 result = rmatrixbdsvd(w, &e, m, isupper, ae_false, a, 0, u, nru, vt, 0, _state); 15331 inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state); 15332 ae_frame_leave(_state); 15339 * Right singular vectors (may be full matrix VT) to be computed 15341 rmatrixlq(a, m, n, &tau, _state); 15342 rmatrixlqunpackq(a, m, n, &tau, nrvt, vt, _state); 15343 for(i=0; i<=m-1; i++) 15345 for(j=i+1; j<=m-1; j++) 15347 a->ptr.pp_double[i][j] = 0; 15350 rmatrixbd(a, m, m, &tauq, &taup, _state); 15351 rmatrixbdunpackq(a, m, m, &tauq, ncu, u, _state); 15352 rmatrixbdunpackdiagonals(a, m, m, &isupper, w, &e, _state); 15353 ae_vector_set_length(&work, ae_maxint(m, n, _state)+1, _state); 15354 inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state); 15355 if( additionalmemory<1 ) 15359 * No additional memory available 15361 rmatrixbdmultiplybyp(a, m, m, &taup, vt, m, n, ae_false, ae_true, _state); 15362 result = rmatrixbdsvd(w, &e, m, isupper, ae_false, a, 0, u, nru, vt, n, _state); 15368 * Large VT. Transforming intermediate matrix T2 15370 rmatrixbdunpackpt(a, m, m, &taup, m, &t2, _state); 15371 result = rmatrixbdsvd(w, &e, m, isupper, ae_false, a, 0, u, nru, &t2, m, _state); 15372 copymatrix(vt, 0, m-1, 0, n-1, a, 0, m-1, 0, n-1, _state); 15373 matrixmatrixmultiply(&t2, 0, m-1, 0, m-1, ae_false, a, 0, m-1, 0, n-1, ae_false, 1.0, vt, 0, m-1, 0, n-1, 0.0, &work, _state); 15375 inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state); 15376 ae_frame_leave(_state); 15383 * We can use inplace transposition of U to get rid of columnwise operations 15387 rmatrixbd(a, m, n, &tauq, &taup, _state); 15388 rmatrixbdunpackq(a, m, n, &tauq, ncu, u, _state); 15389 rmatrixbdunpackpt(a, m, n, &taup, nrvt, vt, _state); 15390 rmatrixbdunpackdiagonals(a, m, n, &isupper, w, &e, _state); 15391 ae_vector_set_length(&work, m+1, _state); 15392 inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state); 15393 result = rmatrixbdsvd(w, &e, minmn, isupper, ae_false, a, 0, u, nru, vt, ncvt, _state); 15394 inplacetranspose(u, 0, nru-1, 0, ncu-1, &work, _state); 15395 ae_frame_leave(_state); 15400 * Simple bidiagonal reduction 15402 rmatrixbd(a, m, n, &tauq, &taup, _state); 15403 rmatrixbdunpackq(a, m, n, &tauq, ncu, u, _state); 15404 rmatrixbdunpackpt(a, m, n, &taup, nrvt, vt, _state); 15405 rmatrixbdunpackdiagonals(a, m, n, &isupper, w, &e, _state); 15406 if( additionalmemory<2||uneeded==0 ) 15410 * We can't use additional memory or there is no need in such operations 15412 result = rmatrixbdsvd(w, &e, minmn, isupper, ae_false, u, nru, a, 0, vt, ncvt, _state); 15418 * We can use additional memory 15420 ae_matrix_set_length(&t2, minmn-1+1, m-1+1, _state); 15421 copyandtranspose(u, 0, m-1, 0, minmn-1, &t2, 0, minmn-1, 0, m-1, _state); 15422 result = rmatrixbdsvd(w, &e, minmn, isupper, ae_false, u, 0, &t2, m, vt, ncvt, _state); 15423 copyandtranspose(&t2, 0, minmn-1, 0, m-1, u, 0, m-1, 0, minmn-1, _state); 15425 ae_frame_leave(_state); 15432 /************************************************************************* 15433 Finding the eigenvalues and eigenvectors of a symmetric matrix 15435 The algorithm finds eigen pairs of a symmetric matrix by reducing it to 15436 tridiagonal form and using the QL/QR algorithm. 15439 A - symmetric matrix which is given by its upper or lower 15441 Array whose indexes range within [0..N-1, 0..N-1]. 15442 N - size of matrix A. 15443 ZNeeded - flag controlling whether the eigenvectors are needed or not. 15444 If ZNeeded is equal to: 15445 * 0, the eigenvectors are not returned; 15446 * 1, the eigenvectors are returned. 15447 IsUpper - storage format. 15450 D - eigenvalues in ascending order. 15451 Array whose index ranges within [0..N-1]. 15452 Z - if ZNeeded is equal to: 15453 * 0, Z hasn’t changed; 15454 * 1, Z contains the eigenvectors. 15455 Array whose indexes range within [0..N-1, 0..N-1]. 15456 The eigenvectors are stored in the matrix columns. 15459 True, if the algorithm has converged. 15460 False, if the algorithm hasn't converged (rare case). 15463 Copyright 2005-2008 by Bochkanov Sergey 15464 *************************************************************************/ 15465 ae_bool smatrixevd(/* Real */ ae_matrix* a, 15469 /* Real */ ae_vector* d, 15470 /* Real */ ae_matrix* z, 15473 ae_frame _frame_block; 15479 ae_frame_make(_state, &_frame_block); 15480 ae_matrix_init_copy(&_a, a, _state, ae_true); 15482 ae_vector_clear(d); 15483 ae_matrix_clear(z); 15484 ae_vector_init(&tau, 0, DT_REAL, _state, ae_true); 15485 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 15487 ae_assert(zneeded==0||zneeded==1, "SMatrixEVD: incorrect ZNeeded
", _state); 15488 smatrixtd(a, n, isupper, &tau, d, &e, _state); 15491 smatrixtdunpackq(a, n, isupper, &tau, z, _state); 15493 result = smatrixtdevd(d, &e, n, zneeded, z, _state); 15494 ae_frame_leave(_state); 15499 /************************************************************************* 15500 Subroutine for finding the eigenvalues (and eigenvectors) of a symmetric 15501 matrix in a given half open interval (A, B] by using a bisection and 15505 A - symmetric matrix which is given by its upper or lower 15506 triangular part. Array [0..N-1, 0..N-1]. 15507 N - size of matrix A. 15508 ZNeeded - flag controlling whether the eigenvectors are needed or not. 15509 If ZNeeded is equal to: 15510 * 0, the eigenvectors are not returned; 15511 * 1, the eigenvectors are returned. 15512 IsUpperA - storage format of matrix A. 15513 B1, B2 - half open interval (B1, B2] to search eigenvalues in. 15516 M - number of eigenvalues found in a given half-interval (M>=0). 15517 W - array of the eigenvalues found. 15518 Array whose index ranges within [0..M-1]. 15519 Z - if ZNeeded is equal to: 15520 * 0, Z hasn’t changed; 15521 * 1, Z contains eigenvectors. 15522 Array whose indexes range within [0..N-1, 0..M-1]. 15523 The eigenvectors are stored in the matrix columns. 15526 True, if successful. M contains the number of eigenvalues in the given 15527 half-interval (could be equal to 0), W contains the eigenvalues, 15528 Z contains the eigenvectors (if needed). 15530 False, if the bisection method subroutine wasn't able to find the 15531 eigenvalues in the given interval or if the inverse iteration subroutine 15532 wasn't able to find all the corresponding eigenvectors. 15533 In that case, the eigenvalues and eigenvectors are not returned, 15537 Copyright 07.01.2006 by Bochkanov Sergey 15538 *************************************************************************/ 15539 ae_bool smatrixevdr(/* Real */ ae_matrix* a, 15546 /* Real */ ae_vector* w, 15547 /* Real */ ae_matrix* z, 15550 ae_frame _frame_block; 15556 ae_frame_make(_state, &_frame_block); 15557 ae_matrix_init_copy(&_a, a, _state, ae_true); 15560 ae_vector_clear(w); 15561 ae_matrix_clear(z); 15562 ae_vector_init(&tau, 0, DT_REAL, _state, ae_true); 15563 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 15565 ae_assert(zneeded==0||zneeded==1, "SMatrixTDEVDR: incorrect ZNeeded
", _state); 15566 smatrixtd(a, n, isupper, &tau, w, &e, _state); 15569 smatrixtdunpackq(a, n, isupper, &tau, z, _state); 15571 result = smatrixtdevdr(w, &e, n, zneeded, b1, b2, m, z, _state); 15572 ae_frame_leave(_state); 15577 /************************************************************************* 15578 Subroutine for finding the eigenvalues and eigenvectors of a symmetric 15579 matrix with given indexes by using bisection and inverse iteration methods. 15582 A - symmetric matrix which is given by its upper or lower 15583 triangular part. Array whose indexes range within [0..N-1, 0..N-1]. 15584 N - size of matrix A. 15585 ZNeeded - flag controlling whether the eigenvectors are needed or not. 15586 If ZNeeded is equal to: 15587 * 0, the eigenvectors are not returned; 15588 * 1, the eigenvectors are returned. 15589 IsUpperA - storage format of matrix A. 15590 I1, I2 - index interval for searching (from I1 to I2). 15591 0 <= I1 <= I2 <= N-1. 15594 W - array of the eigenvalues found. 15595 Array whose index ranges within [0..I2-I1]. 15596 Z - if ZNeeded is equal to: 15597 * 0, Z hasn’t changed; 15598 * 1, Z contains eigenvectors. 15599 Array whose indexes range within [0..N-1, 0..I2-I1]. 15600 In that case, the eigenvectors are stored in the matrix columns. 15603 True, if successful. W contains the eigenvalues, Z contains the 15604 eigenvectors (if needed). 15606 False, if the bisection method subroutine wasn't able to find the 15607 eigenvalues in the given interval or if the inverse iteration subroutine 15608 wasn't able to find all the corresponding eigenvectors. 15609 In that case, the eigenvalues and eigenvectors are not returned. 15612 Copyright 07.01.2006 by Bochkanov Sergey 15613 *************************************************************************/ 15614 ae_bool smatrixevdi(/* Real */ ae_matrix* a, 15620 /* Real */ ae_vector* w, 15621 /* Real */ ae_matrix* z, 15624 ae_frame _frame_block; 15630 ae_frame_make(_state, &_frame_block); 15631 ae_matrix_init_copy(&_a, a, _state, ae_true); 15633 ae_vector_clear(w); 15634 ae_matrix_clear(z); 15635 ae_vector_init(&tau, 0, DT_REAL, _state, ae_true); 15636 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 15638 ae_assert(zneeded==0||zneeded==1, "SMatrixEVDI: incorrect ZNeeded
", _state); 15639 smatrixtd(a, n, isupper, &tau, w, &e, _state); 15642 smatrixtdunpackq(a, n, isupper, &tau, z, _state); 15644 result = smatrixtdevdi(w, &e, n, zneeded, i1, i2, z, _state); 15645 ae_frame_leave(_state); 15650 /************************************************************************* 15651 Finding the eigenvalues and eigenvectors of a Hermitian matrix 15653 The algorithm finds eigen pairs of a Hermitian matrix by reducing it to 15654 real tridiagonal form and using the QL/QR algorithm. 15657 A - Hermitian matrix which is given by its upper or lower 15659 Array whose indexes range within [0..N-1, 0..N-1]. 15660 N - size of matrix A. 15661 IsUpper - storage format. 15662 ZNeeded - flag controlling whether the eigenvectors are needed or 15663 not. If ZNeeded is equal to: 15664 * 0, the eigenvectors are not returned; 15665 * 1, the eigenvectors are returned. 15668 D - eigenvalues in ascending order. 15669 Array whose index ranges within [0..N-1]. 15670 Z - if ZNeeded is equal to: 15671 * 0, Z hasn’t changed; 15672 * 1, Z contains the eigenvectors. 15673 Array whose indexes range within [0..N-1, 0..N-1]. 15674 The eigenvectors are stored in the matrix columns. 15677 True, if the algorithm has converged. 15678 False, if the algorithm hasn't converged (rare case). 15681 eigenvectors of Hermitian matrix are defined up to multiplication by 15682 a complex number L, such that |L|=1. 15685 Copyright 2005, 23 March 2007 by Bochkanov Sergey 15686 *************************************************************************/ 15687 ae_bool hmatrixevd(/* Complex */ ae_matrix* a, 15691 /* Real */ ae_vector* d, 15692 /* Complex */ ae_matrix* z, 15695 ae_frame _frame_block; 15707 ae_frame_make(_state, &_frame_block); 15708 ae_matrix_init_copy(&_a, a, _state, ae_true); 15710 ae_vector_clear(d); 15711 ae_matrix_clear(z); 15712 ae_vector_init(&tau, 0, DT_COMPLEX, _state, ae_true); 15713 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 15714 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 15715 ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true); 15716 ae_matrix_init(&q, 0, 0, DT_COMPLEX, _state, ae_true); 15718 ae_assert(zneeded==0||zneeded==1, "HermitianEVD: incorrect ZNeeded
", _state); 15721 * Reduce to tridiagonal form 15723 hmatrixtd(a, n, isupper, &tau, d, &e, _state); 15726 hmatrixtdunpackq(a, n, isupper, &tau, &q, _state); 15733 result = smatrixtdevd(d, &e, n, zneeded, &t, _state); 15736 * Eigenvectors are needed 15737 * Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T 15739 if( result&&zneeded!=0 ) 15741 ae_vector_set_length(&work, n-1+1, _state); 15742 ae_matrix_set_length(z, n-1+1, n-1+1, _state); 15743 for(i=0; i<=n-1; i++) 15747 * Calculate real part 15749 for(k=0; k<=n-1; k++) 15751 work.ptr.p_double[k] = 0; 15753 for(k=0; k<=n-1; k++) 15755 v = q.ptr.pp_complex[i][k].x; 15756 ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,n-1), v); 15758 for(k=0; k<=n-1; k++) 15760 z->ptr.pp_complex[i][k].x = work.ptr.p_double[k]; 15764 * Calculate imaginary part 15766 for(k=0; k<=n-1; k++) 15768 work.ptr.p_double[k] = 0; 15770 for(k=0; k<=n-1; k++) 15772 v = q.ptr.pp_complex[i][k].y; 15773 ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,n-1), v); 15775 for(k=0; k<=n-1; k++) 15777 z->ptr.pp_complex[i][k].y = work.ptr.p_double[k]; 15781 ae_frame_leave(_state); 15786 /************************************************************************* 15787 Subroutine for finding the eigenvalues (and eigenvectors) of a Hermitian 15788 matrix in a given half-interval (A, B] by using a bisection and inverse 15792 A - Hermitian matrix which is given by its upper or lower 15793 triangular part. Array whose indexes range within 15795 N - size of matrix A. 15796 ZNeeded - flag controlling whether the eigenvectors are needed or 15797 not. If ZNeeded is equal to: 15798 * 0, the eigenvectors are not returned; 15799 * 1, the eigenvectors are returned. 15800 IsUpperA - storage format of matrix A. 15801 B1, B2 - half-interval (B1, B2] to search eigenvalues in. 15804 M - number of eigenvalues found in a given half-interval, M>=0 15805 W - array of the eigenvalues found. 15806 Array whose index ranges within [0..M-1]. 15807 Z - if ZNeeded is equal to: 15808 * 0, Z hasn’t changed; 15809 * 1, Z contains eigenvectors. 15810 Array whose indexes range within [0..N-1, 0..M-1]. 15811 The eigenvectors are stored in the matrix columns. 15814 True, if successful. M contains the number of eigenvalues in the given 15815 half-interval (could be equal to 0), W contains the eigenvalues, 15816 Z contains the eigenvectors (if needed). 15818 False, if the bisection method subroutine wasn't able to find the 15819 eigenvalues in the given interval or if the inverse iteration 15820 subroutine wasn't able to find all the corresponding eigenvectors. 15821 In that case, the eigenvalues and eigenvectors are not returned, M is 15825 eigen vectors of Hermitian matrix are defined up to multiplication by 15826 a complex number L, such as |L|=1. 15829 Copyright 07.01.2006, 24.03.2007 by Bochkanov Sergey. 15830 *************************************************************************/ 15831 ae_bool hmatrixevdr(/* Complex */ ae_matrix* a, 15838 /* Real */ ae_vector* w, 15839 /* Complex */ ae_matrix* z, 15842 ae_frame _frame_block; 15854 ae_frame_make(_state, &_frame_block); 15855 ae_matrix_init_copy(&_a, a, _state, ae_true); 15858 ae_vector_clear(w); 15859 ae_matrix_clear(z); 15860 ae_matrix_init(&q, 0, 0, DT_COMPLEX, _state, ae_true); 15861 ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true); 15862 ae_vector_init(&tau, 0, DT_COMPLEX, _state, ae_true); 15863 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 15864 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 15866 ae_assert(zneeded==0||zneeded==1, "HermitianEigenValuesAndVectorsInInterval: incorrect ZNeeded
", _state); 15869 * Reduce to tridiagonal form 15871 hmatrixtd(a, n, isupper, &tau, w, &e, _state); 15874 hmatrixtdunpackq(a, n, isupper, &tau, &q, _state); 15879 * Bisection and inverse iteration 15881 result = smatrixtdevdr(w, &e, n, zneeded, b1, b2, m, &t, _state); 15884 * Eigenvectors are needed 15885 * Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T 15887 if( (result&&zneeded!=0)&&*m!=0 ) 15889 ae_vector_set_length(&work, *m-1+1, _state); 15890 ae_matrix_set_length(z, n-1+1, *m-1+1, _state); 15891 for(i=0; i<=n-1; i++) 15895 * Calculate real part 15897 for(k=0; k<=*m-1; k++) 15899 work.ptr.p_double[k] = 0; 15901 for(k=0; k<=n-1; k++) 15903 v = q.ptr.pp_complex[i][k].x; 15904 ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,*m-1), v); 15906 for(k=0; k<=*m-1; k++) 15908 z->ptr.pp_complex[i][k].x = work.ptr.p_double[k]; 15912 * Calculate imaginary part 15914 for(k=0; k<=*m-1; k++) 15916 work.ptr.p_double[k] = 0; 15918 for(k=0; k<=n-1; k++) 15920 v = q.ptr.pp_complex[i][k].y; 15921 ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,*m-1), v); 15923 for(k=0; k<=*m-1; k++) 15925 z->ptr.pp_complex[i][k].y = work.ptr.p_double[k]; 15929 ae_frame_leave(_state); 15934 /************************************************************************* 15935 Subroutine for finding the eigenvalues and eigenvectors of a Hermitian 15936 matrix with given indexes by using bisection and inverse iteration methods 15939 A - Hermitian matrix which is given by its upper or lower 15941 Array whose indexes range within [0..N-1, 0..N-1]. 15942 N - size of matrix A. 15943 ZNeeded - flag controlling whether the eigenvectors are needed or 15944 not. If ZNeeded is equal to: 15945 * 0, the eigenvectors are not returned; 15946 * 1, the eigenvectors are returned. 15947 IsUpperA - storage format of matrix A. 15948 I1, I2 - index interval for searching (from I1 to I2). 15949 0 <= I1 <= I2 <= N-1. 15952 W - array of the eigenvalues found. 15953 Array whose index ranges within [0..I2-I1]. 15954 Z - if ZNeeded is equal to: 15955 * 0, Z hasn’t changed; 15956 * 1, Z contains eigenvectors. 15957 Array whose indexes range within [0..N-1, 0..I2-I1]. 15958 In that case, the eigenvectors are stored in the matrix 15962 True, if successful. W contains the eigenvalues, Z contains the 15963 eigenvectors (if needed). 15965 False, if the bisection method subroutine wasn't able to find the 15966 eigenvalues in the given interval or if the inverse iteration 15967 subroutine wasn't able to find all the corresponding eigenvectors. 15968 In that case, the eigenvalues and eigenvectors are not returned. 15971 eigen vectors of Hermitian matrix are defined up to multiplication by 15972 a complex number L, such as |L|=1. 15975 Copyright 07.01.2006, 24.03.2007 by Bochkanov Sergey. 15976 *************************************************************************/ 15977 ae_bool hmatrixevdi(/* Complex */ ae_matrix* a, 15983 /* Real */ ae_vector* w, 15984 /* Complex */ ae_matrix* z, 15987 ae_frame _frame_block; 16000 ae_frame_make(_state, &_frame_block); 16001 ae_matrix_init_copy(&_a, a, _state, ae_true); 16003 ae_vector_clear(w); 16004 ae_matrix_clear(z); 16005 ae_matrix_init(&q, 0, 0, DT_COMPLEX, _state, ae_true); 16006 ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true); 16007 ae_vector_init(&tau, 0, DT_COMPLEX, _state, ae_true); 16008 ae_vector_init(&e, 0, DT_REAL, _state, ae_true); 16009 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 16011 ae_assert(zneeded==0||zneeded==1, "HermitianEigenValuesAndVectorsByIndexes: incorrect ZNeeded
", _state); 16014 * Reduce to tridiagonal form 16016 hmatrixtd(a, n, isupper, &tau, w, &e, _state); 16019 hmatrixtdunpackq(a, n, isupper, &tau, &q, _state); 16024 * Bisection and inverse iteration 16026 result = smatrixtdevdi(w, &e, n, zneeded, i1, i2, &t, _state); 16029 * Eigenvectors are needed 16030 * Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T 16033 if( result&&zneeded!=0 ) 16035 ae_vector_set_length(&work, m-1+1, _state); 16036 ae_matrix_set_length(z, n-1+1, m-1+1, _state); 16037 for(i=0; i<=n-1; i++) 16041 * Calculate real part 16043 for(k=0; k<=m-1; k++) 16045 work.ptr.p_double[k] = 0; 16047 for(k=0; k<=n-1; k++) 16049 v = q.ptr.pp_complex[i][k].x; 16050 ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,m-1), v); 16052 for(k=0; k<=m-1; k++) 16054 z->ptr.pp_complex[i][k].x = work.ptr.p_double[k]; 16058 * Calculate imaginary part 16060 for(k=0; k<=m-1; k++) 16062 work.ptr.p_double[k] = 0; 16064 for(k=0; k<=n-1; k++) 16066 v = q.ptr.pp_complex[i][k].y; 16067 ae_v_addd(&work.ptr.p_double[0], 1, &t.ptr.pp_double[k][0], 1, ae_v_len(0,m-1), v); 16069 for(k=0; k<=m-1; k++) 16071 z->ptr.pp_complex[i][k].y = work.ptr.p_double[k]; 16075 ae_frame_leave(_state); 16080 /************************************************************************* 16081 Finding the eigenvalues and eigenvectors of a tridiagonal symmetric matrix 16083 The algorithm finds the eigen pairs of a tridiagonal symmetric matrix by 16084 using an QL/QR algorithm with implicit shifts. 16087 D - the main diagonal of a tridiagonal matrix. 16088 Array whose index ranges within [0..N-1]. 16089 E - the secondary diagonal of a tridiagonal matrix. 16090 Array whose index ranges within [0..N-2]. 16091 N - size of matrix A. 16092 ZNeeded - flag controlling whether the eigenvectors are needed or not. 16093 If ZNeeded is equal to: 16094 * 0, the eigenvectors are not needed; 16095 * 1, the eigenvectors of a tridiagonal matrix 16096 are multiplied by the square matrix Z. It is used if the 16097 tridiagonal matrix is obtained by the similarity 16098 transformation of a symmetric matrix; 16099 * 2, the eigenvectors of a tridiagonal matrix replace the 16101 * 3, matrix Z contains the first row of the eigenvectors 16103 Z - if ZNeeded=1, Z contains the square matrix by which the 16104 eigenvectors are multiplied. 16105 Array whose indexes range within [0..N-1, 0..N-1]. 16108 D - eigenvalues in ascending order. 16109 Array whose index ranges within [0..N-1]. 16110 Z - if ZNeeded is equal to: 16111 * 0, Z hasn’t changed; 16112 * 1, Z contains the product of a given matrix (from the left) 16113 and the eigenvectors matrix (from the right); 16114 * 2, Z contains the eigenvectors. 16115 * 3, Z contains the first row of the eigenvectors matrix. 16116 If ZNeeded<3, Z is the array whose indexes range within [0..N-1, 0..N-1]. 16117 In that case, the eigenvectors are stored in the matrix columns. 16118 If ZNeeded=3, Z is the array whose indexes range within [0..0, 0..N-1]. 16121 True, if the algorithm has converged. 16122 False, if the algorithm hasn't converged. 16124 -- LAPACK routine (version 3.0) -- 16125 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 16126 Courant Institute, Argonne National Lab, and Rice University 16128 *************************************************************************/ 16129 ae_bool smatrixtdevd(/* Real */ ae_vector* d, 16130 /* Real */ ae_vector* e, 16133 /* Real */ ae_matrix* z, 16136 ae_frame _frame_block; 16144 ae_frame_make(_state, &_frame_block); 16145 ae_vector_init_copy(&_e, e, _state, ae_true); 16147 ae_vector_init(&d1, 0, DT_REAL, _state, ae_true); 16148 ae_vector_init(&e1, 0, DT_REAL, _state, ae_true); 16149 ae_matrix_init(&z1, 0, 0, DT_REAL, _state, ae_true); 16153 * Prepare 1-based task 16155 ae_vector_set_length(&d1, n+1, _state); 16156 ae_vector_set_length(&e1, n+1, _state); 16157 ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n)); 16160 ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1)); 16164 ae_matrix_set_length(&z1, n+1, n+1, _state); 16165 for(i=1; i<=n; i++) 16167 ae_v_move(&z1.ptr.pp_double[i][1], 1, &z->ptr.pp_double[i-1][0], 1, ae_v_len(1,n)); 16172 * Solve 1-based task 16174 result = evd_tridiagonalevd(&d1, &e1, n, zneeded, &z1, _state); 16177 ae_frame_leave(_state); 16182 * Convert back to 0-based result 16184 ae_v_move(&d->ptr.p_double[0], 1, &d1.ptr.p_double[1], 1, ae_v_len(0,n-1)); 16189 for(i=1; i<=n; i++) 16191 ae_v_move(&z->ptr.pp_double[i-1][0], 1, &z1.ptr.pp_double[i][1], 1, ae_v_len(0,n-1)); 16193 ae_frame_leave(_state); 16198 ae_matrix_set_length(z, n-1+1, n-1+1, _state); 16199 for(i=1; i<=n; i++) 16201 ae_v_move(&z->ptr.pp_double[i-1][0], 1, &z1.ptr.pp_double[i][1], 1, ae_v_len(0,n-1)); 16203 ae_frame_leave(_state); 16208 ae_matrix_set_length(z, 0+1, n-1+1, _state); 16209 ae_v_move(&z->ptr.pp_double[0][0], 1, &z1.ptr.pp_double[1][1], 1, ae_v_len(0,n-1)); 16210 ae_frame_leave(_state); 16213 ae_assert(ae_false, "SMatrixTDEVD: Incorrect ZNeeded!
", _state); 16215 ae_frame_leave(_state); 16220 /************************************************************************* 16221 Subroutine for finding the tridiagonal matrix eigenvalues/vectors in a 16222 given half-interval (A, B] by using bisection and inverse iteration. 16225 D - the main diagonal of a tridiagonal matrix. 16226 Array whose index ranges within [0..N-1]. 16227 E - the secondary diagonal of a tridiagonal matrix. 16228 Array whose index ranges within [0..N-2]. 16229 N - size of matrix, N>=0. 16230 ZNeeded - flag controlling whether the eigenvectors are needed or not. 16231 If ZNeeded is equal to: 16232 * 0, the eigenvectors are not needed; 16233 * 1, the eigenvectors of a tridiagonal matrix are multiplied 16234 by the square matrix Z. It is used if the tridiagonal 16235 matrix is obtained by the similarity transformation 16236 of a symmetric matrix. 16237 * 2, the eigenvectors of a tridiagonal matrix replace matrix Z. 16238 A, B - half-interval (A, B] to search eigenvalues in. 16239 Z - if ZNeeded is equal to: 16240 * 0, Z isn't used and remains unchanged; 16241 * 1, Z contains the square matrix (array whose indexes range 16242 within [0..N-1, 0..N-1]) which reduces the given symmetric 16243 matrix to tridiagonal form; 16244 * 2, Z isn't used (but changed on the exit). 16247 D - array of the eigenvalues found. 16248 Array whose index ranges within [0..M-1]. 16249 M - number of eigenvalues found in the given half-interval (M>=0). 16250 Z - if ZNeeded is equal to: 16251 * 0, doesn't contain any information; 16252 * 1, contains the product of a given NxN matrix Z (from the 16253 left) and NxM matrix of the eigenvectors found (from the 16254 right). Array whose indexes range within [0..N-1, 0..M-1]. 16255 * 2, contains the matrix of the eigenvectors found. 16256 Array whose indexes range within [0..N-1, 0..M-1]. 16260 True, if successful. In that case, M contains the number of eigenvalues 16261 in the given half-interval (could be equal to 0), D contains the eigenvalues, 16262 Z contains the eigenvectors (if needed). 16263 It should be noted that the subroutine changes the size of arrays D and Z. 16265 False, if the bisection method subroutine wasn't able to find the 16266 eigenvalues in the given interval or if the inverse iteration subroutine 16267 wasn't able to find all the corresponding eigenvectors. In that case, 16268 the eigenvalues and eigenvectors are not returned, M is equal to 0. 16271 Copyright 31.03.2008 by Bochkanov Sergey 16272 *************************************************************************/ 16273 ae_bool smatrixtdevdr(/* Real */ ae_vector* d, 16274 /* Real */ ae_vector* e, 16280 /* Real */ ae_matrix* z, 16283 ae_frame _frame_block; 16284 ae_int_t errorcode; 16301 ae_frame_make(_state, &_frame_block); 16303 ae_vector_init(&iblock, 0, DT_INT, _state, ae_true); 16304 ae_vector_init(&isplit, 0, DT_INT, _state, ae_true); 16305 ae_vector_init(&ifail, 0, DT_INT, _state, ae_true); 16306 ae_vector_init(&d1, 0, DT_REAL, _state, ae_true); 16307 ae_vector_init(&e1, 0, DT_REAL, _state, ae_true); 16308 ae_vector_init(&w, 0, DT_REAL, _state, ae_true); 16309 ae_matrix_init(&z2, 0, 0, DT_REAL, _state, ae_true); 16310 ae_matrix_init(&z3, 0, 0, DT_REAL, _state, ae_true); 16312 ae_assert(zneeded>=0&&zneeded<=2, "SMatrixTDEVDR: incorrect ZNeeded!
", _state); 16317 if( ae_fp_less_eq(b,a) ) 16321 ae_frame_leave(_state); 16328 ae_frame_leave(_state); 16333 * Copy D,E to D1, E1 16335 ae_vector_set_length(&d1, n+1, _state); 16336 ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n)); 16339 ae_vector_set_length(&e1, n-1+1, _state); 16340 ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1)); 16348 result = evd_internalbisectioneigenvalues(&d1, &e1, n, 2, 1, a, b, 0, 0, -1, &w, m, &nsplit, &iblock, &isplit, &errorcode, _state); 16349 if( !result||*m==0 ) 16352 ae_frame_leave(_state); 16355 ae_vector_set_length(d, *m-1+1, _state); 16356 ae_v_move(&d->ptr.p_double[0], 1, &w.ptr.p_double[1], 1, ae_v_len(0,*m-1)); 16357 ae_frame_leave(_state); 16362 * Eigen vectors are multiplied by Z 16370 result = evd_internalbisectioneigenvalues(&d1, &e1, n, 2, 2, a, b, 0, 0, -1, &w, m, &nsplit, &iblock, &isplit, &errorcode, _state); 16371 if( !result||*m==0 ) 16374 ae_frame_leave(_state); 16377 evd_internaldstein(n, &d1, &e1, *m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state); 16382 ae_frame_leave(_state); 16387 * Sort eigen values and vectors 16389 for(i=1; i<=*m; i++) 16392 for(j=i; j<=*m; j++) 16394 if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) ) 16399 v = w.ptr.p_double[i]; 16400 w.ptr.p_double[i] = w.ptr.p_double[k]; 16401 w.ptr.p_double[k] = v; 16402 for(j=1; j<=n; j++) 16404 v = z2.ptr.pp_double[j][i]; 16405 z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k]; 16406 z2.ptr.pp_double[j][k] = v; 16411 * Transform Z2 and overwrite Z 16413 ae_matrix_set_length(&z3, *m+1, n+1, _state); 16414 for(i=1; i<=*m; i++) 16416 ae_v_move(&z3.ptr.pp_double[i][1], 1, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(1,n)); 16418 for(i=1; i<=n; i++) 16420 for(j=1; j<=*m; j++) 16422 v = ae_v_dotproduct(&z->ptr.pp_double[i-1][0], 1, &z3.ptr.pp_double[j][1], 1, ae_v_len(0,n-1)); 16423 z2.ptr.pp_double[i][j] = v; 16426 ae_matrix_set_length(z, n-1+1, *m-1+1, _state); 16427 for(i=1; i<=*m; i++) 16429 ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1)); 16435 ae_vector_set_length(d, *m-1+1, _state); 16436 for(i=1; i<=*m; i++) 16438 d->ptr.p_double[i-1] = w.ptr.p_double[i]; 16440 ae_frame_leave(_state); 16445 * Eigen vectors are stored in Z 16453 result = evd_internalbisectioneigenvalues(&d1, &e1, n, 2, 2, a, b, 0, 0, -1, &w, m, &nsplit, &iblock, &isplit, &errorcode, _state); 16454 if( !result||*m==0 ) 16457 ae_frame_leave(_state); 16460 evd_internaldstein(n, &d1, &e1, *m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state); 16465 ae_frame_leave(_state); 16470 * Sort eigen values and vectors 16472 for(i=1; i<=*m; i++) 16475 for(j=i; j<=*m; j++) 16477 if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) ) 16482 v = w.ptr.p_double[i]; 16483 w.ptr.p_double[i] = w.ptr.p_double[k]; 16484 w.ptr.p_double[k] = v; 16485 for(j=1; j<=n; j++) 16487 v = z2.ptr.pp_double[j][i]; 16488 z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k]; 16489 z2.ptr.pp_double[j][k] = v; 16496 ae_vector_set_length(d, *m-1+1, _state); 16497 for(i=1; i<=*m; i++) 16499 d->ptr.p_double[i-1] = w.ptr.p_double[i]; 16501 ae_matrix_set_length(z, n-1+1, *m-1+1, _state); 16502 for(i=1; i<=*m; i++) 16504 ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1)); 16506 ae_frame_leave(_state); 16510 ae_frame_leave(_state); 16515 /************************************************************************* 16516 Subroutine for finding tridiagonal matrix eigenvalues/vectors with given 16517 indexes (in ascending order) by using the bisection and inverse iteraion. 16520 D - the main diagonal of a tridiagonal matrix. 16521 Array whose index ranges within [0..N-1]. 16522 E - the secondary diagonal of a tridiagonal matrix. 16523 Array whose index ranges within [0..N-2]. 16524 N - size of matrix. N>=0. 16525 ZNeeded - flag controlling whether the eigenvectors are needed or not. 16526 If ZNeeded is equal to: 16527 * 0, the eigenvectors are not needed; 16528 * 1, the eigenvectors of a tridiagonal matrix are multiplied 16529 by the square matrix Z. It is used if the 16530 tridiagonal matrix is obtained by the similarity transformation 16531 of a symmetric matrix. 16532 * 2, the eigenvectors of a tridiagonal matrix replace 16534 I1, I2 - index interval for searching (from I1 to I2). 16535 0 <= I1 <= I2 <= N-1. 16536 Z - if ZNeeded is equal to: 16537 * 0, Z isn't used and remains unchanged; 16538 * 1, Z contains the square matrix (array whose indexes range within [0..N-1, 0..N-1]) 16539 which reduces the given symmetric matrix to tridiagonal form; 16540 * 2, Z isn't used (but changed on the exit). 16543 D - array of the eigenvalues found. 16544 Array whose index ranges within [0..I2-I1]. 16545 Z - if ZNeeded is equal to: 16546 * 0, doesn't contain any information; 16547 * 1, contains the product of a given NxN matrix Z (from the left) and 16548 Nx(I2-I1) matrix of the eigenvectors found (from the right). 16549 Array whose indexes range within [0..N-1, 0..I2-I1]. 16550 * 2, contains the matrix of the eigenvalues found. 16551 Array whose indexes range within [0..N-1, 0..I2-I1]. 16556 True, if successful. In that case, D contains the eigenvalues, 16557 Z contains the eigenvectors (if needed). 16558 It should be noted that the subroutine changes the size of arrays D and Z. 16560 False, if the bisection method subroutine wasn't able to find the eigenvalues 16561 in the given interval or if the inverse iteration subroutine wasn't able 16562 to find all the corresponding eigenvectors. In that case, the eigenvalues 16563 and eigenvectors are not returned. 16566 Copyright 25.12.2005 by Bochkanov Sergey 16567 *************************************************************************/ 16568 ae_bool smatrixtdevdi(/* Real */ ae_vector* d, 16569 /* Real */ ae_vector* e, 16574 /* Real */ ae_matrix* z, 16577 ae_frame _frame_block; 16578 ae_int_t errorcode; 16596 ae_frame_make(_state, &_frame_block); 16597 ae_vector_init(&iblock, 0, DT_INT, _state, ae_true); 16598 ae_vector_init(&isplit, 0, DT_INT, _state, ae_true); 16599 ae_vector_init(&ifail, 0, DT_INT, _state, ae_true); 16600 ae_vector_init(&w, 0, DT_REAL, _state, ae_true); 16601 ae_vector_init(&d1, 0, DT_REAL, _state, ae_true); 16602 ae_vector_init(&e1, 0, DT_REAL, _state, ae_true); 16603 ae_matrix_init(&z2, 0, 0, DT_REAL, _state, ae_true); 16604 ae_matrix_init(&z3, 0, 0, DT_REAL, _state, ae_true); 16606 ae_assert((0<=i1&&i1<=i2)&&i2<n, "SMatrixTDEVDI: incorrect I1/I2!
", _state); 16609 * Copy D,E to D1, E1 16611 ae_vector_set_length(&d1, n+1, _state); 16612 ae_v_move(&d1.ptr.p_double[1], 1, &d->ptr.p_double[0], 1, ae_v_len(1,n)); 16615 ae_vector_set_length(&e1, n-1+1, _state); 16616 ae_v_move(&e1.ptr.p_double[1], 1, &e->ptr.p_double[0], 1, ae_v_len(1,n-1)); 16624 result = evd_internalbisectioneigenvalues(&d1, &e1, n, 3, 1, 0, 0, i1+1, i2+1, -1, &w, &m, &nsplit, &iblock, &isplit, &errorcode, _state); 16627 ae_frame_leave(_state); 16633 ae_frame_leave(_state); 16636 ae_vector_set_length(d, m-1+1, _state); 16637 for(i=1; i<=m; i++) 16639 d->ptr.p_double[i-1] = w.ptr.p_double[i]; 16641 ae_frame_leave(_state); 16646 * Eigen vectors are multiplied by Z 16654 result = evd_internalbisectioneigenvalues(&d1, &e1, n, 3, 2, 0, 0, i1+1, i2+1, -1, &w, &m, &nsplit, &iblock, &isplit, &errorcode, _state); 16657 ae_frame_leave(_state); 16663 ae_frame_leave(_state); 16666 evd_internaldstein(n, &d1, &e1, m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state); 16670 ae_frame_leave(_state); 16675 * Sort eigen values and vectors 16677 for(i=1; i<=m; i++) 16680 for(j=i; j<=m; j++) 16682 if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) ) 16687 v = w.ptr.p_double[i]; 16688 w.ptr.p_double[i] = w.ptr.p_double[k]; 16689 w.ptr.p_double[k] = v; 16690 for(j=1; j<=n; j++) 16692 v = z2.ptr.pp_double[j][i]; 16693 z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k]; 16694 z2.ptr.pp_double[j][k] = v; 16699 * Transform Z2 and overwrite Z 16701 ae_matrix_set_length(&z3, m+1, n+1, _state); 16702 for(i=1; i<=m; i++) 16704 ae_v_move(&z3.ptr.pp_double[i][1], 1, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(1,n)); 16706 for(i=1; i<=n; i++) 16708 for(j=1; j<=m; j++) 16710 v = ae_v_dotproduct(&z->ptr.pp_double[i-1][0], 1, &z3.ptr.pp_double[j][1], 1, ae_v_len(0,n-1)); 16711 z2.ptr.pp_double[i][j] = v; 16714 ae_matrix_set_length(z, n-1+1, m-1+1, _state); 16715 for(i=1; i<=m; i++) 16717 ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1)); 16723 ae_vector_set_length(d, m-1+1, _state); 16724 for(i=1; i<=m; i++) 16726 d->ptr.p_double[i-1] = w.ptr.p_double[i]; 16728 ae_frame_leave(_state); 16733 * Eigen vectors are stored in Z 16741 result = evd_internalbisectioneigenvalues(&d1, &e1, n, 3, 2, 0, 0, i1+1, i2+1, -1, &w, &m, &nsplit, &iblock, &isplit, &errorcode, _state); 16744 ae_frame_leave(_state); 16750 ae_frame_leave(_state); 16753 evd_internaldstein(n, &d1, &e1, m, &w, &iblock, &isplit, &z2, &ifail, &cr, _state); 16757 ae_frame_leave(_state); 16762 * Sort eigen values and vectors 16764 for(i=1; i<=m; i++) 16767 for(j=i; j<=m; j++) 16769 if( ae_fp_less(w.ptr.p_double[j],w.ptr.p_double[k]) ) 16774 v = w.ptr.p_double[i]; 16775 w.ptr.p_double[i] = w.ptr.p_double[k]; 16776 w.ptr.p_double[k] = v; 16777 for(j=1; j<=n; j++) 16779 v = z2.ptr.pp_double[j][i]; 16780 z2.ptr.pp_double[j][i] = z2.ptr.pp_double[j][k]; 16781 z2.ptr.pp_double[j][k] = v; 16788 ae_matrix_set_length(z, n-1+1, m-1+1, _state); 16789 for(i=1; i<=m; i++) 16791 ae_v_move(&z->ptr.pp_double[0][i-1], z->stride, &z2.ptr.pp_double[1][i], z2.stride, ae_v_len(0,n-1)); 16797 ae_vector_set_length(d, m-1+1, _state); 16798 for(i=1; i<=m; i++) 16800 d->ptr.p_double[i-1] = w.ptr.p_double[i]; 16802 ae_frame_leave(_state); 16806 ae_frame_leave(_state); 16811 /************************************************************************* 16812 Finding eigenvalues and eigenvectors of a general matrix 16814 The algorithm finds eigenvalues and eigenvectors of a general matrix by 16815 using the QR algorithm with multiple shifts. The algorithm can find 16816 eigenvalues and both left and right eigenvectors. 16818 The right eigenvector is a vector x such that A*x = w*x, and the left 16819 eigenvector is a vector y such that y'*A = w*y' (here y' implies a complex 16820 conjugate transposition of vector y). 16823 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 16824 N - size of matrix A. 16825 VNeeded - flag controlling whether eigenvectors are needed or not. 16826 If VNeeded is equal to: 16827 * 0, eigenvectors are not returned; 16828 * 1, right eigenvectors are returned; 16829 * 2, left eigenvectors are returned; 16830 * 3, both left and right eigenvectors are returned. 16833 WR - real parts of eigenvalues. 16834 Array whose index ranges within [0..N-1]. 16835 WR - imaginary parts of eigenvalues. 16836 Array whose index ranges within [0..N-1]. 16837 VL, VR - arrays of left and right eigenvectors (if they are needed). 16838 If WI[i]=0, the respective eigenvalue is a real number, 16839 and it corresponds to the column number I of matrices VL/VR. 16840 If WI[i]>0, we have a pair of complex conjugate numbers with 16841 positive and negative imaginary parts: 16842 the first eigenvalue WR[i] + sqrt(-1)*WI[i]; 16843 the second eigenvalue WR[i+1] + sqrt(-1)*WI[i+1]; 16845 WI[i+1] = -WI[i] < 0 16846 In that case, the eigenvector corresponding to the first 16847 eigenvalue is located in i and i+1 columns of matrices 16848 VL/VR (the column number i contains the real part, and the 16849 column number i+1 contains the imaginary part), and the vector 16850 corresponding to the second eigenvalue is a complex conjugate to 16852 Arrays whose indexes range within [0..N-1, 0..N-1]. 16855 True, if the algorithm has converged. 16856 False, if the algorithm has not converged. 16859 Some users may ask the following question: what if WI[N-1]>0? 16860 WI[N] must contain an eigenvalue which is complex conjugate to the 16861 N-th eigenvalue, but the array has only size N? 16862 The answer is as follows: such a situation cannot occur because the 16863 algorithm finds a pairs of eigenvalues, therefore, if WI[i]>0, I is 16864 strictly less than N-1. 16867 The algorithm performance depends on the value of the internal parameter 16868 NS of the InternalSchurDecomposition subroutine which defines the number 16869 of shifts in the QR algorithm (similarly to the block width in block-matrix 16870 algorithms of linear algebra). If you require maximum performance 16871 on your machine, it is recommended to adjust this parameter manually. 16874 See also the InternalTREVC subroutine. 16876 The algorithm is based on the LAPACK 3.0 library. 16877 *************************************************************************/ 16878 ae_bool rmatrixevd(/* Real */ ae_matrix* a, 16881 /* Real */ ae_vector* wr, 16882 /* Real */ ae_vector* wi, 16883 /* Real */ ae_matrix* vl, 16884 /* Real */ ae_matrix* vr, 16887 ae_frame _frame_block; 16897 ae_frame_make(_state, &_frame_block); 16898 ae_matrix_init_copy(&_a, a, _state, ae_true); 16900 ae_vector_clear(wr); 16901 ae_vector_clear(wi); 16902 ae_matrix_clear(vl); 16903 ae_matrix_clear(vr); 16904 ae_matrix_init(&a1, 0, 0, DT_REAL, _state, ae_true); 16905 ae_matrix_init(&vl1, 0, 0, DT_REAL, _state, ae_true); 16906 ae_matrix_init(&vr1, 0, 0, DT_REAL, _state, ae_true); 16907 ae_vector_init(&wr1, 0, DT_REAL, _state, ae_true); 16908 ae_vector_init(&wi1, 0, DT_REAL, _state, ae_true); 16910 ae_assert(vneeded>=0&&vneeded<=3, "RMatrixEVD: incorrect VNeeded!
", _state); 16911 ae_matrix_set_length(&a1, n+1, n+1, _state); 16912 for(i=1; i<=n; i++) 16914 ae_v_move(&a1.ptr.pp_double[i][1], 1, &a->ptr.pp_double[i-1][0], 1, ae_v_len(1,n)); 16916 result = evd_nonsymmetricevd(&a1, n, vneeded, &wr1, &wi1, &vl1, &vr1, _state); 16919 ae_vector_set_length(wr, n-1+1, _state); 16920 ae_vector_set_length(wi, n-1+1, _state); 16921 ae_v_move(&wr->ptr.p_double[0], 1, &wr1.ptr.p_double[1], 1, ae_v_len(0,n-1)); 16922 ae_v_move(&wi->ptr.p_double[0], 1, &wi1.ptr.p_double[1], 1, ae_v_len(0,n-1)); 16923 if( vneeded==2||vneeded==3 ) 16925 ae_matrix_set_length(vl, n-1+1, n-1+1, _state); 16926 for(i=0; i<=n-1; i++) 16928 ae_v_move(&vl->ptr.pp_double[i][0], 1, &vl1.ptr.pp_double[i+1][1], 1, ae_v_len(0,n-1)); 16931 if( vneeded==1||vneeded==3 ) 16933 ae_matrix_set_length(vr, n-1+1, n-1+1, _state); 16934 for(i=0; i<=n-1; i++) 16936 ae_v_move(&vr->ptr.pp_double[i][0], 1, &vr1.ptr.pp_double[i+1][1], 1, ae_v_len(0,n-1)); 16940 ae_frame_leave(_state); 16945 static ae_bool evd_tridiagonalevd(/* Real */ ae_vector* d, 16946 /* Real */ ae_vector* e, 16949 /* Real */ ae_matrix* z, 16952 ae_frame _frame_block; 17000 ae_bool wastranspose; 17003 ae_frame_make(_state, &_frame_block); 17004 ae_vector_init_copy(&_e, e, _state, ae_true); 17006 ae_vector_init(&work1, 0, DT_REAL, _state, ae_true); 17007 ae_vector_init(&work2, 0, DT_REAL, _state, ae_true); 17008 ae_vector_init(&workc, 0, DT_REAL, _state, ae_true); 17009 ae_vector_init(&works, 0, DT_REAL, _state, ae_true); 17010 ae_vector_init(&wtemp, 0, DT_REAL, _state, ae_true); 17012 ae_assert(zneeded>=0&&zneeded<=3, "TridiagonalEVD: Incorrent ZNeeded
", _state); 17015 * Quick return if possible 17017 if( zneeded<0||zneeded>3 ) 17020 ae_frame_leave(_state); 17026 ae_frame_leave(_state); 17031 if( zneeded==2||zneeded==3 ) 17033 ae_matrix_set_length(z, 1+1, 1+1, _state); 17034 z->ptr.pp_double[1][1] = 1; 17036 ae_frame_leave(_state); 17042 * Initialize arrays 17044 ae_vector_set_length(&wtemp, n+1, _state); 17045 ae_vector_set_length(&work1, n-1+1, _state); 17046 ae_vector_set_length(&work2, n-1+1, _state); 17047 ae_vector_set_length(&workc, n+1, _state); 17048 ae_vector_set_length(&works, n+1, _state); 17051 * Determine the unit roundoff and over/underflow thresholds. 17053 eps = ae_machineepsilon; 17054 eps2 = ae_sqr(eps, _state); 17055 safmin = ae_minrealnumber; 17056 safmax = ae_maxrealnumber; 17057 ssfmax = ae_sqrt(safmax, _state)/3; 17058 ssfmin = ae_sqrt(safmin, _state)/eps2; 17063 * Here we are using transposition to get rid of column operations 17066 wastranspose = ae_false; 17082 wastranspose = ae_true; 17083 inplacetranspose(z, 1, n, 1, n, &wtemp, _state); 17087 wastranspose = ae_true; 17088 ae_matrix_set_length(z, n+1, n+1, _state); 17089 for(i=1; i<=n; i++) 17091 for(j=1; j<=n; j++) 17095 z->ptr.pp_double[i][j] = 1; 17099 z->ptr.pp_double[i][j] = 0; 17106 wastranspose = ae_false; 17107 ae_matrix_set_length(z, 1+1, n+1, _state); 17108 for(j=1; j<=n; j++) 17112 z->ptr.pp_double[1][j] = 1; 17116 z->ptr.pp_double[1][j] = 0; 17124 * Determine where the matrix splits and choose QL or QR iteration 17125 * for each block, according to whether top or bottom diagonal 17126 * element is smaller. 17138 e->ptr.p_double[l1-1] = 0; 17140 gotoflag = ae_false; 17144 for(m=l1; m<=nm1; m++) 17146 tst = ae_fabs(e->ptr.p_double[m], _state); 17147 if( ae_fp_eq(tst,0) ) 17149 gotoflag = ae_true; 17152 if( ae_fp_less_eq(tst,ae_sqrt(ae_fabs(d->ptr.p_double[m], _state), _state)*ae_sqrt(ae_fabs(d->ptr.p_double[m+1], _state), _state)*eps) ) 17154 e->ptr.p_double[m] = 0; 17155 gotoflag = ae_true; 17179 * Scale submatrix in rows and columns L to LEND 17183 anorm = ae_fabs(d->ptr.p_double[l], _state); 17187 anorm = ae_maxreal(ae_fabs(d->ptr.p_double[l], _state)+ae_fabs(e->ptr.p_double[l], _state), ae_fabs(e->ptr.p_double[lend-1], _state)+ae_fabs(d->ptr.p_double[lend], _state), _state); 17188 for(i=l+1; i<=lend-1; i++) 17190 anorm = ae_maxreal(anorm, ae_fabs(d->ptr.p_double[i], _state)+ae_fabs(e->ptr.p_double[i], _state)+ae_fabs(e->ptr.p_double[i-1], _state), _state); 17194 if( ae_fp_eq(anorm,0) ) 17198 if( ae_fp_greater(anorm,ssfmax) ) 17201 tmp = ssfmax/anorm; 17203 ae_v_muld(&d->ptr.p_double[l], 1, ae_v_len(l,lend), tmp); 17204 ae_v_muld(&e->ptr.p_double[l], 1, ae_v_len(l,tmpint), tmp); 17206 if( ae_fp_less(anorm,ssfmin) ) 17209 tmp = ssfmin/anorm; 17211 ae_v_muld(&d->ptr.p_double[l], 1, ae_v_len(l,lend), tmp); 17212 ae_v_muld(&e->ptr.p_double[l], 1, ae_v_len(l,tmpint), tmp); 17216 * Choose between QL and QR iteration 17218 if( ae_fp_less(ae_fabs(d->ptr.p_double[lend], _state),ae_fabs(d->ptr.p_double[l], _state)) ) 17229 * Look for small subdiagonal element. 17233 gotoflag = ae_false; 17237 for(m=l; m<=lendm1; m++) 17239 tst = ae_sqr(ae_fabs(e->ptr.p_double[m], _state), _state); 17240 if( ae_fp_less_eq(tst,eps2*ae_fabs(d->ptr.p_double[m], _state)*ae_fabs(d->ptr.p_double[m+1], _state)+safmin) ) 17242 gotoflag = ae_true; 17253 e->ptr.p_double[m] = 0; 17255 p = d->ptr.p_double[l]; 17260 * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 17261 * to compute its eigensystem. 17267 evd_tdevdev2(d->ptr.p_double[l], e->ptr.p_double[l], d->ptr.p_double[l+1], &rt1, &rt2, &c, &s, _state); 17268 work1.ptr.p_double[l] = c; 17269 work2.ptr.p_double[l] = s; 17270 workc.ptr.p_double[1] = work1.ptr.p_double[l]; 17271 works.ptr.p_double[1] = work2.ptr.p_double[l]; 17272 if( !wastranspose ) 17274 applyrotationsfromtheright(ae_false, 1, zrows, l, l+1, &workc, &works, z, &wtemp, _state); 17278 applyrotationsfromtheleft(ae_false, l, l+1, 1, zrows, &workc, &works, z, &wtemp, _state); 17283 evd_tdevde2(d->ptr.p_double[l], e->ptr.p_double[l], d->ptr.p_double[l+1], &rt1, &rt2, _state); 17285 d->ptr.p_double[l] = rt1; 17286 d->ptr.p_double[l+1] = rt2; 17287 e->ptr.p_double[l] = 0; 17312 g = (d->ptr.p_double[l+1]-p)/(2*e->ptr.p_double[l]); 17313 r = evd_tdevdpythag(g, 1, _state); 17314 g = d->ptr.p_double[m]-p+e->ptr.p_double[l]/(g+evd_tdevdextsign(r, g, _state)); 17323 for(i=mm1; i>=l; i--) 17325 f = s*e->ptr.p_double[i]; 17326 b = c*e->ptr.p_double[i]; 17327 generaterotation(g, f, &c, &s, &r, _state); 17330 e->ptr.p_double[i+1] = r; 17332 g = d->ptr.p_double[i+1]-p; 17333 r = (d->ptr.p_double[i]-g)*s+2*c*b; 17335 d->ptr.p_double[i+1] = g+p; 17339 * If eigenvectors are desired, then save rotations. 17343 work1.ptr.p_double[i] = c; 17344 work2.ptr.p_double[i] = -s; 17349 * If eigenvectors are desired, then apply saved rotations. 17353 for(i=l; i<=m-1; i++) 17355 workc.ptr.p_double[i-l+1] = work1.ptr.p_double[i]; 17356 works.ptr.p_double[i-l+1] = work2.ptr.p_double[i]; 17358 if( !wastranspose ) 17360 applyrotationsfromtheright(ae_false, 1, zrows, l, m, &workc, &works, z, &wtemp, _state); 17364 applyrotationsfromtheleft(ae_false, l, m, 1, zrows, &workc, &works, z, &wtemp, _state); 17367 d->ptr.p_double[l] = d->ptr.p_double[l]-p; 17368 e->ptr.p_double[l] = g; 17373 * Eigenvalue found. 17375 d->ptr.p_double[l] = p; 17390 * Look for small superdiagonal element. 17394 gotoflag = ae_false; 17398 for(m=l; m>=lendp1; m--) 17400 tst = ae_sqr(ae_fabs(e->ptr.p_double[m-1], _state), _state); 17401 if( ae_fp_less_eq(tst,eps2*ae_fabs(d->ptr.p_double[m], _state)*ae_fabs(d->ptr.p_double[m-1], _state)+safmin) ) 17403 gotoflag = ae_true; 17414 e->ptr.p_double[m-1] = 0; 17416 p = d->ptr.p_double[l]; 17421 * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 17422 * to compute its eigensystem. 17428 evd_tdevdev2(d->ptr.p_double[l-1], e->ptr.p_double[l-1], d->ptr.p_double[l], &rt1, &rt2, &c, &s, _state); 17429 work1.ptr.p_double[m] = c; 17430 work2.ptr.p_double[m] = s; 17431 workc.ptr.p_double[1] = c; 17432 works.ptr.p_double[1] = s; 17433 if( !wastranspose ) 17435 applyrotationsfromtheright(ae_true, 1, zrows, l-1, l, &workc, &works, z, &wtemp, _state); 17439 applyrotationsfromtheleft(ae_true, l-1, l, 1, zrows, &workc, &works, z, &wtemp, _state); 17444 evd_tdevde2(d->ptr.p_double[l-1], e->ptr.p_double[l-1], d->ptr.p_double[l], &rt1, &rt2, _state); 17446 d->ptr.p_double[l-1] = rt1; 17447 d->ptr.p_double[l] = rt2; 17448 e->ptr.p_double[l-1] = 0; 17465 g = (d->ptr.p_double[l-1]-p)/(2*e->ptr.p_double[l-1]); 17466 r = evd_tdevdpythag(g, 1, _state); 17467 g = d->ptr.p_double[m]-p+e->ptr.p_double[l-1]/(g+evd_tdevdextsign(r, g, _state)); 17476 for(i=m; i<=lm1; i++) 17478 f = s*e->ptr.p_double[i]; 17479 b = c*e->ptr.p_double[i]; 17480 generaterotation(g, f, &c, &s, &r, _state); 17483 e->ptr.p_double[i-1] = r; 17485 g = d->ptr.p_double[i]-p; 17486 r = (d->ptr.p_double[i+1]-g)*s+2*c*b; 17488 d->ptr.p_double[i] = g+p; 17492 * If eigenvectors are desired, then save rotations. 17496 work1.ptr.p_double[i] = c; 17497 work2.ptr.p_double[i] = s; 17502 * If eigenvectors are desired, then apply saved rotations. 17506 for(i=m; i<=l-1; i++) 17508 workc.ptr.p_double[i-m+1] = work1.ptr.p_double[i]; 17509 works.ptr.p_double[i-m+1] = work2.ptr.p_double[i]; 17511 if( !wastranspose ) 17513 applyrotationsfromtheright(ae_true, 1, zrows, m, l, &workc, &works, z, &wtemp, _state); 17517 applyrotationsfromtheleft(ae_true, m, l, 1, zrows, &workc, &works, z, &wtemp, _state); 17520 d->ptr.p_double[l] = d->ptr.p_double[l]-p; 17521 e->ptr.p_double[lm1] = g; 17526 * Eigenvalue found. 17528 d->ptr.p_double[l] = p; 17539 * Undo scaling if necessary 17543 tmp = anorm/ssfmax; 17545 ae_v_muld(&d->ptr.p_double[lsv], 1, ae_v_len(lsv,lendsv), tmp); 17546 ae_v_muld(&e->ptr.p_double[lsv], 1, ae_v_len(lsv,tmpint), tmp); 17550 tmp = anorm/ssfmin; 17552 ae_v_muld(&d->ptr.p_double[lsv], 1, ae_v_len(lsv,lendsv), tmp); 17553 ae_v_muld(&e->ptr.p_double[lsv], 1, ae_v_len(lsv,tmpint), tmp); 17557 * Check for no convergence to an eigenvalue after a total 17558 * of N*MAXIT iterations. 17565 inplacetranspose(z, 1, n, 1, n, &wtemp, _state); 17567 ae_frame_leave(_state); 17573 * Order eigenvalues and eigenvectors. 17583 ae_frame_leave(_state); 17588 if( ae_fp_greater(d->ptr.p_double[1],d->ptr.p_double[2]) ) 17590 tmp = d->ptr.p_double[1]; 17591 d->ptr.p_double[1] = d->ptr.p_double[2]; 17592 d->ptr.p_double[2] = tmp; 17594 ae_frame_leave(_state); 17604 if( ae_fp_greater_eq(d->ptr.p_double[k],d->ptr.p_double[t]) ) 17610 tmp = d->ptr.p_double[k]; 17611 d->ptr.p_double[k] = d->ptr.p_double[t]; 17612 d->ptr.p_double[t] = tmp; 17622 tmp = d->ptr.p_double[i+1]; 17623 d->ptr.p_double[i+1] = d->ptr.p_double[1]; 17624 d->ptr.p_double[1] = tmp; 17637 if( ae_fp_greater(d->ptr.p_double[k+1],d->ptr.p_double[k]) ) 17642 if( ae_fp_greater_eq(d->ptr.p_double[t],d->ptr.p_double[k]) ) 17648 tmp = d->ptr.p_double[k]; 17649 d->ptr.p_double[k] = d->ptr.p_double[t]; 17650 d->ptr.p_double[t] = tmp; 17663 * Use Selection Sort to minimize swaps of eigenvectors 17665 for(ii=2; ii<=n; ii++) 17669 p = d->ptr.p_double[i]; 17670 for(j=ii; j<=n; j++) 17672 if( ae_fp_less(d->ptr.p_double[j],p) ) 17675 p = d->ptr.p_double[j]; 17680 d->ptr.p_double[k] = d->ptr.p_double[i]; 17681 d->ptr.p_double[i] = p; 17684 ae_v_move(&wtemp.ptr.p_double[1], 1, &z->ptr.pp_double[i][1], 1, ae_v_len(1,n)); 17685 ae_v_move(&z->ptr.pp_double[i][1], 1, &z->ptr.pp_double[k][1], 1, ae_v_len(1,n)); 17686 ae_v_move(&z->ptr.pp_double[k][1], 1, &wtemp.ptr.p_double[1], 1, ae_v_len(1,n)); 17690 ae_v_move(&wtemp.ptr.p_double[1], 1, &z->ptr.pp_double[1][i], z->stride, ae_v_len(1,zrows)); 17691 ae_v_move(&z->ptr.pp_double[1][i], z->stride, &z->ptr.pp_double[1][k], z->stride, ae_v_len(1,zrows)); 17692 ae_v_move(&z->ptr.pp_double[1][k], z->stride, &wtemp.ptr.p_double[1], 1, ae_v_len(1,zrows)); 17698 inplacetranspose(z, 1, n, 1, n, &wtemp, _state); 17701 ae_frame_leave(_state); 17706 /************************************************************************* 17707 DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix 17710 On return, RT1 is the eigenvalue of larger absolute value, and RT2 17711 is the eigenvalue of smaller absolute value. 17713 -- LAPACK auxiliary routine (version 3.0) -- 17714 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 17715 Courant Institute, Argonne National Lab, and Rice University 17717 *************************************************************************/ 17718 static void evd_tdevde2(double a, 17739 adf = ae_fabs(df, _state); 17741 ab = ae_fabs(tb, _state); 17742 if( ae_fp_greater(ae_fabs(a, _state),ae_fabs(c, _state)) ) 17752 if( ae_fp_greater(adf,ab) ) 17754 rt = adf*ae_sqrt(1+ae_sqr(ab/adf, _state), _state); 17758 if( ae_fp_less(adf,ab) ) 17760 rt = ab*ae_sqrt(1+ae_sqr(adf/ab, _state), _state); 17766 * Includes case AB=ADF=0 17768 rt = ab*ae_sqrt(2, _state); 17771 if( ae_fp_less(sm,0) ) 17773 *rt1 = 0.5*(sm-rt); 17776 * Order of execution important. 17777 * To get fully accurate smaller eigenvalue, 17778 * next line needs to be executed in higher precision. 17780 *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b; 17784 if( ae_fp_greater(sm,0) ) 17786 *rt1 = 0.5*(sm+rt); 17789 * Order of execution important. 17790 * To get fully accurate smaller eigenvalue, 17791 * next line needs to be executed in higher precision. 17793 *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b; 17799 * Includes case RT1 = RT2 = 0 17808 /************************************************************************* 17809 DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix 17814 On return, RT1 is the eigenvalue of larger absolute value, RT2 is the 17815 eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right 17816 eigenvector for RT1, giving the decomposition 17818 [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] 17819 [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. 17822 -- LAPACK auxiliary routine (version 3.0) -- 17823 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 17824 Courant Institute, Argonne National Lab, and Rice University 17826 *************************************************************************/ 17827 static void evd_tdevdev2(double a, 17858 * Compute the eigenvalues 17862 adf = ae_fabs(df, _state); 17864 ab = ae_fabs(tb, _state); 17865 if( ae_fp_greater(ae_fabs(a, _state),ae_fabs(c, _state)) ) 17875 if( ae_fp_greater(adf,ab) ) 17877 rt = adf*ae_sqrt(1+ae_sqr(ab/adf, _state), _state); 17881 if( ae_fp_less(adf,ab) ) 17883 rt = ab*ae_sqrt(1+ae_sqr(adf/ab, _state), _state); 17889 * Includes case AB=ADF=0 17891 rt = ab*ae_sqrt(2, _state); 17894 if( ae_fp_less(sm,0) ) 17896 *rt1 = 0.5*(sm-rt); 17900 * Order of execution important. 17901 * To get fully accurate smaller eigenvalue, 17902 * next line needs to be executed in higher precision. 17904 *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b; 17908 if( ae_fp_greater(sm,0) ) 17910 *rt1 = 0.5*(sm+rt); 17914 * Order of execution important. 17915 * To get fully accurate smaller eigenvalue, 17916 * next line needs to be executed in higher precision. 17918 *rt2 = acmx/(*rt1)*acmn-b/(*rt1)*b; 17924 * Includes case RT1 = RT2 = 0 17933 * Compute the eigenvector 17935 if( ae_fp_greater_eq(df,0) ) 17945 acs = ae_fabs(cs, _state); 17946 if( ae_fp_greater(acs,ab) ) 17949 *sn1 = 1/ae_sqrt(1+ct*ct, _state); 17954 if( ae_fp_eq(ab,0) ) 17962 *cs1 = 1/ae_sqrt(1+tn*tn, _state); 17975 /************************************************************************* 17977 *************************************************************************/ 17978 static double evd_tdevdpythag(double a, double b, ae_state *_state) 17983 if( ae_fp_less(ae_fabs(a, _state),ae_fabs(b, _state)) ) 17985 result = ae_fabs(b, _state)*ae_sqrt(1+ae_sqr(a/b, _state), _state); 17989 result = ae_fabs(a, _state)*ae_sqrt(1+ae_sqr(b/a, _state), _state); 17995 /************************************************************************* 17997 *************************************************************************/ 17998 static double evd_tdevdextsign(double a, double b, ae_state *_state) 18003 if( ae_fp_greater_eq(b,0) ) 18005 result = ae_fabs(a, _state); 18009 result = -ae_fabs(a, _state); 18015 static ae_bool evd_internalbisectioneigenvalues(/* Real */ ae_vector* d, 18016 /* Real */ ae_vector* e, 18025 /* Real */ ae_vector* w, 18028 /* Integer */ ae_vector* iblock, 18029 /* Integer */ ae_vector* isplit, 18030 ae_int_t* errorcode, 18033 ae_frame _frame_block; 18077 double scalefactor; 18090 ae_matrix ra1siinx2; 18091 ae_matrix ia1siinx2; 18092 ae_vector iworkspace; 18093 ae_vector rworkspace; 18097 ae_frame_make(_state, &_frame_block); 18098 ae_vector_init_copy(&_d, d, _state, ae_true); 18100 ae_vector_init_copy(&_e, e, _state, ae_true); 18102 ae_vector_clear(w); 18105 ae_vector_clear(iblock); 18106 ae_vector_clear(isplit); 18108 ae_vector_init(&idumma, 0, DT_INT, _state, ae_true); 18109 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 18110 ae_vector_init(&iwork, 0, DT_INT, _state, ae_true); 18111 ae_vector_init(&ia1s2, 0, DT_INT, _state, ae_true); 18112 ae_vector_init(&ra1s2, 0, DT_REAL, _state, ae_true); 18113 ae_matrix_init(&ra1s2x2, 0, 0, DT_REAL, _state, ae_true); 18114 ae_matrix_init(&ia1s2x2, 0, 0, DT_INT, _state, ae_true); 18115 ae_vector_init(&ra1siin, 0, DT_REAL, _state, ae_true); 18116 ae_vector_init(&ra2siin, 0, DT_REAL, _state, ae_true); 18117 ae_vector_init(&ra3siin, 0, DT_REAL, _state, ae_true); 18118 ae_vector_init(&ra4siin, 0, DT_REAL, _state, ae_true); 18119 ae_matrix_init(&ra1siinx2, 0, 0, DT_REAL, _state, ae_true); 18120 ae_matrix_init(&ia1siinx2, 0, 0, DT_INT, _state, ae_true); 18121 ae_vector_init(&iworkspace, 0, DT_INT, _state, ae_true); 18122 ae_vector_init(&rworkspace, 0, DT_REAL, _state, ae_true); 18126 * Quick return if possible 18132 ae_frame_leave(_state); 18137 * Get machine constants 18138 * NB is the minimum vector length for vector bisection, or 0 18139 * if only scalar is to be done. 18143 safemn = ae_minrealnumber; 18144 ulp = 2*ae_machineepsilon; 18145 rtoli = ulp*relfac; 18146 ae_vector_set_length(&idumma, 1+1, _state); 18147 ae_vector_set_length(&work, 4*n+1, _state); 18148 ae_vector_set_length(&iwork, 3*n+1, _state); 18149 ae_vector_set_length(w, n+1, _state); 18150 ae_vector_set_length(iblock, n+1, _state); 18151 ae_vector_set_length(isplit, n+1, _state); 18152 ae_vector_set_length(&ia1s2, 2+1, _state); 18153 ae_vector_set_length(&ra1s2, 2+1, _state); 18154 ae_matrix_set_length(&ra1s2x2, 2+1, 2+1, _state); 18155 ae_matrix_set_length(&ia1s2x2, 2+1, 2+1, _state); 18156 ae_vector_set_length(&ra1siin, n+1, _state); 18157 ae_vector_set_length(&ra2siin, n+1, _state); 18158 ae_vector_set_length(&ra3siin, n+1, _state); 18159 ae_vector_set_length(&ra4siin, n+1, _state); 18160 ae_matrix_set_length(&ra1siinx2, n+1, 2+1, _state); 18161 ae_matrix_set_length(&ia1siinx2, n+1, 2+1, _state); 18162 ae_vector_set_length(&iworkspace, n+1, _state); 18163 ae_vector_set_length(&rworkspace, n+1, _state); 18166 * these initializers are not really necessary, 18167 * but without them compiler complains about uninitialized locals 18177 if( irange<=0||irange>=4 ) 18181 if( iorder<=0||iorder>=3 ) 18189 if( irange==2&&ae_fp_greater_eq(vl,vu) ) 18193 if( irange==3&&(il<1||il>ae_maxint(1, n, _state)) ) 18197 if( irange==3&&(iu<ae_minint(n, il, _state)||iu>n) ) 18201 if( *errorcode!=0 ) 18203 ae_frame_leave(_state); 18208 * Initialize error flags 18216 if( (irange==3&&il==1)&&iu==n ) 18222 * Special Case when N=1 18227 isplit->ptr.p_int[1] = 1; 18228 if( irange==2&&(ae_fp_greater_eq(vl,d->ptr.p_double[1])||ae_fp_less(vu,d->ptr.p_double[1])) ) 18234 w->ptr.p_double[1] = d->ptr.p_double[1]; 18235 iblock->ptr.p_int[1] = 1; 18239 ae_frame_leave(_state); 18246 t = ae_fabs(d->ptr.p_double[n], _state); 18247 for(j=1; j<=n-1; j++) 18249 t = ae_maxreal(t, ae_fabs(d->ptr.p_double[j], _state), _state); 18250 t = ae_maxreal(t, ae_fabs(e->ptr.p_double[j], _state), _state); 18253 if( ae_fp_neq(t,0) ) 18255 if( ae_fp_greater(t,ae_sqrt(ae_sqrt(ae_minrealnumber, _state), _state)*ae_sqrt(ae_maxrealnumber, _state)) ) 18259 if( ae_fp_less(t,ae_sqrt(ae_sqrt(ae_maxrealnumber, _state), _state)*ae_sqrt(ae_minrealnumber, _state)) ) 18263 for(j=1; j<=n-1; j++) 18265 d->ptr.p_double[j] = d->ptr.p_double[j]/scalefactor; 18266 e->ptr.p_double[j] = e->ptr.p_double[j]/scalefactor; 18268 d->ptr.p_double[n] = d->ptr.p_double[n]/scalefactor; 18272 * Compute Splitting Points 18275 work.ptr.p_double[n] = 0; 18277 for(j=2; j<=n; j++) 18279 tmp1 = ae_sqr(e->ptr.p_double[j-1], _state); 18280 if( ae_fp_greater(ae_fabs(d->ptr.p_double[j]*d->ptr.p_double[j-1], _state)*ae_sqr(ulp, _state)+safemn,tmp1) ) 18282 isplit->ptr.p_int[*nsplit] = j-1; 18283 *nsplit = *nsplit+1; 18284 work.ptr.p_double[j-1] = 0; 18288 work.ptr.p_double[j-1] = tmp1; 18289 pivmin = ae_maxreal(pivmin, tmp1, _state); 18292 isplit->ptr.p_int[*nsplit] = n; 18293 pivmin = pivmin*safemn; 18296 * Compute Interval and ATOLI 18302 * RANGE='I': Compute the interval containing eigenvalues 18305 * Compute Gershgorin interval for entire (split) matrix 18306 * and use it as the initial interval 18308 gu = d->ptr.p_double[1]; 18309 gl = d->ptr.p_double[1]; 18311 for(j=1; j<=n-1; j++) 18313 tmp2 = ae_sqrt(work.ptr.p_double[j], _state); 18314 gu = ae_maxreal(gu, d->ptr.p_double[j]+tmp1+tmp2, _state); 18315 gl = ae_minreal(gl, d->ptr.p_double[j]-tmp1-tmp2, _state); 18318 gu = ae_maxreal(gu, d->ptr.p_double[n]+tmp1, _state); 18319 gl = ae_minreal(gl, d->ptr.p_double[n]-tmp1, _state); 18320 tnorm = ae_maxreal(ae_fabs(gl, _state), ae_fabs(gu, _state), _state); 18321 gl = gl-fudge*tnorm*ulp*n-fudge*2*pivmin; 18322 gu = gu+fudge*tnorm*ulp*n+fudge*pivmin; 18325 * Compute Iteration parameters 18327 itmax = ae_iceil((ae_log(tnorm+pivmin, _state)-ae_log(pivmin, _state))/ae_log(2, _state), _state)+2; 18328 if( ae_fp_less_eq(abstol,0) ) 18336 work.ptr.p_double[n+1] = gl; 18337 work.ptr.p_double[n+2] = gl; 18338 work.ptr.p_double[n+3] = gu; 18339 work.ptr.p_double[n+4] = gu; 18340 work.ptr.p_double[n+5] = gl; 18341 work.ptr.p_double[n+6] = gu; 18342 iwork.ptr.p_int[1] = -1; 18343 iwork.ptr.p_int[2] = -1; 18344 iwork.ptr.p_int[3] = n+1; 18345 iwork.ptr.p_int[4] = n+1; 18346 iwork.ptr.p_int[5] = il-1; 18347 iwork.ptr.p_int[6] = iu; 18352 * DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, 18353 * WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, 18354 * IWORK, W, IBLOCK, IINFO ) 18356 ia1s2.ptr.p_int[1] = iwork.ptr.p_int[5]; 18357 ia1s2.ptr.p_int[2] = iwork.ptr.p_int[6]; 18358 ra1s2.ptr.p_double[1] = work.ptr.p_double[n+5]; 18359 ra1s2.ptr.p_double[2] = work.ptr.p_double[n+6]; 18360 ra1s2x2.ptr.pp_double[1][1] = work.ptr.p_double[n+1]; 18361 ra1s2x2.ptr.pp_double[2][1] = work.ptr.p_double[n+2]; 18362 ra1s2x2.ptr.pp_double[1][2] = work.ptr.p_double[n+3]; 18363 ra1s2x2.ptr.pp_double[2][2] = work.ptr.p_double[n+4]; 18364 ia1s2x2.ptr.pp_int[1][1] = iwork.ptr.p_int[1]; 18365 ia1s2x2.ptr.pp_int[2][1] = iwork.ptr.p_int[2]; 18366 ia1s2x2.ptr.pp_int[1][2] = iwork.ptr.p_int[3]; 18367 ia1s2x2.ptr.pp_int[2][2] = iwork.ptr.p_int[4]; 18368 evd_internaldlaebz(3, itmax, n, 2, 2, atoli, rtoli, pivmin, d, e, &work, &ia1s2, &ra1s2x2, &ra1s2, &iout, &ia1s2x2, w, iblock, &iinfo, _state); 18369 iwork.ptr.p_int[5] = ia1s2.ptr.p_int[1]; 18370 iwork.ptr.p_int[6] = ia1s2.ptr.p_int[2]; 18371 work.ptr.p_double[n+5] = ra1s2.ptr.p_double[1]; 18372 work.ptr.p_double[n+6] = ra1s2.ptr.p_double[2]; 18373 work.ptr.p_double[n+1] = ra1s2x2.ptr.pp_double[1][1]; 18374 work.ptr.p_double[n+2] = ra1s2x2.ptr.pp_double[2][1]; 18375 work.ptr.p_double[n+3] = ra1s2x2.ptr.pp_double[1][2]; 18376 work.ptr.p_double[n+4] = ra1s2x2.ptr.pp_double[2][2]; 18377 iwork.ptr.p_int[1] = ia1s2x2.ptr.pp_int[1][1]; 18378 iwork.ptr.p_int[2] = ia1s2x2.ptr.pp_int[2][1]; 18379 iwork.ptr.p_int[3] = ia1s2x2.ptr.pp_int[1][2]; 18380 iwork.ptr.p_int[4] = ia1s2x2.ptr.pp_int[2][2]; 18381 if( iwork.ptr.p_int[6]==iu ) 18383 wl = work.ptr.p_double[n+1]; 18384 wlu = work.ptr.p_double[n+3]; 18385 nwl = iwork.ptr.p_int[1]; 18386 wu = work.ptr.p_double[n+4]; 18387 wul = work.ptr.p_double[n+2]; 18388 nwu = iwork.ptr.p_int[4]; 18392 wl = work.ptr.p_double[n+2]; 18393 wlu = work.ptr.p_double[n+4]; 18394 nwl = iwork.ptr.p_int[2]; 18395 wu = work.ptr.p_double[n+3]; 18396 wul = work.ptr.p_double[n+1]; 18397 nwu = iwork.ptr.p_int[3]; 18399 if( ((nwl<0||nwl>=n)||nwu<1)||nwu>n ) 18403 ae_frame_leave(_state); 18411 * RANGE='A' or 'V' -- Set ATOLI 18413 tnorm = ae_maxreal(ae_fabs(d->ptr.p_double[1], _state)+ae_fabs(e->ptr.p_double[1], _state), ae_fabs(d->ptr.p_double[n], _state)+ae_fabs(e->ptr.p_double[n-1], _state), _state); 18414 for(j=2; j<=n-1; j++) 18416 tnorm = ae_maxreal(tnorm, ae_fabs(d->ptr.p_double[j], _state)+ae_fabs(e->ptr.p_double[j-1], _state)+ae_fabs(e->ptr.p_double[j], _state), _state); 18418 if( ae_fp_less_eq(abstol,0) ) 18439 * Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. 18440 * NWL accumulates the number of eigenvalues .le. WL, 18441 * NWU accumulates the number of eigenvalues .le. WU 18448 for(jb=1; jb<=*nsplit; jb++) 18452 iend = isplit->ptr.p_int[jb]; 18458 * Special Case -- IIN=1 18460 if( irange==1||ae_fp_greater_eq(wl,d->ptr.p_double[ibegin]-pivmin) ) 18464 if( irange==1||ae_fp_greater_eq(wu,d->ptr.p_double[ibegin]-pivmin) ) 18468 if( irange==1||(ae_fp_less(wl,d->ptr.p_double[ibegin]-pivmin)&&ae_fp_greater_eq(wu,d->ptr.p_double[ibegin]-pivmin)) ) 18471 w->ptr.p_double[*m] = d->ptr.p_double[ibegin]; 18472 iblock->ptr.p_int[*m] = jb; 18479 * General Case -- IIN > 1 18481 * Compute Gershgorin Interval 18482 * and use it as the initial interval 18484 gu = d->ptr.p_double[ibegin]; 18485 gl = d->ptr.p_double[ibegin]; 18487 for(j=ibegin; j<=iend-1; j++) 18489 tmp2 = ae_fabs(e->ptr.p_double[j], _state); 18490 gu = ae_maxreal(gu, d->ptr.p_double[j]+tmp1+tmp2, _state); 18491 gl = ae_minreal(gl, d->ptr.p_double[j]-tmp1-tmp2, _state); 18494 gu = ae_maxreal(gu, d->ptr.p_double[iend]+tmp1, _state); 18495 gl = ae_minreal(gl, d->ptr.p_double[iend]-tmp1, _state); 18496 bnorm = ae_maxreal(ae_fabs(gl, _state), ae_fabs(gu, _state), _state); 18497 gl = gl-fudge*bnorm*ulp*iin-fudge*pivmin; 18498 gu = gu+fudge*bnorm*ulp*iin+fudge*pivmin; 18501 * Compute ATOLI for the current submatrix 18503 if( ae_fp_less_eq(abstol,0) ) 18505 atoli = ulp*ae_maxreal(ae_fabs(gl, _state), ae_fabs(gu, _state), _state); 18513 if( ae_fp_less(gu,wl) ) 18519 gl = ae_maxreal(gl, wl, _state); 18520 gu = ae_minreal(gu, wu, _state); 18521 if( ae_fp_greater_eq(gl,gu) ) 18528 * Set Up Initial Interval 18530 work.ptr.p_double[n+1] = gl; 18531 work.ptr.p_double[n+iin+1] = gu; 18536 * CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, 18537 * D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), 18538 * IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, 18539 * IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) 18541 for(tmpi=1; tmpi<=iin; tmpi++) 18543 ra1siin.ptr.p_double[tmpi] = d->ptr.p_double[ibegin-1+tmpi]; 18544 if( ibegin-1+tmpi<n ) 18546 ra2siin.ptr.p_double[tmpi] = e->ptr.p_double[ibegin-1+tmpi]; 18548 ra3siin.ptr.p_double[tmpi] = work.ptr.p_double[ibegin-1+tmpi]; 18549 ra1siinx2.ptr.pp_double[tmpi][1] = work.ptr.p_double[n+tmpi]; 18550 ra1siinx2.ptr.pp_double[tmpi][2] = work.ptr.p_double[n+tmpi+iin]; 18551 ra4siin.ptr.p_double[tmpi] = work.ptr.p_double[n+2*iin+tmpi]; 18552 rworkspace.ptr.p_double[tmpi] = w->ptr.p_double[*m+tmpi]; 18553 iworkspace.ptr.p_int[tmpi] = iblock->ptr.p_int[*m+tmpi]; 18554 ia1siinx2.ptr.pp_int[tmpi][1] = iwork.ptr.p_int[tmpi]; 18555 ia1siinx2.ptr.pp_int[tmpi][2] = iwork.ptr.p_int[tmpi+iin]; 18557 evd_internaldlaebz(1, 0, iin, iin, 1, atoli, rtoli, pivmin, &ra1siin, &ra2siin, &ra3siin, &idumma, &ra1siinx2, &ra4siin, &im, &ia1siinx2, &rworkspace, &iworkspace, &iinfo, _state); 18558 for(tmpi=1; tmpi<=iin; tmpi++) 18560 work.ptr.p_double[n+tmpi] = ra1siinx2.ptr.pp_double[tmpi][1]; 18561 work.ptr.p_double[n+tmpi+iin] = ra1siinx2.ptr.pp_double[tmpi][2]; 18562 work.ptr.p_double[n+2*iin+tmpi] = ra4siin.ptr.p_double[tmpi]; 18563 w->ptr.p_double[*m+tmpi] = rworkspace.ptr.p_double[tmpi]; 18564 iblock->ptr.p_int[*m+tmpi] = iworkspace.ptr.p_int[tmpi]; 18565 iwork.ptr.p_int[tmpi] = ia1siinx2.ptr.pp_int[tmpi][1]; 18566 iwork.ptr.p_int[tmpi+iin] = ia1siinx2.ptr.pp_int[tmpi][2]; 18568 nwl = nwl+iwork.ptr.p_int[1]; 18569 nwu = nwu+iwork.ptr.p_int[iin+1]; 18570 iwoff = *m-iwork.ptr.p_int[1]; 18573 * Compute Eigenvalues 18575 itmax = ae_iceil((ae_log(gu-gl+pivmin, _state)-ae_log(pivmin, _state))/ae_log(2, _state), _state)+2; 18580 *CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, 18581 * D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), 18582 * IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, 18583 * IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) 18585 for(tmpi=1; tmpi<=iin; tmpi++) 18587 ra1siin.ptr.p_double[tmpi] = d->ptr.p_double[ibegin-1+tmpi]; 18588 if( ibegin-1+tmpi<n ) 18590 ra2siin.ptr.p_double[tmpi] = e->ptr.p_double[ibegin-1+tmpi]; 18592 ra3siin.ptr.p_double[tmpi] = work.ptr.p_double[ibegin-1+tmpi]; 18593 ra1siinx2.ptr.pp_double[tmpi][1] = work.ptr.p_double[n+tmpi]; 18594 ra1siinx2.ptr.pp_double[tmpi][2] = work.ptr.p_double[n+tmpi+iin]; 18595 ra4siin.ptr.p_double[tmpi] = work.ptr.p_double[n+2*iin+tmpi]; 18596 rworkspace.ptr.p_double[tmpi] = w->ptr.p_double[*m+tmpi]; 18597 iworkspace.ptr.p_int[tmpi] = iblock->ptr.p_int[*m+tmpi]; 18598 ia1siinx2.ptr.pp_int[tmpi][1] = iwork.ptr.p_int[tmpi]; 18599 ia1siinx2.ptr.pp_int[tmpi][2] = iwork.ptr.p_int[tmpi+iin]; 18601 evd_internaldlaebz(2, itmax, iin, iin, 1, atoli, rtoli, pivmin, &ra1siin, &ra2siin, &ra3siin, &idumma, &ra1siinx2, &ra4siin, &iout, &ia1siinx2, &rworkspace, &iworkspace, &iinfo, _state); 18602 for(tmpi=1; tmpi<=iin; tmpi++) 18604 work.ptr.p_double[n+tmpi] = ra1siinx2.ptr.pp_double[tmpi][1]; 18605 work.ptr.p_double[n+tmpi+iin] = ra1siinx2.ptr.pp_double[tmpi][2]; 18606 work.ptr.p_double[n+2*iin+tmpi] = ra4siin.ptr.p_double[tmpi]; 18607 w->ptr.p_double[*m+tmpi] = rworkspace.ptr.p_double[tmpi]; 18608 iblock->ptr.p_int[*m+tmpi] = iworkspace.ptr.p_int[tmpi]; 18609 iwork.ptr.p_int[tmpi] = ia1siinx2.ptr.pp_int[tmpi][1]; 18610 iwork.ptr.p_int[tmpi+iin] = ia1siinx2.ptr.pp_int[tmpi][2]; 18614 * Copy Eigenvalues Into W and IBLOCK 18615 * Use -JB for block number for unconverged eigenvalues. 18617 for(j=1; j<=iout; j++) 18619 tmp1 = 0.5*(work.ptr.p_double[j+n]+work.ptr.p_double[j+iin+n]); 18622 * Flag non-convergence. 18633 for(je=iwork.ptr.p_int[j]+1+iwoff; je<=iwork.ptr.p_int[j+iin]+iwoff; je++) 18635 w->ptr.p_double[je] = tmp1; 18636 iblock->ptr.p_int[je] = ib; 18644 * If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU 18645 * If NWL+1 < IL or NWU > IU, discard extra eigenvalues. 18652 if( idiscl>0||idiscu>0 ) 18654 for(je=1; je<=*m; je++) 18656 if( ae_fp_less_eq(w->ptr.p_double[je],wlu)&&idiscl>0 ) 18662 if( ae_fp_greater_eq(w->ptr.p_double[je],wul)&&idiscu>0 ) 18669 w->ptr.p_double[im] = w->ptr.p_double[je]; 18670 iblock->ptr.p_int[im] = iblock->ptr.p_int[je]; 18676 if( idiscl>0||idiscu>0 ) 18680 * Code to deal with effects of bad arithmetic: 18681 * Some low eigenvalues to be discarded are not in (WL,WLU], 18682 * or high eigenvalues to be discarded are not in (WUL,WU] 18683 * so just kill off the smallest IDISCL/largest IDISCU 18684 * eigenvalues, by simply finding the smallest/largest 18687 * (If N(w) is monotone non-decreasing, this should never 18693 for(jdisc=1; jdisc<=idiscl; jdisc++) 18696 for(je=1; je<=*m; je++) 18698 if( iblock->ptr.p_int[je]!=0&&(ae_fp_less(w->ptr.p_double[je],wkill)||iw==0) ) 18701 wkill = w->ptr.p_double[je]; 18704 iblock->ptr.p_int[iw] = 0; 18710 for(jdisc=1; jdisc<=idiscu; jdisc++) 18713 for(je=1; je<=*m; je++) 18715 if( iblock->ptr.p_int[je]!=0&&(ae_fp_greater(w->ptr.p_double[je],wkill)||iw==0) ) 18718 wkill = w->ptr.p_double[je]; 18721 iblock->ptr.p_int[iw] = 0; 18725 for(je=1; je<=*m; je++) 18727 if( iblock->ptr.p_int[je]!=0 ) 18730 w->ptr.p_double[im] = w->ptr.p_double[je]; 18731 iblock->ptr.p_int[im] = iblock->ptr.p_int[je]; 18736 if( idiscl<0||idiscu<0 ) 18743 * If ORDER='B', do nothing -- the eigenvalues are already sorted 18745 * If ORDER='E', sort the eigenvalues from smallest to largest 18747 if( iorder==1&&*nsplit>1 ) 18749 for(je=1; je<=*m-1; je++) 18752 tmp1 = w->ptr.p_double[je]; 18753 for(j=je+1; j<=*m; j++) 18755 if( ae_fp_less(w->ptr.p_double[j],tmp1) ) 18758 tmp1 = w->ptr.p_double[j]; 18763 itmp1 = iblock->ptr.p_int[ie]; 18764 w->ptr.p_double[ie] = w->ptr.p_double[je]; 18765 iblock->ptr.p_int[ie] = iblock->ptr.p_int[je]; 18766 w->ptr.p_double[je] = tmp1; 18767 iblock->ptr.p_int[je] = itmp1; 18771 for(j=1; j<=*m; j++) 18773 w->ptr.p_double[j] = w->ptr.p_double[j]*scalefactor; 18778 *errorcode = *errorcode+1; 18782 *errorcode = *errorcode+2; 18784 result = *errorcode==0; 18785 ae_frame_leave(_state); 18790 static void evd_internaldstein(ae_int_t n, 18791 /* Real */ ae_vector* d, 18792 /* Real */ ae_vector* e, 18794 /* Real */ ae_vector* w, 18795 /* Integer */ ae_vector* iblock, 18796 /* Integer */ ae_vector* isplit, 18797 /* Real */ ae_matrix* z, 18798 /* Integer */ ae_vector* ifail, 18802 ae_frame _frame_block; 18839 ae_bool tmpcriterion; 18845 ae_frame_make(_state, &_frame_block); 18846 ae_vector_init_copy(&_e, e, _state, ae_true); 18848 ae_vector_init_copy(&_w, w, _state, ae_true); 18850 ae_matrix_clear(z); 18851 ae_vector_clear(ifail); 18853 ae_vector_init(&work1, 0, DT_REAL, _state, ae_true); 18854 ae_vector_init(&work2, 0, DT_REAL, _state, ae_true); 18855 ae_vector_init(&work3, 0, DT_REAL, _state, ae_true); 18856 ae_vector_init(&work4, 0, DT_REAL, _state, ae_true); 18857 ae_vector_init(&work5, 0, DT_REAL, _state, ae_true); 18858 ae_vector_init(&iwork, 0, DT_INT, _state, ae_true); 18862 ae_vector_set_length(&work1, ae_maxint(n, 1, _state)+1, _state); 18863 ae_vector_set_length(&work2, ae_maxint(n-1, 1, _state)+1, _state); 18864 ae_vector_set_length(&work3, ae_maxint(n, 1, _state)+1, _state); 18865 ae_vector_set_length(&work4, ae_maxint(n, 1, _state)+1, _state); 18866 ae_vector_set_length(&work5, ae_maxint(n, 1, _state)+1, _state); 18867 ae_vector_set_length(&iwork, ae_maxint(n, 1, _state)+1, _state); 18868 ae_vector_set_length(ifail, ae_maxint(m, 1, _state)+1, _state); 18869 ae_matrix_set_length(z, ae_maxint(n, 1, _state)+1, ae_maxint(m, 1, _state)+1, _state); 18872 * these initializers are not really necessary, 18873 * but without them compiler complains about uninitialized locals 18882 * Test the input parameters. 18885 for(i=1; i<=m; i++) 18887 ifail->ptr.p_int[i] = 0; 18892 ae_frame_leave(_state); 18898 ae_frame_leave(_state); 18901 for(j=2; j<=m; j++) 18903 if( iblock->ptr.p_int[j]<iblock->ptr.p_int[j-1] ) 18908 if( iblock->ptr.p_int[j]==iblock->ptr.p_int[j-1]&&ae_fp_less(w->ptr.p_double[j],w->ptr.p_double[j-1]) ) 18916 ae_frame_leave(_state); 18921 * Quick return if possible 18925 ae_frame_leave(_state); 18930 z->ptr.pp_double[1][1] = 1; 18931 ae_frame_leave(_state); 18936 * Some preparations 18939 ae_v_move(&work1.ptr.p_double[1], 1, &e->ptr.p_double[1], 1, ae_v_len(1,ti)); 18940 ae_vector_set_length(e, n+1, _state); 18941 ae_v_move(&e->ptr.p_double[1], 1, &work1.ptr.p_double[1], 1, ae_v_len(1,ti)); 18942 ae_v_move(&work1.ptr.p_double[1], 1, &w->ptr.p_double[1], 1, ae_v_len(1,m)); 18943 ae_vector_set_length(w, n+1, _state); 18944 ae_v_move(&w->ptr.p_double[1], 1, &work1.ptr.p_double[1], 1, ae_v_len(1,m)); 18947 * Get machine constants. 18949 eps = ae_machineepsilon; 18952 * Compute eigenvectors of matrix blocks. 18955 for(nblk=1; nblk<=iblock->ptr.p_int[m]; nblk++) 18959 * Find starting and ending indices of block nblk. 18967 b1 = isplit->ptr.p_int[nblk-1]+1; 18969 bn = isplit->ptr.p_int[nblk]; 18975 * Compute reorthogonalization criterion and stopping criterion. 18978 onenrm = ae_fabs(d->ptr.p_double[b1], _state)+ae_fabs(e->ptr.p_double[b1], _state); 18979 onenrm = ae_maxreal(onenrm, ae_fabs(d->ptr.p_double[bn], _state)+ae_fabs(e->ptr.p_double[bn-1], _state), _state); 18980 for(i=b1+1; i<=bn-1; i++) 18982 onenrm = ae_maxreal(onenrm, ae_fabs(d->ptr.p_double[i], _state)+ae_fabs(e->ptr.p_double[i-1], _state)+ae_fabs(e->ptr.p_double[i], _state), _state); 18984 ortol = 0.001*onenrm; 18985 dtpcrt = ae_sqrt(0.1/blksiz, _state); 18989 * Loop through eigenvalues of block nblk. 18992 for(j=j1; j<=m; j++) 18994 if( iblock->ptr.p_int[j]!=nblk ) 19000 xj = w->ptr.p_double[j]; 19005 * Skip all the work if the block size is one. 19007 work1.ptr.p_double[1] = 1; 19013 * If eigenvalues j and j-1 are too close, add a relatively 19014 * small perturbation. 19018 eps1 = ae_fabs(eps*xj, _state); 19021 if( ae_fp_less(sep,pertol) ) 19030 * Get random starting vector. 19032 for(ti=1; ti<=blksiz; ti++) 19034 work1.ptr.p_double[ti] = 2*ae_randomreal(_state)-1; 19038 * Copy the matrix T so it won't be destroyed in factorization. 19040 for(ti=1; ti<=blksiz-1; ti++) 19042 work2.ptr.p_double[ti] = e->ptr.p_double[b1+ti-1]; 19043 work3.ptr.p_double[ti] = e->ptr.p_double[b1+ti-1]; 19044 work4.ptr.p_double[ti] = d->ptr.p_double[b1+ti-1]; 19046 work4.ptr.p_double[blksiz] = d->ptr.p_double[b1+blksiz-1]; 19049 * Compute LU factors with partial pivoting ( PT = LU ) 19052 evd_tdininternaldlagtf(blksiz, &work4, xj, &work2, &work3, tol, &work5, &iwork, &iinfo, _state); 19055 * Update iteration count. 19064 * If stopping criterion was not satisfied, update info and 19065 * store eigenvector number in array ifail. 19068 ifail->ptr.p_int[*info] = j; 19073 * Normalize and scale the righthand side vector Pb. 19076 for(ti=1; ti<=blksiz; ti++) 19078 v = v+ae_fabs(work1.ptr.p_double[ti], _state); 19080 scl = blksiz*onenrm*ae_maxreal(eps, ae_fabs(work4.ptr.p_double[blksiz], _state), _state)/v; 19081 ae_v_muld(&work1.ptr.p_double[1], 1, ae_v_len(1,blksiz), scl); 19084 * Solve the system LU = Pb. 19086 evd_tdininternaldlagts(blksiz, &work4, &work2, &work3, &work5, &iwork, &work1, &tol, &iinfo, _state); 19089 * Reorthogonalize by modified Gram-Schmidt if eigenvalues are 19094 if( ae_fp_greater(ae_fabs(xj-xjm, _state),ortol) ) 19100 for(i=gpind; i<=j-1; i++) 19104 ztr = ae_v_dotproduct(&work1.ptr.p_double[1], 1, &z->ptr.pp_double[i1][i], z->stride, ae_v_len(1,blksiz)); 19105 ae_v_subd(&work1.ptr.p_double[1], 1, &z->ptr.pp_double[i1][i], z->stride, ae_v_len(1,blksiz), ztr); 19106 touchint(&i2, _state); 19112 * Check the infinity norm of the iterate. 19114 jmax = vectoridxabsmax(&work1, 1, blksiz, _state); 19115 nrm = ae_fabs(work1.ptr.p_double[jmax], _state); 19118 * Continue for additional iterations after norm reaches 19119 * stopping criterion. 19121 tmpcriterion = ae_false; 19122 if( ae_fp_less(nrm,dtpcrt) ) 19124 tmpcriterion = ae_true; 19129 if( nrmchk<extra+1 ) 19131 tmpcriterion = ae_true; 19135 while(tmpcriterion); 19138 * Accept iterate as jth eigenvector. 19140 scl = 1/vectornorm2(&work1, 1, blksiz, _state); 19141 jmax = vectoridxabsmax(&work1, 1, blksiz, _state); 19142 if( ae_fp_less(work1.ptr.p_double[jmax],0) ) 19146 ae_v_muld(&work1.ptr.p_double[1], 1, ae_v_len(1,blksiz), scl); 19148 for(i=1; i<=n; i++) 19150 z->ptr.pp_double[i][j] = 0; 19152 for(i=1; i<=blksiz; i++) 19154 z->ptr.pp_double[b1+i-1][j] = work1.ptr.p_double[i]; 19158 * Save the shift to check eigenvalue spacing at next 19164 ae_frame_leave(_state); 19168 static void evd_tdininternaldlagtf(ae_int_t n, 19169 /* Real */ ae_vector* a, 19171 /* Real */ ae_vector* b, 19172 /* Real */ ae_vector* c, 19174 /* Real */ ae_vector* d, 19175 /* Integer */ ae_vector* iin, 19201 a->ptr.p_double[1] = a->ptr.p_double[1]-lambdav; 19202 iin->ptr.p_int[n] = 0; 19205 if( ae_fp_eq(a->ptr.p_double[1],0) ) 19207 iin->ptr.p_int[1] = 1; 19211 eps = ae_machineepsilon; 19212 tl = ae_maxreal(tol, eps, _state); 19213 scale1 = ae_fabs(a->ptr.p_double[1], _state)+ae_fabs(b->ptr.p_double[1], _state); 19214 for(k=1; k<=n-1; k++) 19216 a->ptr.p_double[k+1] = a->ptr.p_double[k+1]-lambdav; 19217 scale2 = ae_fabs(c->ptr.p_double[k], _state)+ae_fabs(a->ptr.p_double[k+1], _state); 19220 scale2 = scale2+ae_fabs(b->ptr.p_double[k+1], _state); 19222 if( ae_fp_eq(a->ptr.p_double[k],0) ) 19228 piv1 = ae_fabs(a->ptr.p_double[k], _state)/scale1; 19230 if( ae_fp_eq(c->ptr.p_double[k],0) ) 19232 iin->ptr.p_int[k] = 0; 19237 d->ptr.p_double[k] = 0; 19242 piv2 = ae_fabs(c->ptr.p_double[k], _state)/scale2; 19243 if( ae_fp_less_eq(piv2,piv1) ) 19245 iin->ptr.p_int[k] = 0; 19247 c->ptr.p_double[k] = c->ptr.p_double[k]/a->ptr.p_double[k]; 19248 a->ptr.p_double[k+1] = a->ptr.p_double[k+1]-c->ptr.p_double[k]*b->ptr.p_double[k]; 19251 d->ptr.p_double[k] = 0; 19256 iin->ptr.p_int[k] = 1; 19257 mult = a->ptr.p_double[k]/c->ptr.p_double[k]; 19258 a->ptr.p_double[k] = c->ptr.p_double[k]; 19259 temp = a->ptr.p_double[k+1]; 19260 a->ptr.p_double[k+1] = b->ptr.p_double[k]-mult*temp; 19263 d->ptr.p_double[k] = b->ptr.p_double[k+1]; 19264 b->ptr.p_double[k+1] = -mult*d->ptr.p_double[k]; 19266 b->ptr.p_double[k] = temp; 19267 c->ptr.p_double[k] = mult; 19270 if( ae_fp_less_eq(ae_maxreal(piv1, piv2, _state),tl)&&iin->ptr.p_int[n]==0 ) 19272 iin->ptr.p_int[n] = k; 19275 if( ae_fp_less_eq(ae_fabs(a->ptr.p_double[n], _state),scale1*tl)&&iin->ptr.p_int[n]==0 ) 19277 iin->ptr.p_int[n] = n; 19282 static void evd_tdininternaldlagts(ae_int_t n, 19283 /* Real */ ae_vector* a, 19284 /* Real */ ae_vector* b, 19285 /* Real */ ae_vector* c, 19286 /* Real */ ae_vector* d, 19287 /* Integer */ ae_vector* iin, 19288 /* Real */ ae_vector* y, 19314 eps = ae_machineepsilon; 19315 sfmin = ae_minrealnumber; 19317 if( ae_fp_less_eq(*tol,0) ) 19319 *tol = ae_fabs(a->ptr.p_double[1], _state); 19322 *tol = ae_maxreal(*tol, ae_maxreal(ae_fabs(a->ptr.p_double[2], _state), ae_fabs(b->ptr.p_double[1], _state), _state), _state); 19324 for(k=3; k<=n; k++) 19326 *tol = ae_maxreal(*tol, ae_maxreal(ae_fabs(a->ptr.p_double[k], _state), ae_maxreal(ae_fabs(b->ptr.p_double[k-1], _state), ae_fabs(d->ptr.p_double[k-2], _state), _state), _state), _state); 19329 if( ae_fp_eq(*tol,0) ) 19334 for(k=2; k<=n; k++) 19336 if( iin->ptr.p_int[k-1]==0 ) 19338 y->ptr.p_double[k] = y->ptr.p_double[k]-c->ptr.p_double[k-1]*y->ptr.p_double[k-1]; 19342 temp = y->ptr.p_double[k-1]; 19343 y->ptr.p_double[k-1] = y->ptr.p_double[k]; 19344 y->ptr.p_double[k] = temp-c->ptr.p_double[k-1]*y->ptr.p_double[k]; 19347 for(k=n; k>=1; k--) 19351 temp = y->ptr.p_double[k]-b->ptr.p_double[k]*y->ptr.p_double[k+1]-d->ptr.p_double[k]*y->ptr.p_double[k+2]; 19357 temp = y->ptr.p_double[k]-b->ptr.p_double[k]*y->ptr.p_double[k+1]; 19361 temp = y->ptr.p_double[k]; 19364 ak = a->ptr.p_double[k]; 19365 pert = ae_fabs(*tol, _state); 19366 if( ae_fp_less(ak,0) ) 19372 absak = ae_fabs(ak, _state); 19373 if( ae_fp_less(absak,1) ) 19375 if( ae_fp_less(absak,sfmin) ) 19377 if( ae_fp_eq(absak,0)||ae_fp_greater(ae_fabs(temp, _state)*sfmin,absak) ) 19385 temp = temp*bignum; 19391 if( ae_fp_greater(ae_fabs(temp, _state),absak*bignum) ) 19401 y->ptr.p_double[k] = temp/ak; 19406 static void evd_internaldlaebz(ae_int_t ijob, 19414 /* Real */ ae_vector* d, 19415 /* Real */ ae_vector* e, 19416 /* Real */ ae_vector* e2, 19417 /* Integer */ ae_vector* nval, 19418 /* Real */ ae_matrix* ab, 19419 /* Real */ ae_vector* c, 19421 /* Integer */ ae_matrix* nab, 19422 /* Real */ ae_vector* work, 19423 /* Integer */ ae_vector* iwork, 19444 if( ijob<1||ijob>3 ) 19457 * Compute the number of eigenvalues in the initial intervals. 19464 for(ji=1; ji<=minp; ji++) 19466 for(jp=1; jp<=2; jp++) 19468 tmp1 = d->ptr.p_double[1]-ab->ptr.pp_double[ji][jp]; 19469 if( ae_fp_less(ae_fabs(tmp1, _state),pivmin) ) 19473 nab->ptr.pp_int[ji][jp] = 0; 19474 if( ae_fp_less_eq(tmp1,0) ) 19476 nab->ptr.pp_int[ji][jp] = 1; 19478 for(j=2; j<=n; j++) 19480 tmp1 = d->ptr.p_double[j]-e2->ptr.p_double[j-1]/tmp1-ab->ptr.pp_double[ji][jp]; 19481 if( ae_fp_less(ae_fabs(tmp1, _state),pivmin) ) 19485 if( ae_fp_less_eq(tmp1,0) ) 19487 nab->ptr.pp_int[ji][jp] = nab->ptr.pp_int[ji][jp]+1; 19491 *mout = *mout+nab->ptr.pp_int[ji][2]-nab->ptr.pp_int[ji][1]; 19497 * Initialize for loop 19499 * KF and KL have the following meaning: 19500 * Intervals 1,...,KF-1 have converged. 19501 * Intervals KF,...,KL still need to be refined. 19507 * If IJOB=2, initialize C. 19508 * If IJOB=3, use the user-supplied starting point. 19512 for(ji=1; ji<=minp; ji++) 19514 c->ptr.p_double[ji] = 0.5*(ab->ptr.pp_double[ji][1]+ab->ptr.pp_double[ji][2]); 19521 for(jit=1; jit<=nitmax; jit++) 19525 * Loop over intervals 19528 * Serial Version of the loop 19531 for(ji=kf; ji<=kl; ji++) 19535 * Compute N(w), the number of eigenvalues less than w 19537 tmp1 = c->ptr.p_double[ji]; 19538 tmp2 = d->ptr.p_double[1]-tmp1; 19540 if( ae_fp_less_eq(tmp2,pivmin) ) 19543 tmp2 = ae_minreal(tmp2, -pivmin, _state); 19547 * A series of compiler directives to defeat vectorization 19548 * for the next loop 19559 *CIBM PREFER SCALAR 19562 for(j=2; j<=n; j++) 19564 tmp2 = d->ptr.p_double[j]-e2->ptr.p_double[j-1]/tmp2-tmp1; 19565 if( ae_fp_less_eq(tmp2,pivmin) ) 19568 tmp2 = ae_minreal(tmp2, -pivmin, _state); 19575 * IJOB=2: Choose all intervals containing eigenvalues. 19577 * Insure that N(w) is monotone 19579 itmp1 = ae_minint(nab->ptr.pp_int[ji][2], ae_maxint(nab->ptr.pp_int[ji][1], itmp1, _state), _state); 19582 * Update the Queue -- add intervals if both halves 19583 * contain eigenvalues. 19585 if( itmp1==nab->ptr.pp_int[ji][2] ) 19589 * No eigenvalue in the upper interval: 19590 * just use the lower interval. 19592 ab->ptr.pp_double[ji][2] = tmp1; 19596 if( itmp1==nab->ptr.pp_int[ji][1] ) 19600 * No eigenvalue in the lower interval: 19601 * just use the upper interval. 19603 ab->ptr.pp_double[ji][1] = tmp1; 19611 * Eigenvalue in both intervals -- add upper to queue. 19614 ab->ptr.pp_double[klnew][2] = ab->ptr.pp_double[ji][2]; 19615 nab->ptr.pp_int[klnew][2] = nab->ptr.pp_int[ji][2]; 19616 ab->ptr.pp_double[klnew][1] = tmp1; 19617 nab->ptr.pp_int[klnew][1] = itmp1; 19618 ab->ptr.pp_double[ji][2] = tmp1; 19619 nab->ptr.pp_int[ji][2] = itmp1; 19633 * IJOB=3: Binary search. Keep only the interval 19634 * containing w s.t. N(w) = NVAL 19636 if( itmp1<=nval->ptr.p_int[ji] ) 19638 ab->ptr.pp_double[ji][1] = tmp1; 19639 nab->ptr.pp_int[ji][1] = itmp1; 19641 if( itmp1>=nval->ptr.p_int[ji] ) 19643 ab->ptr.pp_double[ji][2] = tmp1; 19644 nab->ptr.pp_int[ji][2] = itmp1; 19651 * Check for convergence 19654 for(ji=kf; ji<=kl; ji++) 19656 tmp1 = ae_fabs(ab->ptr.pp_double[ji][2]-ab->ptr.pp_double[ji][1], _state); 19657 tmp2 = ae_maxreal(ae_fabs(ab->ptr.pp_double[ji][2], _state), ae_fabs(ab->ptr.pp_double[ji][1], _state), _state); 19658 if( ae_fp_less(tmp1,ae_maxreal(abstol, ae_maxreal(pivmin, reltol*tmp2, _state), _state))||nab->ptr.pp_int[ji][1]>=nab->ptr.pp_int[ji][2] ) 19662 * Converged -- Swap with position KFNEW, 19663 * then increment KFNEW 19667 tmp1 = ab->ptr.pp_double[ji][1]; 19668 tmp2 = ab->ptr.pp_double[ji][2]; 19669 itmp1 = nab->ptr.pp_int[ji][1]; 19670 itmp2 = nab->ptr.pp_int[ji][2]; 19671 ab->ptr.pp_double[ji][1] = ab->ptr.pp_double[kfnew][1]; 19672 ab->ptr.pp_double[ji][2] = ab->ptr.pp_double[kfnew][2]; 19673 nab->ptr.pp_int[ji][1] = nab->ptr.pp_int[kfnew][1]; 19674 nab->ptr.pp_int[ji][2] = nab->ptr.pp_int[kfnew][2]; 19675 ab->ptr.pp_double[kfnew][1] = tmp1; 19676 ab->ptr.pp_double[kfnew][2] = tmp2; 19677 nab->ptr.pp_int[kfnew][1] = itmp1; 19678 nab->ptr.pp_int[kfnew][2] = itmp2; 19681 itmp1 = nval->ptr.p_int[ji]; 19682 nval->ptr.p_int[ji] = nval->ptr.p_int[kfnew]; 19683 nval->ptr.p_int[kfnew] = itmp1; 19694 for(ji=kf; ji<=kl; ji++) 19696 c->ptr.p_double[ji] = 0.5*(ab->ptr.pp_double[ji][1]+ab->ptr.pp_double[ji][2]); 19700 * If no more intervals to refine, quit. 19711 *info = ae_maxint(kl+1-kf, 0, _state); 19716 /************************************************************************* 19717 Internal subroutine 19719 -- LAPACK routine (version 3.0) -- 19720 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 19721 Courant Institute, Argonne National Lab, and Rice University 19723 *************************************************************************/ 19724 static void evd_internaltrevc(/* Real */ ae_matrix* t, 19728 /* Boolean */ ae_vector* vselect, 19729 /* Real */ ae_matrix* vl, 19730 /* Real */ ae_matrix* vr, 19735 ae_frame _frame_block; 19736 ae_vector _vselect; 19788 ae_matrix ipivot44; 19792 ae_frame_make(_state, &_frame_block); 19793 ae_vector_init_copy(&_vselect, vselect, _state, ae_true); 19794 vselect = &_vselect; 19797 ae_matrix_init(&x, 0, 0, DT_REAL, _state, ae_true); 19798 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 19799 ae_vector_init(&temp, 0, DT_REAL, _state, ae_true); 19800 ae_matrix_init(&temp11, 0, 0, DT_REAL, _state, ae_true); 19801 ae_matrix_init(&temp22, 0, 0, DT_REAL, _state, ae_true); 19802 ae_matrix_init(&temp11b, 0, 0, DT_REAL, _state, ae_true); 19803 ae_matrix_init(&temp21b, 0, 0, DT_REAL, _state, ae_true); 19804 ae_matrix_init(&temp12b, 0, 0, DT_REAL, _state, ae_true); 19805 ae_matrix_init(&temp22b, 0, 0, DT_REAL, _state, ae_true); 19806 ae_vector_init(&rswap4, 0, DT_BOOL, _state, ae_true); 19807 ae_vector_init(&zswap4, 0, DT_BOOL, _state, ae_true); 19808 ae_matrix_init(&ipivot44, 0, 0, DT_INT, _state, ae_true); 19809 ae_vector_init(&civ4, 0, DT_REAL, _state, ae_true); 19810 ae_vector_init(&crv4, 0, DT_REAL, _state, ae_true); 19812 ae_matrix_set_length(&x, 2+1, 2+1, _state); 19813 ae_matrix_set_length(&temp11, 1+1, 1+1, _state); 19814 ae_matrix_set_length(&temp11b, 1+1, 1+1, _state); 19815 ae_matrix_set_length(&temp21b, 2+1, 1+1, _state); 19816 ae_matrix_set_length(&temp12b, 1+1, 2+1, _state); 19817 ae_matrix_set_length(&temp22b, 2+1, 2+1, _state); 19818 ae_matrix_set_length(&temp22, 2+1, 2+1, _state); 19819 ae_vector_set_length(&work, 3*n+1, _state); 19820 ae_vector_set_length(&temp, n+1, _state); 19821 ae_vector_set_length(&rswap4, 4+1, _state); 19822 ae_vector_set_length(&zswap4, 4+1, _state); 19823 ae_matrix_set_length(&ipivot44, 4+1, 4+1, _state); 19824 ae_vector_set_length(&civ4, 4+1, _state); 19825 ae_vector_set_length(&crv4, 4+1, _state); 19828 if( side==1||side==3 ) 19830 ae_matrix_set_length(vr, n+1, n+1, _state); 19832 if( side==2||side==3 ) 19834 ae_matrix_set_length(vl, n+1, n+1, _state); 19839 * Decode and test the input parameters 19842 rightv = side==1||bothv; 19843 leftv = side==2||bothv; 19851 ae_frame_leave(_state); 19854 if( !rightv&&!leftv ) 19857 ae_frame_leave(_state); 19860 if( (!allv&&!over)&&!somev ) 19863 ae_frame_leave(_state); 19868 * Set M to the number of columns required to store the selected 19869 * eigenvectors, standardize the array SELECT if necessary, and 19876 for(j=1; j<=n; j++) 19881 vselect->ptr.p_bool[j] = ae_false; 19887 if( ae_fp_eq(t->ptr.pp_double[j+1][j],0) ) 19889 if( vselect->ptr.p_bool[j] ) 19897 if( vselect->ptr.p_bool[j]||vselect->ptr.p_bool[j+1] ) 19899 vselect->ptr.p_bool[j] = ae_true; 19906 if( vselect->ptr.p_bool[n] ) 19920 * Quick return if possible. 19924 ae_frame_leave(_state); 19929 * Set the constants to control overflow. 19931 unfl = ae_minrealnumber; 19932 ulp = ae_machineepsilon; 19933 smlnum = unfl*(n/ulp); 19934 bignum = (1-ulp)/smlnum; 19937 * Compute 1-norm of each column of strictly upper triangular 19938 * part of T to control overflow in triangular solver. 19940 work.ptr.p_double[1] = 0; 19941 for(j=2; j<=n; j++) 19943 work.ptr.p_double[j] = 0; 19944 for(i=1; i<=j-1; i++) 19946 work.ptr.p_double[j] = work.ptr.p_double[j]+ae_fabs(t->ptr.pp_double[i][j], _state); 19951 * Index IP is used to specify the real or complex eigenvalue: 19952 * IP = 0, real eigenvalue, 19953 * 1, first of conjugate complex pair: (wr,wi) 19954 * -1, second of conjugate complex pair: (wr,wi) 19961 * Compute right eigenvectors. 19965 for(ki=n; ki>=1; ki--) 19967 skipflag = ae_false; 19970 skipflag = ae_true; 19976 if( ae_fp_neq(t->ptr.pp_double[ki][ki-1],0) ) 19985 if( !vselect->ptr.p_bool[ki] ) 19987 skipflag = ae_true; 19992 if( !vselect->ptr.p_bool[ki-1] ) 19994 skipflag = ae_true; 20003 * Compute the KI-th eigenvalue (WR,WI). 20005 wr = t->ptr.pp_double[ki][ki]; 20009 wi = ae_sqrt(ae_fabs(t->ptr.pp_double[ki][ki-1], _state), _state)*ae_sqrt(ae_fabs(t->ptr.pp_double[ki-1][ki], _state), _state); 20011 smin = ae_maxreal(ulp*(ae_fabs(wr, _state)+ae_fabs(wi, _state)), smlnum, _state); 20016 * Real right eigenvector 20018 work.ptr.p_double[ki+n] = 1; 20021 * Form right-hand side 20023 for(k=1; k<=ki-1; k++) 20025 work.ptr.p_double[k+n] = -t->ptr.pp_double[k][ki]; 20029 * Solve the upper quasi-triangular system: 20030 * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. 20033 for(j=ki-1; j>=1; j--) 20044 if( ae_fp_neq(t->ptr.pp_double[j][j-1],0) ) 20054 * 1-by-1 diagonal block 20056 temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j]; 20057 temp11b.ptr.pp_double[1][1] = work.ptr.p_double[j+n]; 20058 evd_internalhsevdlaln2(ae_false, 1, 1, smin, 1, &temp11, 1.0, 1.0, &temp11b, wr, 0.0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20061 * Scale X(1,1) to avoid overflow when updating 20062 * the right-hand side. 20064 if( ae_fp_greater(xnorm,1) ) 20066 if( ae_fp_greater(work.ptr.p_double[j],bignum/xnorm) ) 20068 x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]/xnorm; 20074 * Scale if necessary 20076 if( ae_fp_neq(scl,1) ) 20080 ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl); 20082 work.ptr.p_double[j+n] = x.ptr.pp_double[1][1]; 20085 * Update right-hand side 20090 vt = -x.ptr.pp_double[1][1]; 20091 ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(k1,k2), vt); 20097 * 2-by-2 diagonal block 20099 temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j-1][j-1]; 20100 temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j-1][j]; 20101 temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j][j-1]; 20102 temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j][j]; 20103 temp21b.ptr.pp_double[1][1] = work.ptr.p_double[j-1+n]; 20104 temp21b.ptr.pp_double[2][1] = work.ptr.p_double[j+n]; 20105 evd_internalhsevdlaln2(ae_false, 2, 1, smin, 1.0, &temp22, 1.0, 1.0, &temp21b, wr, 0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20108 * Scale X(1,1) and X(2,1) to avoid overflow when 20109 * updating the right-hand side. 20111 if( ae_fp_greater(xnorm,1) ) 20113 beta = ae_maxreal(work.ptr.p_double[j-1], work.ptr.p_double[j], _state); 20114 if( ae_fp_greater(beta,bignum/xnorm) ) 20116 x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]/xnorm; 20117 x.ptr.pp_double[2][1] = x.ptr.pp_double[2][1]/xnorm; 20123 * Scale if necessary 20125 if( ae_fp_neq(scl,1) ) 20129 ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl); 20131 work.ptr.p_double[j-1+n] = x.ptr.pp_double[1][1]; 20132 work.ptr.p_double[j+n] = x.ptr.pp_double[2][1]; 20135 * Update right-hand side 20141 vt = -x.ptr.pp_double[1][1]; 20142 ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[1][k4], t->stride, ae_v_len(k1,k2), vt); 20143 vt = -x.ptr.pp_double[2][1]; 20144 ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(k1,k2), vt); 20149 * Copy the vector x or Q*x to VR and normalize. 20155 ae_v_move(&vr->ptr.pp_double[1][iis], vr->stride, &work.ptr.p_double[k1], 1, ae_v_len(1,ki)); 20156 ii = columnidxabsmax(vr, 1, ki, iis, _state); 20157 remax = 1/ae_fabs(vr->ptr.pp_double[ii][iis], _state); 20158 ae_v_muld(&vr->ptr.pp_double[1][iis], vr->stride, ae_v_len(1,ki), remax); 20159 for(k=ki+1; k<=n; k++) 20161 vr->ptr.pp_double[k][iis] = 0; 20168 ae_v_move(&temp.ptr.p_double[1], 1, &vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n)); 20169 matrixvectormultiply(vr, 1, n, 1, ki-1, ae_false, &work, 1+n, ki-1+n, 1.0, &temp, 1, n, work.ptr.p_double[ki+n], _state); 20170 ae_v_move(&vr->ptr.pp_double[1][ki], vr->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n)); 20172 ii = columnidxabsmax(vr, 1, n, ki, _state); 20173 remax = 1/ae_fabs(vr->ptr.pp_double[ii][ki], _state); 20174 ae_v_muld(&vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n), remax); 20181 * Complex right eigenvector. 20184 * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. 20185 * [ (T(KI,KI-1) T(KI,KI) ) ] 20187 if( ae_fp_greater_eq(ae_fabs(t->ptr.pp_double[ki-1][ki], _state),ae_fabs(t->ptr.pp_double[ki][ki-1], _state)) ) 20189 work.ptr.p_double[ki-1+n] = 1; 20190 work.ptr.p_double[ki+n2] = wi/t->ptr.pp_double[ki-1][ki]; 20194 work.ptr.p_double[ki-1+n] = -wi/t->ptr.pp_double[ki][ki-1]; 20195 work.ptr.p_double[ki+n2] = 1; 20197 work.ptr.p_double[ki+n] = 0; 20198 work.ptr.p_double[ki-1+n2] = 0; 20201 * Form right-hand side 20203 for(k=1; k<=ki-2; k++) 20205 work.ptr.p_double[k+n] = -work.ptr.p_double[ki-1+n]*t->ptr.pp_double[k][ki-1]; 20206 work.ptr.p_double[k+n2] = -work.ptr.p_double[ki+n2]*t->ptr.pp_double[k][ki]; 20210 * Solve upper quasi-triangular system: 20211 * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) 20214 for(j=ki-2; j>=1; j--) 20225 if( ae_fp_neq(t->ptr.pp_double[j][j-1],0) ) 20235 * 1-by-1 diagonal block 20237 temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j]; 20238 temp12b.ptr.pp_double[1][1] = work.ptr.p_double[j+n]; 20239 temp12b.ptr.pp_double[1][2] = work.ptr.p_double[j+n+n]; 20240 evd_internalhsevdlaln2(ae_false, 1, 2, smin, 1.0, &temp11, 1.0, 1.0, &temp12b, wr, wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20243 * Scale X(1,1) and X(1,2) to avoid overflow when 20244 * updating the right-hand side. 20246 if( ae_fp_greater(xnorm,1) ) 20248 if( ae_fp_greater(work.ptr.p_double[j],bignum/xnorm) ) 20250 x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]/xnorm; 20251 x.ptr.pp_double[1][2] = x.ptr.pp_double[1][2]/xnorm; 20257 * Scale if necessary 20259 if( ae_fp_neq(scl,1) ) 20263 ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl); 20266 ae_v_muld(&work.ptr.p_double[k1], 1, ae_v_len(k1,k2), scl); 20268 work.ptr.p_double[j+n] = x.ptr.pp_double[1][1]; 20269 work.ptr.p_double[j+n2] = x.ptr.pp_double[1][2]; 20272 * Update the right-hand side 20278 vt = -x.ptr.pp_double[1][1]; 20279 ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[k3][j], t->stride, ae_v_len(k1,k2), vt); 20284 vt = -x.ptr.pp_double[1][2]; 20285 ae_v_addd(&work.ptr.p_double[k1], 1, &t->ptr.pp_double[k3][j], t->stride, ae_v_len(k1,k2), vt); 20291 * 2-by-2 diagonal block 20293 temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j-1][j-1]; 20294 temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j-1][j]; 20295 temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j][j-1]; 20296 temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j][j]; 20297 temp22b.ptr.pp_double[1][1] = work.ptr.p_double[j-1+n]; 20298 temp22b.ptr.pp_double[1][2] = work.ptr.p_double[j-1+n+n]; 20299 temp22b.ptr.pp_double[2][1] = work.ptr.p_double[j+n]; 20300 temp22b.ptr.pp_double[2][2] = work.ptr.p_double[j+n+n]; 20301 evd_internalhsevdlaln2(ae_false, 2, 2, smin, 1.0, &temp22, 1.0, 1.0, &temp22b, wr, wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20304 * Scale X to avoid overflow when updating 20305 * the right-hand side. 20307 if( ae_fp_greater(xnorm,1) ) 20309 beta = ae_maxreal(work.ptr.p_double[j-1], work.ptr.p_double[j], _state); 20310 if( ae_fp_greater(beta,bignum/xnorm) ) 20313 x.ptr.pp_double[1][1] = x.ptr.pp_double[1][1]*rec; 20314 x.ptr.pp_double[1][2] = x.ptr.pp_double[1][2]*rec; 20315 x.ptr.pp_double[2][1] = x.ptr.pp_double[2][1]*rec; 20316 x.ptr.pp_double[2][2] = x.ptr.pp_double[2][2]*rec; 20322 * Scale if necessary 20324 if( ae_fp_neq(scl,1) ) 20326 ae_v_muld(&work.ptr.p_double[1+n], 1, ae_v_len(1+n,ki+n), scl); 20327 ae_v_muld(&work.ptr.p_double[1+n2], 1, ae_v_len(1+n2,ki+n2), scl); 20329 work.ptr.p_double[j-1+n] = x.ptr.pp_double[1][1]; 20330 work.ptr.p_double[j+n] = x.ptr.pp_double[2][1]; 20331 work.ptr.p_double[j-1+n2] = x.ptr.pp_double[1][2]; 20332 work.ptr.p_double[j+n2] = x.ptr.pp_double[2][2]; 20335 * Update the right-hand side 20337 vt = -x.ptr.pp_double[1][1]; 20338 ae_v_addd(&work.ptr.p_double[n+1], 1, &t->ptr.pp_double[1][j-1], t->stride, ae_v_len(n+1,n+j-2), vt); 20339 vt = -x.ptr.pp_double[2][1]; 20340 ae_v_addd(&work.ptr.p_double[n+1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(n+1,n+j-2), vt); 20341 vt = -x.ptr.pp_double[1][2]; 20342 ae_v_addd(&work.ptr.p_double[n2+1], 1, &t->ptr.pp_double[1][j-1], t->stride, ae_v_len(n2+1,n2+j-2), vt); 20343 vt = -x.ptr.pp_double[2][2]; 20344 ae_v_addd(&work.ptr.p_double[n2+1], 1, &t->ptr.pp_double[1][j], t->stride, ae_v_len(n2+1,n2+j-2), vt); 20349 * Copy the vector x or Q*x to VR and normalize. 20353 ae_v_move(&vr->ptr.pp_double[1][iis-1], vr->stride, &work.ptr.p_double[n+1], 1, ae_v_len(1,ki)); 20354 ae_v_move(&vr->ptr.pp_double[1][iis], vr->stride, &work.ptr.p_double[n2+1], 1, ae_v_len(1,ki)); 20356 for(k=1; k<=ki; k++) 20358 emax = ae_maxreal(emax, ae_fabs(vr->ptr.pp_double[k][iis-1], _state)+ae_fabs(vr->ptr.pp_double[k][iis], _state), _state); 20361 ae_v_muld(&vr->ptr.pp_double[1][iis-1], vr->stride, ae_v_len(1,ki), remax); 20362 ae_v_muld(&vr->ptr.pp_double[1][iis], vr->stride, ae_v_len(1,ki), remax); 20363 for(k=ki+1; k<=n; k++) 20365 vr->ptr.pp_double[k][iis-1] = 0; 20366 vr->ptr.pp_double[k][iis] = 0; 20373 ae_v_move(&temp.ptr.p_double[1], 1, &vr->ptr.pp_double[1][ki-1], vr->stride, ae_v_len(1,n)); 20374 matrixvectormultiply(vr, 1, n, 1, ki-2, ae_false, &work, 1+n, ki-2+n, 1.0, &temp, 1, n, work.ptr.p_double[ki-1+n], _state); 20375 ae_v_move(&vr->ptr.pp_double[1][ki-1], vr->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n)); 20376 ae_v_move(&temp.ptr.p_double[1], 1, &vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n)); 20377 matrixvectormultiply(vr, 1, n, 1, ki-2, ae_false, &work, 1+n2, ki-2+n2, 1.0, &temp, 1, n, work.ptr.p_double[ki+n2], _state); 20378 ae_v_move(&vr->ptr.pp_double[1][ki], vr->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n)); 20382 vt = work.ptr.p_double[ki-1+n]; 20383 ae_v_muld(&vr->ptr.pp_double[1][ki-1], vr->stride, ae_v_len(1,n), vt); 20384 vt = work.ptr.p_double[ki+n2]; 20385 ae_v_muld(&vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n), vt); 20388 for(k=1; k<=n; k++) 20390 emax = ae_maxreal(emax, ae_fabs(vr->ptr.pp_double[k][ki-1], _state)+ae_fabs(vr->ptr.pp_double[k][ki], _state), _state); 20393 ae_v_muld(&vr->ptr.pp_double[1][ki-1], vr->stride, ae_v_len(1,n), remax); 20394 ae_v_muld(&vr->ptr.pp_double[1][ki], vr->stride, ae_v_len(1,n), remax); 20417 * Compute left eigenvectors. 20421 for(ki=1; ki<=n; ki++) 20423 skipflag = ae_false; 20426 skipflag = ae_true; 20432 if( ae_fp_neq(t->ptr.pp_double[ki+1][ki],0) ) 20439 if( !vselect->ptr.p_bool[ki] ) 20441 skipflag = ae_true; 20449 * Compute the KI-th eigenvalue (WR,WI). 20451 wr = t->ptr.pp_double[ki][ki]; 20455 wi = ae_sqrt(ae_fabs(t->ptr.pp_double[ki][ki+1], _state), _state)*ae_sqrt(ae_fabs(t->ptr.pp_double[ki+1][ki], _state), _state); 20457 smin = ae_maxreal(ulp*(ae_fabs(wr, _state)+ae_fabs(wi, _state)), smlnum, _state); 20462 * Real left eigenvector. 20464 work.ptr.p_double[ki+n] = 1; 20467 * Form right-hand side 20469 for(k=ki+1; k<=n; k++) 20471 work.ptr.p_double[k+n] = -t->ptr.pp_double[ki][k]; 20475 * Solve the quasi-triangular system: 20476 * (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK 20481 for(j=ki+1; j<=n; j++) 20492 if( ae_fp_neq(t->ptr.pp_double[j+1][j],0) ) 20502 * 1-by-1 diagonal block 20504 * Scale if necessary to avoid overflow when forming 20505 * the right-hand side. 20507 if( ae_fp_greater(work.ptr.p_double[j],vcrit) ) 20510 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec); 20514 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+1][j], t->stride, &work.ptr.p_double[ki+1+n], 1, ae_v_len(ki+1,j-1)); 20515 work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt; 20518 * Solve (T(J,J)-WR)'*X = WORK 20520 temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j]; 20521 temp11b.ptr.pp_double[1][1] = work.ptr.p_double[j+n]; 20522 evd_internalhsevdlaln2(ae_false, 1, 1, smin, 1.0, &temp11, 1.0, 1.0, &temp11b, wr, 0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20525 * Scale if necessary 20527 if( ae_fp_neq(scl,1) ) 20529 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl); 20531 work.ptr.p_double[j+n] = x.ptr.pp_double[1][1]; 20532 vmax = ae_maxreal(ae_fabs(work.ptr.p_double[j+n], _state), vmax, _state); 20533 vcrit = bignum/vmax; 20539 * 2-by-2 diagonal block 20541 * Scale if necessary to avoid overflow when forming 20542 * the right-hand side. 20544 beta = ae_maxreal(work.ptr.p_double[j], work.ptr.p_double[j+1], _state); 20545 if( ae_fp_greater(beta,vcrit) ) 20548 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec); 20552 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+1][j], t->stride, &work.ptr.p_double[ki+1+n], 1, ae_v_len(ki+1,j-1)); 20553 work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt; 20554 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+1][j+1], t->stride, &work.ptr.p_double[ki+1+n], 1, ae_v_len(ki+1,j-1)); 20555 work.ptr.p_double[j+1+n] = work.ptr.p_double[j+1+n]-vt; 20559 * [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) 20560 * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) 20562 temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j][j]; 20563 temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j][j+1]; 20564 temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j+1][j]; 20565 temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j+1][j+1]; 20566 temp21b.ptr.pp_double[1][1] = work.ptr.p_double[j+n]; 20567 temp21b.ptr.pp_double[2][1] = work.ptr.p_double[j+1+n]; 20568 evd_internalhsevdlaln2(ae_true, 2, 1, smin, 1.0, &temp22, 1.0, 1.0, &temp21b, wr, 0, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20571 * Scale if necessary 20573 if( ae_fp_neq(scl,1) ) 20575 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl); 20577 work.ptr.p_double[j+n] = x.ptr.pp_double[1][1]; 20578 work.ptr.p_double[j+1+n] = x.ptr.pp_double[2][1]; 20579 vmax = ae_maxreal(ae_fabs(work.ptr.p_double[j+n], _state), ae_maxreal(ae_fabs(work.ptr.p_double[j+1+n], _state), vmax, _state), _state); 20580 vcrit = bignum/vmax; 20585 * Copy the vector x or Q*x to VL and normalize. 20589 ae_v_move(&vl->ptr.pp_double[ki][iis], vl->stride, &work.ptr.p_double[ki+n], 1, ae_v_len(ki,n)); 20590 ii = columnidxabsmax(vl, ki, n, iis, _state); 20591 remax = 1/ae_fabs(vl->ptr.pp_double[ii][iis], _state); 20592 ae_v_muld(&vl->ptr.pp_double[ki][iis], vl->stride, ae_v_len(ki,n), remax); 20593 for(k=1; k<=ki-1; k++) 20595 vl->ptr.pp_double[k][iis] = 0; 20602 ae_v_move(&temp.ptr.p_double[1], 1, &vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n)); 20603 matrixvectormultiply(vl, 1, n, ki+1, n, ae_false, &work, ki+1+n, n+n, 1.0, &temp, 1, n, work.ptr.p_double[ki+n], _state); 20604 ae_v_move(&vl->ptr.pp_double[1][ki], vl->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n)); 20606 ii = columnidxabsmax(vl, 1, n, ki, _state); 20607 remax = 1/ae_fabs(vl->ptr.pp_double[ii][ki], _state); 20608 ae_v_muld(&vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n), remax); 20615 * Complex left eigenvector. 20618 * ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. 20619 * ((T(KI+1,KI) T(KI+1,KI+1)) ) 20621 if( ae_fp_greater_eq(ae_fabs(t->ptr.pp_double[ki][ki+1], _state),ae_fabs(t->ptr.pp_double[ki+1][ki], _state)) ) 20623 work.ptr.p_double[ki+n] = wi/t->ptr.pp_double[ki][ki+1]; 20624 work.ptr.p_double[ki+1+n2] = 1; 20628 work.ptr.p_double[ki+n] = 1; 20629 work.ptr.p_double[ki+1+n2] = -wi/t->ptr.pp_double[ki+1][ki]; 20631 work.ptr.p_double[ki+1+n] = 0; 20632 work.ptr.p_double[ki+n2] = 0; 20635 * Form right-hand side 20637 for(k=ki+2; k<=n; k++) 20639 work.ptr.p_double[k+n] = -work.ptr.p_double[ki+n]*t->ptr.pp_double[ki][k]; 20640 work.ptr.p_double[k+n2] = -work.ptr.p_double[ki+1+n2]*t->ptr.pp_double[ki+1][k]; 20644 * Solve complex quasi-triangular system: 20645 * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 20650 for(j=ki+2; j<=n; j++) 20661 if( ae_fp_neq(t->ptr.pp_double[j+1][j],0) ) 20671 * 1-by-1 diagonal block 20673 * Scale if necessary to avoid overflow when 20674 * forming the right-hand side elements. 20676 if( ae_fp_greater(work.ptr.p_double[j],vcrit) ) 20679 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec); 20680 ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), rec); 20684 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n], 1, ae_v_len(ki+2,j-1)); 20685 work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt; 20686 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n2], 1, ae_v_len(ki+2,j-1)); 20687 work.ptr.p_double[j+n2] = work.ptr.p_double[j+n2]-vt; 20690 * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 20692 temp11.ptr.pp_double[1][1] = t->ptr.pp_double[j][j]; 20693 temp12b.ptr.pp_double[1][1] = work.ptr.p_double[j+n]; 20694 temp12b.ptr.pp_double[1][2] = work.ptr.p_double[j+n+n]; 20695 evd_internalhsevdlaln2(ae_false, 1, 2, smin, 1.0, &temp11, 1.0, 1.0, &temp12b, wr, -wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20698 * Scale if necessary 20700 if( ae_fp_neq(scl,1) ) 20702 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl); 20703 ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), scl); 20705 work.ptr.p_double[j+n] = x.ptr.pp_double[1][1]; 20706 work.ptr.p_double[j+n2] = x.ptr.pp_double[1][2]; 20707 vmax = ae_maxreal(ae_fabs(work.ptr.p_double[j+n], _state), ae_maxreal(ae_fabs(work.ptr.p_double[j+n2], _state), vmax, _state), _state); 20708 vcrit = bignum/vmax; 20714 * 2-by-2 diagonal block 20716 * Scale if necessary to avoid overflow when forming 20717 * the right-hand side elements. 20719 beta = ae_maxreal(work.ptr.p_double[j], work.ptr.p_double[j+1], _state); 20720 if( ae_fp_greater(beta,vcrit) ) 20723 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), rec); 20724 ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), rec); 20728 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n], 1, ae_v_len(ki+2,j-1)); 20729 work.ptr.p_double[j+n] = work.ptr.p_double[j+n]-vt; 20730 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j], t->stride, &work.ptr.p_double[ki+2+n2], 1, ae_v_len(ki+2,j-1)); 20731 work.ptr.p_double[j+n2] = work.ptr.p_double[j+n2]-vt; 20732 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j+1], t->stride, &work.ptr.p_double[ki+2+n], 1, ae_v_len(ki+2,j-1)); 20733 work.ptr.p_double[j+1+n] = work.ptr.p_double[j+1+n]-vt; 20734 vt = ae_v_dotproduct(&t->ptr.pp_double[ki+2][j+1], t->stride, &work.ptr.p_double[ki+2+n2], 1, ae_v_len(ki+2,j-1)); 20735 work.ptr.p_double[j+1+n2] = work.ptr.p_double[j+1+n2]-vt; 20738 * Solve 2-by-2 complex linear equation 20739 * ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B 20740 * ([T(j+1,j) T(j+1,j+1)] ) 20742 temp22.ptr.pp_double[1][1] = t->ptr.pp_double[j][j]; 20743 temp22.ptr.pp_double[1][2] = t->ptr.pp_double[j][j+1]; 20744 temp22.ptr.pp_double[2][1] = t->ptr.pp_double[j+1][j]; 20745 temp22.ptr.pp_double[2][2] = t->ptr.pp_double[j+1][j+1]; 20746 temp22b.ptr.pp_double[1][1] = work.ptr.p_double[j+n]; 20747 temp22b.ptr.pp_double[1][2] = work.ptr.p_double[j+n+n]; 20748 temp22b.ptr.pp_double[2][1] = work.ptr.p_double[j+1+n]; 20749 temp22b.ptr.pp_double[2][2] = work.ptr.p_double[j+1+n+n]; 20750 evd_internalhsevdlaln2(ae_true, 2, 2, smin, 1.0, &temp22, 1.0, 1.0, &temp22b, wr, -wi, &rswap4, &zswap4, &ipivot44, &civ4, &crv4, &x, &scl, &xnorm, &ierr, _state); 20753 * Scale if necessary 20755 if( ae_fp_neq(scl,1) ) 20757 ae_v_muld(&work.ptr.p_double[ki+n], 1, ae_v_len(ki+n,n+n), scl); 20758 ae_v_muld(&work.ptr.p_double[ki+n2], 1, ae_v_len(ki+n2,n+n2), scl); 20760 work.ptr.p_double[j+n] = x.ptr.pp_double[1][1]; 20761 work.ptr.p_double[j+n2] = x.ptr.pp_double[1][2]; 20762 work.ptr.p_double[j+1+n] = x.ptr.pp_double[2][1]; 20763 work.ptr.p_double[j+1+n2] = x.ptr.pp_double[2][2]; 20764 vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[1][1], _state), vmax, _state); 20765 vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[1][2], _state), vmax, _state); 20766 vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[2][1], _state), vmax, _state); 20767 vmax = ae_maxreal(ae_fabs(x.ptr.pp_double[2][2], _state), vmax, _state); 20768 vcrit = bignum/vmax; 20773 * Copy the vector x or Q*x to VL and normalize. 20777 ae_v_move(&vl->ptr.pp_double[ki][iis], vl->stride, &work.ptr.p_double[ki+n], 1, ae_v_len(ki,n)); 20778 ae_v_move(&vl->ptr.pp_double[ki][iis+1], vl->stride, &work.ptr.p_double[ki+n2], 1, ae_v_len(ki,n)); 20780 for(k=ki; k<=n; k++) 20782 emax = ae_maxreal(emax, ae_fabs(vl->ptr.pp_double[k][iis], _state)+ae_fabs(vl->ptr.pp_double[k][iis+1], _state), _state); 20785 ae_v_muld(&vl->ptr.pp_double[ki][iis], vl->stride, ae_v_len(ki,n), remax); 20786 ae_v_muld(&vl->ptr.pp_double[ki][iis+1], vl->stride, ae_v_len(ki,n), remax); 20787 for(k=1; k<=ki-1; k++) 20789 vl->ptr.pp_double[k][iis] = 0; 20790 vl->ptr.pp_double[k][iis+1] = 0; 20797 ae_v_move(&temp.ptr.p_double[1], 1, &vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n)); 20798 matrixvectormultiply(vl, 1, n, ki+2, n, ae_false, &work, ki+2+n, n+n, 1.0, &temp, 1, n, work.ptr.p_double[ki+n], _state); 20799 ae_v_move(&vl->ptr.pp_double[1][ki], vl->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n)); 20800 ae_v_move(&temp.ptr.p_double[1], 1, &vl->ptr.pp_double[1][ki+1], vl->stride, ae_v_len(1,n)); 20801 matrixvectormultiply(vl, 1, n, ki+2, n, ae_false, &work, ki+2+n2, n+n2, 1.0, &temp, 1, n, work.ptr.p_double[ki+1+n2], _state); 20802 ae_v_move(&vl->ptr.pp_double[1][ki+1], vl->stride, &temp.ptr.p_double[1], 1, ae_v_len(1,n)); 20806 vt = work.ptr.p_double[ki+n]; 20807 ae_v_muld(&vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n), vt); 20808 vt = work.ptr.p_double[ki+1+n2]; 20809 ae_v_muld(&vl->ptr.pp_double[1][ki+1], vl->stride, ae_v_len(1,n), vt); 20812 for(k=1; k<=n; k++) 20814 emax = ae_maxreal(emax, ae_fabs(vl->ptr.pp_double[k][ki], _state)+ae_fabs(vl->ptr.pp_double[k][ki+1], _state), _state); 20817 ae_v_muld(&vl->ptr.pp_double[1][ki], vl->stride, ae_v_len(1,n), remax); 20818 ae_v_muld(&vl->ptr.pp_double[1][ki+1], vl->stride, ae_v_len(1,n), remax); 20837 ae_frame_leave(_state); 20841 /************************************************************************* 20842 DLALN2 solves a system of the form (ca A - w D ) X = s B 20843 or (ca A' - w D) X = s B with possible scaling ("s
") and 20844 perturbation of A. (A' means A-transpose.) 20846 A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA 20847 real diagonal matrix, w is a real or complex value, and X and B are 20848 NA x 1 matrices -- real if w is real, complex if w is complex. NA 20851 If w is complex, X and B are represented as NA x 2 matrices, 20852 the first column of each being the real part and the second 20853 being the imaginary part. 20855 "s
" is a scaling factor (.LE. 1), computed by DLALN2, which is 20856 so chosen that X can be computed without overflow. X is further 20857 scaled if necessary to assure that norm(ca A - w D)*norm(X) is less 20860 If both singular values of (ca A - w D) are less than SMIN, 20861 SMIN*identity will be used instead of (ca A - w D). If only one 20862 singular value is less than SMIN, one element of (ca A - w D) will be 20863 perturbed enough to make the smallest singular value roughly SMIN. 20864 If both singular values are at least SMIN, (ca A - w D) will not be 20865 perturbed. In any case, the perturbation will be at most some small 20866 multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values 20867 are computed by infinity-norm approximations, and thus will only be 20868 correct to a factor of 2 or so. 20870 Note: all input quantities are assumed to be smaller than overflow 20871 by a reasonable factor. (See BIGNUM.) 20873 -- LAPACK auxiliary routine (version 3.0) -- 20874 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 20875 Courant Institute, Argonne National Lab, and Rice University 20877 *************************************************************************/ 20878 static void evd_internalhsevdlaln2(ae_bool ltrans, 20883 /* Real */ ae_matrix* a, 20886 /* Real */ ae_matrix* b, 20889 /* Boolean */ ae_vector* rswap4, 20890 /* Boolean */ ae_vector* zswap4, 20891 /* Integer */ ae_matrix* ipivot44, 20892 /* Real */ ae_vector* civ4, 20893 /* Real */ ae_vector* crv4, 20894 /* Real */ ae_matrix* x, 20944 zswap4->ptr.p_bool[1] = ae_false; 20945 zswap4->ptr.p_bool[2] = ae_false; 20946 zswap4->ptr.p_bool[3] = ae_true; 20947 zswap4->ptr.p_bool[4] = ae_true; 20948 rswap4->ptr.p_bool[1] = ae_false; 20949 rswap4->ptr.p_bool[2] = ae_true; 20950 rswap4->ptr.p_bool[3] = ae_false; 20951 rswap4->ptr.p_bool[4] = ae_true; 20952 ipivot44->ptr.pp_int[1][1] = 1; 20953 ipivot44->ptr.pp_int[2][1] = 2; 20954 ipivot44->ptr.pp_int[3][1] = 3; 20955 ipivot44->ptr.pp_int[4][1] = 4; 20956 ipivot44->ptr.pp_int[1][2] = 2; 20957 ipivot44->ptr.pp_int[2][2] = 1; 20958 ipivot44->ptr.pp_int[3][2] = 4; 20959 ipivot44->ptr.pp_int[4][2] = 3; 20960 ipivot44->ptr.pp_int[1][3] = 3; 20961 ipivot44->ptr.pp_int[2][3] = 4; 20962 ipivot44->ptr.pp_int[3][3] = 1; 20963 ipivot44->ptr.pp_int[4][3] = 2; 20964 ipivot44->ptr.pp_int[1][4] = 4; 20965 ipivot44->ptr.pp_int[2][4] = 3; 20966 ipivot44->ptr.pp_int[3][4] = 2; 20967 ipivot44->ptr.pp_int[4][4] = 1; 20968 smlnum = 2*ae_minrealnumber; 20970 smini = ae_maxreal(smin, smlnum, _state); 20973 * Don't check for input errors 20978 * Standard Initializations 20985 * 1 x 1 (i.e., scalar) system C X = B 20995 csr = ca*a->ptr.pp_double[1][1]-wr*d1; 20996 cnorm = ae_fabs(csr, _state); 20999 * If | C | < SMINI, use C = SMINI 21001 if( ae_fp_less(cnorm,smini) ) 21009 * Check scaling for X = B / C 21011 bnorm = ae_fabs(b->ptr.pp_double[1][1], _state); 21012 if( ae_fp_less(cnorm,1)&&ae_fp_greater(bnorm,1) ) 21014 if( ae_fp_greater(bnorm,bignum*cnorm) ) 21023 x->ptr.pp_double[1][1] = b->ptr.pp_double[1][1]*(*scl)/csr; 21024 *xnorm = ae_fabs(x->ptr.pp_double[1][1], _state); 21030 * Complex 1x1 system (w is complex) 21034 csr = ca*a->ptr.pp_double[1][1]-wr*d1; 21036 cnorm = ae_fabs(csr, _state)+ae_fabs(csi, _state); 21039 * If | C | < SMINI, use C = SMINI 21041 if( ae_fp_less(cnorm,smini) ) 21050 * Check scaling for X = B / C 21052 bnorm = ae_fabs(b->ptr.pp_double[1][1], _state)+ae_fabs(b->ptr.pp_double[1][2], _state); 21053 if( ae_fp_less(cnorm,1)&&ae_fp_greater(bnorm,1) ) 21055 if( ae_fp_greater(bnorm,bignum*cnorm) ) 21064 evd_internalhsevdladiv(*scl*b->ptr.pp_double[1][1], *scl*b->ptr.pp_double[1][2], csr, csi, &tmp1, &tmp2, _state); 21065 x->ptr.pp_double[1][1] = tmp1; 21066 x->ptr.pp_double[1][2] = tmp2; 21067 *xnorm = ae_fabs(x->ptr.pp_double[1][1], _state)+ae_fabs(x->ptr.pp_double[1][2], _state); 21076 * Compute the real part of C = ca A - w D (or ca A' - w D ) 21078 crv4->ptr.p_double[1+0] = ca*a->ptr.pp_double[1][1]-wr*d1; 21079 crv4->ptr.p_double[2+2] = ca*a->ptr.pp_double[2][2]-wr*d2; 21082 crv4->ptr.p_double[1+2] = ca*a->ptr.pp_double[2][1]; 21083 crv4->ptr.p_double[2+0] = ca*a->ptr.pp_double[1][2]; 21087 crv4->ptr.p_double[2+0] = ca*a->ptr.pp_double[2][1]; 21088 crv4->ptr.p_double[1+2] = ca*a->ptr.pp_double[1][2]; 21094 * Real 2x2 system (w is real) 21096 * Find the largest element in C 21100 for(j=1; j<=4; j++) 21102 if( ae_fp_greater(ae_fabs(crv4->ptr.p_double[j], _state),cmax) ) 21104 cmax = ae_fabs(crv4->ptr.p_double[j], _state); 21110 * If norm(C) < SMINI, use SMINI*identity. 21112 if( ae_fp_less(cmax,smini) ) 21114 bnorm = ae_maxreal(ae_fabs(b->ptr.pp_double[1][1], _state), ae_fabs(b->ptr.pp_double[2][1], _state), _state); 21115 if( ae_fp_less(smini,1)&&ae_fp_greater(bnorm,1) ) 21117 if( ae_fp_greater(bnorm,bignum*smini) ) 21123 x->ptr.pp_double[1][1] = temp*b->ptr.pp_double[1][1]; 21124 x->ptr.pp_double[2][1] = temp*b->ptr.pp_double[2][1]; 21125 *xnorm = temp*bnorm; 21131 * Gaussian elimination with complete pivoting. 21133 ur11 = crv4->ptr.p_double[icmax]; 21134 cr21 = crv4->ptr.p_double[ipivot44->ptr.pp_int[2][icmax]]; 21135 ur12 = crv4->ptr.p_double[ipivot44->ptr.pp_int[3][icmax]]; 21136 cr22 = crv4->ptr.p_double[ipivot44->ptr.pp_int[4][icmax]]; 21139 ur22 = cr22-ur12*lr21; 21142 * If smaller pivot < SMINI, use SMINI 21144 if( ae_fp_less(ae_fabs(ur22, _state),smini) ) 21149 if( rswap4->ptr.p_bool[icmax] ) 21151 br1 = b->ptr.pp_double[2][1]; 21152 br2 = b->ptr.pp_double[1][1]; 21156 br1 = b->ptr.pp_double[1][1]; 21157 br2 = b->ptr.pp_double[2][1]; 21159 br2 = br2-lr21*br1; 21160 bbnd = ae_maxreal(ae_fabs(br1*(ur22*ur11r), _state), ae_fabs(br2, _state), _state); 21161 if( ae_fp_greater(bbnd,1)&&ae_fp_less(ae_fabs(ur22, _state),1) ) 21163 if( ae_fp_greater_eq(bbnd,bignum*ae_fabs(ur22, _state)) ) 21168 xr2 = br2*(*scl)/ur22; 21169 xr1 = *scl*br1*ur11r-xr2*(ur11r*ur12); 21170 if( zswap4->ptr.p_bool[icmax] ) 21172 x->ptr.pp_double[1][1] = xr2; 21173 x->ptr.pp_double[2][1] = xr1; 21177 x->ptr.pp_double[1][1] = xr1; 21178 x->ptr.pp_double[2][1] = xr2; 21180 *xnorm = ae_maxreal(ae_fabs(xr1, _state), ae_fabs(xr2, _state), _state); 21183 * Further scaling if norm(A) norm(X) > overflow 21185 if( ae_fp_greater(*xnorm,1)&&ae_fp_greater(cmax,1) ) 21187 if( ae_fp_greater(*xnorm,bignum/cmax) ) 21189 temp = cmax/bignum; 21190 x->ptr.pp_double[1][1] = temp*x->ptr.pp_double[1][1]; 21191 x->ptr.pp_double[2][1] = temp*x->ptr.pp_double[2][1]; 21192 *xnorm = temp*(*xnorm); 21193 *scl = temp*(*scl); 21201 * Complex 2x2 system (w is complex) 21203 * Find the largest element in C 21205 civ4->ptr.p_double[1+0] = -wi*d1; 21206 civ4->ptr.p_double[2+0] = 0; 21207 civ4->ptr.p_double[1+2] = 0; 21208 civ4->ptr.p_double[2+2] = -wi*d2; 21211 for(j=1; j<=4; j++) 21213 if( ae_fp_greater(ae_fabs(crv4->ptr.p_double[j], _state)+ae_fabs(civ4->ptr.p_double[j], _state),cmax) ) 21215 cmax = ae_fabs(crv4->ptr.p_double[j], _state)+ae_fabs(civ4->ptr.p_double[j], _state); 21221 * If norm(C) < SMINI, use SMINI*identity. 21223 if( ae_fp_less(cmax,smini) ) 21225 bnorm = ae_maxreal(ae_fabs(b->ptr.pp_double[1][1], _state)+ae_fabs(b->ptr.pp_double[1][2], _state), ae_fabs(b->ptr.pp_double[2][1], _state)+ae_fabs(b->ptr.pp_double[2][2], _state), _state); 21226 if( ae_fp_less(smini,1)&&ae_fp_greater(bnorm,1) ) 21228 if( ae_fp_greater(bnorm,bignum*smini) ) 21234 x->ptr.pp_double[1][1] = temp*b->ptr.pp_double[1][1]; 21235 x->ptr.pp_double[2][1] = temp*b->ptr.pp_double[2][1]; 21236 x->ptr.pp_double[1][2] = temp*b->ptr.pp_double[1][2]; 21237 x->ptr.pp_double[2][2] = temp*b->ptr.pp_double[2][2]; 21238 *xnorm = temp*bnorm; 21244 * Gaussian elimination with complete pivoting. 21246 ur11 = crv4->ptr.p_double[icmax]; 21247 ui11 = civ4->ptr.p_double[icmax]; 21248 cr21 = crv4->ptr.p_double[ipivot44->ptr.pp_int[2][icmax]]; 21249 ci21 = civ4->ptr.p_double[ipivot44->ptr.pp_int[2][icmax]]; 21250 ur12 = crv4->ptr.p_double[ipivot44->ptr.pp_int[3][icmax]]; 21251 ui12 = civ4->ptr.p_double[ipivot44->ptr.pp_int[3][icmax]]; 21252 cr22 = crv4->ptr.p_double[ipivot44->ptr.pp_int[4][icmax]]; 21253 ci22 = civ4->ptr.p_double[ipivot44->ptr.pp_int[4][icmax]]; 21254 if( icmax==1||icmax==4 ) 21258 * Code when off-diagonals of pivoted C are real 21260 if( ae_fp_greater(ae_fabs(ur11, _state),ae_fabs(ui11, _state)) ) 21263 ur11r = 1/(ur11*(1+ae_sqr(temp, _state))); 21264 ui11r = -temp*ur11r; 21269 ui11r = -1/(ui11*(1+ae_sqr(temp, _state))); 21270 ur11r = -temp*ui11r; 21274 ur12s = ur12*ur11r; 21275 ui12s = ur12*ui11r; 21276 ur22 = cr22-ur12*lr21; 21277 ui22 = ci22-ur12*li21; 21283 * Code when diagonals of pivoted C are real 21289 ur12s = ur12*ur11r; 21290 ui12s = ui12*ur11r; 21291 ur22 = cr22-ur12*lr21+ui12*li21; 21292 ui22 = -ur12*li21-ui12*lr21; 21294 u22abs = ae_fabs(ur22, _state)+ae_fabs(ui22, _state); 21297 * If smaller pivot < SMINI, use SMINI 21299 if( ae_fp_less(u22abs,smini) ) 21305 if( rswap4->ptr.p_bool[icmax] ) 21307 br2 = b->ptr.pp_double[1][1]; 21308 br1 = b->ptr.pp_double[2][1]; 21309 bi2 = b->ptr.pp_double[1][2]; 21310 bi1 = b->ptr.pp_double[2][2]; 21314 br1 = b->ptr.pp_double[1][1]; 21315 br2 = b->ptr.pp_double[2][1]; 21316 bi1 = b->ptr.pp_double[1][2]; 21317 bi2 = b->ptr.pp_double[2][2]; 21319 br2 = br2-lr21*br1+li21*bi1; 21320 bi2 = bi2-li21*br1-lr21*bi1; 21321 bbnd = ae_maxreal((ae_fabs(br1, _state)+ae_fabs(bi1, _state))*(u22abs*(ae_fabs(ur11r, _state)+ae_fabs(ui11r, _state))), ae_fabs(br2, _state)+ae_fabs(bi2, _state), _state); 21322 if( ae_fp_greater(bbnd,1)&&ae_fp_less(u22abs,1) ) 21324 if( ae_fp_greater_eq(bbnd,bignum*u22abs) ) 21333 evd_internalhsevdladiv(br2, bi2, ur22, ui22, &xr2, &xi2, _state); 21334 xr1 = ur11r*br1-ui11r*bi1-ur12s*xr2+ui12s*xi2; 21335 xi1 = ui11r*br1+ur11r*bi1-ui12s*xr2-ur12s*xi2; 21336 if( zswap4->ptr.p_bool[icmax] ) 21338 x->ptr.pp_double[1][1] = xr2; 21339 x->ptr.pp_double[2][1] = xr1; 21340 x->ptr.pp_double[1][2] = xi2; 21341 x->ptr.pp_double[2][2] = xi1; 21345 x->ptr.pp_double[1][1] = xr1; 21346 x->ptr.pp_double[2][1] = xr2; 21347 x->ptr.pp_double[1][2] = xi1; 21348 x->ptr.pp_double[2][2] = xi2; 21350 *xnorm = ae_maxreal(ae_fabs(xr1, _state)+ae_fabs(xi1, _state), ae_fabs(xr2, _state)+ae_fabs(xi2, _state), _state); 21353 * Further scaling if norm(A) norm(X) > overflow 21355 if( ae_fp_greater(*xnorm,1)&&ae_fp_greater(cmax,1) ) 21357 if( ae_fp_greater(*xnorm,bignum/cmax) ) 21359 temp = cmax/bignum; 21360 x->ptr.pp_double[1][1] = temp*x->ptr.pp_double[1][1]; 21361 x->ptr.pp_double[2][1] = temp*x->ptr.pp_double[2][1]; 21362 x->ptr.pp_double[1][2] = temp*x->ptr.pp_double[1][2]; 21363 x->ptr.pp_double[2][2] = temp*x->ptr.pp_double[2][2]; 21364 *xnorm = temp*(*xnorm); 21365 *scl = temp*(*scl); 21373 /************************************************************************* 21374 performs complex division in real arithmetic 21377 p + i*q = --------- 21380 The algorithm is due to Robert L. Smith and can be found 21381 in D. Knuth, The art of Computer Programming, Vol.2, p.195 21383 -- LAPACK auxiliary routine (version 3.0) -- 21384 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 21385 Courant Institute, Argonne National Lab, and Rice University 21387 *************************************************************************/ 21388 static void evd_internalhsevdladiv(double a, 21402 if( ae_fp_less(ae_fabs(d, _state),ae_fabs(c, _state)) ) 21419 static ae_bool evd_nonsymmetricevd(/* Real */ ae_matrix* a, 21422 /* Real */ ae_vector* wr, 21423 /* Real */ ae_vector* wi, 21424 /* Real */ ae_matrix* vl, 21425 /* Real */ ae_matrix* vr, 21428 ae_frame _frame_block; 21438 ae_frame_make(_state, &_frame_block); 21439 ae_matrix_init_copy(&_a, a, _state, ae_true); 21441 ae_vector_clear(wr); 21442 ae_vector_clear(wi); 21443 ae_matrix_clear(vl); 21444 ae_matrix_clear(vr); 21445 ae_matrix_init(&s, 0, 0, DT_REAL, _state, ae_true); 21446 ae_vector_init(&tau, 0, DT_REAL, _state, ae_true); 21447 ae_vector_init(&sel, 0, DT_BOOL, _state, ae_true); 21449 ae_assert(vneeded>=0&&vneeded<=3, "NonSymmetricEVD: incorrect VNeeded!
", _state); 21454 * Eigen values only 21456 evd_toupperhessenberg(a, n, &tau, _state); 21457 internalschurdecomposition(a, n, 0, 0, wr, wi, &s, &info, _state); 21459 ae_frame_leave(_state); 21464 * Eigen values and vectors 21466 evd_toupperhessenberg(a, n, &tau, _state); 21467 evd_unpackqfromupperhessenberg(a, n, &tau, &s, _state); 21468 internalschurdecomposition(a, n, 1, 1, wr, wi, &s, &info, _state); 21472 ae_frame_leave(_state); 21475 if( vneeded==1||vneeded==3 ) 21477 ae_matrix_set_length(vr, n+1, n+1, _state); 21478 for(i=1; i<=n; i++) 21480 ae_v_move(&vr->ptr.pp_double[i][1], 1, &s.ptr.pp_double[i][1], 1, ae_v_len(1,n)); 21483 if( vneeded==2||vneeded==3 ) 21485 ae_matrix_set_length(vl, n+1, n+1, _state); 21486 for(i=1; i<=n; i++) 21488 ae_v_move(&vl->ptr.pp_double[i][1], 1, &s.ptr.pp_double[i][1], 1, ae_v_len(1,n)); 21491 evd_internaltrevc(a, n, vneeded, 1, &sel, vl, vr, &m, &info, _state); 21493 ae_frame_leave(_state); 21498 static void evd_toupperhessenberg(/* Real */ ae_matrix* a, 21500 /* Real */ ae_vector* tau, 21503 ae_frame _frame_block; 21511 ae_frame_make(_state, &_frame_block); 21512 ae_vector_clear(tau); 21513 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 21514 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 21516 ae_assert(n>=0, "ToUpperHessenberg: incorrect N!
", _state); 21519 * Quick return if possible 21523 ae_frame_leave(_state); 21526 ae_vector_set_length(tau, n-1+1, _state); 21527 ae_vector_set_length(&t, n+1, _state); 21528 ae_vector_set_length(&work, n+1, _state); 21529 for(i=1; i<=n-1; i++) 21533 * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) 21537 ae_v_move(&t.ptr.p_double[1], 1, &a->ptr.pp_double[ip1][i], a->stride, ae_v_len(1,nmi)); 21538 generatereflection(&t, nmi, &v, _state); 21539 ae_v_move(&a->ptr.pp_double[ip1][i], a->stride, &t.ptr.p_double[1], 1, ae_v_len(ip1,n)); 21540 tau->ptr.p_double[i] = v; 21541 t.ptr.p_double[1] = 1; 21544 * Apply H(i) to A(1:ihi,i+1:ihi) from the right 21546 applyreflectionfromtheright(a, v, &t, 1, n, i+1, n, &work, _state); 21549 * Apply H(i) to A(i+1:ihi,i+1:n) from the left 21551 applyreflectionfromtheleft(a, v, &t, i+1, n, i+1, n, &work, _state); 21553 ae_frame_leave(_state); 21557 static void evd_unpackqfromupperhessenberg(/* Real */ ae_matrix* a, 21559 /* Real */ ae_vector* tau, 21560 /* Real */ ae_matrix* q, 21563 ae_frame _frame_block; 21571 ae_frame_make(_state, &_frame_block); 21572 ae_matrix_clear(q); 21573 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 21574 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 21578 ae_frame_leave(_state); 21585 ae_matrix_set_length(q, n+1, n+1, _state); 21586 ae_vector_set_length(&v, n+1, _state); 21587 ae_vector_set_length(&work, n+1, _state); 21588 for(i=1; i<=n; i++) 21590 for(j=1; j<=n; j++) 21594 q->ptr.pp_double[i][j] = 1; 21598 q->ptr.pp_double[i][j] = 0; 21606 for(i=1; i<=n-1; i++) 21614 ae_v_move(&v.ptr.p_double[1], 1, &a->ptr.pp_double[ip1][i], a->stride, ae_v_len(1,nmi)); 21615 v.ptr.p_double[1] = 1; 21616 applyreflectionfromtheright(q, tau->ptr.p_double[i], &v, 1, n, i+1, n, &work, _state); 21618 ae_frame_leave(_state); 21624 /************************************************************************* 21625 Generation of a random uniformly distributed (Haar) orthogonal matrix 21628 N - matrix size, N>=1 21631 A - orthogonal NxN matrix, array[0..N-1,0..N-1] 21633 -- ALGLIB routine -- 21636 *************************************************************************/ 21637 void rmatrixrndorthogonal(ae_int_t n, 21638 /* Real */ ae_matrix* a, 21644 ae_matrix_clear(a); 21646 ae_assert(n>=1, "RMatrixRndOrthogonal: N<1!
", _state); 21647 ae_matrix_set_length(a, n, n, _state); 21648 for(i=0; i<=n-1; i++) 21650 for(j=0; j<=n-1; j++) 21654 a->ptr.pp_double[i][j] = 1; 21658 a->ptr.pp_double[i][j] = 0; 21662 rmatrixrndorthogonalfromtheright(a, n, n, _state); 21666 /************************************************************************* 21667 Generation of random NxN matrix with given condition number and norm2(A)=1 21671 C - condition number (in 2-norm) 21674 A - random matrix with norm2(A)=1 and cond(A)=C 21676 -- ALGLIB routine -- 21679 *************************************************************************/ 21680 void rmatrixrndcond(ae_int_t n, 21682 /* Real */ ae_matrix* a, 21685 ae_frame _frame_block; 21692 ae_frame_make(_state, &_frame_block); 21693 ae_matrix_clear(a); 21694 _hqrndstate_init(&rs, _state, ae_true); 21696 ae_assert(n>=1&&ae_fp_greater_eq(c,1), "RMatrixRndCond: N<1
or C<1!
", _state); 21697 ae_matrix_set_length(a, n, n, _state); 21704 a->ptr.pp_double[0][0] = 2*ae_randominteger(2, _state)-1; 21705 ae_frame_leave(_state); 21708 hqrndrandomize(&rs, _state); 21710 l2 = ae_log(1/c, _state); 21711 for(i=0; i<=n-1; i++) 21713 for(j=0; j<=n-1; j++) 21715 a->ptr.pp_double[i][j] = 0; 21718 a->ptr.pp_double[0][0] = ae_exp(l1, _state); 21719 for(i=1; i<=n-2; i++) 21721 a->ptr.pp_double[i][i] = ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state); 21723 a->ptr.pp_double[n-1][n-1] = ae_exp(l2, _state); 21724 rmatrixrndorthogonalfromtheleft(a, n, n, _state); 21725 rmatrixrndorthogonalfromtheright(a, n, n, _state); 21726 ae_frame_leave(_state); 21730 /************************************************************************* 21731 Generation of a random Haar distributed orthogonal complex matrix 21734 N - matrix size, N>=1 21737 A - orthogonal NxN matrix, array[0..N-1,0..N-1] 21739 -- ALGLIB routine -- 21742 *************************************************************************/ 21743 void cmatrixrndorthogonal(ae_int_t n, 21744 /* Complex */ ae_matrix* a, 21750 ae_matrix_clear(a); 21752 ae_assert(n>=1, "CMatrixRndOrthogonal: N<1!
", _state); 21753 ae_matrix_set_length(a, n, n, _state); 21754 for(i=0; i<=n-1; i++) 21756 for(j=0; j<=n-1; j++) 21760 a->ptr.pp_complex[i][j] = ae_complex_from_d(1); 21764 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 21768 cmatrixrndorthogonalfromtheright(a, n, n, _state); 21772 /************************************************************************* 21773 Generation of random NxN complex matrix with given condition number C and 21778 C - condition number (in 2-norm) 21781 A - random matrix with norm2(A)=1 and cond(A)=C 21783 -- ALGLIB routine -- 21786 *************************************************************************/ 21787 void cmatrixrndcond(ae_int_t n, 21789 /* Complex */ ae_matrix* a, 21792 ae_frame _frame_block; 21800 ae_frame_make(_state, &_frame_block); 21801 ae_matrix_clear(a); 21802 _hqrndstate_init(&state, _state, ae_true); 21804 ae_assert(n>=1&&ae_fp_greater_eq(c,1), "CMatrixRndCond: N<1
or C<1!
", _state); 21805 ae_matrix_set_length(a, n, n, _state); 21812 hqrndrandomize(&state, _state); 21813 hqrndunit2(&state, &v.x, &v.y, _state); 21814 a->ptr.pp_complex[0][0] = v; 21815 ae_frame_leave(_state); 21818 hqrndrandomize(&state, _state); 21820 l2 = ae_log(1/c, _state); 21821 for(i=0; i<=n-1; i++) 21823 for(j=0; j<=n-1; j++) 21825 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 21828 a->ptr.pp_complex[0][0] = ae_complex_from_d(ae_exp(l1, _state)); 21829 for(i=1; i<=n-2; i++) 21831 a->ptr.pp_complex[i][i] = ae_complex_from_d(ae_exp(hqrnduniformr(&state, _state)*(l2-l1)+l1, _state)); 21833 a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(ae_exp(l2, _state)); 21834 cmatrixrndorthogonalfromtheleft(a, n, n, _state); 21835 cmatrixrndorthogonalfromtheright(a, n, n, _state); 21836 ae_frame_leave(_state); 21840 /************************************************************************* 21841 Generation of random NxN symmetric matrix with given condition number and 21846 C - condition number (in 2-norm) 21849 A - random matrix with norm2(A)=1 and cond(A)=C 21851 -- ALGLIB routine -- 21854 *************************************************************************/ 21855 void smatrixrndcond(ae_int_t n, 21857 /* Real */ ae_matrix* a, 21860 ae_frame _frame_block; 21867 ae_frame_make(_state, &_frame_block); 21868 ae_matrix_clear(a); 21869 _hqrndstate_init(&rs, _state, ae_true); 21871 ae_assert(n>=1&&ae_fp_greater_eq(c,1), "SMatrixRndCond: N<1
or C<1!
", _state); 21872 ae_matrix_set_length(a, n, n, _state); 21879 a->ptr.pp_double[0][0] = 2*ae_randominteger(2, _state)-1; 21880 ae_frame_leave(_state); 21887 hqrndrandomize(&rs, _state); 21889 l2 = ae_log(1/c, _state); 21890 for(i=0; i<=n-1; i++) 21892 for(j=0; j<=n-1; j++) 21894 a->ptr.pp_double[i][j] = 0; 21897 a->ptr.pp_double[0][0] = ae_exp(l1, _state); 21898 for(i=1; i<=n-2; i++) 21900 a->ptr.pp_double[i][i] = (2*hqrnduniformi(&rs, 2, _state)-1)*ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state); 21902 a->ptr.pp_double[n-1][n-1] = ae_exp(l2, _state); 21907 smatrixrndmultiply(a, n, _state); 21908 ae_frame_leave(_state); 21912 /************************************************************************* 21913 Generation of random NxN symmetric positive definite matrix with given 21914 condition number and norm2(A)=1 21918 C - condition number (in 2-norm) 21921 A - random SPD matrix with norm2(A)=1 and cond(A)=C 21923 -- ALGLIB routine -- 21926 *************************************************************************/ 21927 void spdmatrixrndcond(ae_int_t n, 21929 /* Real */ ae_matrix* a, 21932 ae_frame _frame_block; 21939 ae_frame_make(_state, &_frame_block); 21940 ae_matrix_clear(a); 21941 _hqrndstate_init(&rs, _state, ae_true); 21947 if( n<=0||ae_fp_less(c,1) ) 21949 ae_frame_leave(_state); 21952 ae_matrix_set_length(a, n, n, _state); 21955 a->ptr.pp_double[0][0] = 1; 21956 ae_frame_leave(_state); 21963 hqrndrandomize(&rs, _state); 21965 l2 = ae_log(1/c, _state); 21966 for(i=0; i<=n-1; i++) 21968 for(j=0; j<=n-1; j++) 21970 a->ptr.pp_double[i][j] = 0; 21973 a->ptr.pp_double[0][0] = ae_exp(l1, _state); 21974 for(i=1; i<=n-2; i++) 21976 a->ptr.pp_double[i][i] = ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state); 21978 a->ptr.pp_double[n-1][n-1] = ae_exp(l2, _state); 21983 smatrixrndmultiply(a, n, _state); 21984 ae_frame_leave(_state); 21988 /************************************************************************* 21989 Generation of random NxN Hermitian matrix with given condition number and 21994 C - condition number (in 2-norm) 21997 A - random matrix with norm2(A)=1 and cond(A)=C 21999 -- ALGLIB routine -- 22002 *************************************************************************/ 22003 void hmatrixrndcond(ae_int_t n, 22005 /* Complex */ ae_matrix* a, 22008 ae_frame _frame_block; 22015 ae_frame_make(_state, &_frame_block); 22016 ae_matrix_clear(a); 22017 _hqrndstate_init(&rs, _state, ae_true); 22019 ae_assert(n>=1&&ae_fp_greater_eq(c,1), "HMatrixRndCond: N<1
or C<1!
", _state); 22020 ae_matrix_set_length(a, n, n, _state); 22027 a->ptr.pp_complex[0][0] = ae_complex_from_d(2*ae_randominteger(2, _state)-1); 22028 ae_frame_leave(_state); 22035 hqrndrandomize(&rs, _state); 22037 l2 = ae_log(1/c, _state); 22038 for(i=0; i<=n-1; i++) 22040 for(j=0; j<=n-1; j++) 22042 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 22045 a->ptr.pp_complex[0][0] = ae_complex_from_d(ae_exp(l1, _state)); 22046 for(i=1; i<=n-2; i++) 22048 a->ptr.pp_complex[i][i] = ae_complex_from_d((2*hqrnduniformi(&rs, 2, _state)-1)*ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state)); 22050 a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(ae_exp(l2, _state)); 22055 hmatrixrndmultiply(a, n, _state); 22058 * post-process to ensure that matrix diagonal is real 22060 for(i=0; i<=n-1; i++) 22062 a->ptr.pp_complex[i][i].y = 0; 22064 ae_frame_leave(_state); 22068 /************************************************************************* 22069 Generation of random NxN Hermitian positive definite matrix with given 22070 condition number and norm2(A)=1 22074 C - condition number (in 2-norm) 22077 A - random HPD matrix with norm2(A)=1 and cond(A)=C 22079 -- ALGLIB routine -- 22082 *************************************************************************/ 22083 void hpdmatrixrndcond(ae_int_t n, 22085 /* Complex */ ae_matrix* a, 22088 ae_frame _frame_block; 22095 ae_frame_make(_state, &_frame_block); 22096 ae_matrix_clear(a); 22097 _hqrndstate_init(&rs, _state, ae_true); 22103 if( n<=0||ae_fp_less(c,1) ) 22105 ae_frame_leave(_state); 22108 ae_matrix_set_length(a, n, n, _state); 22111 a->ptr.pp_complex[0][0] = ae_complex_from_d(1); 22112 ae_frame_leave(_state); 22119 hqrndrandomize(&rs, _state); 22121 l2 = ae_log(1/c, _state); 22122 for(i=0; i<=n-1; i++) 22124 for(j=0; j<=n-1; j++) 22126 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 22129 a->ptr.pp_complex[0][0] = ae_complex_from_d(ae_exp(l1, _state)); 22130 for(i=1; i<=n-2; i++) 22132 a->ptr.pp_complex[i][i] = ae_complex_from_d(ae_exp(hqrnduniformr(&rs, _state)*(l2-l1)+l1, _state)); 22134 a->ptr.pp_complex[n-1][n-1] = ae_complex_from_d(ae_exp(l2, _state)); 22139 hmatrixrndmultiply(a, n, _state); 22142 * post-process to ensure that matrix diagonal is real 22144 for(i=0; i<=n-1; i++) 22146 a->ptr.pp_complex[i][i].y = 0; 22148 ae_frame_leave(_state); 22152 /************************************************************************* 22153 Multiplication of MxN matrix by NxN random Haar distributed orthogonal matrix 22156 A - matrix, array[0..M-1, 0..N-1] 22160 A - A*Q, where Q is random NxN orthogonal matrix 22162 -- ALGLIB routine -- 22165 *************************************************************************/ 22166 void rmatrixrndorthogonalfromtheright(/* Real */ ae_matrix* a, 22171 ae_frame _frame_block; 22182 ae_frame_make(_state, &_frame_block); 22183 ae_vector_init(&w, 0, DT_REAL, _state, ae_true); 22184 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 22185 _hqrndstate_init(&state, _state, ae_true); 22187 ae_assert(n>=1&&m>=1, "RMatrixRndOrthogonalFromTheRight: N<1
or M<1!
", _state); 22194 tau = 2*ae_randominteger(2, _state)-1; 22195 for(i=0; i<=m-1; i++) 22197 a->ptr.pp_double[i][0] = a->ptr.pp_double[i][0]*tau; 22199 ae_frame_leave(_state); 22207 ae_vector_set_length(&w, m, _state); 22208 ae_vector_set_length(&v, n+1, _state); 22209 hqrndrandomize(&state, _state); 22210 for(s=2; s<=n; s++) 22214 * Prepare random normal v 22221 hqrndnormal2(&state, &u1, &u2, _state); 22222 v.ptr.p_double[i] = u1; 22225 v.ptr.p_double[i+1] = u2; 22229 lambdav = ae_v_dotproduct(&v.ptr.p_double[1], 1, &v.ptr.p_double[1], 1, ae_v_len(1,s)); 22231 while(ae_fp_eq(lambdav,0)); 22234 * Prepare and apply reflection 22236 generatereflection(&v, s, &tau, _state); 22237 v.ptr.p_double[1] = 1; 22238 applyreflectionfromtheright(a, tau, &v, 0, m-1, n-s, n-1, &w, _state); 22244 for(i=0; i<=n-1; i++) 22246 tau = 2*hqrnduniformi(&state, 2, _state)-1; 22247 ae_v_muld(&a->ptr.pp_double[0][i], a->stride, ae_v_len(0,m-1), tau); 22249 ae_frame_leave(_state); 22253 /************************************************************************* 22254 Multiplication of MxN matrix by MxM random Haar distributed orthogonal matrix 22257 A - matrix, array[0..M-1, 0..N-1] 22261 A - Q*A, where Q is random MxM orthogonal matrix 22263 -- ALGLIB routine -- 22266 *************************************************************************/ 22267 void rmatrixrndorthogonalfromtheleft(/* Real */ ae_matrix* a, 22272 ae_frame _frame_block; 22284 ae_frame_make(_state, &_frame_block); 22285 ae_vector_init(&w, 0, DT_REAL, _state, ae_true); 22286 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 22287 _hqrndstate_init(&state, _state, ae_true); 22289 ae_assert(n>=1&&m>=1, "RMatrixRndOrthogonalFromTheRight: N<1
or M<1!
", _state); 22296 tau = 2*ae_randominteger(2, _state)-1; 22297 for(j=0; j<=n-1; j++) 22299 a->ptr.pp_double[0][j] = a->ptr.pp_double[0][j]*tau; 22301 ae_frame_leave(_state); 22309 ae_vector_set_length(&w, n, _state); 22310 ae_vector_set_length(&v, m+1, _state); 22311 hqrndrandomize(&state, _state); 22312 for(s=2; s<=m; s++) 22316 * Prepare random normal v 22323 hqrndnormal2(&state, &u1, &u2, _state); 22324 v.ptr.p_double[i] = u1; 22327 v.ptr.p_double[i+1] = u2; 22331 lambdav = ae_v_dotproduct(&v.ptr.p_double[1], 1, &v.ptr.p_double[1], 1, ae_v_len(1,s)); 22333 while(ae_fp_eq(lambdav,0)); 22336 * Prepare and apply reflection 22338 generatereflection(&v, s, &tau, _state); 22339 v.ptr.p_double[1] = 1; 22340 applyreflectionfromtheleft(a, tau, &v, m-s, m-1, 0, n-1, &w, _state); 22346 for(i=0; i<=m-1; i++) 22348 tau = 2*hqrnduniformi(&state, 2, _state)-1; 22349 ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), tau); 22351 ae_frame_leave(_state); 22355 /************************************************************************* 22356 Multiplication of MxN complex matrix by NxN random Haar distributed 22357 complex orthogonal matrix 22360 A - matrix, array[0..M-1, 0..N-1] 22364 A - A*Q, where Q is random NxN orthogonal matrix 22366 -- ALGLIB routine -- 22369 *************************************************************************/ 22370 void cmatrixrndorthogonalfromtheright(/* Complex */ ae_matrix* a, 22375 ae_frame _frame_block; 22376 ae_complex lambdav; 22384 ae_frame_make(_state, &_frame_block); 22385 ae_vector_init(&w, 0, DT_COMPLEX, _state, ae_true); 22386 ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true); 22387 _hqrndstate_init(&state, _state, ae_true); 22389 ae_assert(n>=1&&m>=1, "CMatrixRndOrthogonalFromTheRight: N<1
or M<1!
", _state); 22396 hqrndrandomize(&state, _state); 22397 hqrndunit2(&state, &tau.x, &tau.y, _state); 22398 for(i=0; i<=m-1; i++) 22400 a->ptr.pp_complex[i][0] = ae_c_mul(a->ptr.pp_complex[i][0],tau); 22402 ae_frame_leave(_state); 22410 ae_vector_set_length(&w, m, _state); 22411 ae_vector_set_length(&v, n+1, _state); 22412 hqrndrandomize(&state, _state); 22413 for(s=2; s<=n; s++) 22417 * Prepare random normal v 22421 for(i=1; i<=s; i++) 22423 hqrndnormal2(&state, &tau.x, &tau.y, _state); 22424 v.ptr.p_complex[i] = tau; 22426 lambdav = ae_v_cdotproduct(&v.ptr.p_complex[1], 1, "N
", &v.ptr.p_complex[1], 1, "Conj
", ae_v_len(1,s)); 22428 while(ae_c_eq_d(lambdav,0)); 22431 * Prepare and apply reflection 22433 complexgeneratereflection(&v, s, &tau, _state); 22434 v.ptr.p_complex[1] = ae_complex_from_d(1); 22435 complexapplyreflectionfromtheright(a, tau, &v, 0, m-1, n-s, n-1, &w, _state); 22441 for(i=0; i<=n-1; i++) 22443 hqrndunit2(&state, &tau.x, &tau.y, _state); 22444 ae_v_cmulc(&a->ptr.pp_complex[0][i], a->stride, ae_v_len(0,m-1), tau); 22446 ae_frame_leave(_state); 22450 /************************************************************************* 22451 Multiplication of MxN complex matrix by MxM random Haar distributed 22452 complex orthogonal matrix 22455 A - matrix, array[0..M-1, 0..N-1] 22459 A - Q*A, where Q is random MxM orthogonal matrix 22461 -- ALGLIB routine -- 22464 *************************************************************************/ 22465 void cmatrixrndorthogonalfromtheleft(/* Complex */ ae_matrix* a, 22470 ae_frame _frame_block; 22472 ae_complex lambdav; 22480 ae_frame_make(_state, &_frame_block); 22481 ae_vector_init(&w, 0, DT_COMPLEX, _state, ae_true); 22482 ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true); 22483 _hqrndstate_init(&state, _state, ae_true); 22485 ae_assert(n>=1&&m>=1, "CMatrixRndOrthogonalFromTheRight: N<1
or M<1!
", _state); 22492 hqrndrandomize(&state, _state); 22493 hqrndunit2(&state, &tau.x, &tau.y, _state); 22494 for(j=0; j<=n-1; j++) 22496 a->ptr.pp_complex[0][j] = ae_c_mul(a->ptr.pp_complex[0][j],tau); 22498 ae_frame_leave(_state); 22506 ae_vector_set_length(&w, n, _state); 22507 ae_vector_set_length(&v, m+1, _state); 22508 hqrndrandomize(&state, _state); 22509 for(s=2; s<=m; s++) 22513 * Prepare random normal v 22517 for(i=1; i<=s; i++) 22519 hqrndnormal2(&state, &tau.x, &tau.y, _state); 22520 v.ptr.p_complex[i] = tau; 22522 lambdav = ae_v_cdotproduct(&v.ptr.p_complex[1], 1, "N
", &v.ptr.p_complex[1], 1, "Conj
", ae_v_len(1,s)); 22524 while(ae_c_eq_d(lambdav,0)); 22527 * Prepare and apply reflection 22529 complexgeneratereflection(&v, s, &tau, _state); 22530 v.ptr.p_complex[1] = ae_complex_from_d(1); 22531 complexapplyreflectionfromtheleft(a, tau, &v, m-s, m-1, 0, n-1, &w, _state); 22537 for(i=0; i<=m-1; i++) 22539 hqrndunit2(&state, &tau.x, &tau.y, _state); 22540 ae_v_cmulc(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), tau); 22542 ae_frame_leave(_state); 22546 /************************************************************************* 22547 Symmetric multiplication of NxN matrix by random Haar distributed 22551 A - matrix, array[0..N-1, 0..N-1] 22555 A - Q'*A*Q, where Q is random NxN orthogonal matrix 22557 -- ALGLIB routine -- 22560 *************************************************************************/ 22561 void smatrixrndmultiply(/* Real */ ae_matrix* a, 22565 ae_frame _frame_block; 22576 ae_frame_make(_state, &_frame_block); 22577 ae_vector_init(&w, 0, DT_REAL, _state, ae_true); 22578 ae_vector_init(&v, 0, DT_REAL, _state, ae_true); 22579 _hqrndstate_init(&state, _state, ae_true); 22585 ae_vector_set_length(&w, n, _state); 22586 ae_vector_set_length(&v, n+1, _state); 22587 hqrndrandomize(&state, _state); 22588 for(s=2; s<=n; s++) 22592 * Prepare random normal v 22599 hqrndnormal2(&state, &u1, &u2, _state); 22600 v.ptr.p_double[i] = u1; 22603 v.ptr.p_double[i+1] = u2; 22607 lambdav = ae_v_dotproduct(&v.ptr.p_double[1], 1, &v.ptr.p_double[1], 1, ae_v_len(1,s)); 22609 while(ae_fp_eq(lambdav,0)); 22612 * Prepare and apply reflection 22614 generatereflection(&v, s, &tau, _state); 22615 v.ptr.p_double[1] = 1; 22616 applyreflectionfromtheright(a, tau, &v, 0, n-1, n-s, n-1, &w, _state); 22617 applyreflectionfromtheleft(a, tau, &v, n-s, n-1, 0, n-1, &w, _state); 22623 for(i=0; i<=n-1; i++) 22625 tau = 2*hqrnduniformi(&state, 2, _state)-1; 22626 ae_v_muld(&a->ptr.pp_double[0][i], a->stride, ae_v_len(0,n-1), tau); 22627 ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), tau); 22631 * Copy upper triangle to lower 22633 for(i=0; i<=n-2; i++) 22635 ae_v_move(&a->ptr.pp_double[i+1][i], a->stride, &a->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1)); 22637 ae_frame_leave(_state); 22641 /************************************************************************* 22642 Hermitian multiplication of NxN matrix by random Haar distributed 22643 complex orthogonal matrix 22646 A - matrix, array[0..N-1, 0..N-1] 22650 A - Q^H*A*Q, where Q is random NxN orthogonal matrix 22652 -- ALGLIB routine -- 22655 *************************************************************************/ 22656 void hmatrixrndmultiply(/* Complex */ ae_matrix* a, 22660 ae_frame _frame_block; 22662 ae_complex lambdav; 22669 ae_frame_make(_state, &_frame_block); 22670 ae_vector_init(&w, 0, DT_COMPLEX, _state, ae_true); 22671 ae_vector_init(&v, 0, DT_COMPLEX, _state, ae_true); 22672 _hqrndstate_init(&state, _state, ae_true); 22678 ae_vector_set_length(&w, n, _state); 22679 ae_vector_set_length(&v, n+1, _state); 22680 hqrndrandomize(&state, _state); 22681 for(s=2; s<=n; s++) 22685 * Prepare random normal v 22689 for(i=1; i<=s; i++) 22691 hqrndnormal2(&state, &tau.x, &tau.y, _state); 22692 v.ptr.p_complex[i] = tau; 22694 lambdav = ae_v_cdotproduct(&v.ptr.p_complex[1], 1, "N
", &v.ptr.p_complex[1], 1, "Conj
", ae_v_len(1,s)); 22696 while(ae_c_eq_d(lambdav,0)); 22699 * Prepare and apply reflection 22701 complexgeneratereflection(&v, s, &tau, _state); 22702 v.ptr.p_complex[1] = ae_complex_from_d(1); 22703 complexapplyreflectionfromtheright(a, tau, &v, 0, n-1, n-s, n-1, &w, _state); 22704 complexapplyreflectionfromtheleft(a, ae_c_conj(tau, _state), &v, n-s, n-1, 0, n-1, &w, _state); 22710 for(i=0; i<=n-1; i++) 22712 hqrndunit2(&state, &tau.x, &tau.y, _state); 22713 ae_v_cmulc(&a->ptr.pp_complex[0][i], a->stride, ae_v_len(0,n-1), tau); 22714 tau = ae_c_conj(tau, _state); 22715 ae_v_cmulc(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), tau); 22719 * Change all values from lower triangle by complex-conjugate values 22722 for(i=0; i<=n-2; i++) 22724 ae_v_cmove(&a->ptr.pp_complex[i+1][i], a->stride, &a->ptr.pp_complex[i][i+1], 1, "N
", ae_v_len(i+1,n-1)); 22726 for(s=0; s<=n-2; s++) 22728 for(i=s+1; i<=n-1; i++) 22730 a->ptr.pp_complex[i][s].y = -a->ptr.pp_complex[i][s].y; 22733 ae_frame_leave(_state); 22739 /************************************************************************* 22740 LU decomposition of a general real matrix with row pivoting 22742 A is represented as A = P*L*U, where: 22743 * L is lower unitriangular matrix 22744 * U is upper triangular matrix 22745 * P = P0*P1*...*PK, K=min(M,N)-1, 22746 Pi - permutation matrix for I and Pivots[I] 22748 This is cache-oblivous implementation of LU decomposition. 22749 It is optimized for square matrices. As for rectangular matrices: 22751 * worst case - N>>M, small M, large N, matrix does not fit in CPU cache 22754 A - array[0..M-1, 0..N-1]. 22755 M - number of rows in matrix A. 22756 N - number of columns in matrix A. 22760 A - matrices L and U in compact form: 22761 * L is stored under main diagonal 22762 * U is stored on and above main diagonal 22763 Pivots - permutation matrix in compact form. 22764 array[0..Min(M-1,N-1)]. 22766 -- ALGLIB routine -- 22769 *************************************************************************/ 22770 void rmatrixlu(/* Real */ ae_matrix* a, 22773 /* Integer */ ae_vector* pivots, 22777 ae_vector_clear(pivots); 22779 ae_assert(m>0, "RMatrixLU: incorrect M!
", _state); 22780 ae_assert(n>0, "RMatrixLU: incorrect N!
", _state); 22781 rmatrixplu(a, m, n, pivots, _state); 22785 /************************************************************************* 22786 LU decomposition of a general complex matrix with row pivoting 22788 A is represented as A = P*L*U, where: 22789 * L is lower unitriangular matrix 22790 * U is upper triangular matrix 22791 * P = P0*P1*...*PK, K=min(M,N)-1, 22792 Pi - permutation matrix for I and Pivots[I] 22794 This is cache-oblivous implementation of LU decomposition. It is optimized 22795 for square matrices. As for rectangular matrices: 22797 * worst case - N>>M, small M, large N, matrix does not fit in CPU cache 22800 A - array[0..M-1, 0..N-1]. 22801 M - number of rows in matrix A. 22802 N - number of columns in matrix A. 22806 A - matrices L and U in compact form: 22807 * L is stored under main diagonal 22808 * U is stored on and above main diagonal 22809 Pivots - permutation matrix in compact form. 22810 array[0..Min(M-1,N-1)]. 22812 -- ALGLIB routine -- 22815 *************************************************************************/ 22816 void cmatrixlu(/* Complex */ ae_matrix* a, 22819 /* Integer */ ae_vector* pivots, 22823 ae_vector_clear(pivots); 22825 ae_assert(m>0, "CMatrixLU: incorrect M!
", _state); 22826 ae_assert(n>0, "CMatrixLU: incorrect N!
", _state); 22827 cmatrixplu(a, m, n, pivots, _state); 22831 /************************************************************************* 22832 Cache-oblivious Cholesky decomposition 22834 The algorithm computes Cholesky decomposition of a Hermitian positive- 22835 definite matrix. The result of an algorithm is a representation of A as 22836 A=U'*U or A=L*L' (here X' detones conj(X^T)). 22839 A - upper or lower triangle of a factorized matrix. 22840 array with elements [0..N-1, 0..N-1]. 22841 N - size of matrix A. 22842 IsUpper - if IsUpper=True, then A contains an upper triangle of 22843 a symmetric matrix, otherwise A contains a lower one. 22846 A - the result of factorization. If IsUpper=True, then 22847 the upper triangle contains matrix U, so that A = U'*U, 22848 and the elements below the main diagonal are not modified. 22849 Similarly, if IsUpper = False. 22852 If the matrix is positive-definite, the function returns True. 22853 Otherwise, the function returns False. Contents of A is not determined 22856 -- ALGLIB routine -- 22859 *************************************************************************/ 22860 ae_bool hpdmatrixcholesky(/* Complex */ ae_matrix* a, 22865 ae_frame _frame_block; 22869 ae_frame_make(_state, &_frame_block); 22870 ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true); 22875 ae_frame_leave(_state); 22878 result = trfac_hpdmatrixcholeskyrec(a, 0, n, isupper, &tmp, _state); 22879 ae_frame_leave(_state); 22884 /************************************************************************* 22885 Cache-oblivious Cholesky decomposition 22887 The algorithm computes Cholesky decomposition of a symmetric positive- 22888 definite matrix. The result of an algorithm is a representation of A as 22892 A - upper or lower triangle of a factorized matrix. 22893 array with elements [0..N-1, 0..N-1]. 22894 N - size of matrix A. 22895 IsUpper - if IsUpper=True, then A contains an upper triangle of 22896 a symmetric matrix, otherwise A contains a lower one. 22899 A - the result of factorization. If IsUpper=True, then 22900 the upper triangle contains matrix U, so that A = U^T*U, 22901 and the elements below the main diagonal are not modified. 22902 Similarly, if IsUpper = False. 22905 If the matrix is positive-definite, the function returns True. 22906 Otherwise, the function returns False. Contents of A is not determined 22909 -- ALGLIB routine -- 22912 *************************************************************************/ 22913 ae_bool spdmatrixcholesky(/* Real */ ae_matrix* a, 22918 ae_frame _frame_block; 22922 ae_frame_make(_state, &_frame_block); 22923 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 22928 ae_frame_leave(_state); 22931 result = spdmatrixcholeskyrec(a, 0, n, isupper, &tmp, _state); 22932 ae_frame_leave(_state); 22937 void rmatrixlup(/* Real */ ae_matrix* a, 22940 /* Integer */ ae_vector* pivots, 22943 ae_frame _frame_block; 22950 ae_frame_make(_state, &_frame_block); 22951 ae_vector_clear(pivots); 22952 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 22956 * Internal LU decomposition subroutine. 22957 * Never call it directly. 22959 ae_assert(m>0, "RMatrixLUP: incorrect M!
", _state); 22960 ae_assert(n>0, "RMatrixLUP: incorrect N!
", _state); 22963 * Scale matrix to avoid overflows, 22964 * decompose it, then scale back. 22967 for(i=0; i<=m-1; i++) 22969 for(j=0; j<=n-1; j++) 22971 mx = ae_maxreal(mx, ae_fabs(a->ptr.pp_double[i][j], _state), _state); 22974 if( ae_fp_neq(mx,0) ) 22977 for(i=0; i<=m-1; i++) 22979 ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), v); 22982 ae_vector_set_length(pivots, ae_minint(m, n, _state), _state); 22983 ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state); 22984 trfac_rmatrixluprec(a, 0, m, n, pivots, &tmp, _state); 22985 if( ae_fp_neq(mx,0) ) 22988 for(i=0; i<=m-1; i++) 22990 ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,ae_minint(i, n-1, _state)), v); 22993 ae_frame_leave(_state); 22997 void cmatrixlup(/* Complex */ ae_matrix* a, 23000 /* Integer */ ae_vector* pivots, 23003 ae_frame _frame_block; 23010 ae_frame_make(_state, &_frame_block); 23011 ae_vector_clear(pivots); 23012 ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true); 23016 * Internal LU decomposition subroutine. 23017 * Never call it directly. 23019 ae_assert(m>0, "CMatrixLUP: incorrect M!
", _state); 23020 ae_assert(n>0, "CMatrixLUP: incorrect N!
", _state); 23023 * Scale matrix to avoid overflows, 23024 * decompose it, then scale back. 23027 for(i=0; i<=m-1; i++) 23029 for(j=0; j<=n-1; j++) 23031 mx = ae_maxreal(mx, ae_c_abs(a->ptr.pp_complex[i][j], _state), _state); 23034 if( ae_fp_neq(mx,0) ) 23037 for(i=0; i<=m-1; i++) 23039 ae_v_cmuld(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), v); 23042 ae_vector_set_length(pivots, ae_minint(m, n, _state), _state); 23043 ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state); 23044 trfac_cmatrixluprec(a, 0, m, n, pivots, &tmp, _state); 23045 if( ae_fp_neq(mx,0) ) 23048 for(i=0; i<=m-1; i++) 23050 ae_v_cmuld(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,ae_minint(i, n-1, _state)), v); 23053 ae_frame_leave(_state); 23057 void rmatrixplu(/* Real */ ae_matrix* a, 23060 /* Integer */ ae_vector* pivots, 23063 ae_frame _frame_block; 23070 ae_frame_make(_state, &_frame_block); 23071 ae_vector_clear(pivots); 23072 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 23076 * Internal LU decomposition subroutine. 23077 * Never call it directly. 23079 ae_assert(m>0, "RMatrixPLU: incorrect M!
", _state); 23080 ae_assert(n>0, "RMatrixPLU: incorrect N!
", _state); 23081 ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state); 23082 ae_vector_set_length(pivots, ae_minint(m, n, _state), _state); 23085 * Scale matrix to avoid overflows, 23086 * decompose it, then scale back. 23089 for(i=0; i<=m-1; i++) 23091 for(j=0; j<=n-1; j++) 23093 mx = ae_maxreal(mx, ae_fabs(a->ptr.pp_double[i][j], _state), _state); 23096 if( ae_fp_neq(mx,0) ) 23099 for(i=0; i<=m-1; i++) 23101 ae_v_muld(&a->ptr.pp_double[i][0], 1, ae_v_len(0,n-1), v); 23104 trfac_rmatrixplurec(a, 0, m, n, pivots, &tmp, _state); 23105 if( ae_fp_neq(mx,0) ) 23108 for(i=0; i<=ae_minint(m, n, _state)-1; i++) 23110 ae_v_muld(&a->ptr.pp_double[i][i], 1, ae_v_len(i,n-1), v); 23113 ae_frame_leave(_state); 23117 void cmatrixplu(/* Complex */ ae_matrix* a, 23120 /* Integer */ ae_vector* pivots, 23123 ae_frame _frame_block; 23130 ae_frame_make(_state, &_frame_block); 23131 ae_vector_clear(pivots); 23132 ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true); 23136 * Internal LU decomposition subroutine. 23137 * Never call it directly. 23139 ae_assert(m>0, "CMatrixPLU: incorrect M!
", _state); 23140 ae_assert(n>0, "CMatrixPLU: incorrect N!
", _state); 23141 ae_vector_set_length(&tmp, 2*ae_maxint(m, n, _state), _state); 23142 ae_vector_set_length(pivots, ae_minint(m, n, _state), _state); 23145 * Scale matrix to avoid overflows, 23146 * decompose it, then scale back. 23149 for(i=0; i<=m-1; i++) 23151 for(j=0; j<=n-1; j++) 23153 mx = ae_maxreal(mx, ae_c_abs(a->ptr.pp_complex[i][j], _state), _state); 23156 if( ae_fp_neq(mx,0) ) 23158 v = ae_complex_from_d(1/mx); 23159 for(i=0; i<=m-1; i++) 23161 ae_v_cmulc(&a->ptr.pp_complex[i][0], 1, ae_v_len(0,n-1), v); 23164 trfac_cmatrixplurec(a, 0, m, n, pivots, &tmp, _state); 23165 if( ae_fp_neq(mx,0) ) 23167 v = ae_complex_from_d(mx); 23168 for(i=0; i<=ae_minint(m, n, _state)-1; i++) 23170 ae_v_cmulc(&a->ptr.pp_complex[i][i], 1, ae_v_len(i,n-1), v); 23173 ae_frame_leave(_state); 23177 /************************************************************************* 23178 Recursive computational subroutine for SPDMatrixCholesky. 23181 A - matrix given by upper or lower triangle 23182 Offs - offset of diagonal block to decompose 23183 N - diagonal block size 23184 IsUpper - what half is given 23185 Tmp - temporary array; allocated by function, if its size is too 23186 small; can be reused on subsequent calls. 23189 A - upper (or lower) triangle contains Cholesky decomposition 23195 -- ALGLIB routine -- 23198 *************************************************************************/ 23199 ae_bool spdmatrixcholeskyrec(/* Real */ ae_matrix* a, 23203 /* Real */ ae_vector* tmp, 23226 ae_vector_set_length(tmp, 2*n, _state); 23234 if( ae_fp_greater(a->ptr.pp_double[offs][offs],0) ) 23236 a->ptr.pp_double[offs][offs] = ae_sqrt(a->ptr.pp_double[offs][offs], _state); 23245 if( n<=ablasblocksize(a, _state) ) 23247 result = trfac_spdmatrixcholesky2(a, offs, n, isupper, tmp, _state); 23252 * general case: split task in cache-oblivious manner 23255 ablassplitlength(a, n, &n1, &n2, _state); 23256 result = spdmatrixcholeskyrec(a, offs, n1, isupper, tmp, _state); 23265 rmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 1, a, offs, offs+n1, _state); 23266 rmatrixsyrk(n2, n1, -1.0, a, offs, offs+n1, 1, 1.0, a, offs+n1, offs+n1, isupper, _state); 23270 rmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 1, a, offs+n1, offs, _state); 23271 rmatrixsyrk(n2, n1, -1.0, a, offs+n1, offs, 0, 1.0, a, offs+n1, offs+n1, isupper, _state); 23273 result = spdmatrixcholeskyrec(a, offs+n1, n2, isupper, tmp, _state); 23283 /************************************************************************* 23284 Recurrent complex LU subroutine. 23285 Never call it directly. 23287 -- ALGLIB routine -- 23290 *************************************************************************/ 23291 static void trfac_cmatrixluprec(/* Complex */ ae_matrix* a, 23295 /* Integer */ ae_vector* pivots, 23296 /* Complex */ ae_vector* tmp, 23308 if( ae_minint(m, n, _state)<=ablascomplexblocksize(a, _state) ) 23310 trfac_cmatrixlup2(a, offs, m, n, pivots, tmp, _state); 23315 * Preliminary step, make N>=M 23318 * A = ( ), where A1 is square 23321 * Factorize A1, update A2 23325 trfac_cmatrixluprec(a, offs, n, n, pivots, tmp, _state); 23326 for(i=0; i<=n-1; i++) 23328 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+n][offs+i], a->stride, "N
", ae_v_len(0,m-n-1)); 23329 ae_v_cmove(&a->ptr.pp_complex[offs+n][offs+i], a->stride, &a->ptr.pp_complex[offs+n][pivots->ptr.p_int[offs+i]], a->stride, "N
", ae_v_len(offs+n,offs+m-1)); 23330 ae_v_cmove(&a->ptr.pp_complex[offs+n][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs+n,offs+m-1)); 23332 cmatrixrighttrsm(m-n, n, a, offs, offs, ae_true, ae_true, 0, a, offs+n, offs, _state); 23339 ablascomplexsplitlength(a, m, &m1, &m2, _state); 23340 trfac_cmatrixluprec(a, offs, m1, n, pivots, tmp, _state); 23343 for(i=0; i<=m1-1; i++) 23345 if( offs+i!=pivots->ptr.p_int[offs+i] ) 23347 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+m1][offs+i], a->stride, "N
", ae_v_len(0,m2-1)); 23348 ae_v_cmove(&a->ptr.pp_complex[offs+m1][offs+i], a->stride, &a->ptr.pp_complex[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, "N
", ae_v_len(offs+m1,offs+m-1)); 23349 ae_v_cmove(&a->ptr.pp_complex[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs+m1,offs+m-1)); 23352 cmatrixrighttrsm(m2, m1, a, offs, offs, ae_true, ae_true, 0, a, offs+m1, offs, _state); 23353 cmatrixgemm(m-m1, n-m1, m1, ae_complex_from_d(-1.0), a, offs+m1, offs, 0, a, offs, offs+m1, 0, ae_complex_from_d(1.0), a, offs+m1, offs+m1, _state); 23354 trfac_cmatrixluprec(a, offs+m1, m-m1, n-m1, pivots, tmp, _state); 23355 for(i=0; i<=m2-1; i++) 23357 if( offs+m1+i!=pivots->ptr.p_int[offs+m1+i] ) 23359 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs][offs+m1+i], a->stride, "N
", ae_v_len(0,m1-1)); 23360 ae_v_cmove(&a->ptr.pp_complex[offs][offs+m1+i], a->stride, &a->ptr.pp_complex[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, "N
", ae_v_len(offs,offs+m1-1)); 23361 ae_v_cmove(&a->ptr.pp_complex[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs,offs+m1-1)); 23368 /************************************************************************* 23369 Recurrent real LU subroutine. 23370 Never call it directly. 23372 -- ALGLIB routine -- 23375 *************************************************************************/ 23376 static void trfac_rmatrixluprec(/* Real */ ae_matrix* a, 23380 /* Integer */ ae_vector* pivots, 23381 /* Real */ ae_vector* tmp, 23393 if( ae_minint(m, n, _state)<=ablasblocksize(a, _state) ) 23395 trfac_rmatrixlup2(a, offs, m, n, pivots, tmp, _state); 23400 * Preliminary step, make N>=M 23403 * A = ( ), where A1 is square 23406 * Factorize A1, update A2 23410 trfac_rmatrixluprec(a, offs, n, n, pivots, tmp, _state); 23411 for(i=0; i<=n-1; i++) 23413 if( offs+i!=pivots->ptr.p_int[offs+i] ) 23415 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+n][offs+i], a->stride, ae_v_len(0,m-n-1)); 23416 ae_v_move(&a->ptr.pp_double[offs+n][offs+i], a->stride, &a->ptr.pp_double[offs+n][pivots->ptr.p_int[offs+i]], a->stride, ae_v_len(offs+n,offs+m-1)); 23417 ae_v_move(&a->ptr.pp_double[offs+n][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs+n,offs+m-1)); 23420 rmatrixrighttrsm(m-n, n, a, offs, offs, ae_true, ae_true, 0, a, offs+n, offs, _state); 23427 ablassplitlength(a, m, &m1, &m2, _state); 23428 trfac_rmatrixluprec(a, offs, m1, n, pivots, tmp, _state); 23431 for(i=0; i<=m1-1; i++) 23433 if( offs+i!=pivots->ptr.p_int[offs+i] ) 23435 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+m1][offs+i], a->stride, ae_v_len(0,m2-1)); 23436 ae_v_move(&a->ptr.pp_double[offs+m1][offs+i], a->stride, &a->ptr.pp_double[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, ae_v_len(offs+m1,offs+m-1)); 23437 ae_v_move(&a->ptr.pp_double[offs+m1][pivots->ptr.p_int[offs+i]], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs+m1,offs+m-1)); 23440 rmatrixrighttrsm(m2, m1, a, offs, offs, ae_true, ae_true, 0, a, offs+m1, offs, _state); 23441 rmatrixgemm(m-m1, n-m1, m1, -1.0, a, offs+m1, offs, 0, a, offs, offs+m1, 0, 1.0, a, offs+m1, offs+m1, _state); 23442 trfac_rmatrixluprec(a, offs+m1, m-m1, n-m1, pivots, tmp, _state); 23443 for(i=0; i<=m2-1; i++) 23445 if( offs+m1+i!=pivots->ptr.p_int[offs+m1+i] ) 23447 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs][offs+m1+i], a->stride, ae_v_len(0,m1-1)); 23448 ae_v_move(&a->ptr.pp_double[offs][offs+m1+i], a->stride, &a->ptr.pp_double[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, ae_v_len(offs,offs+m1-1)); 23449 ae_v_move(&a->ptr.pp_double[offs][pivots->ptr.p_int[offs+m1+i]], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+m1-1)); 23456 /************************************************************************* 23457 Recurrent complex LU subroutine. 23458 Never call it directly. 23460 -- ALGLIB routine -- 23463 *************************************************************************/ 23464 static void trfac_cmatrixplurec(/* Complex */ ae_matrix* a, 23468 /* Integer */ ae_vector* pivots, 23469 /* Complex */ ae_vector* tmp, 23481 if( ae_minint(m, n, _state)<=ablascomplexblocksize(a, _state) ) 23483 trfac_cmatrixplu2(a, offs, m, n, pivots, tmp, _state); 23488 * Preliminary step, make M>=N. 23490 * A = (A1 A2), where A1 is square 23491 * Factorize A1, update A2 23495 trfac_cmatrixplurec(a, offs, m, m, pivots, tmp, _state); 23496 for(i=0; i<=m-1; i++) 23498 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+i][offs+m], 1, "N
", ae_v_len(0,n-m-1)); 23499 ae_v_cmove(&a->ptr.pp_complex[offs+i][offs+m], 1, &a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+m], 1, "N
", ae_v_len(offs+m,offs+n-1)); 23500 ae_v_cmove(&a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+m], 1, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs+m,offs+n-1)); 23502 cmatrixlefttrsm(m, n-m, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+m, _state); 23509 ablascomplexsplitlength(a, n, &n1, &n2, _state); 23510 trfac_cmatrixplurec(a, offs, m, n1, pivots, tmp, _state); 23513 for(i=0; i<=n1-1; i++) 23515 if( offs+i!=pivots->ptr.p_int[offs+i] ) 23517 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+i][offs+n1], 1, "N
", ae_v_len(0,n2-1)); 23518 ae_v_cmove(&a->ptr.pp_complex[offs+i][offs+n1], 1, &a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+n1], 1, "N
", ae_v_len(offs+n1,offs+n-1)); 23519 ae_v_cmove(&a->ptr.pp_complex[pivots->ptr.p_int[offs+i]][offs+n1], 1, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs+n1,offs+n-1)); 23522 cmatrixlefttrsm(n1, n2, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+n1, _state); 23523 cmatrixgemm(m-n1, n-n1, n1, ae_complex_from_d(-1.0), a, offs+n1, offs, 0, a, offs, offs+n1, 0, ae_complex_from_d(1.0), a, offs+n1, offs+n1, _state); 23524 trfac_cmatrixplurec(a, offs+n1, m-n1, n-n1, pivots, tmp, _state); 23525 for(i=0; i<=n2-1; i++) 23527 if( offs+n1+i!=pivots->ptr.p_int[offs+n1+i] ) 23529 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+n1+i][offs], 1, "N
", ae_v_len(0,n1-1)); 23530 ae_v_cmove(&a->ptr.pp_complex[offs+n1+i][offs], 1, &a->ptr.pp_complex[pivots->ptr.p_int[offs+n1+i]][offs], 1, "N
", ae_v_len(offs,offs+n1-1)); 23531 ae_v_cmove(&a->ptr.pp_complex[pivots->ptr.p_int[offs+n1+i]][offs], 1, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs,offs+n1-1)); 23538 /************************************************************************* 23539 Recurrent real LU subroutine. 23540 Never call it directly. 23542 -- ALGLIB routine -- 23545 *************************************************************************/ 23546 static void trfac_rmatrixplurec(/* Real */ ae_matrix* a, 23550 /* Integer */ ae_vector* pivots, 23551 /* Real */ ae_vector* tmp, 23563 if( ae_minint(m, n, _state)<=ablasblocksize(a, _state) ) 23565 trfac_rmatrixplu2(a, offs, m, n, pivots, tmp, _state); 23570 * Preliminary step, make M>=N. 23572 * A = (A1 A2), where A1 is square 23573 * Factorize A1, update A2 23577 trfac_rmatrixplurec(a, offs, m, m, pivots, tmp, _state); 23578 for(i=0; i<=m-1; i++) 23580 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+i][offs+m], 1, ae_v_len(0,n-m-1)); 23581 ae_v_move(&a->ptr.pp_double[offs+i][offs+m], 1, &a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+m], 1, ae_v_len(offs+m,offs+n-1)); 23582 ae_v_move(&a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+m], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs+m,offs+n-1)); 23584 rmatrixlefttrsm(m, n-m, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+m, _state); 23591 ablassplitlength(a, n, &n1, &n2, _state); 23592 trfac_rmatrixplurec(a, offs, m, n1, pivots, tmp, _state); 23595 for(i=0; i<=n1-1; i++) 23597 if( offs+i!=pivots->ptr.p_int[offs+i] ) 23599 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(0,n2-1)); 23600 ae_v_move(&a->ptr.pp_double[offs+i][offs+n1], 1, &a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+n1], 1, ae_v_len(offs+n1,offs+n-1)); 23601 ae_v_move(&a->ptr.pp_double[pivots->ptr.p_int[offs+i]][offs+n1], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs+n1,offs+n-1)); 23604 rmatrixlefttrsm(n1, n2, a, offs, offs, ae_false, ae_true, 0, a, offs, offs+n1, _state); 23605 rmatrixgemm(m-n1, n-n1, n1, -1.0, a, offs+n1, offs, 0, a, offs, offs+n1, 0, 1.0, a, offs+n1, offs+n1, _state); 23606 trfac_rmatrixplurec(a, offs+n1, m-n1, n-n1, pivots, tmp, _state); 23607 for(i=0; i<=n2-1; i++) 23609 if( offs+n1+i!=pivots->ptr.p_int[offs+n1+i] ) 23611 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(0,n1-1)); 23612 ae_v_move(&a->ptr.pp_double[offs+n1+i][offs], 1, &a->ptr.pp_double[pivots->ptr.p_int[offs+n1+i]][offs], 1, ae_v_len(offs,offs+n1-1)); 23613 ae_v_move(&a->ptr.pp_double[pivots->ptr.p_int[offs+n1+i]][offs], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+n1-1)); 23620 /************************************************************************* 23623 -- ALGLIB routine -- 23626 *************************************************************************/ 23627 static void trfac_cmatrixlup2(/* Complex */ ae_matrix* a, 23631 /* Integer */ ae_vector* pivots, 23632 /* Complex */ ae_vector* tmp, 23643 * Quick return if possible 23653 for(j=0; j<=ae_minint(m-1, n-1, _state); j++) 23657 * Find pivot, swap columns 23660 for(i=j+1; i<=n-1; i++) 23662 if( ae_fp_greater(ae_c_abs(a->ptr.pp_complex[offs+j][offs+i], _state),ae_c_abs(a->ptr.pp_complex[offs+j][offs+jp], _state)) ) 23667 pivots->ptr.p_int[offs+j] = offs+jp; 23670 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs][offs+j], a->stride, "N
", ae_v_len(0,m-1)); 23671 ae_v_cmove(&a->ptr.pp_complex[offs][offs+j], a->stride, &a->ptr.pp_complex[offs][offs+jp], a->stride, "N
", ae_v_len(offs,offs+m-1)); 23672 ae_v_cmove(&a->ptr.pp_complex[offs][offs+jp], a->stride, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs,offs+m-1)); 23676 * LU decomposition of 1x(N-J) matrix 23678 if( ae_c_neq_d(a->ptr.pp_complex[offs+j][offs+j],0)&&j+1<=n-1 ) 23680 s = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]); 23681 ae_v_cmulc(&a->ptr.pp_complex[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), s); 23685 * Update trailing (M-J-1)x(N-J-1) matrix 23687 if( j<ae_minint(m-1, n-1, _state) ) 23689 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+j+1][offs+j], a->stride, "N
", ae_v_len(0,m-j-2)); 23690 ae_v_cmoveneg(&tmp->ptr.p_complex[m], 1, &a->ptr.pp_complex[offs+j][offs+j+1], 1, "N
", ae_v_len(m,m+n-j-2)); 23691 cmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state); 23697 /************************************************************************* 23700 -- ALGLIB routine -- 23703 *************************************************************************/ 23704 static void trfac_rmatrixlup2(/* Real */ ae_matrix* a, 23708 /* Integer */ ae_vector* pivots, 23709 /* Real */ ae_vector* tmp, 23720 * Quick return if possible 23730 for(j=0; j<=ae_minint(m-1, n-1, _state); j++) 23734 * Find pivot, swap columns 23737 for(i=j+1; i<=n-1; i++) 23739 if( ae_fp_greater(ae_fabs(a->ptr.pp_double[offs+j][offs+i], _state),ae_fabs(a->ptr.pp_double[offs+j][offs+jp], _state)) ) 23744 pivots->ptr.p_int[offs+j] = offs+jp; 23747 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs][offs+j], a->stride, ae_v_len(0,m-1)); 23748 ae_v_move(&a->ptr.pp_double[offs][offs+j], a->stride, &a->ptr.pp_double[offs][offs+jp], a->stride, ae_v_len(offs,offs+m-1)); 23749 ae_v_move(&a->ptr.pp_double[offs][offs+jp], a->stride, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+m-1)); 23753 * LU decomposition of 1x(N-J) matrix 23755 if( ae_fp_neq(a->ptr.pp_double[offs+j][offs+j],0)&&j+1<=n-1 ) 23757 s = 1/a->ptr.pp_double[offs+j][offs+j]; 23758 ae_v_muld(&a->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), s); 23762 * Update trailing (M-J-1)x(N-J-1) matrix 23764 if( j<ae_minint(m-1, n-1, _state) ) 23766 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(0,m-j-2)); 23767 ae_v_moveneg(&tmp->ptr.p_double[m], 1, &a->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(m,m+n-j-2)); 23768 rmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state); 23774 /************************************************************************* 23777 -- LAPACK routine (version 3.0) -- 23778 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 23779 Courant Institute, Argonne National Lab, and Rice University 23781 *************************************************************************/ 23782 static void trfac_cmatrixplu2(/* Complex */ ae_matrix* a, 23786 /* Integer */ ae_vector* pivots, 23787 /* Complex */ ae_vector* tmp, 23798 * Quick return if possible 23804 for(j=0; j<=ae_minint(m-1, n-1, _state); j++) 23808 * Find pivot and test for singularity. 23811 for(i=j+1; i<=m-1; i++) 23813 if( ae_fp_greater(ae_c_abs(a->ptr.pp_complex[offs+i][offs+j], _state),ae_c_abs(a->ptr.pp_complex[offs+jp][offs+j], _state)) ) 23818 pivots->ptr.p_int[offs+j] = offs+jp; 23819 if( ae_c_neq_d(a->ptr.pp_complex[offs+jp][offs+j],0) ) 23823 *Apply the interchange to rows 23827 for(i=0; i<=n-1; i++) 23829 s = a->ptr.pp_complex[offs+j][offs+i]; 23830 a->ptr.pp_complex[offs+j][offs+i] = a->ptr.pp_complex[offs+jp][offs+i]; 23831 a->ptr.pp_complex[offs+jp][offs+i] = s; 23836 *Compute elements J+1:M of J-th column. 23840 s = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]); 23841 ae_v_cmulc(&a->ptr.pp_complex[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+m-1), s); 23844 if( j<ae_minint(m, n, _state)-1 ) 23848 *Update trailing submatrix. 23850 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+j+1][offs+j], a->stride, "N
", ae_v_len(0,m-j-2)); 23851 ae_v_cmoveneg(&tmp->ptr.p_complex[m], 1, &a->ptr.pp_complex[offs+j][offs+j+1], 1, "N
", ae_v_len(m,m+n-j-2)); 23852 cmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state); 23858 /************************************************************************* 23861 -- LAPACK routine (version 3.0) -- 23862 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 23863 Courant Institute, Argonne National Lab, and Rice University 23865 *************************************************************************/ 23866 static void trfac_rmatrixplu2(/* Real */ ae_matrix* a, 23870 /* Integer */ ae_vector* pivots, 23871 /* Real */ ae_vector* tmp, 23882 * Quick return if possible 23888 for(j=0; j<=ae_minint(m-1, n-1, _state); j++) 23892 * Find pivot and test for singularity. 23895 for(i=j+1; i<=m-1; i++) 23897 if( ae_fp_greater(ae_fabs(a->ptr.pp_double[offs+i][offs+j], _state),ae_fabs(a->ptr.pp_double[offs+jp][offs+j], _state)) ) 23902 pivots->ptr.p_int[offs+j] = offs+jp; 23903 if( ae_fp_neq(a->ptr.pp_double[offs+jp][offs+j],0) ) 23907 *Apply the interchange to rows 23911 for(i=0; i<=n-1; i++) 23913 s = a->ptr.pp_double[offs+j][offs+i]; 23914 a->ptr.pp_double[offs+j][offs+i] = a->ptr.pp_double[offs+jp][offs+i]; 23915 a->ptr.pp_double[offs+jp][offs+i] = s; 23920 *Compute elements J+1:M of J-th column. 23924 s = 1/a->ptr.pp_double[offs+j][offs+j]; 23925 ae_v_muld(&a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+m-1), s); 23928 if( j<ae_minint(m, n, _state)-1 ) 23932 *Update trailing submatrix. 23934 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(0,m-j-2)); 23935 ae_v_moveneg(&tmp->ptr.p_double[m], 1, &a->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(m,m+n-j-2)); 23936 rmatrixrank1(m-j-1, n-j-1, a, offs+j+1, offs+j+1, tmp, 0, tmp, m, _state); 23942 /************************************************************************* 23943 Recursive computational subroutine for HPDMatrixCholesky 23945 -- ALGLIB routine -- 23948 *************************************************************************/ 23949 static ae_bool trfac_hpdmatrixcholeskyrec(/* Complex */ ae_matrix* a, 23953 /* Complex */ ae_vector* tmp, 23976 ae_vector_set_length(tmp, 2*n, _state); 23984 if( ae_fp_greater(a->ptr.pp_complex[offs][offs].x,0) ) 23986 a->ptr.pp_complex[offs][offs] = ae_complex_from_d(ae_sqrt(a->ptr.pp_complex[offs][offs].x, _state)); 23995 if( n<=ablascomplexblocksize(a, _state) ) 23997 result = trfac_hpdmatrixcholesky2(a, offs, n, isupper, tmp, _state); 24002 * general case: split task in cache-oblivious manner 24005 ablascomplexsplitlength(a, n, &n1, &n2, _state); 24006 result = trfac_hpdmatrixcholeskyrec(a, offs, n1, isupper, tmp, _state); 24015 cmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 2, a, offs, offs+n1, _state); 24016 cmatrixsyrk(n2, n1, -1.0, a, offs, offs+n1, 2, 1.0, a, offs+n1, offs+n1, isupper, _state); 24020 cmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 2, a, offs+n1, offs, _state); 24021 cmatrixsyrk(n2, n1, -1.0, a, offs+n1, offs, 0, 1.0, a, offs+n1, offs+n1, isupper, _state); 24023 result = trfac_hpdmatrixcholeskyrec(a, offs+n1, n2, isupper, tmp, _state); 24033 /************************************************************************* 24034 Level-2 Hermitian Cholesky subroutine. 24036 -- LAPACK routine (version 3.0) -- 24037 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 24038 Courant Institute, Argonne National Lab, and Rice University 24040 *************************************************************************/ 24041 static ae_bool trfac_hpdmatrixcholesky2(/* Complex */ ae_matrix* aaa, 24045 /* Complex */ ae_vector* tmp, 24064 * Quick return if possible 24074 * Compute the Cholesky factorization A = U'*U. 24076 for(j=0; j<=n-1; j++) 24080 * Compute U(J,J) and test for non-positive-definiteness. 24082 v = ae_v_cdotproduct(&aaa->ptr.pp_complex[offs][offs+j], aaa->stride, "Conj
", &aaa->ptr.pp_complex[offs][offs+j], aaa->stride, "N
", ae_v_len(offs,offs+j-1)); 24083 ajj = ae_c_sub(aaa->ptr.pp_complex[offs+j][offs+j],v).x; 24084 if( ae_fp_less_eq(ajj,0) ) 24086 aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj); 24090 ajj = ae_sqrt(ajj, _state); 24091 aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj); 24094 * Compute elements J+1:N-1 of row J. 24100 ae_v_cmoveneg(&tmp->ptr.p_complex[0], 1, &aaa->ptr.pp_complex[offs][offs+j], aaa->stride, "Conj
", ae_v_len(0,j-1)); 24101 cmatrixmv(n-j-1, j, aaa, offs, offs+j+1, 1, tmp, 0, tmp, n, _state); 24102 ae_v_cadd(&aaa->ptr.pp_complex[offs+j][offs+j+1], 1, &tmp->ptr.p_complex[n], 1, "N
", ae_v_len(offs+j+1,offs+n-1)); 24105 ae_v_cmuld(&aaa->ptr.pp_complex[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), r); 24113 * Compute the Cholesky factorization A = L*L'. 24115 for(j=0; j<=n-1; j++) 24119 * Compute L(J+1,J+1) and test for non-positive-definiteness. 24121 v = ae_v_cdotproduct(&aaa->ptr.pp_complex[offs+j][offs], 1, "Conj
", &aaa->ptr.pp_complex[offs+j][offs], 1, "N
", ae_v_len(offs,offs+j-1)); 24122 ajj = ae_c_sub(aaa->ptr.pp_complex[offs+j][offs+j],v).x; 24123 if( ae_fp_less_eq(ajj,0) ) 24125 aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj); 24129 ajj = ae_sqrt(ajj, _state); 24130 aaa->ptr.pp_complex[offs+j][offs+j] = ae_complex_from_d(ajj); 24133 * Compute elements J+1:N of column J. 24139 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &aaa->ptr.pp_complex[offs+j][offs], 1, "Conj
", ae_v_len(0,j-1)); 24140 cmatrixmv(n-j-1, j, aaa, offs+j+1, offs, 0, tmp, 0, tmp, n, _state); 24141 for(i=0; i<=n-j-2; i++) 24143 aaa->ptr.pp_complex[offs+j+1+i][offs+j] = ae_c_div_d(ae_c_sub(aaa->ptr.pp_complex[offs+j+1+i][offs+j],tmp->ptr.p_complex[n+i]),ajj); 24148 for(i=0; i<=n-j-2; i++) 24150 aaa->ptr.pp_complex[offs+j+1+i][offs+j] = ae_c_div_d(aaa->ptr.pp_complex[offs+j+1+i][offs+j],ajj); 24160 /************************************************************************* 24161 Level-2 Cholesky subroutine 24163 -- LAPACK routine (version 3.0) -- 24164 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 24165 Courant Institute, Argonne National Lab, and Rice University 24167 *************************************************************************/ 24168 static ae_bool trfac_spdmatrixcholesky2(/* Real */ ae_matrix* aaa, 24172 /* Real */ ae_vector* tmp, 24191 * Quick return if possible 24201 * Compute the Cholesky factorization A = U'*U. 24203 for(j=0; j<=n-1; j++) 24207 * Compute U(J,J) and test for non-positive-definiteness. 24209 v = ae_v_dotproduct(&aaa->ptr.pp_double[offs][offs+j], aaa->stride, &aaa->ptr.pp_double[offs][offs+j], aaa->stride, ae_v_len(offs,offs+j-1)); 24210 ajj = aaa->ptr.pp_double[offs+j][offs+j]-v; 24211 if( ae_fp_less_eq(ajj,0) ) 24213 aaa->ptr.pp_double[offs+j][offs+j] = ajj; 24217 ajj = ae_sqrt(ajj, _state); 24218 aaa->ptr.pp_double[offs+j][offs+j] = ajj; 24221 * Compute elements J+1:N-1 of row J. 24227 ae_v_moveneg(&tmp->ptr.p_double[0], 1, &aaa->ptr.pp_double[offs][offs+j], aaa->stride, ae_v_len(0,j-1)); 24228 rmatrixmv(n-j-1, j, aaa, offs, offs+j+1, 1, tmp, 0, tmp, n, _state); 24229 ae_v_add(&aaa->ptr.pp_double[offs+j][offs+j+1], 1, &tmp->ptr.p_double[n], 1, ae_v_len(offs+j+1,offs+n-1)); 24232 ae_v_muld(&aaa->ptr.pp_double[offs+j][offs+j+1], 1, ae_v_len(offs+j+1,offs+n-1), r); 24240 * Compute the Cholesky factorization A = L*L'. 24242 for(j=0; j<=n-1; j++) 24246 * Compute L(J+1,J+1) and test for non-positive-definiteness. 24248 v = ae_v_dotproduct(&aaa->ptr.pp_double[offs+j][offs], 1, &aaa->ptr.pp_double[offs+j][offs], 1, ae_v_len(offs,offs+j-1)); 24249 ajj = aaa->ptr.pp_double[offs+j][offs+j]-v; 24250 if( ae_fp_less_eq(ajj,0) ) 24252 aaa->ptr.pp_double[offs+j][offs+j] = ajj; 24256 ajj = ae_sqrt(ajj, _state); 24257 aaa->ptr.pp_double[offs+j][offs+j] = ajj; 24260 * Compute elements J+1:N of column J. 24266 ae_v_move(&tmp->ptr.p_double[0], 1, &aaa->ptr.pp_double[offs+j][offs], 1, ae_v_len(0,j-1)); 24267 rmatrixmv(n-j-1, j, aaa, offs+j+1, offs, 0, tmp, 0, tmp, n, _state); 24268 for(i=0; i<=n-j-2; i++) 24270 aaa->ptr.pp_double[offs+j+1+i][offs+j] = (aaa->ptr.pp_double[offs+j+1+i][offs+j]-tmp->ptr.p_double[n+i])/ajj; 24275 for(i=0; i<=n-j-2; i++) 24277 aaa->ptr.pp_double[offs+j+1+i][offs+j] = aaa->ptr.pp_double[offs+j+1+i][offs+j]/ajj; 24289 /************************************************************************* 24290 Estimate of a matrix condition number (1-norm) 24292 The algorithm calculates a lower bound of the condition number. In this case, 24293 the algorithm does not return a lower bound of the condition number, but an 24294 inverse number (to avoid an overflow in case of a singular matrix). 24297 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 24298 N - size of matrix A. 24300 Result: 1/LowerBound(cond(A)) 24303 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24304 0.0 is returned in such cases. 24305 *************************************************************************/ 24306 double rmatrixrcond1(/* Real */ ae_matrix* a, 24310 ae_frame _frame_block; 24320 ae_frame_make(_state, &_frame_block); 24321 ae_matrix_init_copy(&_a, a, _state, ae_true); 24323 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 24324 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 24326 ae_assert(n>=1, "RMatrixRCond1: N<1!
", _state); 24327 ae_vector_set_length(&t, n, _state); 24328 for(i=0; i<=n-1; i++) 24330 t.ptr.p_double[i] = 0; 24332 for(i=0; i<=n-1; i++) 24334 for(j=0; j<=n-1; j++) 24336 t.ptr.p_double[j] = t.ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state); 24340 for(i=0; i<=n-1; i++) 24342 nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state); 24344 rmatrixlu(a, n, n, &pivots, _state); 24345 rcond_rmatrixrcondluinternal(a, n, ae_true, ae_true, nrm, &v, _state); 24347 ae_frame_leave(_state); 24352 /************************************************************************* 24353 Estimate of a matrix condition number (infinity-norm). 24355 The algorithm calculates a lower bound of the condition number. In this case, 24356 the algorithm does not return a lower bound of the condition number, but an 24357 inverse number (to avoid an overflow in case of a singular matrix). 24360 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 24361 N - size of matrix A. 24363 Result: 1/LowerBound(cond(A)) 24366 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24367 0.0 is returned in such cases. 24368 *************************************************************************/ 24369 double rmatrixrcondinf(/* Real */ ae_matrix* a, 24373 ae_frame _frame_block; 24382 ae_frame_make(_state, &_frame_block); 24383 ae_matrix_init_copy(&_a, a, _state, ae_true); 24385 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 24387 ae_assert(n>=1, "RMatrixRCondInf: N<1!
", _state); 24389 for(i=0; i<=n-1; i++) 24392 for(j=0; j<=n-1; j++) 24394 v = v+ae_fabs(a->ptr.pp_double[i][j], _state); 24396 nrm = ae_maxreal(nrm, v, _state); 24398 rmatrixlu(a, n, n, &pivots, _state); 24399 rcond_rmatrixrcondluinternal(a, n, ae_false, ae_true, nrm, &v, _state); 24401 ae_frame_leave(_state); 24406 /************************************************************************* 24407 Condition number estimate of a symmetric positive definite matrix. 24409 The algorithm calculates a lower bound of the condition number. In this case, 24410 the algorithm does not return a lower bound of the condition number, but an 24411 inverse number (to avoid an overflow in case of a singular matrix). 24413 It should be noted that 1-norm and inf-norm of condition numbers of symmetric 24414 matrices are equal, so the algorithm doesn't take into account the 24415 differences between these types of norms. 24418 A - symmetric positive definite matrix which is given by its 24419 upper or lower triangle depending on the value of 24420 IsUpper. Array with elements [0..N-1, 0..N-1]. 24421 N - size of matrix A. 24422 IsUpper - storage format. 24425 1/LowerBound(cond(A)), if matrix A is positive definite, 24426 -1, if matrix A is not positive definite, and its condition number 24427 could not be found by this algorithm. 24430 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24431 0.0 is returned in such cases. 24432 *************************************************************************/ 24433 double spdmatrixrcond(/* Real */ ae_matrix* a, 24438 ae_frame _frame_block; 24449 ae_frame_make(_state, &_frame_block); 24450 ae_matrix_init_copy(&_a, a, _state, ae_true); 24452 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 24454 ae_vector_set_length(&t, n, _state); 24455 for(i=0; i<=n-1; i++) 24457 t.ptr.p_double[i] = 0; 24459 for(i=0; i<=n-1; i++) 24471 for(j=j1; j<=j2; j++) 24475 t.ptr.p_double[i] = t.ptr.p_double[i]+ae_fabs(a->ptr.pp_double[i][i], _state); 24479 t.ptr.p_double[i] = t.ptr.p_double[i]+ae_fabs(a->ptr.pp_double[i][j], _state); 24480 t.ptr.p_double[j] = t.ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state); 24485 for(i=0; i<=n-1; i++) 24487 nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state); 24489 if( spdmatrixcholesky(a, n, isupper, _state) ) 24491 rcond_spdmatrixrcondcholeskyinternal(a, n, isupper, ae_true, nrm, &v, _state); 24498 ae_frame_leave(_state); 24503 /************************************************************************* 24504 Triangular matrix: estimate of a condition number (1-norm) 24506 The algorithm calculates a lower bound of the condition number. In this case, 24507 the algorithm does not return a lower bound of the condition number, but an 24508 inverse number (to avoid an overflow in case of a singular matrix). 24511 A - matrix. Array[0..N-1, 0..N-1]. 24513 IsUpper - True, if the matrix is upper triangular. 24514 IsUnit - True, if the matrix has a unit diagonal. 24516 Result: 1/LowerBound(cond(A)) 24519 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24520 0.0 is returned in such cases. 24521 *************************************************************************/ 24522 double rmatrixtrrcond1(/* Real */ ae_matrix* a, 24528 ae_frame _frame_block; 24539 ae_frame_make(_state, &_frame_block); 24540 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 24541 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 24543 ae_assert(n>=1, "RMatrixTRRCond1: N<1!
", _state); 24544 ae_vector_set_length(&t, n, _state); 24545 for(i=0; i<=n-1; i++) 24547 t.ptr.p_double[i] = 0; 24549 for(i=0; i<=n-1; i++) 24561 for(j=j1; j<=j2; j++) 24563 t.ptr.p_double[j] = t.ptr.p_double[j]+ae_fabs(a->ptr.pp_double[i][j], _state); 24567 t.ptr.p_double[i] = t.ptr.p_double[i]+1; 24571 t.ptr.p_double[i] = t.ptr.p_double[i]+ae_fabs(a->ptr.pp_double[i][i], _state); 24575 for(i=0; i<=n-1; i++) 24577 nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state); 24579 rcond_rmatrixrcondtrinternal(a, n, isupper, isunit, ae_true, nrm, &v, _state); 24581 ae_frame_leave(_state); 24586 /************************************************************************* 24587 Triangular matrix: estimate of a matrix condition number (infinity-norm). 24589 The algorithm calculates a lower bound of the condition number. In this case, 24590 the algorithm does not return a lower bound of the condition number, but an 24591 inverse number (to avoid an overflow in case of a singular matrix). 24594 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 24595 N - size of matrix A. 24596 IsUpper - True, if the matrix is upper triangular. 24597 IsUnit - True, if the matrix has a unit diagonal. 24599 Result: 1/LowerBound(cond(A)) 24602 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24603 0.0 is returned in such cases. 24604 *************************************************************************/ 24605 double rmatrixtrrcondinf(/* Real */ ae_matrix* a, 24611 ae_frame _frame_block; 24621 ae_frame_make(_state, &_frame_block); 24622 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 24624 ae_assert(n>=1, "RMatrixTRRCondInf: N<1!
", _state); 24626 for(i=0; i<=n-1; i++) 24639 for(j=j1; j<=j2; j++) 24641 v = v+ae_fabs(a->ptr.pp_double[i][j], _state); 24649 v = v+ae_fabs(a->ptr.pp_double[i][i], _state); 24651 nrm = ae_maxreal(nrm, v, _state); 24653 rcond_rmatrixrcondtrinternal(a, n, isupper, isunit, ae_false, nrm, &v, _state); 24655 ae_frame_leave(_state); 24660 /************************************************************************* 24661 Condition number estimate of a Hermitian positive definite matrix. 24663 The algorithm calculates a lower bound of the condition number. In this case, 24664 the algorithm does not return a lower bound of the condition number, but an 24665 inverse number (to avoid an overflow in case of a singular matrix). 24667 It should be noted that 1-norm and inf-norm of condition numbers of symmetric 24668 matrices are equal, so the algorithm doesn't take into account the 24669 differences between these types of norms. 24672 A - Hermitian positive definite matrix which is given by its 24673 upper or lower triangle depending on the value of 24674 IsUpper. Array with elements [0..N-1, 0..N-1]. 24675 N - size of matrix A. 24676 IsUpper - storage format. 24679 1/LowerBound(cond(A)), if matrix A is positive definite, 24680 -1, if matrix A is not positive definite, and its condition number 24681 could not be found by this algorithm. 24684 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24685 0.0 is returned in such cases. 24686 *************************************************************************/ 24687 double hpdmatrixrcond(/* Complex */ ae_matrix* a, 24692 ae_frame _frame_block; 24703 ae_frame_make(_state, &_frame_block); 24704 ae_matrix_init_copy(&_a, a, _state, ae_true); 24706 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 24708 ae_vector_set_length(&t, n, _state); 24709 for(i=0; i<=n-1; i++) 24711 t.ptr.p_double[i] = 0; 24713 for(i=0; i<=n-1; i++) 24725 for(j=j1; j<=j2; j++) 24729 t.ptr.p_double[i] = t.ptr.p_double[i]+ae_c_abs(a->ptr.pp_complex[i][i], _state); 24733 t.ptr.p_double[i] = t.ptr.p_double[i]+ae_c_abs(a->ptr.pp_complex[i][j], _state); 24734 t.ptr.p_double[j] = t.ptr.p_double[j]+ae_c_abs(a->ptr.pp_complex[i][j], _state); 24739 for(i=0; i<=n-1; i++) 24741 nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state); 24743 if( hpdmatrixcholesky(a, n, isupper, _state) ) 24745 rcond_hpdmatrixrcondcholeskyinternal(a, n, isupper, ae_true, nrm, &v, _state); 24752 ae_frame_leave(_state); 24757 /************************************************************************* 24758 Estimate of a matrix condition number (1-norm) 24760 The algorithm calculates a lower bound of the condition number. In this case, 24761 the algorithm does not return a lower bound of the condition number, but an 24762 inverse number (to avoid an overflow in case of a singular matrix). 24765 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 24766 N - size of matrix A. 24768 Result: 1/LowerBound(cond(A)) 24771 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24772 0.0 is returned in such cases. 24773 *************************************************************************/ 24774 double cmatrixrcond1(/* Complex */ ae_matrix* a, 24778 ae_frame _frame_block; 24788 ae_frame_make(_state, &_frame_block); 24789 ae_matrix_init_copy(&_a, a, _state, ae_true); 24791 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 24792 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 24794 ae_assert(n>=1, "CMatrixRCond1: N<1!
", _state); 24795 ae_vector_set_length(&t, n, _state); 24796 for(i=0; i<=n-1; i++) 24798 t.ptr.p_double[i] = 0; 24800 for(i=0; i<=n-1; i++) 24802 for(j=0; j<=n-1; j++) 24804 t.ptr.p_double[j] = t.ptr.p_double[j]+ae_c_abs(a->ptr.pp_complex[i][j], _state); 24808 for(i=0; i<=n-1; i++) 24810 nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state); 24812 cmatrixlu(a, n, n, &pivots, _state); 24813 rcond_cmatrixrcondluinternal(a, n, ae_true, ae_true, nrm, &v, _state); 24815 ae_frame_leave(_state); 24820 /************************************************************************* 24821 Estimate of a matrix condition number (infinity-norm). 24823 The algorithm calculates a lower bound of the condition number. In this case, 24824 the algorithm does not return a lower bound of the condition number, but an 24825 inverse number (to avoid an overflow in case of a singular matrix). 24828 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 24829 N - size of matrix A. 24831 Result: 1/LowerBound(cond(A)) 24834 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24835 0.0 is returned in such cases. 24836 *************************************************************************/ 24837 double cmatrixrcondinf(/* Complex */ ae_matrix* a, 24841 ae_frame _frame_block; 24850 ae_frame_make(_state, &_frame_block); 24851 ae_matrix_init_copy(&_a, a, _state, ae_true); 24853 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 24855 ae_assert(n>=1, "CMatrixRCondInf: N<1!
", _state); 24857 for(i=0; i<=n-1; i++) 24860 for(j=0; j<=n-1; j++) 24862 v = v+ae_c_abs(a->ptr.pp_complex[i][j], _state); 24864 nrm = ae_maxreal(nrm, v, _state); 24866 cmatrixlu(a, n, n, &pivots, _state); 24867 rcond_cmatrixrcondluinternal(a, n, ae_false, ae_true, nrm, &v, _state); 24869 ae_frame_leave(_state); 24874 /************************************************************************* 24875 Estimate of the condition number of a matrix given by its LU decomposition (1-norm) 24877 The algorithm calculates a lower bound of the condition number. In this case, 24878 the algorithm does not return a lower bound of the condition number, but an 24879 inverse number (to avoid an overflow in case of a singular matrix). 24882 LUA - LU decomposition of a matrix in compact form. Output of 24883 the RMatrixLU subroutine. 24884 N - size of matrix A. 24886 Result: 1/LowerBound(cond(A)) 24889 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24890 0.0 is returned in such cases. 24891 *************************************************************************/ 24892 double rmatrixlurcond1(/* Real */ ae_matrix* lua, 24900 rcond_rmatrixrcondluinternal(lua, n, ae_true, ae_false, 0, &v, _state); 24906 /************************************************************************* 24907 Estimate of the condition number of a matrix given by its LU decomposition 24910 The algorithm calculates a lower bound of the condition number. In this case, 24911 the algorithm does not return a lower bound of the condition number, but an 24912 inverse number (to avoid an overflow in case of a singular matrix). 24915 LUA - LU decomposition of a matrix in compact form. Output of 24916 the RMatrixLU subroutine. 24917 N - size of matrix A. 24919 Result: 1/LowerBound(cond(A)) 24922 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24923 0.0 is returned in such cases. 24924 *************************************************************************/ 24925 double rmatrixlurcondinf(/* Real */ ae_matrix* lua, 24933 rcond_rmatrixrcondluinternal(lua, n, ae_false, ae_false, 0, &v, _state); 24939 /************************************************************************* 24940 Condition number estimate of a symmetric positive definite matrix given by 24941 Cholesky decomposition. 24943 The algorithm calculates a lower bound of the condition number. In this 24944 case, the algorithm does not return a lower bound of the condition number, 24945 but an inverse number (to avoid an overflow in case of a singular matrix). 24947 It should be noted that 1-norm and inf-norm condition numbers of symmetric 24948 matrices are equal, so the algorithm doesn't take into account the 24949 differences between these types of norms. 24952 CD - Cholesky decomposition of matrix A, 24953 output of SMatrixCholesky subroutine. 24954 N - size of matrix A. 24956 Result: 1/LowerBound(cond(A)) 24959 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24960 0.0 is returned in such cases. 24961 *************************************************************************/ 24962 double spdmatrixcholeskyrcond(/* Real */ ae_matrix* a, 24971 rcond_spdmatrixrcondcholeskyinternal(a, n, isupper, ae_false, 0, &v, _state); 24977 /************************************************************************* 24978 Condition number estimate of a Hermitian positive definite matrix given by 24979 Cholesky decomposition. 24981 The algorithm calculates a lower bound of the condition number. In this 24982 case, the algorithm does not return a lower bound of the condition number, 24983 but an inverse number (to avoid an overflow in case of a singular matrix). 24985 It should be noted that 1-norm and inf-norm condition numbers of symmetric 24986 matrices are equal, so the algorithm doesn't take into account the 24987 differences between these types of norms. 24990 CD - Cholesky decomposition of matrix A, 24991 output of SMatrixCholesky subroutine. 24992 N - size of matrix A. 24994 Result: 1/LowerBound(cond(A)) 24997 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 24998 0.0 is returned in such cases. 24999 *************************************************************************/ 25000 double hpdmatrixcholeskyrcond(/* Complex */ ae_matrix* a, 25009 rcond_hpdmatrixrcondcholeskyinternal(a, n, isupper, ae_false, 0, &v, _state); 25015 /************************************************************************* 25016 Estimate of the condition number of a matrix given by its LU decomposition (1-norm) 25018 The algorithm calculates a lower bound of the condition number. In this case, 25019 the algorithm does not return a lower bound of the condition number, but an 25020 inverse number (to avoid an overflow in case of a singular matrix). 25023 LUA - LU decomposition of a matrix in compact form. Output of 25024 the CMatrixLU subroutine. 25025 N - size of matrix A. 25027 Result: 1/LowerBound(cond(A)) 25030 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 25031 0.0 is returned in such cases. 25032 *************************************************************************/ 25033 double cmatrixlurcond1(/* Complex */ ae_matrix* lua, 25041 ae_assert(n>=1, "CMatrixLURCond1: N<1!
", _state); 25042 rcond_cmatrixrcondluinternal(lua, n, ae_true, ae_false, 0.0, &v, _state); 25048 /************************************************************************* 25049 Estimate of the condition number of a matrix given by its LU decomposition 25052 The algorithm calculates a lower bound of the condition number. In this case, 25053 the algorithm does not return a lower bound of the condition number, but an 25054 inverse number (to avoid an overflow in case of a singular matrix). 25057 LUA - LU decomposition of a matrix in compact form. Output of 25058 the CMatrixLU subroutine. 25059 N - size of matrix A. 25061 Result: 1/LowerBound(cond(A)) 25064 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 25065 0.0 is returned in such cases. 25066 *************************************************************************/ 25067 double cmatrixlurcondinf(/* Complex */ ae_matrix* lua, 25075 ae_assert(n>=1, "CMatrixLURCondInf: N<1!
", _state); 25076 rcond_cmatrixrcondluinternal(lua, n, ae_false, ae_false, 0.0, &v, _state); 25082 /************************************************************************* 25083 Triangular matrix: estimate of a condition number (1-norm) 25085 The algorithm calculates a lower bound of the condition number. In this case, 25086 the algorithm does not return a lower bound of the condition number, but an 25087 inverse number (to avoid an overflow in case of a singular matrix). 25090 A - matrix. Array[0..N-1, 0..N-1]. 25092 IsUpper - True, if the matrix is upper triangular. 25093 IsUnit - True, if the matrix has a unit diagonal. 25095 Result: 1/LowerBound(cond(A)) 25098 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 25099 0.0 is returned in such cases. 25100 *************************************************************************/ 25101 double cmatrixtrrcond1(/* Complex */ ae_matrix* a, 25107 ae_frame _frame_block; 25118 ae_frame_make(_state, &_frame_block); 25119 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 25120 ae_vector_init(&t, 0, DT_REAL, _state, ae_true); 25122 ae_assert(n>=1, "RMatrixTRRCond1: N<1!
", _state); 25123 ae_vector_set_length(&t, n, _state); 25124 for(i=0; i<=n-1; i++) 25126 t.ptr.p_double[i] = 0; 25128 for(i=0; i<=n-1; i++) 25140 for(j=j1; j<=j2; j++) 25142 t.ptr.p_double[j] = t.ptr.p_double[j]+ae_c_abs(a->ptr.pp_complex[i][j], _state); 25146 t.ptr.p_double[i] = t.ptr.p_double[i]+1; 25150 t.ptr.p_double[i] = t.ptr.p_double[i]+ae_c_abs(a->ptr.pp_complex[i][i], _state); 25154 for(i=0; i<=n-1; i++) 25156 nrm = ae_maxreal(nrm, t.ptr.p_double[i], _state); 25158 rcond_cmatrixrcondtrinternal(a, n, isupper, isunit, ae_true, nrm, &v, _state); 25160 ae_frame_leave(_state); 25165 /************************************************************************* 25166 Triangular matrix: estimate of a matrix condition number (infinity-norm). 25168 The algorithm calculates a lower bound of the condition number. In this case, 25169 the algorithm does not return a lower bound of the condition number, but an 25170 inverse number (to avoid an overflow in case of a singular matrix). 25173 A - matrix. Array whose indexes range within [0..N-1, 0..N-1]. 25174 N - size of matrix A. 25175 IsUpper - True, if the matrix is upper triangular. 25176 IsUnit - True, if the matrix has a unit diagonal. 25178 Result: 1/LowerBound(cond(A)) 25181 if k(A) is very large, then matrix is assumed degenerate, k(A)=INF, 25182 0.0 is returned in such cases. 25183 *************************************************************************/ 25184 double cmatrixtrrcondinf(/* Complex */ ae_matrix* a, 25190 ae_frame _frame_block; 25200 ae_frame_make(_state, &_frame_block); 25201 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 25203 ae_assert(n>=1, "RMatrixTRRCondInf: N<1!
", _state); 25205 for(i=0; i<=n-1; i++) 25218 for(j=j1; j<=j2; j++) 25220 v = v+ae_c_abs(a->ptr.pp_complex[i][j], _state); 25228 v = v+ae_c_abs(a->ptr.pp_complex[i][i], _state); 25230 nrm = ae_maxreal(nrm, v, _state); 25232 rcond_cmatrixrcondtrinternal(a, n, isupper, isunit, ae_false, nrm, &v, _state); 25234 ae_frame_leave(_state); 25239 /************************************************************************* 25240 Threshold for rcond: matrices with condition number beyond this threshold 25241 are considered singular. 25243 Threshold must be far enough from underflow, at least Sqr(Threshold) must 25244 be greater than underflow. 25245 *************************************************************************/ 25246 double rcondthreshold(ae_state *_state) 25251 result = ae_sqrt(ae_sqrt(ae_minrealnumber, _state), _state); 25256 /************************************************************************* 25257 Internal subroutine for condition number estimation 25259 -- LAPACK routine (version 3.0) -- 25260 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 25261 Courant Institute, Argonne National Lab, and Rice University 25263 *************************************************************************/ 25264 static void rcond_rmatrixrcondtrinternal(/* Real */ ae_matrix* a, 25273 ae_frame _frame_block; 25288 ae_frame_make(_state, &_frame_block); 25290 ae_vector_init(&ex, 0, DT_REAL, _state, ae_true); 25291 ae_vector_init(&ev, 0, DT_REAL, _state, ae_true); 25292 ae_vector_init(&iwork, 0, DT_INT, _state, ae_true); 25293 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 25297 * RC=0 if something happens 25312 ae_vector_set_length(&iwork, n+1, _state); 25313 ae_vector_set_length(&tmp, n, _state); 25316 * prepare parameters for triangular solver 25318 maxgrowth = 1/rcondthreshold(_state); 25320 for(i=0; i<=n-1; i++) 25332 for(j=j1; j<=j2; j++) 25334 s = ae_maxreal(s, ae_fabs(a->ptr.pp_double[i][j], _state), _state); 25338 s = ae_maxreal(s, 1, _state); 25342 s = ae_maxreal(s, ae_fabs(a->ptr.pp_double[i][i], _state), _state); 25345 if( ae_fp_eq(s,0) ) 25352 * Scale according to S 25357 * Quick return if possible 25358 * We assume that ANORM<>0 after this block 25360 if( ae_fp_eq(anorm,0) ) 25362 ae_frame_leave(_state); 25368 ae_frame_leave(_state); 25373 * Estimate the norm of inv(A). 25379 rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &ainvnm, &kase, _state); 25386 * from 1-based array to 0-based 25388 for(i=0; i<=n-1; i++) 25390 ex.ptr.p_double[i] = ex.ptr.p_double[i+1]; 25394 * multiply by inv(A) or inv(A') 25400 * multiply by inv(A) 25402 if( !rmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 0, isunit, maxgrowth, _state) ) 25404 ae_frame_leave(_state); 25412 * multiply by inv(A') 25414 if( !rmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 1, isunit, maxgrowth, _state) ) 25416 ae_frame_leave(_state); 25422 * from 0-based array to 1-based 25424 for(i=n-1; i>=0; i--) 25426 ex.ptr.p_double[i+1] = ex.ptr.p_double[i]; 25431 * Compute the estimate of the reciprocal condition number. 25433 if( ae_fp_neq(ainvnm,0) ) 25437 if( ae_fp_less(*rc,rcondthreshold(_state)) ) 25442 ae_frame_leave(_state); 25446 /************************************************************************* 25447 Condition number estimation 25449 -- LAPACK routine (version 3.0) -- 25450 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 25451 Courant Institute, Argonne National Lab, and Rice University 25453 *************************************************************************/ 25454 static void rcond_cmatrixrcondtrinternal(/* Complex */ ae_matrix* a, 25463 ae_frame _frame_block; 25480 ae_frame_make(_state, &_frame_block); 25482 ae_vector_init(&ex, 0, DT_COMPLEX, _state, ae_true); 25483 ae_vector_init(&cwork2, 0, DT_COMPLEX, _state, ae_true); 25484 ae_vector_init(&cwork3, 0, DT_COMPLEX, _state, ae_true); 25485 ae_vector_init(&cwork4, 0, DT_COMPLEX, _state, ae_true); 25486 ae_vector_init(&isave, 0, DT_INT, _state, ae_true); 25487 ae_vector_init(&rsave, 0, DT_REAL, _state, ae_true); 25491 * RC=0 if something happens 25500 ae_frame_leave(_state); 25506 ae_frame_leave(_state); 25509 ae_vector_set_length(&cwork2, n+1, _state); 25512 * prepare parameters for triangular solver 25514 maxgrowth = 1/rcondthreshold(_state); 25516 for(i=0; i<=n-1; i++) 25528 for(j=j1; j<=j2; j++) 25530 s = ae_maxreal(s, ae_c_abs(a->ptr.pp_complex[i][j], _state), _state); 25534 s = ae_maxreal(s, 1, _state); 25538 s = ae_maxreal(s, ae_c_abs(a->ptr.pp_complex[i][i], _state), _state); 25541 if( ae_fp_eq(s,0) ) 25548 * Scale according to S 25553 * Quick return if possible 25555 if( ae_fp_eq(anorm,0) ) 25557 ae_frame_leave(_state); 25562 * Estimate the norm of inv(A). 25576 rcond_cmatrixestimatenorm(n, &cwork4, &ex, &ainvnm, &kase, &isave, &rsave, _state); 25583 * From 1-based to 0-based 25585 for(i=0; i<=n-1; i++) 25587 ex.ptr.p_complex[i] = ex.ptr.p_complex[i+1]; 25591 * multiply by inv(A) or inv(A') 25597 * multiply by inv(A) 25599 if( !cmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 0, isunit, maxgrowth, _state) ) 25601 ae_frame_leave(_state); 25609 * multiply by inv(A') 25611 if( !cmatrixscaledtrsafesolve(a, s, n, &ex, isupper, 2, isunit, maxgrowth, _state) ) 25613 ae_frame_leave(_state); 25619 * from 0-based to 1-based 25621 for(i=n-1; i>=0; i--) 25623 ex.ptr.p_complex[i+1] = ex.ptr.p_complex[i]; 25628 * Compute the estimate of the reciprocal condition number. 25630 if( ae_fp_neq(ainvnm,0) ) 25634 if( ae_fp_less(*rc,rcondthreshold(_state)) ) 25639 ae_frame_leave(_state); 25643 /************************************************************************* 25644 Internal subroutine for condition number estimation 25646 -- LAPACK routine (version 3.0) -- 25647 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 25648 Courant Institute, Argonne National Lab, and Rice University 25650 *************************************************************************/ 25651 static void rcond_spdmatrixrcondcholeskyinternal(/* Real */ ae_matrix* cha, 25654 ae_bool isnormprovided, 25659 ae_frame _frame_block; 25672 ae_frame_make(_state, &_frame_block); 25674 ae_vector_init(&ex, 0, DT_REAL, _state, ae_true); 25675 ae_vector_init(&ev, 0, DT_REAL, _state, ae_true); 25676 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 25677 ae_vector_init(&iwork, 0, DT_INT, _state, ae_true); 25679 ae_assert(n>=1, "Assertion failed
", _state); 25680 ae_vector_set_length(&tmp, n, _state); 25683 * RC=0 if something happens 25688 * prepare parameters for triangular solver 25690 maxgrowth = 1/rcondthreshold(_state); 25694 for(i=0; i<=n-1; i++) 25696 for(j=i; j<=n-1; j++) 25698 sa = ae_maxreal(sa, ae_c_abs(ae_complex_from_d(cha->ptr.pp_double[i][j]), _state), _state); 25704 for(i=0; i<=n-1; i++) 25706 for(j=0; j<=i; j++) 25708 sa = ae_maxreal(sa, ae_c_abs(ae_complex_from_d(cha->ptr.pp_double[i][j]), _state), _state); 25712 if( ae_fp_eq(sa,0) ) 25719 * Estimate the norm of A. 25721 if( !isnormprovided ) 25727 rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &anorm, &kase, _state); 25738 for(i=1; i<=n; i++) 25740 v = ae_v_dotproduct(&cha->ptr.pp_double[i-1][i-1], 1, &ex.ptr.p_double[i], 1, ae_v_len(i-1,n-1)); 25741 ex.ptr.p_double[i] = v; 25743 ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa); 25748 for(i=0; i<=n-1; i++) 25750 tmp.ptr.p_double[i] = 0; 25752 for(i=0; i<=n-1; i++) 25754 v = ex.ptr.p_double[i+1]; 25755 ae_v_addd(&tmp.ptr.p_double[i], 1, &cha->ptr.pp_double[i][i], 1, ae_v_len(i,n-1), v); 25757 ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n)); 25758 ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa); 25766 for(i=0; i<=n-1; i++) 25768 tmp.ptr.p_double[i] = 0; 25770 for(i=0; i<=n-1; i++) 25772 v = ex.ptr.p_double[i+1]; 25773 ae_v_addd(&tmp.ptr.p_double[0], 1, &cha->ptr.pp_double[i][0], 1, ae_v_len(0,i), v); 25775 ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n)); 25776 ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa); 25781 for(i=n; i>=1; i--) 25783 v = ae_v_dotproduct(&cha->ptr.pp_double[i-1][0], 1, &ex.ptr.p_double[1], 1, ae_v_len(0,i-1)); 25784 ex.ptr.p_double[i] = v; 25786 ae_v_muld(&ex.ptr.p_double[1], 1, ae_v_len(1,n), sa); 25792 * Quick return if possible 25794 if( ae_fp_eq(anorm,0) ) 25796 ae_frame_leave(_state); 25802 ae_frame_leave(_state); 25807 * Estimate the 1-norm of inv(A). 25812 rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &ainvnm, &kase, _state); 25817 for(i=0; i<=n-1; i++) 25819 ex.ptr.p_double[i] = ex.ptr.p_double[i+1]; 25825 * Multiply by inv(U'). 25827 if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 1, ae_false, maxgrowth, _state) ) 25829 ae_frame_leave(_state); 25834 * Multiply by inv(U). 25836 if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) ) 25838 ae_frame_leave(_state); 25846 * Multiply by inv(L). 25848 if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) ) 25850 ae_frame_leave(_state); 25855 * Multiply by inv(L'). 25857 if( !rmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 1, ae_false, maxgrowth, _state) ) 25859 ae_frame_leave(_state); 25863 for(i=n-1; i>=0; i--) 25865 ex.ptr.p_double[i+1] = ex.ptr.p_double[i]; 25870 * Compute the estimate of the reciprocal condition number. 25872 if( ae_fp_neq(ainvnm,0) ) 25876 if( ae_fp_less(*rc,rcondthreshold(_state)) ) 25881 ae_frame_leave(_state); 25885 /************************************************************************* 25886 Internal subroutine for condition number estimation 25888 -- LAPACK routine (version 3.0) -- 25889 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 25890 Courant Institute, Argonne National Lab, and Rice University 25892 *************************************************************************/ 25893 static void rcond_hpdmatrixrcondcholeskyinternal(/* Complex */ ae_matrix* cha, 25896 ae_bool isnormprovided, 25901 ae_frame _frame_block; 25915 ae_frame_make(_state, &_frame_block); 25917 ae_vector_init(&isave, 0, DT_INT, _state, ae_true); 25918 ae_vector_init(&rsave, 0, DT_REAL, _state, ae_true); 25919 ae_vector_init(&ex, 0, DT_COMPLEX, _state, ae_true); 25920 ae_vector_init(&ev, 0, DT_COMPLEX, _state, ae_true); 25921 ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true); 25923 ae_assert(n>=1, "Assertion failed
", _state); 25924 ae_vector_set_length(&tmp, n, _state); 25927 * RC=0 if something happens 25932 * prepare parameters for triangular solver 25934 maxgrowth = 1/rcondthreshold(_state); 25938 for(i=0; i<=n-1; i++) 25940 for(j=i; j<=n-1; j++) 25942 sa = ae_maxreal(sa, ae_c_abs(cha->ptr.pp_complex[i][j], _state), _state); 25948 for(i=0; i<=n-1; i++) 25950 for(j=0; j<=i; j++) 25952 sa = ae_maxreal(sa, ae_c_abs(cha->ptr.pp_complex[i][j], _state), _state); 25956 if( ae_fp_eq(sa,0) ) 25963 * Estimate the norm of A 25965 if( !isnormprovided ) 25971 rcond_cmatrixestimatenorm(n, &ev, &ex, &anorm, &kase, &isave, &rsave, _state); 25982 for(i=1; i<=n; i++) 25984 v = ae_v_cdotproduct(&cha->ptr.pp_complex[i-1][i-1], 1, "N
", &ex.ptr.p_complex[i], 1, "N
", ae_v_len(i-1,n-1)); 25985 ex.ptr.p_complex[i] = v; 25987 ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa); 25992 for(i=0; i<=n-1; i++) 25994 tmp.ptr.p_complex[i] = ae_complex_from_d(0); 25996 for(i=0; i<=n-1; i++) 25998 v = ex.ptr.p_complex[i+1]; 25999 ae_v_caddc(&tmp.ptr.p_complex[i], 1, &cha->ptr.pp_complex[i][i], 1, "Conj
", ae_v_len(i,n-1), v); 26001 ae_v_cmove(&ex.ptr.p_complex[1], 1, &tmp.ptr.p_complex[0], 1, "N
", ae_v_len(1,n)); 26002 ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa); 26010 for(i=0; i<=n-1; i++) 26012 tmp.ptr.p_complex[i] = ae_complex_from_d(0); 26014 for(i=0; i<=n-1; i++) 26016 v = ex.ptr.p_complex[i+1]; 26017 ae_v_caddc(&tmp.ptr.p_complex[0], 1, &cha->ptr.pp_complex[i][0], 1, "Conj
", ae_v_len(0,i), v); 26019 ae_v_cmove(&ex.ptr.p_complex[1], 1, &tmp.ptr.p_complex[0], 1, "N
", ae_v_len(1,n)); 26020 ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa); 26025 for(i=n; i>=1; i--) 26027 v = ae_v_cdotproduct(&cha->ptr.pp_complex[i-1][0], 1, "N
", &ex.ptr.p_complex[1], 1, "N
", ae_v_len(0,i-1)); 26028 ex.ptr.p_complex[i] = v; 26030 ae_v_cmuld(&ex.ptr.p_complex[1], 1, ae_v_len(1,n), sa); 26036 * Quick return if possible 26037 * After this block we assume that ANORM<>0 26039 if( ae_fp_eq(anorm,0) ) 26041 ae_frame_leave(_state); 26047 ae_frame_leave(_state); 26052 * Estimate the norm of inv(A). 26058 rcond_cmatrixestimatenorm(n, &ev, &ex, &ainvnm, &kase, &isave, &rsave, _state); 26063 for(i=0; i<=n-1; i++) 26065 ex.ptr.p_complex[i] = ex.ptr.p_complex[i+1]; 26071 * Multiply by inv(U'). 26073 if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 2, ae_false, maxgrowth, _state) ) 26075 ae_frame_leave(_state); 26080 * Multiply by inv(U). 26082 if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) ) 26084 ae_frame_leave(_state); 26092 * Multiply by inv(L). 26094 if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 0, ae_false, maxgrowth, _state) ) 26096 ae_frame_leave(_state); 26101 * Multiply by inv(L'). 26103 if( !cmatrixscaledtrsafesolve(cha, sa, n, &ex, isupper, 2, ae_false, maxgrowth, _state) ) 26105 ae_frame_leave(_state); 26109 for(i=n-1; i>=0; i--) 26111 ex.ptr.p_complex[i+1] = ex.ptr.p_complex[i]; 26116 * Compute the estimate of the reciprocal condition number. 26118 if( ae_fp_neq(ainvnm,0) ) 26122 if( ae_fp_less(*rc,rcondthreshold(_state)) ) 26127 ae_frame_leave(_state); 26131 /************************************************************************* 26132 Internal subroutine for condition number estimation 26134 -- LAPACK routine (version 3.0) -- 26135 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 26136 Courant Institute, Argonne National Lab, and Rice University 26138 *************************************************************************/ 26139 static void rcond_rmatrixrcondluinternal(/* Real */ ae_matrix* lua, 26142 ae_bool isanormprovided, 26147 ae_frame _frame_block; 26164 ae_frame_make(_state, &_frame_block); 26166 ae_vector_init(&ex, 0, DT_REAL, _state, ae_true); 26167 ae_vector_init(&ev, 0, DT_REAL, _state, ae_true); 26168 ae_vector_init(&iwork, 0, DT_INT, _state, ae_true); 26169 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 26173 * RC=0 if something happens 26190 ae_vector_set_length(&iwork, n+1, _state); 26191 ae_vector_set_length(&tmp, n, _state); 26194 * prepare parameters for triangular solver 26196 maxgrowth = 1/rcondthreshold(_state); 26199 for(i=0; i<=n-1; i++) 26201 for(j=0; j<=i-1; j++) 26203 sl = ae_maxreal(sl, ae_fabs(lua->ptr.pp_double[i][j], _state), _state); 26205 for(j=i; j<=n-1; j++) 26207 su = ae_maxreal(su, ae_fabs(lua->ptr.pp_double[i][j], _state), _state); 26210 if( ae_fp_eq(su,0) ) 26218 * Estimate the norm of A. 26220 if( !isanormprovided ) 26226 rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &anorm, &kase, _state); 26237 for(i=1; i<=n; i++) 26239 v = ae_v_dotproduct(&lua->ptr.pp_double[i-1][i-1], 1, &ex.ptr.p_double[i], 1, ae_v_len(i-1,n-1)); 26240 ex.ptr.p_double[i] = v; 26246 for(i=n; i>=1; i--) 26250 v = ae_v_dotproduct(&lua->ptr.pp_double[i-1][0], 1, &ex.ptr.p_double[1], 1, ae_v_len(0,i-2)); 26256 ex.ptr.p_double[i] = ex.ptr.p_double[i]+v; 26265 for(i=0; i<=n-1; i++) 26267 tmp.ptr.p_double[i] = 0; 26269 for(i=0; i<=n-1; i++) 26271 v = ex.ptr.p_double[i+1]; 26274 ae_v_addd(&tmp.ptr.p_double[0], 1, &lua->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), v); 26276 tmp.ptr.p_double[i] = tmp.ptr.p_double[i]+v; 26278 ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n)); 26283 for(i=0; i<=n-1; i++) 26285 tmp.ptr.p_double[i] = 0; 26287 for(i=0; i<=n-1; i++) 26289 v = ex.ptr.p_double[i+1]; 26290 ae_v_addd(&tmp.ptr.p_double[i], 1, &lua->ptr.pp_double[i][i], 1, ae_v_len(i,n-1), v); 26292 ae_v_move(&ex.ptr.p_double[1], 1, &tmp.ptr.p_double[0], 1, ae_v_len(1,n)); 26298 * Scale according to SU/SL 26300 anorm = anorm*su*sl; 26303 * Quick return if possible 26304 * We assume that ANORM<>0 after this block 26306 if( ae_fp_eq(anorm,0) ) 26308 ae_frame_leave(_state); 26314 ae_frame_leave(_state); 26319 * Estimate the norm of inv(A). 26325 rcond_rmatrixestimatenorm(n, &ev, &ex, &iwork, &ainvnm, &kase, _state); 26332 * from 1-based array to 0-based 26334 for(i=0; i<=n-1; i++) 26336 ex.ptr.p_double[i] = ex.ptr.p_double[i+1]; 26340 * multiply by inv(A) or inv(A') 26346 * Multiply by inv(L). 26348 if( !rmatrixscaledtrsafesolve(lua, sl, n, &ex, !mupper, 0, munit, maxgrowth, _state) ) 26350 ae_frame_leave(_state); 26355 * Multiply by inv(U). 26357 if( !rmatrixscaledtrsafesolve(lua, su, n, &ex, mupper, 0, !munit, maxgrowth, _state) ) 26359 ae_frame_leave(_state); 26367 * Multiply by inv(U'). 26369 if( !rmatrixscaledtrsafesolve(lua, su, n, &ex, mupper, 1, !munit, maxgrowth, _state) ) 26371 ae_frame_leave(_state); 26376 * Multiply by inv(L'). 26378 if( !rmatrixscaledtrsafesolve(lua, sl, n, &ex, !mupper, 1, munit, maxgrowth, _state) ) 26380 ae_frame_leave(_state); 26386 * from 0-based array to 1-based 26388 for(i=n-1; i>=0; i--) 26390 ex.ptr.p_double[i+1] = ex.ptr.p_double[i]; 26395 * Compute the estimate of the reciprocal condition number. 26397 if( ae_fp_neq(ainvnm,0) ) 26401 if( ae_fp_less(*rc,rcondthreshold(_state)) ) 26406 ae_frame_leave(_state); 26410 /************************************************************************* 26411 Condition number estimation 26413 -- LAPACK routine (version 3.0) -- 26414 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 26415 Courant Institute, Argonne National Lab, and Rice University 26417 *************************************************************************/ 26418 static void rcond_cmatrixrcondluinternal(/* Complex */ ae_matrix* lua, 26421 ae_bool isanormprovided, 26426 ae_frame _frame_block; 26443 ae_frame_make(_state, &_frame_block); 26445 ae_vector_init(&ex, 0, DT_COMPLEX, _state, ae_true); 26446 ae_vector_init(&cwork2, 0, DT_COMPLEX, _state, ae_true); 26447 ae_vector_init(&cwork3, 0, DT_COMPLEX, _state, ae_true); 26448 ae_vector_init(&cwork4, 0, DT_COMPLEX, _state, ae_true); 26449 ae_vector_init(&isave, 0, DT_INT, _state, ae_true); 26450 ae_vector_init(&rsave, 0, DT_REAL, _state, ae_true); 26454 ae_frame_leave(_state); 26457 ae_vector_set_length(&cwork2, n+1, _state); 26462 ae_frame_leave(_state); 26467 * prepare parameters for triangular solver 26469 maxgrowth = 1/rcondthreshold(_state); 26472 for(i=0; i<=n-1; i++) 26474 for(j=0; j<=i-1; j++) 26476 sl = ae_maxreal(sl, ae_c_abs(lua->ptr.pp_complex[i][j], _state), _state); 26478 for(j=i; j<=n-1; j++) 26480 su = ae_maxreal(su, ae_c_abs(lua->ptr.pp_complex[i][j], _state), _state); 26483 if( ae_fp_eq(su,0) ) 26491 * Estimate the norm of SU*SL*A. 26493 if( !isanormprovided ) 26507 rcond_cmatrixestimatenorm(n, &cwork4, &ex, &anorm, &kase, &isave, &rsave, _state); 26516 for(i=1; i<=n; i++) 26518 v = ae_v_cdotproduct(&lua->ptr.pp_complex[i-1][i-1], 1, "N
", &ex.ptr.p_complex[i], 1, "N
", ae_v_len(i-1,n-1)); 26519 ex.ptr.p_complex[i] = v; 26525 for(i=n; i>=1; i--) 26527 v = ae_complex_from_d(0); 26530 v = ae_v_cdotproduct(&lua->ptr.pp_complex[i-1][0], 1, "N
", &ex.ptr.p_complex[1], 1, "N
", ae_v_len(0,i-2)); 26532 ex.ptr.p_complex[i] = ae_c_add(v,ex.ptr.p_complex[i]); 26541 for(i=1; i<=n; i++) 26543 cwork2.ptr.p_complex[i] = ae_complex_from_d(0); 26545 for(i=1; i<=n; i++) 26547 v = ex.ptr.p_complex[i]; 26550 ae_v_caddc(&cwork2.ptr.p_complex[1], 1, &lua->ptr.pp_complex[i-1][0], 1, "Conj
", ae_v_len(1,i-1), v); 26552 cwork2.ptr.p_complex[i] = ae_c_add(cwork2.ptr.p_complex[i],v); 26558 for(i=1; i<=n; i++) 26560 ex.ptr.p_complex[i] = ae_complex_from_d(0); 26562 for(i=1; i<=n; i++) 26564 v = cwork2.ptr.p_complex[i]; 26565 ae_v_caddc(&ex.ptr.p_complex[i], 1, &lua->ptr.pp_complex[i-1][i-1], 1, "Conj
", ae_v_len(i,n), v); 26574 * Scale according to SU/SL 26576 anorm = anorm*su*sl; 26579 * Quick return if possible 26581 if( ae_fp_eq(anorm,0) ) 26583 ae_frame_leave(_state); 26588 * Estimate the norm of inv(A). 26602 rcond_cmatrixestimatenorm(n, &cwork4, &ex, &ainvnm, &kase, &isave, &rsave, _state); 26609 * From 1-based to 0-based 26611 for(i=0; i<=n-1; i++) 26613 ex.ptr.p_complex[i] = ex.ptr.p_complex[i+1]; 26617 * multiply by inv(A) or inv(A') 26623 * Multiply by inv(L). 26625 if( !cmatrixscaledtrsafesolve(lua, sl, n, &ex, ae_false, 0, ae_true, maxgrowth, _state) ) 26628 ae_frame_leave(_state); 26633 * Multiply by inv(U). 26635 if( !cmatrixscaledtrsafesolve(lua, su, n, &ex, ae_true, 0, ae_false, maxgrowth, _state) ) 26638 ae_frame_leave(_state); 26646 * Multiply by inv(U'). 26648 if( !cmatrixscaledtrsafesolve(lua, su, n, &ex, ae_true, 2, ae_false, maxgrowth, _state) ) 26651 ae_frame_leave(_state); 26656 * Multiply by inv(L'). 26658 if( !cmatrixscaledtrsafesolve(lua, sl, n, &ex, ae_false, 2, ae_true, maxgrowth, _state) ) 26661 ae_frame_leave(_state); 26667 * from 0-based to 1-based 26669 for(i=n-1; i>=0; i--) 26671 ex.ptr.p_complex[i+1] = ex.ptr.p_complex[i]; 26676 * Compute the estimate of the reciprocal condition number. 26678 if( ae_fp_neq(ainvnm,0) ) 26682 if( ae_fp_less(*rc,rcondthreshold(_state)) ) 26687 ae_frame_leave(_state); 26691 /************************************************************************* 26692 Internal subroutine for matrix norm estimation 26694 -- LAPACK auxiliary routine (version 3.0) -- 26695 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 26696 Courant Institute, Argonne National Lab, and Rice University 26698 *************************************************************************/ 26699 static void rcond_rmatrixestimatenorm(ae_int_t n, 26700 /* Real */ ae_vector* v, 26701 /* Real */ ae_vector* x, 26702 /* Integer */ ae_vector* isgn, 26715 ae_int_t posaltsgn; 26716 ae_int_t posestold; 26730 ae_vector_set_length(v, n+4, _state); 26731 ae_vector_set_length(x, n+1, _state); 26732 ae_vector_set_length(isgn, n+5, _state); 26733 t = (double)1/(double)n; 26734 for(i=1; i<=n; i++) 26736 x->ptr.p_double[i] = t; 26739 isgn->ptr.p_int[posjump] = 1; 26744 * ................ ENTRY (JUMP = 1) 26745 * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. 26747 if( isgn->ptr.p_int[posjump]==1 ) 26751 v->ptr.p_double[1] = x->ptr.p_double[1]; 26752 *est = ae_fabs(v->ptr.p_double[1], _state); 26757 for(i=1; i<=n; i++) 26759 *est = *est+ae_fabs(x->ptr.p_double[i], _state); 26761 for(i=1; i<=n; i++) 26763 if( ae_fp_greater_eq(x->ptr.p_double[i],0) ) 26765 x->ptr.p_double[i] = 1; 26769 x->ptr.p_double[i] = -1; 26771 isgn->ptr.p_int[i] = ae_sign(x->ptr.p_double[i], _state); 26774 isgn->ptr.p_int[posjump] = 2; 26779 * ................ ENTRY (JUMP = 2) 26780 * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. 26782 if( isgn->ptr.p_int[posjump]==2 ) 26784 isgn->ptr.p_int[posj] = 1; 26785 for(i=2; i<=n; i++) 26787 if( ae_fp_greater(ae_fabs(x->ptr.p_double[i], _state),ae_fabs(x->ptr.p_double[isgn->ptr.p_int[posj]], _state)) ) 26789 isgn->ptr.p_int[posj] = i; 26792 isgn->ptr.p_int[positer] = 2; 26795 * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. 26797 for(i=1; i<=n; i++) 26799 x->ptr.p_double[i] = 0; 26801 x->ptr.p_double[isgn->ptr.p_int[posj]] = 1; 26803 isgn->ptr.p_int[posjump] = 3; 26808 * ................ ENTRY (JUMP = 3) 26809 * X HAS BEEN OVERWRITTEN BY A*X. 26811 if( isgn->ptr.p_int[posjump]==3 ) 26813 ae_v_move(&v->ptr.p_double[1], 1, &x->ptr.p_double[1], 1, ae_v_len(1,n)); 26814 v->ptr.p_double[posestold] = *est; 26816 for(i=1; i<=n; i++) 26818 *est = *est+ae_fabs(v->ptr.p_double[i], _state); 26821 for(i=1; i<=n; i++) 26823 if( (ae_fp_greater_eq(x->ptr.p_double[i],0)&&isgn->ptr.p_int[i]<0)||(ae_fp_less(x->ptr.p_double[i],0)&&isgn->ptr.p_int[i]>=0) ) 26830 * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. 26831 * OR MAY BE CYCLING. 26833 if( !flg||ae_fp_less_eq(*est,v->ptr.p_double[posestold]) ) 26835 v->ptr.p_double[posaltsgn] = 1; 26836 for(i=1; i<=n; i++) 26838 x->ptr.p_double[i] = v->ptr.p_double[posaltsgn]*(1+(double)(i-1)/(double)(n-1)); 26839 v->ptr.p_double[posaltsgn] = -v->ptr.p_double[posaltsgn]; 26842 isgn->ptr.p_int[posjump] = 5; 26845 for(i=1; i<=n; i++) 26847 if( ae_fp_greater_eq(x->ptr.p_double[i],0) ) 26849 x->ptr.p_double[i] = 1; 26850 isgn->ptr.p_int[i] = 1; 26854 x->ptr.p_double[i] = -1; 26855 isgn->ptr.p_int[i] = -1; 26859 isgn->ptr.p_int[posjump] = 4; 26864 * ................ ENTRY (JUMP = 4) 26865 * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. 26867 if( isgn->ptr.p_int[posjump]==4 ) 26869 isgn->ptr.p_int[posjlast] = isgn->ptr.p_int[posj]; 26870 isgn->ptr.p_int[posj] = 1; 26871 for(i=2; i<=n; i++) 26873 if( ae_fp_greater(ae_fabs(x->ptr.p_double[i], _state),ae_fabs(x->ptr.p_double[isgn->ptr.p_int[posj]], _state)) ) 26875 isgn->ptr.p_int[posj] = i; 26878 if( ae_fp_neq(x->ptr.p_double[isgn->ptr.p_int[posjlast]],ae_fabs(x->ptr.p_double[isgn->ptr.p_int[posj]], _state))&&isgn->ptr.p_int[positer]<itmax ) 26880 isgn->ptr.p_int[positer] = isgn->ptr.p_int[positer]+1; 26881 for(i=1; i<=n; i++) 26883 x->ptr.p_double[i] = 0; 26885 x->ptr.p_double[isgn->ptr.p_int[posj]] = 1; 26887 isgn->ptr.p_int[posjump] = 3; 26892 * ITERATION COMPLETE. FINAL STAGE. 26894 v->ptr.p_double[posaltsgn] = 1; 26895 for(i=1; i<=n; i++) 26897 x->ptr.p_double[i] = v->ptr.p_double[posaltsgn]*(1+(double)(i-1)/(double)(n-1)); 26898 v->ptr.p_double[posaltsgn] = -v->ptr.p_double[posaltsgn]; 26901 isgn->ptr.p_int[posjump] = 5; 26906 * ................ ENTRY (JUMP = 5) 26907 * X HAS BEEN OVERWRITTEN BY A*X. 26909 if( isgn->ptr.p_int[posjump]==5 ) 26911 v->ptr.p_double[postemp] = 0; 26912 for(i=1; i<=n; i++) 26914 v->ptr.p_double[postemp] = v->ptr.p_double[postemp]+ae_fabs(x->ptr.p_double[i], _state); 26916 v->ptr.p_double[postemp] = 2*v->ptr.p_double[postemp]/(3*n); 26917 if( ae_fp_greater(v->ptr.p_double[postemp],*est) ) 26919 ae_v_move(&v->ptr.p_double[1], 1, &x->ptr.p_double[1], 1, ae_v_len(1,n)); 26920 *est = v->ptr.p_double[postemp]; 26928 static void rcond_cmatrixestimatenorm(ae_int_t n, 26929 /* Complex */ ae_vector* v, 26930 /* Complex */ ae_vector* x, 26933 /* Integer */ ae_vector* isave, 26934 /* Real */ ae_vector* rsave, 26952 *Executable Statements .. 26955 safmin = ae_minrealnumber; 26958 ae_vector_set_length(v, n+1, _state); 26959 ae_vector_set_length(x, n+1, _state); 26960 ae_vector_set_length(isave, 5, _state); 26961 ae_vector_set_length(rsave, 4, _state); 26962 for(i=1; i<=n; i++) 26964 x->ptr.p_complex[i] = ae_complex_from_d((double)1/(double)n); 26968 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 26971 rcond_internalcomplexrcondloadall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 26975 * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. 26981 v->ptr.p_complex[1] = x->ptr.p_complex[1]; 26982 *est = ae_c_abs(v->ptr.p_complex[1], _state); 26984 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 26987 *est = rcond_internalcomplexrcondscsum1(x, n, _state); 26988 for(i=1; i<=n; i++) 26990 absxi = ae_c_abs(x->ptr.p_complex[i], _state); 26991 if( ae_fp_greater(absxi,safmin) ) 26993 x->ptr.p_complex[i] = ae_c_div_d(x->ptr.p_complex[i],absxi); 26997 x->ptr.p_complex[i] = ae_complex_from_d(1); 27002 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27008 * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. 27012 j = rcond_internalcomplexrcondicmax1(x, n, _state); 27016 * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. 27018 for(i=1; i<=n; i++) 27020 x->ptr.p_complex[i] = ae_complex_from_d(0); 27022 x->ptr.p_complex[j] = ae_complex_from_d(1); 27025 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27031 * X HAS BEEN OVERWRITTEN BY A*X. 27035 ae_v_cmove(&v->ptr.p_complex[1], 1, &x->ptr.p_complex[1], 1, "N
", ae_v_len(1,n)); 27037 *est = rcond_internalcomplexrcondscsum1(v, n, _state); 27040 * TEST FOR CYCLING. 27042 if( ae_fp_less_eq(*est,estold) ) 27046 * ITERATION COMPLETE. FINAL STAGE. 27049 for(i=1; i<=n; i++) 27051 x->ptr.p_complex[i] = ae_complex_from_d(altsgn*(1+(double)(i-1)/(double)(n-1))); 27056 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27059 for(i=1; i<=n; i++) 27061 absxi = ae_c_abs(x->ptr.p_complex[i], _state); 27062 if( ae_fp_greater(absxi,safmin) ) 27064 x->ptr.p_complex[i] = ae_c_div_d(x->ptr.p_complex[i],absxi); 27068 x->ptr.p_complex[i] = ae_complex_from_d(1); 27073 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27079 * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. 27084 j = rcond_internalcomplexrcondicmax1(x, n, _state); 27085 if( ae_fp_neq(ae_c_abs(x->ptr.p_complex[jlast], _state),ae_c_abs(x->ptr.p_complex[j], _state))&&iter<itmax ) 27090 * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. 27092 for(i=1; i<=n; i++) 27094 x->ptr.p_complex[i] = ae_complex_from_d(0); 27096 x->ptr.p_complex[j] = ae_complex_from_d(1); 27099 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27104 * ITERATION COMPLETE. FINAL STAGE. 27107 for(i=1; i<=n; i++) 27109 x->ptr.p_complex[i] = ae_complex_from_d(altsgn*(1+(double)(i-1)/(double)(n-1))); 27114 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27120 * X HAS BEEN OVERWRITTEN BY A*X. 27124 temp = 2*(rcond_internalcomplexrcondscsum1(x, n, _state)/(3*n)); 27125 if( ae_fp_greater(temp,*est) ) 27127 ae_v_cmove(&v->ptr.p_complex[1], 1, &x->ptr.p_complex[1], 1, "N
", ae_v_len(1,n)); 27131 rcond_internalcomplexrcondsaveall(isave, rsave, &i, &iter, &j, &jlast, &jump, &absxi, &altsgn, &estold, &temp, _state); 27137 static double rcond_internalcomplexrcondscsum1(/* Complex */ ae_vector* x, 27146 for(i=1; i<=n; i++) 27148 result = result+ae_c_abs(x->ptr.p_complex[i], _state); 27154 static ae_int_t rcond_internalcomplexrcondicmax1(/* Complex */ ae_vector* x, 27164 m = ae_c_abs(x->ptr.p_complex[1], _state); 27165 for(i=2; i<=n; i++) 27167 if( ae_fp_greater(ae_c_abs(x->ptr.p_complex[i], _state),m) ) 27170 m = ae_c_abs(x->ptr.p_complex[i], _state); 27177 static void rcond_internalcomplexrcondsaveall(/* Integer */ ae_vector* isave, 27178 /* Real */ ae_vector* rsave, 27192 isave->ptr.p_int[0] = *i; 27193 isave->ptr.p_int[1] = *iter; 27194 isave->ptr.p_int[2] = *j; 27195 isave->ptr.p_int[3] = *jlast; 27196 isave->ptr.p_int[4] = *jump; 27197 rsave->ptr.p_double[0] = *absxi; 27198 rsave->ptr.p_double[1] = *altsgn; 27199 rsave->ptr.p_double[2] = *estold; 27200 rsave->ptr.p_double[3] = *temp; 27204 static void rcond_internalcomplexrcondloadall(/* Integer */ ae_vector* isave, 27205 /* Real */ ae_vector* rsave, 27219 *i = isave->ptr.p_int[0]; 27220 *iter = isave->ptr.p_int[1]; 27221 *j = isave->ptr.p_int[2]; 27222 *jlast = isave->ptr.p_int[3]; 27223 *jump = isave->ptr.p_int[4]; 27224 *absxi = rsave->ptr.p_double[0]; 27225 *altsgn = rsave->ptr.p_double[1]; 27226 *estold = rsave->ptr.p_double[2]; 27227 *temp = rsave->ptr.p_double[3]; 27233 /************************************************************************* 27234 Inversion of a matrix given by its LU decomposition. 27237 A - LU decomposition of the matrix 27238 (output of RMatrixLU subroutine). 27239 Pivots - table of permutations 27240 (the output of RMatrixLU subroutine). 27241 N - size of matrix A (optional) : 27242 * if given, only principal NxN submatrix is processed and 27243 overwritten. other elements are unchanged. 27244 * if not given, size is automatically determined from 27245 matrix size (A must be square matrix) 27248 Info - return code: 27249 * -3 A is singular, or VERY close to singular. 27250 it is filled by zeros in such cases. 27251 * 1 task is solved (but matrix A may be ill-conditioned, 27252 check R1/RInf parameters for condition numbers). 27253 Rep - solver report, see below for more info 27254 A - inverse of matrix A. 27255 Array whose indexes range within [0..N-1, 0..N-1]. 27259 Subroutine sets following fields of the Rep structure: 27260 * R1 reciprocal of condition number: 1/cond(A), 1-norm. 27261 * RInf reciprocal of condition number: 1/cond(A), inf-norm. 27263 -- ALGLIB routine -- 27266 *************************************************************************/ 27267 void rmatrixluinverse(/* Real */ ae_matrix* a, 27268 /* Integer */ ae_vector* pivots, 27274 ae_frame _frame_block; 27281 ae_frame_make(_state, &_frame_block); 27283 _matinvreport_clear(rep); 27284 ae_vector_init(&work, 0, DT_REAL, _state, ae_true); 27286 ae_assert(n>0, "RMatrixLUInverse: N<=0!
", _state); 27287 ae_assert(a->cols>=n, "RMatrixLUInverse: cols(A)<N!
", _state); 27288 ae_assert(a->rows>=n, "RMatrixLUInverse: rows(A)<N!
", _state); 27289 ae_assert(pivots->cnt>=n, "RMatrixLUInverse:
len(Pivots)<N!
", _state); 27290 ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixLUInverse: A contains infinite
or NaN values!
", _state); 27292 for(i=0; i<=n-1; i++) 27294 if( pivots->ptr.p_int[i]>n-1||pivots->ptr.p_int[i]<i ) 27299 ae_assert(*info>0, "RMatrixLUInverse: incorrect Pivots array!
", _state); 27302 * calculate condition numbers 27304 rep->r1 = rmatrixlurcond1(a, n, _state); 27305 rep->rinf = rmatrixlurcondinf(a, n, _state); 27306 if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) ) 27308 for(i=0; i<=n-1; i++) 27310 for(j=0; j<=n-1; j++) 27312 a->ptr.pp_double[i][j] = 0; 27318 ae_frame_leave(_state); 27323 * Call cache-oblivious code 27325 ae_vector_set_length(&work, n, _state); 27326 matinv_rmatrixluinverserec(a, 0, n, &work, info, rep, _state); 27329 * apply permutations 27331 for(i=0; i<=n-1; i++) 27333 for(j=n-2; j>=0; j--) 27335 k = pivots->ptr.p_int[j]; 27336 v = a->ptr.pp_double[i][j]; 27337 a->ptr.pp_double[i][j] = a->ptr.pp_double[i][k]; 27338 a->ptr.pp_double[i][k] = v; 27341 ae_frame_leave(_state); 27345 /************************************************************************* 27346 Inversion of a general matrix. 27350 N - size of matrix A (optional) : 27351 * if given, only principal NxN submatrix is processed and 27352 overwritten. other elements are unchanged. 27353 * if not given, size is automatically determined from 27354 matrix size (A must be square matrix) 27357 Info - return code, same as in RMatrixLUInverse 27358 Rep - solver report, same as in RMatrixLUInverse 27359 A - inverse of matrix A, same as in RMatrixLUInverse 27362 True, if the matrix is not singular. 27363 False, if the matrix is singular. 27366 Copyright 2005-2010 by Bochkanov Sergey 27367 *************************************************************************/ 27368 void rmatrixinverse(/* Real */ ae_matrix* a, 27374 ae_frame _frame_block; 27377 ae_frame_make(_state, &_frame_block); 27379 _matinvreport_clear(rep); 27380 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 27382 ae_assert(n>0, "RMatrixInverse: N<=0!
", _state); 27383 ae_assert(a->cols>=n, "RMatrixInverse: cols(A)<N!
", _state); 27384 ae_assert(a->rows>=n, "RMatrixInverse: rows(A)<N!
", _state); 27385 ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixInverse: A contains infinite
or NaN values!
", _state); 27386 rmatrixlu(a, n, n, &pivots, _state); 27387 rmatrixluinverse(a, &pivots, n, info, rep, _state); 27388 ae_frame_leave(_state); 27392 /************************************************************************* 27393 Inversion of a matrix given by its LU decomposition. 27396 A - LU decomposition of the matrix 27397 (output of CMatrixLU subroutine). 27398 Pivots - table of permutations 27399 (the output of CMatrixLU subroutine). 27400 N - size of matrix A (optional) : 27401 * if given, only principal NxN submatrix is processed and 27402 overwritten. other elements are unchanged. 27403 * if not given, size is automatically determined from 27404 matrix size (A must be square matrix) 27407 Info - return code, same as in RMatrixLUInverse 27408 Rep - solver report, same as in RMatrixLUInverse 27409 A - inverse of matrix A, same as in RMatrixLUInverse 27411 -- ALGLIB routine -- 27414 *************************************************************************/ 27415 void cmatrixluinverse(/* Complex */ ae_matrix* a, 27416 /* Integer */ ae_vector* pivots, 27422 ae_frame _frame_block; 27429 ae_frame_make(_state, &_frame_block); 27431 _matinvreport_clear(rep); 27432 ae_vector_init(&work, 0, DT_COMPLEX, _state, ae_true); 27434 ae_assert(n>0, "CMatrixLUInverse: N<=0!
", _state); 27435 ae_assert(a->cols>=n, "CMatrixLUInverse: cols(A)<N!
", _state); 27436 ae_assert(a->rows>=n, "CMatrixLUInverse: rows(A)<N!
", _state); 27437 ae_assert(pivots->cnt>=n, "CMatrixLUInverse:
len(Pivots)<N!
", _state); 27438 ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixLUInverse: A contains infinite
or NaN values!
", _state); 27440 for(i=0; i<=n-1; i++) 27442 if( pivots->ptr.p_int[i]>n-1||pivots->ptr.p_int[i]<i ) 27447 ae_assert(*info>0, "CMatrixLUInverse: incorrect Pivots array!
", _state); 27450 * calculate condition numbers 27452 rep->r1 = cmatrixlurcond1(a, n, _state); 27453 rep->rinf = cmatrixlurcondinf(a, n, _state); 27454 if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) ) 27456 for(i=0; i<=n-1; i++) 27458 for(j=0; j<=n-1; j++) 27460 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 27466 ae_frame_leave(_state); 27471 * Call cache-oblivious code 27473 ae_vector_set_length(&work, n, _state); 27474 matinv_cmatrixluinverserec(a, 0, n, &work, info, rep, _state); 27477 * apply permutations 27479 for(i=0; i<=n-1; i++) 27481 for(j=n-2; j>=0; j--) 27483 k = pivots->ptr.p_int[j]; 27484 v = a->ptr.pp_complex[i][j]; 27485 a->ptr.pp_complex[i][j] = a->ptr.pp_complex[i][k]; 27486 a->ptr.pp_complex[i][k] = v; 27489 ae_frame_leave(_state); 27493 /************************************************************************* 27494 Inversion of a general matrix. 27498 N - size of matrix A (optional) : 27499 * if given, only principal NxN submatrix is processed and 27500 overwritten. other elements are unchanged. 27501 * if not given, size is automatically determined from 27502 matrix size (A must be square matrix) 27505 Info - return code, same as in RMatrixLUInverse 27506 Rep - solver report, same as in RMatrixLUInverse 27507 A - inverse of matrix A, same as in RMatrixLUInverse 27510 Copyright 2005 by Bochkanov Sergey 27511 *************************************************************************/ 27512 void cmatrixinverse(/* Complex */ ae_matrix* a, 27518 ae_frame _frame_block; 27521 ae_frame_make(_state, &_frame_block); 27523 _matinvreport_clear(rep); 27524 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 27526 ae_assert(n>0, "CRMatrixInverse: N<=0!
", _state); 27527 ae_assert(a->cols>=n, "CRMatrixInverse: cols(A)<N!
", _state); 27528 ae_assert(a->rows>=n, "CRMatrixInverse: rows(A)<N!
", _state); 27529 ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixInverse: A contains infinite
or NaN values!
", _state); 27530 cmatrixlu(a, n, n, &pivots, _state); 27531 cmatrixluinverse(a, &pivots, n, info, rep, _state); 27532 ae_frame_leave(_state); 27536 /************************************************************************* 27537 Inversion of a symmetric positive definite matrix which is given 27538 by Cholesky decomposition. 27541 A - Cholesky decomposition of the matrix to be inverted: 27542 A=U’*U or A = L*L'. 27543 Output of SPDMatrixCholesky subroutine. 27544 N - size of matrix A (optional) : 27545 * if given, only principal NxN submatrix is processed and 27546 overwritten. other elements are unchanged. 27547 * if not given, size is automatically determined from 27548 matrix size (A must be square matrix) 27549 IsUpper - storage type (optional): 27550 * if True, symmetric matrix A is given by its upper 27551 triangle, and the lower triangle isn’t used/changed by 27553 * if False, symmetric matrix A is given by its lower 27554 triangle, and the upper triangle isn’t used/changed by 27556 * if not given, lower half is used. 27559 Info - return code, same as in RMatrixLUInverse 27560 Rep - solver report, same as in RMatrixLUInverse 27561 A - inverse of matrix A, same as in RMatrixLUInverse 27563 -- ALGLIB routine -- 27566 *************************************************************************/ 27567 void spdmatrixcholeskyinverse(/* Real */ ae_matrix* a, 27574 ae_frame _frame_block; 27581 ae_frame_make(_state, &_frame_block); 27583 _matinvreport_clear(rep); 27584 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 27585 _matinvreport_init(&rep2, _state, ae_true); 27587 ae_assert(n>0, "SPDMatrixCholeskyInverse: N<=0!
", _state); 27588 ae_assert(a->cols>=n, "SPDMatrixCholeskyInverse: cols(A)<N!
", _state); 27589 ae_assert(a->rows>=n, "SPDMatrixCholeskyInverse: rows(A)<N!
", _state); 27592 for(i=0; i<=n-1; i++) 27594 f = f&&ae_isfinite(a->ptr.pp_double[i][i], _state); 27596 ae_assert(f, "SPDMatrixCholeskyInverse: A contains infinite
or NaN values!
", _state); 27599 * calculate condition numbers 27601 rep->r1 = spdmatrixcholeskyrcond(a, n, isupper, _state); 27602 rep->rinf = rep->r1; 27603 if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) ) 27607 for(i=0; i<=n-1; i++) 27609 for(j=i; j<=n-1; j++) 27611 a->ptr.pp_double[i][j] = 0; 27617 for(i=0; i<=n-1; i++) 27619 for(j=0; j<=i; j++) 27621 a->ptr.pp_double[i][j] = 0; 27628 ae_frame_leave(_state); 27635 ae_vector_set_length(&tmp, n, _state); 27636 matinv_spdmatrixcholeskyinverserec(a, 0, n, isupper, &tmp, _state); 27637 ae_frame_leave(_state); 27641 /************************************************************************* 27642 Inversion of a symmetric positive definite matrix. 27644 Given an upper or lower triangle of a symmetric positive definite matrix, 27645 the algorithm generates matrix A^-1 and saves the upper or lower triangle 27646 depending on the input. 27649 A - matrix to be inverted (upper or lower triangle). 27650 Array with elements [0..N-1,0..N-1]. 27651 N - size of matrix A (optional) : 27652 * if given, only principal NxN submatrix is processed and 27653 overwritten. other elements are unchanged. 27654 * if not given, size is automatically determined from 27655 matrix size (A must be square matrix) 27656 IsUpper - storage type (optional): 27657 * if True, symmetric matrix A is given by its upper 27658 triangle, and the lower triangle isn’t used/changed by 27660 * if False, symmetric matrix A is given by its lower 27661 triangle, and the upper triangle isn’t used/changed by 27663 * if not given, both lower and upper triangles must be 27667 Info - return code, same as in RMatrixLUInverse 27668 Rep - solver report, same as in RMatrixLUInverse 27669 A - inverse of matrix A, same as in RMatrixLUInverse 27671 -- ALGLIB routine -- 27674 *************************************************************************/ 27675 void spdmatrixinverse(/* Real */ ae_matrix* a, 27684 _matinvreport_clear(rep); 27686 ae_assert(n>0, "SPDMatrixInverse: N<=0!
", _state); 27687 ae_assert(a->cols>=n, "SPDMatrixInverse: cols(A)<N!
", _state); 27688 ae_assert(a->rows>=n, "SPDMatrixInverse: rows(A)<N!
", _state); 27689 ae_assert(isfinitertrmatrix(a, n, isupper, _state), "SPDMatrixInverse: A contains infinite
or NaN values!
", _state); 27691 if( spdmatrixcholesky(a, n, isupper, _state) ) 27693 spdmatrixcholeskyinverse(a, n, isupper, info, rep, _state); 27702 /************************************************************************* 27703 Inversion of a Hermitian positive definite matrix which is given 27704 by Cholesky decomposition. 27707 A - Cholesky decomposition of the matrix to be inverted: 27708 A=U’*U or A = L*L'. 27709 Output of HPDMatrixCholesky subroutine. 27710 N - size of matrix A (optional) : 27711 * if given, only principal NxN submatrix is processed and 27712 overwritten. other elements are unchanged. 27713 * if not given, size is automatically determined from 27714 matrix size (A must be square matrix) 27715 IsUpper - storage type (optional): 27716 * if True, symmetric matrix A is given by its upper 27717 triangle, and the lower triangle isn’t used/changed by 27719 * if False, symmetric matrix A is given by its lower 27720 triangle, and the upper triangle isn’t used/changed by 27722 * if not given, lower half is used. 27725 Info - return code, same as in RMatrixLUInverse 27726 Rep - solver report, same as in RMatrixLUInverse 27727 A - inverse of matrix A, same as in RMatrixLUInverse 27729 -- ALGLIB routine -- 27732 *************************************************************************/ 27733 void hpdmatrixcholeskyinverse(/* Complex */ ae_matrix* a, 27740 ae_frame _frame_block; 27747 ae_frame_make(_state, &_frame_block); 27749 _matinvreport_clear(rep); 27750 _matinvreport_init(&rep2, _state, ae_true); 27751 ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true); 27753 ae_assert(n>0, "HPDMatrixCholeskyInverse: N<=0!
", _state); 27754 ae_assert(a->cols>=n, "HPDMatrixCholeskyInverse: cols(A)<N!
", _state); 27755 ae_assert(a->rows>=n, "HPDMatrixCholeskyInverse: rows(A)<N!
", _state); 27757 for(i=0; i<=n-1; i++) 27759 f = (f&&ae_isfinite(a->ptr.pp_complex[i][i].x, _state))&&ae_isfinite(a->ptr.pp_complex[i][i].y, _state); 27761 ae_assert(f, "HPDMatrixCholeskyInverse: A contains infinite
or NaN values!
", _state); 27765 * calculate condition numbers 27767 rep->r1 = hpdmatrixcholeskyrcond(a, n, isupper, _state); 27768 rep->rinf = rep->r1; 27769 if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) ) 27773 for(i=0; i<=n-1; i++) 27775 for(j=i; j<=n-1; j++) 27777 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 27783 for(i=0; i<=n-1; i++) 27785 for(j=0; j<=i; j++) 27787 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 27794 ae_frame_leave(_state); 27801 ae_vector_set_length(&tmp, n, _state); 27802 matinv_hpdmatrixcholeskyinverserec(a, 0, n, isupper, &tmp, _state); 27803 ae_frame_leave(_state); 27807 /************************************************************************* 27808 Inversion of a Hermitian positive definite matrix. 27810 Given an upper or lower triangle of a Hermitian positive definite matrix, 27811 the algorithm generates matrix A^-1 and saves the upper or lower triangle 27812 depending on the input. 27815 A - matrix to be inverted (upper or lower triangle). 27816 Array with elements [0..N-1,0..N-1]. 27817 N - size of matrix A (optional) : 27818 * if given, only principal NxN submatrix is processed and 27819 overwritten. other elements are unchanged. 27820 * if not given, size is automatically determined from 27821 matrix size (A must be square matrix) 27822 IsUpper - storage type (optional): 27823 * if True, symmetric matrix A is given by its upper 27824 triangle, and the lower triangle isn’t used/changed by 27826 * if False, symmetric matrix A is given by its lower 27827 triangle, and the upper triangle isn’t used/changed by 27829 * if not given, both lower and upper triangles must be 27833 Info - return code, same as in RMatrixLUInverse 27834 Rep - solver report, same as in RMatrixLUInverse 27835 A - inverse of matrix A, same as in RMatrixLUInverse 27837 -- ALGLIB routine -- 27840 *************************************************************************/ 27841 void hpdmatrixinverse(/* Complex */ ae_matrix* a, 27850 _matinvreport_clear(rep); 27852 ae_assert(n>0, "HPDMatrixInverse: N<=0!
", _state); 27853 ae_assert(a->cols>=n, "HPDMatrixInverse: cols(A)<N!
", _state); 27854 ae_assert(a->rows>=n, "HPDMatrixInverse: rows(A)<N!
", _state); 27855 ae_assert(apservisfinitectrmatrix(a, n, isupper, _state), "HPDMatrixInverse: A contains infinite
or NaN values!
", _state); 27857 if( hpdmatrixcholesky(a, n, isupper, _state) ) 27859 hpdmatrixcholeskyinverse(a, n, isupper, info, rep, _state); 27868 /************************************************************************* 27869 Triangular matrix inverse (real) 27871 The subroutine inverts the following types of matrices: 27873 * upper triangular with unit diagonal 27875 * lower triangular with unit diagonal 27877 In case of an upper (lower) triangular matrix, the inverse matrix will 27878 also be upper (lower) triangular, and after the end of the algorithm, the 27879 inverse matrix replaces the source matrix. The elements below (above) the 27880 main diagonal are not changed by the algorithm. 27882 If the matrix has a unit diagonal, the inverse matrix also has a unit 27883 diagonal, and the diagonal elements are not passed to the algorithm. 27886 A - matrix, array[0..N-1, 0..N-1]. 27887 N - size of matrix A (optional) : 27888 * if given, only principal NxN submatrix is processed and 27889 overwritten. other elements are unchanged. 27890 * if not given, size is automatically determined from 27891 matrix size (A must be square matrix) 27892 IsUpper - True, if the matrix is upper triangular. 27893 IsUnit - diagonal type (optional): 27894 * if True, matrix has unit diagonal (a[i,i] are NOT used) 27895 * if False, matrix diagonal is arbitrary 27896 * if not given, False is assumed 27899 Info - same as for RMatrixLUInverse 27900 Rep - same as for RMatrixLUInverse 27901 A - same as for RMatrixLUInverse. 27904 Copyright 05.02.2010 by Bochkanov Sergey 27905 *************************************************************************/ 27906 void rmatrixtrinverse(/* Real */ ae_matrix* a, 27914 ae_frame _frame_block; 27919 ae_frame_make(_state, &_frame_block); 27921 _matinvreport_clear(rep); 27922 ae_vector_init(&tmp, 0, DT_REAL, _state, ae_true); 27924 ae_assert(n>0, "RMatrixTRInverse: N<=0!
", _state); 27925 ae_assert(a->cols>=n, "RMatrixTRInverse: cols(A)<N!
", _state); 27926 ae_assert(a->rows>=n, "RMatrixTRInverse: rows(A)<N!
", _state); 27927 ae_assert(isfinitertrmatrix(a, n, isupper, _state), "RMatrixTRInverse: A contains infinite
or NaN values!
", _state); 27931 * calculate condition numbers 27933 rep->r1 = rmatrixtrrcond1(a, n, isupper, isunit, _state); 27934 rep->rinf = rmatrixtrrcondinf(a, n, isupper, isunit, _state); 27935 if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) ) 27937 for(i=0; i<=n-1; i++) 27939 for(j=0; j<=n-1; j++) 27941 a->ptr.pp_double[i][j] = 0; 27947 ae_frame_leave(_state); 27954 ae_vector_set_length(&tmp, n, _state); 27955 matinv_rmatrixtrinverserec(a, 0, n, isupper, isunit, &tmp, info, rep, _state); 27956 ae_frame_leave(_state); 27960 /************************************************************************* 27961 Triangular matrix inverse (complex) 27963 The subroutine inverts the following types of matrices: 27965 * upper triangular with unit diagonal 27967 * lower triangular with unit diagonal 27969 In case of an upper (lower) triangular matrix, the inverse matrix will 27970 also be upper (lower) triangular, and after the end of the algorithm, the 27971 inverse matrix replaces the source matrix. The elements below (above) the 27972 main diagonal are not changed by the algorithm. 27974 If the matrix has a unit diagonal, the inverse matrix also has a unit 27975 diagonal, and the diagonal elements are not passed to the algorithm. 27978 A - matrix, array[0..N-1, 0..N-1]. 27979 N - size of matrix A (optional) : 27980 * if given, only principal NxN submatrix is processed and 27981 overwritten. other elements are unchanged. 27982 * if not given, size is automatically determined from 27983 matrix size (A must be square matrix) 27984 IsUpper - True, if the matrix is upper triangular. 27985 IsUnit - diagonal type (optional): 27986 * if True, matrix has unit diagonal (a[i,i] are NOT used) 27987 * if False, matrix diagonal is arbitrary 27988 * if not given, False is assumed 27991 Info - same as for RMatrixLUInverse 27992 Rep - same as for RMatrixLUInverse 27993 A - same as for RMatrixLUInverse. 27996 Copyright 05.02.2010 by Bochkanov Sergey 27997 *************************************************************************/ 27998 void cmatrixtrinverse(/* Complex */ ae_matrix* a, 28006 ae_frame _frame_block; 28011 ae_frame_make(_state, &_frame_block); 28013 _matinvreport_clear(rep); 28014 ae_vector_init(&tmp, 0, DT_COMPLEX, _state, ae_true); 28016 ae_assert(n>0, "CMatrixTRInverse: N<=0!
", _state); 28017 ae_assert(a->cols>=n, "CMatrixTRInverse: cols(A)<N!
", _state); 28018 ae_assert(a->rows>=n, "CMatrixTRInverse: rows(A)<N!
", _state); 28019 ae_assert(apservisfinitectrmatrix(a, n, isupper, _state), "CMatrixTRInverse: A contains infinite
or NaN values!
", _state); 28023 * calculate condition numbers 28025 rep->r1 = cmatrixtrrcond1(a, n, isupper, isunit, _state); 28026 rep->rinf = cmatrixtrrcondinf(a, n, isupper, isunit, _state); 28027 if( ae_fp_less(rep->r1,rcondthreshold(_state))||ae_fp_less(rep->rinf,rcondthreshold(_state)) ) 28029 for(i=0; i<=n-1; i++) 28031 for(j=0; j<=n-1; j++) 28033 a->ptr.pp_complex[i][j] = ae_complex_from_d(0); 28039 ae_frame_leave(_state); 28046 ae_vector_set_length(&tmp, n, _state); 28047 matinv_cmatrixtrinverserec(a, 0, n, isupper, isunit, &tmp, info, rep, _state); 28048 ae_frame_leave(_state); 28052 /************************************************************************* 28053 Triangular matrix inversion, recursive subroutine 28056 05.02.2010, Bochkanov Sergey. 28057 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 28058 Courant Institute, Argonne National Lab, and Rice University 28060 *************************************************************************/ 28061 static void matinv_rmatrixtrinverserec(/* Real */ ae_matrix* a, 28066 /* Real */ ae_vector* tmp, 28088 if( n<=ablasblocksize(a, _state) ) 28094 * Compute inverse of upper triangular matrix. 28096 for(j=0; j<=n-1; j++) 28100 if( ae_fp_eq(a->ptr.pp_double[offs+j][offs+j],0) ) 28105 a->ptr.pp_double[offs+j][offs+j] = 1/a->ptr.pp_double[offs+j][offs+j]; 28106 ajj = -a->ptr.pp_double[offs+j][offs+j]; 28114 * Compute elements 1:j-1 of j-th column. 28118 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+0][offs+j], a->stride, ae_v_len(0,j-1)); 28119 for(i=0; i<=j-1; i++) 28123 v = ae_v_dotproduct(&a->ptr.pp_double[offs+i][offs+i+1], 1, &tmp->ptr.p_double[i+1], 1, ae_v_len(offs+i+1,offs+j-1)); 28131 a->ptr.pp_double[offs+i][offs+j] = v+a->ptr.pp_double[offs+i][offs+i]*tmp->ptr.p_double[i]; 28135 a->ptr.pp_double[offs+i][offs+j] = v+tmp->ptr.p_double[i]; 28138 ae_v_muld(&a->ptr.pp_double[offs+0][offs+j], a->stride, ae_v_len(offs+0,offs+j-1), ajj); 28146 * Compute inverse of lower triangular matrix. 28148 for(j=n-1; j>=0; j--) 28152 if( ae_fp_eq(a->ptr.pp_double[offs+j][offs+j],0) ) 28157 a->ptr.pp_double[offs+j][offs+j] = 1/a->ptr.pp_double[offs+j][offs+j]; 28158 ajj = -a->ptr.pp_double[offs+j][offs+j]; 28168 * Compute elements j+1:n of j-th column. 28170 ae_v_move(&tmp->ptr.p_double[j+1], 1, &a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(j+1,n-1)); 28171 for(i=j+1; i<=n-1; i++) 28175 v = ae_v_dotproduct(&a->ptr.pp_double[offs+i][offs+j+1], 1, &tmp->ptr.p_double[j+1], 1, ae_v_len(offs+j+1,offs+i-1)); 28183 a->ptr.pp_double[offs+i][offs+j] = v+a->ptr.pp_double[offs+i][offs+i]*tmp->ptr.p_double[i]; 28187 a->ptr.pp_double[offs+i][offs+j] = v+tmp->ptr.p_double[i]; 28190 ae_v_muld(&a->ptr.pp_double[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+n-1), ajj); 28200 ablassplitlength(a, n, &n1, &n2, _state); 28205 for(i=0; i<=n1-1; i++) 28207 ae_v_muld(&a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1); 28209 rmatrixlefttrsm(n1, n2, a, offs, offs, isupper, isunit, 0, a, offs, offs+n1, _state); 28210 rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs, offs+n1, _state); 28214 for(i=0; i<=n2-1; i++) 28216 ae_v_muld(&a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1); 28218 rmatrixrighttrsm(n2, n1, a, offs, offs, isupper, isunit, 0, a, offs+n1, offs, _state); 28219 rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs+n1, offs, _state); 28221 matinv_rmatrixtrinverserec(a, offs+n1, n2, isupper, isunit, tmp, info, rep, _state); 28223 matinv_rmatrixtrinverserec(a, offs, n1, isupper, isunit, tmp, info, rep, _state); 28227 /************************************************************************* 28228 Triangular matrix inversion, recursive subroutine 28231 05.02.2010, Bochkanov Sergey. 28232 Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 28233 Courant Institute, Argonne National Lab, and Rice University 28235 *************************************************************************/ 28236 static void matinv_cmatrixtrinverserec(/* Complex */ ae_matrix* a, 28241 /* Complex */ ae_vector* tmp, 28263 if( n<=ablascomplexblocksize(a, _state) ) 28269 * Compute inverse of upper triangular matrix. 28271 for(j=0; j<=n-1; j++) 28275 if( ae_c_eq_d(a->ptr.pp_complex[offs+j][offs+j],0) ) 28280 a->ptr.pp_complex[offs+j][offs+j] = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]); 28281 ajj = ae_c_neg(a->ptr.pp_complex[offs+j][offs+j]); 28285 ajj = ae_complex_from_d(-1); 28289 * Compute elements 1:j-1 of j-th column. 28293 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+0][offs+j], a->stride, "N
", ae_v_len(0,j-1)); 28294 for(i=0; i<=j-1; i++) 28298 v = ae_v_cdotproduct(&a->ptr.pp_complex[offs+i][offs+i+1], 1, "N
", &tmp->ptr.p_complex[i+1], 1, "N
", ae_v_len(offs+i+1,offs+j-1)); 28302 v = ae_complex_from_d(0); 28306 a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,ae_c_mul(a->ptr.pp_complex[offs+i][offs+i],tmp->ptr.p_complex[i])); 28310 a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,tmp->ptr.p_complex[i]); 28313 ae_v_cmulc(&a->ptr.pp_complex[offs+0][offs+j], a->stride, ae_v_len(offs+0,offs+j-1), ajj); 28321 * Compute inverse of lower triangular matrix. 28323 for(j=n-1; j>=0; j--) 28327 if( ae_c_eq_d(a->ptr.pp_complex[offs+j][offs+j],0) ) 28332 a->ptr.pp_complex[offs+j][offs+j] = ae_c_d_div(1,a->ptr.pp_complex[offs+j][offs+j]); 28333 ajj = ae_c_neg(a->ptr.pp_complex[offs+j][offs+j]); 28337 ajj = ae_complex_from_d(-1); 28343 * Compute elements j+1:n of j-th column. 28345 ae_v_cmove(&tmp->ptr.p_complex[j+1], 1, &a->ptr.pp_complex[offs+j+1][offs+j], a->stride, "N
", ae_v_len(j+1,n-1)); 28346 for(i=j+1; i<=n-1; i++) 28350 v = ae_v_cdotproduct(&a->ptr.pp_complex[offs+i][offs+j+1], 1, "N
", &tmp->ptr.p_complex[j+1], 1, "N
", ae_v_len(offs+j+1,offs+i-1)); 28354 v = ae_complex_from_d(0); 28358 a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,ae_c_mul(a->ptr.pp_complex[offs+i][offs+i],tmp->ptr.p_complex[i])); 28362 a->ptr.pp_complex[offs+i][offs+j] = ae_c_add(v,tmp->ptr.p_complex[i]); 28365 ae_v_cmulc(&a->ptr.pp_complex[offs+j+1][offs+j], a->stride, ae_v_len(offs+j+1,offs+n-1), ajj); 28375 ablascomplexsplitlength(a, n, &n1, &n2, _state); 28380 for(i=0; i<=n1-1; i++) 28382 ae_v_cmuld(&a->ptr.pp_complex[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1); 28384 cmatrixlefttrsm(n1, n2, a, offs, offs, isupper, isunit, 0, a, offs, offs+n1, _state); 28385 cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs, offs+n1, _state); 28389 for(i=0; i<=n2-1; i++) 28391 ae_v_cmuld(&a->ptr.pp_complex[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1); 28393 cmatrixrighttrsm(n2, n1, a, offs, offs, isupper, isunit, 0, a, offs+n1, offs, _state); 28394 cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, isunit, 0, a, offs+n1, offs, _state); 28396 matinv_cmatrixtrinverserec(a, offs+n1, n2, isupper, isunit, tmp, info, rep, _state); 28398 matinv_cmatrixtrinverserec(a, offs, n1, isupper, isunit, tmp, info, rep, _state); 28402 static void matinv_rmatrixluinverserec(/* Real */ ae_matrix* a, 28405 /* Real */ ae_vector* work, 28426 if( n<=ablasblocksize(a, _state) ) 28432 matinv_rmatrixtrinverserec(a, offs, n, ae_true, ae_false, work, info, rep, _state); 28439 * Solve the equation inv(A)*L = inv(U) for inv(A). 28441 for(j=n-1; j>=0; j--) 28445 * Copy current column of L to WORK and replace with zeros. 28447 for(i=j+1; i<=n-1; i++) 28449 work->ptr.p_double[i] = a->ptr.pp_double[offs+i][offs+j]; 28450 a->ptr.pp_double[offs+i][offs+j] = 0; 28454 * Compute current column of inv(A). 28458 for(i=0; i<=n-1; i++) 28460 v = ae_v_dotproduct(&a->ptr.pp_double[offs+i][offs+j+1], 1, &work->ptr.p_double[j+1], 1, ae_v_len(offs+j+1,offs+n-1)); 28461 a->ptr.pp_double[offs+i][offs+j] = a->ptr.pp_double[offs+i][offs+j]-v; 28471 * ( L1 ) ( U1 U12 ) 28473 * ( L12 L2 ) ( U2 ) 28479 ablassplitlength(a, n, &n1, &n2, _state); 28480 ae_assert(n2>0, "LUInverseRec:
internal error!
", _state); 28483 * X := inv(U1)*U12*inv(U2) 28485 rmatrixlefttrsm(n1, n2, a, offs, offs, ae_true, ae_false, 0, a, offs, offs+n1, _state); 28486 rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs, offs+n1, _state); 28489 * Y := inv(L2)*L12*inv(L1) 28491 rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs+n1, offs, _state); 28492 rmatrixrighttrsm(n2, n1, a, offs, offs, ae_false, ae_true, 0, a, offs+n1, offs, _state); 28495 * W := inv(L1*U1)+X*Y 28497 matinv_rmatrixluinverserec(a, offs, n1, work, info, rep, _state); 28502 rmatrixgemm(n1, n1, n2, 1.0, a, offs, offs+n1, 0, a, offs+n1, offs, 0, 1.0, a, offs, offs, _state); 28508 rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs, offs+n1, _state); 28509 for(i=0; i<=n1-1; i++) 28511 ae_v_muld(&a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1); 28513 rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs+n1, offs, _state); 28514 for(i=0; i<=n2-1; i++) 28516 ae_v_muld(&a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1); 28522 matinv_rmatrixluinverserec(a, offs+n1, n2, work, info, rep, _state); 28526 static void matinv_cmatrixluinverserec(/* Complex */ ae_matrix* a, 28529 /* Complex */ ae_vector* work, 28550 if( n<=ablascomplexblocksize(a, _state) ) 28556 matinv_cmatrixtrinverserec(a, offs, n, ae_true, ae_false, work, info, rep, _state); 28563 * Solve the equation inv(A)*L = inv(U) for inv(A). 28565 for(j=n-1; j>=0; j--) 28569 * Copy current column of L to WORK and replace with zeros. 28571 for(i=j+1; i<=n-1; i++) 28573 work->ptr.p_complex[i] = a->ptr.pp_complex[offs+i][offs+j]; 28574 a->ptr.pp_complex[offs+i][offs+j] = ae_complex_from_d(0); 28578 * Compute current column of inv(A). 28582 for(i=0; i<=n-1; i++) 28584 v = ae_v_cdotproduct(&a->ptr.pp_complex[offs+i][offs+j+1], 1, "N
", &work->ptr.p_complex[j+1], 1, "N
", ae_v_len(offs+j+1,offs+n-1)); 28585 a->ptr.pp_complex[offs+i][offs+j] = ae_c_sub(a->ptr.pp_complex[offs+i][offs+j],v); 28595 * ( L1 ) ( U1 U12 ) 28597 * ( L12 L2 ) ( U2 ) 28603 ablascomplexsplitlength(a, n, &n1, &n2, _state); 28604 ae_assert(n2>0, "LUInverseRec:
internal error!
", _state); 28607 * X := inv(U1)*U12*inv(U2) 28609 cmatrixlefttrsm(n1, n2, a, offs, offs, ae_true, ae_false, 0, a, offs, offs+n1, _state); 28610 cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs, offs+n1, _state); 28613 * Y := inv(L2)*L12*inv(L1) 28615 cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs+n1, offs, _state); 28616 cmatrixrighttrsm(n2, n1, a, offs, offs, ae_false, ae_true, 0, a, offs+n1, offs, _state); 28619 * W := inv(L1*U1)+X*Y 28621 matinv_cmatrixluinverserec(a, offs, n1, work, info, rep, _state); 28626 cmatrixgemm(n1, n1, n2, ae_complex_from_d(1.0), a, offs, offs+n1, 0, a, offs+n1, offs, 0, ae_complex_from_d(1.0), a, offs, offs, _state); 28632 cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, ae_false, ae_true, 0, a, offs, offs+n1, _state); 28633 for(i=0; i<=n1-1; i++) 28635 ae_v_cmuld(&a->ptr.pp_complex[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1); 28637 cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, ae_true, ae_false, 0, a, offs+n1, offs, _state); 28638 for(i=0; i<=n2-1; i++) 28640 ae_v_cmuld(&a->ptr.pp_complex[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1); 28646 matinv_cmatrixluinverserec(a, offs+n1, n2, work, info, rep, _state); 28650 /************************************************************************* 28651 Recursive subroutine for SPD inversion. 28653 -- ALGLIB routine -- 28656 *************************************************************************/ 28657 static void matinv_spdmatrixcholeskyinverserec(/* Real */ ae_matrix* a, 28661 /* Real */ ae_vector* tmp, 28664 ae_frame _frame_block; 28673 ae_frame_make(_state, &_frame_block); 28674 _matinvreport_init(&rep2, _state, ae_true); 28678 ae_frame_leave(_state); 28685 if( n<=ablasblocksize(a, _state) ) 28687 matinv_rmatrixtrinverserec(a, offs, n, isupper, ae_false, tmp, &info2, &rep2, _state); 28692 * Compute the product U * U'. 28693 * NOTE: we never assume that diagonal of U is real 28695 for(i=0; i<=n-1; i++) 28703 a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state); 28709 * (I+1)x(I+1) matrix, 28711 * ( A11 A12 ) ( A11^H ) ( A11*A11^H+A12*A12^H A12*A22^H ) 28713 * ( A22 ) ( A12^H A22^H ) ( A22*A12^H A22*A22^H ) 28715 * A11 is IxI, A22 is 1x1. 28717 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs][offs+i], a->stride, ae_v_len(0,i-1)); 28718 for(j=0; j<=i-1; j++) 28720 v = a->ptr.pp_double[offs+j][offs+i]; 28721 ae_v_addd(&a->ptr.pp_double[offs+j][offs+j], 1, &tmp->ptr.p_double[j], 1, ae_v_len(offs+j,offs+i-1), v); 28723 v = a->ptr.pp_double[offs+i][offs+i]; 28724 ae_v_muld(&a->ptr.pp_double[offs][offs+i], a->stride, ae_v_len(offs,offs+i-1), v); 28725 a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state); 28733 * Compute the product L' * L 28734 * NOTE: we never assume that diagonal of L is real 28736 for(i=0; i<=n-1; i++) 28744 a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state); 28750 * (I+1)x(I+1) matrix, 28752 * ( A11^H A21^H ) ( A11 ) ( A11^H*A11+A21^H*A21 A21^H*A22 ) 28754 * ( A22^H ) ( A21 A22 ) ( A22^H*A21 A22^H*A22 ) 28756 * A11 is IxI, A22 is 1x1. 28758 ae_v_move(&tmp->ptr.p_double[0], 1, &a->ptr.pp_double[offs+i][offs], 1, ae_v_len(0,i-1)); 28759 for(j=0; j<=i-1; j++) 28761 v = a->ptr.pp_double[offs+i][offs+j]; 28762 ae_v_addd(&a->ptr.pp_double[offs+j][offs], 1, &tmp->ptr.p_double[0], 1, ae_v_len(offs,offs+j), v); 28764 v = a->ptr.pp_double[offs+i][offs+i]; 28765 ae_v_muld(&a->ptr.pp_double[offs+i][offs], 1, ae_v_len(offs,offs+i-1), v); 28766 a->ptr.pp_double[offs+i][offs+i] = ae_sqr(a->ptr.pp_double[offs+i][offs+i], _state); 28770 ae_frame_leave(_state); 28775 * Recursive code: triangular factor inversion merged with 28776 * UU' or L'L multiplication 28778 ablassplitlength(a, n, &n1, &n2, _state); 28781 * form off-diagonal block of trangular inverse 28785 for(i=0; i<=n1-1; i++) 28787 ae_v_muld(&a->ptr.pp_double[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1); 28789 rmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 0, a, offs, offs+n1, _state); 28790 rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs, offs+n1, _state); 28794 for(i=0; i<=n2-1; i++) 28796 ae_v_muld(&a->ptr.pp_double[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1); 28798 rmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 0, a, offs+n1, offs, _state); 28799 rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs+n1, offs, _state); 28803 * invert first diagonal block 28805 matinv_spdmatrixcholeskyinverserec(a, offs, n1, isupper, tmp, _state); 28808 * update first diagonal block with off-diagonal block, 28809 * update off-diagonal block 28813 rmatrixsyrk(n1, n2, 1.0, a, offs, offs+n1, 0, 1.0, a, offs, offs, isupper, _state); 28814 rmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 1, a, offs, offs+n1, _state); 28818 rmatrixsyrk(n1, n2, 1.0, a, offs+n1, offs, 1, 1.0, a, offs, offs, isupper, _state); 28819 rmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 1, a, offs+n1, offs, _state); 28823 * invert second diagonal block 28825 matinv_spdmatrixcholeskyinverserec(a, offs+n1, n2, isupper, tmp, _state); 28826 ae_frame_leave(_state); 28830 /************************************************************************* 28831 Recursive subroutine for HPD inversion. 28833 -- ALGLIB routine -- 28836 *************************************************************************/ 28837 static void matinv_hpdmatrixcholeskyinverserec(/* Complex */ ae_matrix* a, 28841 /* Complex */ ae_vector* tmp, 28844 ae_frame _frame_block; 28853 ae_frame_make(_state, &_frame_block); 28854 _matinvreport_init(&rep2, _state, ae_true); 28858 ae_frame_leave(_state); 28865 if( n<=ablascomplexblocksize(a, _state) ) 28867 matinv_cmatrixtrinverserec(a, offs, n, isupper, ae_false, tmp, &info2, &rep2, _state); 28872 * Compute the product U * U'. 28873 * NOTE: we never assume that diagonal of U is real 28875 for(i=0; i<=n-1; i++) 28883 a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state)); 28889 * (I+1)x(I+1) matrix, 28891 * ( A11 A12 ) ( A11^H ) ( A11*A11^H+A12*A12^H A12*A22^H ) 28893 * ( A22 ) ( A12^H A22^H ) ( A22*A12^H A22*A22^H ) 28895 * A11 is IxI, A22 is 1x1. 28897 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs][offs+i], a->stride, "Conj
", ae_v_len(0,i-1)); 28898 for(j=0; j<=i-1; j++) 28900 v = a->ptr.pp_complex[offs+j][offs+i]; 28901 ae_v_caddc(&a->ptr.pp_complex[offs+j][offs+j], 1, &tmp->ptr.p_complex[j], 1, "N
", ae_v_len(offs+j,offs+i-1), v); 28903 v = ae_c_conj(a->ptr.pp_complex[offs+i][offs+i], _state); 28904 ae_v_cmulc(&a->ptr.pp_complex[offs][offs+i], a->stride, ae_v_len(offs,offs+i-1), v); 28905 a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state)); 28913 * Compute the product L' * L 28914 * NOTE: we never assume that diagonal of L is real 28916 for(i=0; i<=n-1; i++) 28924 a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state)); 28930 * (I+1)x(I+1) matrix, 28932 * ( A11^H A21^H ) ( A11 ) ( A11^H*A11+A21^H*A21 A21^H*A22 ) 28934 * ( A22^H ) ( A21 A22 ) ( A22^H*A21 A22^H*A22 ) 28936 * A11 is IxI, A22 is 1x1. 28938 ae_v_cmove(&tmp->ptr.p_complex[0], 1, &a->ptr.pp_complex[offs+i][offs], 1, "N
", ae_v_len(0,i-1)); 28939 for(j=0; j<=i-1; j++) 28941 v = ae_c_conj(a->ptr.pp_complex[offs+i][offs+j], _state); 28942 ae_v_caddc(&a->ptr.pp_complex[offs+j][offs], 1, &tmp->ptr.p_complex[0], 1, "N
", ae_v_len(offs,offs+j), v); 28944 v = ae_c_conj(a->ptr.pp_complex[offs+i][offs+i], _state); 28945 ae_v_cmulc(&a->ptr.pp_complex[offs+i][offs], 1, ae_v_len(offs,offs+i-1), v); 28946 a->ptr.pp_complex[offs+i][offs+i] = ae_complex_from_d(ae_sqr(a->ptr.pp_complex[offs+i][offs+i].x, _state)+ae_sqr(a->ptr.pp_complex[offs+i][offs+i].y, _state)); 28950 ae_frame_leave(_state); 28955 * Recursive code: triangular factor inversion merged with 28956 * UU' or L'L multiplication 28958 ablascomplexsplitlength(a, n, &n1, &n2, _state); 28961 * form off-diagonal block of trangular inverse 28965 for(i=0; i<=n1-1; i++) 28967 ae_v_cmuld(&a->ptr.pp_complex[offs+i][offs+n1], 1, ae_v_len(offs+n1,offs+n-1), -1); 28969 cmatrixlefttrsm(n1, n2, a, offs, offs, isupper, ae_false, 0, a, offs, offs+n1, _state); 28970 cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs, offs+n1, _state); 28974 for(i=0; i<=n2-1; i++) 28976 ae_v_cmuld(&a->ptr.pp_complex[offs+n1+i][offs], 1, ae_v_len(offs,offs+n1-1), -1); 28978 cmatrixrighttrsm(n2, n1, a, offs, offs, isupper, ae_false, 0, a, offs+n1, offs, _state); 28979 cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 0, a, offs+n1, offs, _state); 28983 * invert first diagonal block 28985 matinv_hpdmatrixcholeskyinverserec(a, offs, n1, isupper, tmp, _state); 28988 * update first diagonal block with off-diagonal block, 28989 * update off-diagonal block 28993 cmatrixsyrk(n1, n2, 1.0, a, offs, offs+n1, 0, 1.0, a, offs, offs, isupper, _state); 28994 cmatrixrighttrsm(n1, n2, a, offs+n1, offs+n1, isupper, ae_false, 2, a, offs, offs+n1, _state); 28998 cmatrixsyrk(n1, n2, 1.0, a, offs+n1, offs, 2, 1.0, a, offs, offs, isupper, _state); 28999 cmatrixlefttrsm(n2, n1, a, offs+n1, offs+n1, isupper, ae_false, 2, a, offs+n1, offs, _state); 29003 * invert second diagonal block 29005 matinv_hpdmatrixcholeskyinverserec(a, offs+n1, n2, isupper, tmp, _state); 29006 ae_frame_leave(_state); 29010 ae_bool _matinvreport_init(void* _p, ae_state *_state, ae_bool make_automatic) 29012 matinvreport *p = (matinvreport*)_p; 29013 ae_touch_ptr((void*)p); 29018 ae_bool _matinvreport_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic) 29020 matinvreport *dst = (matinvreport*)_dst; 29021 matinvreport *src = (matinvreport*)_src; 29023 dst->rinf = src->rinf; 29028 void _matinvreport_clear(void* _p) 29030 matinvreport *p = (matinvreport*)_p; 29031 ae_touch_ptr((void*)p); 29035 void _matinvreport_destroy(void* _p) 29037 matinvreport *p = (matinvreport*)_p; 29038 ae_touch_ptr((void*)p); 29044 /************************************************************************* 29045 This function creates sparse matrix in a Hash-Table format. 29047 This function creates Hast-Table matrix, which can be converted to CRS 29048 format after its initialization is over. Typical usage scenario for a 29050 1. creation in a Hash-Table format 29051 2. insertion of the matrix elements 29052 3. conversion to the CRS representation 29053 4. matrix is passed to some linear algebra algorithm 29055 Some information about different matrix formats can be found below, in 29056 the "NOTES
" section. 29059 M - number of rows in a matrix, M>=1 29060 N - number of columns in a matrix, N>=1 29061 K - K>=0, expected number of non-zero elements in a matrix. 29062 K can be inexact approximation, can be less than actual 29063 number of elements (table will grow when needed) or 29065 It is important to understand that although hash-table 29066 may grow automatically, it is better to provide good 29067 estimate of data size. 29070 S - sparse M*N matrix in Hash-Table representation. 29071 All elements of the matrix are zero. 29075 Sparse matrices can be stored using either Hash-Table representation or 29076 Compressed Row Storage representation. Hast-table is better suited for 29077 querying and dynamic operations (thus, it is used for matrix 29078 initialization), but it is inefficient when you want to make some linear 29079 algebra operations. 29081 From the other side, CRS is better suited for linear algebra operations, 29082 but initialization is less convenient - you have to tell row sizes at the 29083 initialization, and you can fill matrix only row by row, from left to 29084 right. CRS is also very inefficient when you want to find matrix element 29087 Thus, Hash-Table representation does not support linear algebra 29088 operations, while CRS format does not support modification of the table. 29089 Tables below outline information about these two formats: 29091 OPERATIONS WITH MATRIX HASH CRS 29095 add value to element + 29096 A*x (dense vector) + 29097 A'*x (dense vector) + 29098 A*X (dense matrix) + 29099 A'*X (dense matrix) + 29103 Hash-tables use memory inefficiently, and they have to keep some amount 29104 of the "spare memory
" in order to have good performance. Hash table for 29105 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes, 29106 where C is a small constant, about 1.5-2 in magnitude. 29108 CRS storage, from the other side, is more memory-efficient, and needs 29109 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows 29112 When you convert from the Hash-Table to CRS representation, all unneeded 29113 memory will be freed. 29115 -- ALGLIB PROJECT -- 29116 Copyright 14.10.2011 by Bochkanov Sergey 29117 *************************************************************************/ 29118 void sparsecreate(ae_int_t m, 29127 _sparsematrix_clear(s); 29129 ae_assert(m>0, "SparseCreate: M<=0
", _state); 29130 ae_assert(n>0, "SparseCreate: N<=0
", _state); 29131 ae_assert(k>=0, "SparseCreate:
K<0
", _state); 29132 sz = ae_round(k/sparse_desiredloadfactor+sparse_additional, _state); 29137 ae_vector_set_length(&s->vals, sz, _state); 29138 ae_vector_set_length(&s->idx, 2*sz, _state); 29139 for(i=0; i<=sz-1; i++) 29141 s->idx.ptr.p_int[2*i] = -1; 29146 /************************************************************************* 29147 This function creates sparse matrix in a CRS format (expert function for 29148 situations when you are running out of memory). 29150 This function creates CRS matrix. Typical usage scenario for a CRS matrix 29152 1. creation (you have to tell number of non-zero elements at each row at 29154 2. insertion of the matrix elements (row by row, from left to right) 29155 3. matrix is passed to some linear algebra algorithm 29157 This function is a memory-efficient alternative to SparseCreate(), but it 29158 is more complex because it requires you to know in advance how large your 29159 matrix is. Some information about different matrix formats can be found 29160 below, in the "NOTES
" section. 29163 M - number of rows in a matrix, M>=1 29164 N - number of columns in a matrix, N>=1 29165 NER - number of elements at each row, array[M], NER[I]>=0 29168 S - sparse M*N matrix in CRS representation. 29169 You have to fill ALL non-zero elements by calling 29170 SparseSet() BEFORE you try to use this matrix. 29174 Sparse matrices can be stored using either Hash-Table representation or 29175 Compressed Row Storage representation. Hast-table is better suited for 29176 querying and dynamic operations (thus, it is used for matrix 29177 initialization), but it is inefficient when you want to make some linear 29178 algebra operations. 29180 From the other side, CRS is better suited for linear algebra operations, 29181 but initialization is less convenient - you have to tell row sizes at the 29182 initialization, and you can fill matrix only row by row, from left to 29183 right. CRS is also very inefficient when you want to find matrix element 29186 Thus, Hash-Table representation does not support linear algebra 29187 operations, while CRS format does not support modification of the table. 29188 Tables below outline information about these two formats: 29190 OPERATIONS WITH MATRIX HASH CRS 29194 add value to element + 29195 A*x (dense vector) + 29196 A'*x (dense vector) + 29197 A*X (dense matrix) + 29198 A'*X (dense matrix) + 29202 Hash-tables use memory inefficiently, and they have to keep some amount 29203 of the "spare memory
" in order to have good performance. Hash table for 29204 matrix with K non-zero elements will need C*K*(8+2*sizeof(int)) bytes, 29205 where C is a small constant, about 1.5-2 in magnitude. 29207 CRS storage, from the other side, is more memory-efficient, and needs 29208 just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a number of rows 29211 When you convert from the Hash-Table to CRS representation, all unneeded 29212 memory will be freed. 29214 -- ALGLIB PROJECT -- 29215 Copyright 14.10.2011 by Bochkanov Sergey 29216 *************************************************************************/ 29217 void sparsecreatecrs(ae_int_t m, 29219 /* Integer */ ae_vector* ner, 29226 _sparsematrix_clear(s); 29228 ae_assert(m>0, "SparseCreateCRS: M<=0
", _state); 29229 ae_assert(n>0, "SparseCreateCRS: N<=0
", _state); 29230 ae_assert(ner->cnt>=m, "SparseCreateCRS: Length(NER)<M
", _state); 29233 s->ninitialized = 0; 29236 ae_vector_set_length(&s->ridx, s->m+1, _state); 29237 s->ridx.ptr.p_int[0] = 0; 29238 for(i=0; i<=s->m-1; i++) 29240 ae_assert(ner->ptr.p_int[i]>=0, "SparseCreateCRS: NER[] contains negative elements
", _state); 29241 noe = noe+ner->ptr.p_int[i]; 29242 s->ridx.ptr.p_int[i+1] = s->ridx.ptr.p_int[i]+ner->ptr.p_int[i]; 29244 ae_vector_set_length(&s->vals, noe, _state); 29245 ae_vector_set_length(&s->idx, noe, _state); 29248 sparse_sparseinitduidx(s, _state); 29253 /************************************************************************* 29254 This function copies S0 to S1. 29256 NOTE: this function does not verify its arguments, it just copies all 29257 fields of the structure. 29259 -- ALGLIB PROJECT -- 29260 Copyright 14.10.2011 by Bochkanov Sergey 29261 *************************************************************************/ 29262 void sparsecopy(sparsematrix* s0, sparsematrix* s1, ae_state *_state) 29267 _sparsematrix_clear(s1); 29269 s1->matrixtype = s0->matrixtype; 29272 s1->nfree = s0->nfree; 29273 s1->ninitialized = s0->ninitialized; 29276 * Initialization for arrays 29279 ae_vector_set_length(&s1->vals, l, _state); 29280 for(i=0; i<=l-1; i++) 29282 s1->vals.ptr.p_double[i] = s0->vals.ptr.p_double[i]; 29285 ae_vector_set_length(&s1->ridx, l, _state); 29286 for(i=0; i<=l-1; i++) 29288 s1->ridx.ptr.p_int[i] = s0->ridx.ptr.p_int[i]; 29291 ae_vector_set_length(&s1->idx, l, _state); 29292 for(i=0; i<=l-1; i++) 29294 s1->idx.ptr.p_int[i] = s0->idx.ptr.p_int[i]; 29298 * Initialization for CRS-parameters 29301 ae_vector_set_length(&s1->uidx, l, _state); 29302 for(i=0; i<=l-1; i++) 29304 s1->uidx.ptr.p_int[i] = s0->uidx.ptr.p_int[i]; 29307 ae_vector_set_length(&s1->didx, l, _state); 29308 for(i=0; i<=l-1; i++) 29310 s1->didx.ptr.p_int[i] = s0->didx.ptr.p_int[i]; 29315 /************************************************************************* 29316 This function adds value to S[i,j] - element of the sparse matrix. Matrix 29317 must be in a Hash-Table mode. 29319 In case S[i,j] already exists in the table, V i added to its value. In 29320 case S[i,j] is non-existent, it is inserted in the table. Table 29321 automatically grows when necessary. 29324 S - sparse M*N matrix in Hash-Table representation. 29325 Exception will be thrown for CRS matrix. 29326 I - row index of the element to modify, 0<=I<M 29327 J - column index of the element to modify, 0<=J<N 29328 V - value to add, must be finite number 29331 S - modified matrix 29333 NOTE 1: when S[i,j] is exactly zero after modification, it is deleted 29336 -- ALGLIB PROJECT -- 29337 Copyright 14.10.2011 by Bochkanov Sergey 29338 *************************************************************************/ 29339 void sparseadd(sparsematrix* s, 29350 ae_assert(s->matrixtype==0, "SparseAdd: matrix must be
in the Hash-Table
mode to
do this operation
", _state); 29351 ae_assert(i>=0, "SparseAdd: I<0
", _state); 29352 ae_assert(i<s->m, "SparseAdd: I>=M
", _state); 29353 ae_assert(j>=0, "SparseAdd: J<0
", _state); 29354 ae_assert(j<s->n, "SparseAdd: J>=N
", _state); 29355 ae_assert(ae_isfinite(v, _state), "SparseAdd: V is not finite number
", _state); 29356 if( ae_fp_eq(v,0) ) 29362 if( ae_fp_greater_eq((1-sparse_maxloadfactor)*k,s->nfree) ) 29364 sparseresizematrix(s, _state); 29367 hashcode = sparse_hash(i, j, k, _state); 29370 if( s->idx.ptr.p_int[2*hashcode]==-1 ) 29376 s->vals.ptr.p_double[hashcode] = v; 29377 s->idx.ptr.p_int[2*hashcode] = i; 29378 s->idx.ptr.p_int[2*hashcode+1] = j; 29381 s->nfree = s->nfree-1; 29387 if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j ) 29389 s->vals.ptr.p_double[hashcode] = s->vals.ptr.p_double[hashcode]+v; 29390 if( ae_fp_eq(s->vals.ptr.p_double[hashcode],0) ) 29392 s->idx.ptr.p_int[2*hashcode] = -2; 29398 * Is it deleted element? 29400 if( tcode==-1&&s->idx.ptr.p_int[2*hashcode]==-2 ) 29408 hashcode = (hashcode+1)%k; 29414 /************************************************************************* 29415 This function modifies S[i,j] - element of the sparse matrix. 29417 For Hash-based storage format: 29418 * new value can be zero or non-zero. In case new value of S[i,j] is zero, 29419 this element is deleted from the table. 29420 * this function has no effect when called with zero V for non-existent 29423 For CRS-bases storage format: 29424 * new value MUST be non-zero. Exception will be thrown for zero V. 29425 * elements must be initialized in correct order - from top row to bottom, 29426 within row - from left to right. 29429 S - sparse M*N matrix in Hash-Table or CRS representation. 29430 I - row index of the element to modify, 0<=I<M 29431 J - column index of the element to modify, 0<=J<N 29432 V - value to set, must be finite number, can be zero 29435 S - modified matrix 29437 -- ALGLIB PROJECT -- 29438 Copyright 14.10.2011 by Bochkanov Sergey 29439 *************************************************************************/ 29440 void sparseset(sparsematrix* s, 29451 ae_assert(i>=0, "SparseSet: I<0
", _state); 29452 ae_assert(i<s->m, "SparseSet: I>=M
", _state); 29453 ae_assert(j>=0, "SparseSet: J<0
", _state); 29454 ae_assert(j<s->n, "SparseSet: J>=N
", _state); 29455 ae_assert(ae_isfinite(v, _state), "SparseSet: V is not finite number
", _state); 29458 * Hash-table matrix 29460 if( s->matrixtype==0 ) 29464 if( ae_fp_greater_eq((1-sparse_maxloadfactor)*k,s->nfree) ) 29466 sparseresizematrix(s, _state); 29469 hashcode = sparse_hash(i, j, k, _state); 29472 if( s->idx.ptr.p_int[2*hashcode]==-1 ) 29474 if( ae_fp_neq(v,0) ) 29480 s->vals.ptr.p_double[hashcode] = v; 29481 s->idx.ptr.p_int[2*hashcode] = i; 29482 s->idx.ptr.p_int[2*hashcode+1] = j; 29485 s->nfree = s->nfree-1; 29492 if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j ) 29494 if( ae_fp_eq(v,0) ) 29496 s->idx.ptr.p_int[2*hashcode] = -2; 29500 s->vals.ptr.p_double[hashcode] = v; 29504 if( tcode==-1&&s->idx.ptr.p_int[2*hashcode]==-2 ) 29512 hashcode = (hashcode+1)%k; 29520 if( s->matrixtype==1 ) 29522 ae_assert(ae_fp_neq(v,0), "SparseSet: CRS format does not allow you to
write zero elements
", _state); 29523 ae_assert(s->ridx.ptr.p_int[i]<=s->ninitialized, "SparseSet: too few initialized elements at some row (you have promised more when called SparceCreateCRS)
", _state); 29524 ae_assert(s->ridx.ptr.p_int[i+1]>s->ninitialized, "SparseSet: too many initialized elements at some row (you have promised less when called SparceCreateCRS)
", _state); 29525 ae_assert(s->ninitialized==s->ridx.ptr.p_int[i]||s->idx.ptr.p_int[s->ninitialized-1]<j, "SparseSet: incorrect column order (you must fill every row from left to right)
", _state); 29526 s->vals.ptr.p_double[s->ninitialized] = v; 29527 s->idx.ptr.p_int[s->ninitialized] = j; 29528 s->ninitialized = s->ninitialized+1; 29531 * If matrix has been created then 29532 * initiale 'S.UIdx' and 'S.DIdx' 29534 if( s->ninitialized==s->ridx.ptr.p_int[s->m] ) 29536 sparse_sparseinitduidx(s, _state); 29542 /************************************************************************* 29543 This function returns S[i,j] - element of the sparse matrix. Matrix can 29544 be in any mode (Hash-Table or CRS), but this function is less efficient 29545 for CRS matrices. Hash-Table matrices can find element in O(1) time, 29546 while CRS matrices need O(log(RS)) time, where RS is an number of non- 29547 zero elements in a row. 29550 S - sparse M*N matrix in Hash-Table representation. 29551 Exception will be thrown for CRS matrix. 29552 I - row index of the element to modify, 0<=I<M 29553 J - column index of the element to modify, 0<=J<N 29556 value of S[I,J] or zero (in case no element with such index is found) 29558 -- ALGLIB PROJECT -- 29559 Copyright 14.10.2011 by Bochkanov Sergey 29560 *************************************************************************/ 29561 double sparseget(sparsematrix* s, 29573 ae_assert(i>=0, "SparseGet: I<0
", _state); 29574 ae_assert(i<s->m, "SparseGet: I>=M
", _state); 29575 ae_assert(j>=0, "SparseGet: J<0
", _state); 29576 ae_assert(j<s->n, "SparseGet: J>=N
", _state); 29579 if( s->matrixtype==0 ) 29581 hashcode = sparse_hash(i, j, k, _state); 29584 if( s->idx.ptr.p_int[2*hashcode]==-1 ) 29588 if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j ) 29590 result = s->vals.ptr.p_double[hashcode]; 29593 hashcode = (hashcode+1)%k; 29596 if( s->matrixtype==1 ) 29598 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseGet: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 29599 k0 = s->ridx.ptr.p_int[i]; 29600 k1 = s->ridx.ptr.p_int[i+1]-1; 29604 if( s->idx.ptr.p_int[k]==j ) 29606 result = s->vals.ptr.p_double[k]; 29609 if( s->idx.ptr.p_int[k]<j ) 29624 /************************************************************************* 29625 This function returns I-th diagonal element of the sparse matrix. 29627 Matrix can be in any mode (Hash-Table or CRS storage), but this function 29628 is most efficient for CRS matrices - it requires less than 50 CPU cycles 29629 to extract diagonal element. For Hash-Table matrices we still have O(1) 29630 query time, but function is many times slower. 29633 S - sparse M*N matrix in Hash-Table representation. 29634 Exception will be thrown for CRS matrix. 29635 I - index of the element to modify, 0<=I<min(M,N) 29638 value of S[I,I] or zero (in case no element with such index is found) 29640 -- ALGLIB PROJECT -- 29641 Copyright 14.10.2011 by Bochkanov Sergey 29642 *************************************************************************/ 29643 double sparsegetdiagonal(sparsematrix* s, ae_int_t i, ae_state *_state) 29648 ae_assert(i>=0, "SparseGetDiagonal: I<0
", _state); 29649 ae_assert(i<s->m, "SparseGetDiagonal: I>=M
", _state); 29650 ae_assert(i<s->n, "SparseGetDiagonal: I>=N
", _state); 29652 if( s->matrixtype==0 ) 29654 result = sparseget(s, i, i, _state); 29657 if( s->matrixtype==1 ) 29659 if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] ) 29661 result = s->vals.ptr.p_double[s->didx.ptr.p_int[i]]; 29669 /************************************************************************* 29670 This function converts matrix to CRS format. 29672 Some algorithms (linear algebra ones, for example) require matrices in 29676 S - sparse M*N matrix in any format 29679 S - matrix in CRS format 29681 NOTE: this function has no effect when called with matrix which is 29682 already in CRS mode. 29684 -- ALGLIB PROJECT -- 29685 Copyright 14.10.2011 by Bochkanov Sergey 29686 *************************************************************************/ 29687 void sparseconverttocrs(sparsematrix* s, ae_state *_state) 29689 ae_frame _frame_block; 29697 ae_frame_make(_state, &_frame_block); 29698 ae_vector_init(&tvals, 0, DT_REAL, _state, ae_true); 29699 ae_vector_init(&tidx, 0, DT_INT, _state, ae_true); 29700 ae_vector_init(&temp, 0, DT_INT, _state, ae_true); 29702 ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseConvertToCRS: invalid matrix
type", _state); 29703 if( s->matrixtype==1 ) 29705 ae_frame_leave(_state); 29711 ae_swap_vectors(&s->vals, &tvals); 29712 ae_swap_vectors(&s->idx, &tidx); 29713 ae_vector_set_length(&s->ridx, s->m+1, _state); 29714 for(i=0; i<=s->m; i++) 29716 s->ridx.ptr.p_int[i] = 0; 29718 ae_vector_set_length(&temp, s->m, _state); 29719 for(i=0; i<=s->m-1; i++) 29721 temp.ptr.p_int[i] = 0; 29725 * Number of elements per row 29727 for(i=0; i<=k-1; i++) 29729 if( tidx.ptr.p_int[2*i]>=0 ) 29731 s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]+1] = s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]+1]+1; 29737 * Fill RIdx (offsets of rows) 29739 for(i=0; i<=s->m-1; i++) 29741 s->ridx.ptr.p_int[i+1] = s->ridx.ptr.p_int[i+1]+s->ridx.ptr.p_int[i]; 29747 ae_vector_set_length(&s->vals, nonne, _state); 29748 ae_vector_set_length(&s->idx, nonne, _state); 29749 for(i=0; i<=k-1; i++) 29751 if( tidx.ptr.p_int[2*i]>=0 ) 29753 s->vals.ptr.p_double[s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]]+temp.ptr.p_int[tidx.ptr.p_int[2*i]]] = tvals.ptr.p_double[i]; 29754 s->idx.ptr.p_int[s->ridx.ptr.p_int[tidx.ptr.p_int[2*i]]+temp.ptr.p_int[tidx.ptr.p_int[2*i]]] = tidx.ptr.p_int[2*i+1]; 29755 temp.ptr.p_int[tidx.ptr.p_int[2*i]] = temp.ptr.p_int[tidx.ptr.p_int[2*i]]+1; 29762 s->ninitialized = s->ridx.ptr.p_int[s->m]; 29765 * Sorting of elements 29767 for(i=0; i<=s->m-1; i++) 29769 tagsortmiddleir(&s->idx, &s->vals, s->ridx.ptr.p_int[i], s->ridx.ptr.p_int[i+1]-s->ridx.ptr.p_int[i], _state); 29773 * Initialization 'S.UIdx' and 'S.DIdx' 29775 sparse_sparseinitduidx(s, _state); 29776 ae_frame_leave(_state); 29780 /************************************************************************* 29781 This function calculates matrix-vector product S*x. Matrix S must be 29782 stored in CRS format (exception will be thrown otherwise). 29785 S - sparse M*N matrix in CRS format (you MUST convert it 29786 to CRS before calling this function). 29787 X - array[N], input vector. For performance reasons we 29788 make only quick checks - we check that array size is 29789 at least N, but we do not check for NAN's or INF's. 29790 Y - output buffer, possibly preallocated. In case buffer 29791 size is too small to store result, this buffer is 29792 automatically resized. 29797 NOTE: this function throws exception when called for non-CRS matrix. You 29798 must convert your matrix with SparseConvertToCRS() before using this 29801 -- ALGLIB PROJECT -- 29802 Copyright 14.10.2011 by Bochkanov Sergey 29803 *************************************************************************/ 29804 void sparsemv(sparsematrix* s, 29805 /* Real */ ae_vector* x, 29806 /* Real */ ae_vector* y, 29816 ae_assert(s->matrixtype==1, "SparseMV: incorrect matrix
type (convert your matrix to CRS)
", _state); 29817 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 29818 ae_assert(x->cnt>=s->n, "SparseMV:
length(X)<N
", _state); 29819 rvectorsetlengthatleast(y, s->m, _state); 29820 for(i=0; i<=s->m-1; i++) 29823 lt = s->ridx.ptr.p_int[i]; 29824 rt = s->ridx.ptr.p_int[i+1]; 29825 for(j=lt; j<=rt-1; j++) 29827 tval = tval+x->ptr.p_double[s->idx.ptr.p_int[j]]*s->vals.ptr.p_double[j]; 29829 y->ptr.p_double[i] = tval; 29834 /************************************************************************* 29835 This function calculates matrix-vector product S^T*x. Matrix S must be 29836 stored in CRS format (exception will be thrown otherwise). 29839 S - sparse M*N matrix in CRS format (you MUST convert it 29840 to CRS before calling this function). 29841 X - array[M], input vector. For performance reasons we 29842 make only quick checks - we check that array size is 29843 at least M, but we do not check for NAN's or INF's. 29844 Y - output buffer, possibly preallocated. In case buffer 29845 size is too small to store result, this buffer is 29846 automatically resized. 29849 Y - array[N], S^T*x 29851 NOTE: this function throws exception when called for non-CRS matrix. You 29852 must convert your matrix with SparseConvertToCRS() before using this 29855 -- ALGLIB PROJECT -- 29856 Copyright 14.10.2011 by Bochkanov Sergey 29857 *************************************************************************/ 29858 void sparsemtv(sparsematrix* s, 29859 /* Real */ ae_vector* x, 29860 /* Real */ ae_vector* y, 29871 ae_assert(s->matrixtype==1, "SparseMTV: incorrect matrix
type (convert your matrix to CRS)
", _state); 29872 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMTV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 29873 ae_assert(x->cnt>=s->m, "SparseMTV: Length(X)<M
", _state); 29874 rvectorsetlengthatleast(y, s->n, _state); 29875 for(i=0; i<=s->n-1; i++) 29877 y->ptr.p_double[i] = 0; 29879 for(i=0; i<=s->m-1; i++) 29881 lt = s->ridx.ptr.p_int[i]; 29882 rt = s->ridx.ptr.p_int[i+1]; 29883 v = x->ptr.p_double[i]; 29884 for(j=lt; j<=rt-1; j++) 29886 ct = s->idx.ptr.p_int[j]; 29887 y->ptr.p_double[ct] = y->ptr.p_double[ct]+v*s->vals.ptr.p_double[j]; 29893 /************************************************************************* 29894 This function simultaneously calculates two matrix-vector products: 29896 S must be square (non-rectangular) matrix stored in CRS format (exception 29897 will be thrown otherwise). 29900 S - sparse N*N matrix in CRS format (you MUST convert it 29901 to CRS before calling this function). 29902 X - array[N], input vector. For performance reasons we 29903 make only quick checks - we check that array size is 29904 at least N, but we do not check for NAN's or INF's. 29905 Y0 - output buffer, possibly preallocated. In case buffer 29906 size is too small to store result, this buffer is 29907 automatically resized. 29908 Y1 - output buffer, possibly preallocated. In case buffer 29909 size is too small to store result, this buffer is 29910 automatically resized. 29914 Y1 - array[N], S^T*x 29916 NOTE: this function throws exception when called for non-CRS matrix. You 29917 must convert your matrix with SparseConvertToCRS() before using this 29918 function. It also throws exception when S is non-square. 29920 -- ALGLIB PROJECT -- 29921 Copyright 14.10.2011 by Bochkanov Sergey 29922 *************************************************************************/ 29923 void sparsemv2(sparsematrix* s, 29924 /* Real */ ae_vector* x, 29925 /* Real */ ae_vector* y0, 29926 /* Real */ ae_vector* y1, 29940 ae_assert(s->matrixtype==1, "SparseMV2: incorrect matrix
type (convert your matrix to CRS)
", _state); 29941 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 29942 ae_assert(s->m==s->n, "SparseMV2: matrix is non-square
", _state); 29944 ae_assert(l>=s->n, "SparseMV2: Length(X)<N
", _state); 29945 rvectorsetlengthatleast(y0, l, _state); 29946 rvectorsetlengthatleast(y1, l, _state); 29947 for(i=0; i<=s->n-1; i++) 29949 y1->ptr.p_double[i] = 0; 29951 for(i=0; i<=s->m-1; i++) 29954 vx = x->ptr.p_double[i]; 29955 j0 = s->ridx.ptr.p_int[i]; 29956 j1 = s->ridx.ptr.p_int[i+1]-1; 29957 for(j=j0; j<=j1; j++) 29959 vi = s->idx.ptr.p_int[j]; 29960 vs = s->vals.ptr.p_double[j]; 29961 tval = tval+x->ptr.p_double[vi]*vs; 29962 y1->ptr.p_double[vi] = y1->ptr.p_double[vi]+vx*vs; 29964 y0->ptr.p_double[i] = tval; 29969 /************************************************************************* 29970 This function calculates matrix-vector product S*x, when S is symmetric 29971 matrix. Matrix S must be stored in CRS format (exception will be 29975 S - sparse M*M matrix in CRS format (you MUST convert it 29976 to CRS before calling this function). 29977 IsUpper - whether upper or lower triangle of S is given: 29978 * if upper triangle is given, only S[i,j] for j>=i 29979 are used, and lower triangle is ignored (it can be 29980 empty - these elements are not referenced at all). 29981 * if lower triangle is given, only S[i,j] for j<=i 29982 are used, and upper triangle is ignored. 29983 X - array[N], input vector. For performance reasons we 29984 make only quick checks - we check that array size is 29985 at least N, but we do not check for NAN's or INF's. 29986 Y - output buffer, possibly preallocated. In case buffer 29987 size is too small to store result, this buffer is 29988 automatically resized. 29993 NOTE: this function throws exception when called for non-CRS matrix. You 29994 must convert your matrix with SparseConvertToCRS() before using this 29997 -- ALGLIB PROJECT -- 29998 Copyright 14.10.2011 by Bochkanov Sergey 29999 *************************************************************************/ 30000 void sparsesmv(sparsematrix* s, 30002 /* Real */ ae_vector* x, 30003 /* Real */ ae_vector* y, 30016 ae_assert(s->matrixtype==1, "SparseSMV: incorrect matrix
type (convert your matrix to CRS)
", _state); 30017 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseSMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30018 ae_assert(x->cnt>=s->n, "SparseSMV:
length(X)<N
", _state); 30019 ae_assert(s->m==s->n, "SparseSMV: non-square matrix
", _state); 30020 rvectorsetlengthatleast(y, s->m, _state); 30021 for(i=0; i<=s->m-1; i++) 30023 y->ptr.p_double[i] = 0; 30025 for(i=0; i<=s->m-1; i++) 30027 if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] ) 30029 y->ptr.p_double[i] = y->ptr.p_double[i]+s->vals.ptr.p_double[s->didx.ptr.p_int[i]]*x->ptr.p_double[s->idx.ptr.p_int[s->didx.ptr.p_int[i]]]; 30033 lt = s->uidx.ptr.p_int[i]; 30034 rt = s->ridx.ptr.p_int[i+1]; 30036 vx = x->ptr.p_double[i]; 30037 for(j=lt; j<=rt-1; j++) 30039 id = s->idx.ptr.p_int[j]; 30040 v = s->vals.ptr.p_double[j]; 30041 vy = vy+x->ptr.p_double[id]*v; 30042 y->ptr.p_double[id] = y->ptr.p_double[id]+vx*v; 30044 y->ptr.p_double[i] = y->ptr.p_double[i]+vy; 30048 lt = s->ridx.ptr.p_int[i]; 30049 rt = s->didx.ptr.p_int[i]; 30051 vx = x->ptr.p_double[i]; 30052 for(j=lt; j<=rt-1; j++) 30054 id = s->idx.ptr.p_int[j]; 30055 v = s->vals.ptr.p_double[j]; 30056 vy = vy+x->ptr.p_double[id]*v; 30057 y->ptr.p_double[id] = y->ptr.p_double[id]+vx*v; 30059 y->ptr.p_double[i] = y->ptr.p_double[i]+vy; 30065 /************************************************************************* 30066 This function calculates matrix-matrix product S*A. Matrix S must be 30067 stored in CRS format (exception will be thrown otherwise). 30070 S - sparse M*N matrix in CRS format (you MUST convert it 30071 to CRS before calling this function). 30072 A - array[N][K], input dense matrix. For performance reasons 30073 we make only quick checks - we check that array size 30074 is at least N, but we do not check for NAN's or INF's. 30075 K - number of columns of matrix (A). 30076 B - output buffer, possibly preallocated. In case buffer 30077 size is too small to store result, this buffer is 30078 automatically resized. 30081 B - array[M][K], S*A 30083 NOTE: this function throws exception when called for non-CRS matrix. You 30084 must convert your matrix with SparseConvertToCRS() before using this 30087 -- ALGLIB PROJECT -- 30088 Copyright 14.10.2011 by Bochkanov Sergey 30089 *************************************************************************/ 30090 void sparsemm(sparsematrix* s, 30091 /* Real */ ae_matrix* a, 30093 /* Real */ ae_matrix* b, 30106 ae_assert(s->matrixtype==1, "SparseMV: incorrect matrix
type (convert your matrix to CRS)
", _state); 30107 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMV: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30108 ae_assert(a->rows>=s->n, "SparseMV: Rows(A)<N
", _state); 30109 ae_assert(k>0, "SparseMV:
K<=0
", _state); 30110 rmatrixsetlengthatleast(b, s->m, k, _state); 30111 if( k<sparse_linalgswitch ) 30113 for(i=0; i<=s->m-1; i++) 30115 for(j=0; j<=k-1; j++) 30118 lt = s->ridx.ptr.p_int[i]; 30119 rt = s->ridx.ptr.p_int[i+1]; 30120 for(k0=lt; k0<=rt-1; k0++) 30122 tval = tval+s->vals.ptr.p_double[k0]*a->ptr.pp_double[s->idx.ptr.p_int[k0]][j]; 30124 b->ptr.pp_double[i][j] = tval; 30130 for(i=0; i<=s->m-1; i++) 30132 for(j=0; j<=k-1; j++) 30134 b->ptr.pp_double[i][j] = 0; 30137 for(i=0; i<=s->m-1; i++) 30139 lt = s->ridx.ptr.p_int[i]; 30140 rt = s->ridx.ptr.p_int[i+1]; 30141 for(j=lt; j<=rt-1; j++) 30143 id = s->idx.ptr.p_int[j]; 30144 v = s->vals.ptr.p_double[j]; 30145 ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[id][0], 1, ae_v_len(0,k-1), v); 30152 /************************************************************************* 30153 This function calculates matrix-matrix product S^T*A. Matrix S must be 30154 stored in CRS format (exception will be thrown otherwise). 30157 S - sparse M*N matrix in CRS format (you MUST convert it 30158 to CRS before calling this function). 30159 A - array[M][K], input dense matrix. For performance reasons 30160 we make only quick checks - we check that array size is 30161 at least M, but we do not check for NAN's or INF's. 30162 K - number of columns of matrix (A). 30163 B - output buffer, possibly preallocated. In case buffer 30164 size is too small to store result, this buffer is 30165 automatically resized. 30168 B - array[N][K], S^T*A 30170 NOTE: this function throws exception when called for non-CRS matrix. You 30171 must convert your matrix with SparseConvertToCRS() before using this 30174 -- ALGLIB PROJECT -- 30175 Copyright 14.10.2011 by Bochkanov Sergey 30176 *************************************************************************/ 30177 void sparsemtm(sparsematrix* s, 30178 /* Real */ ae_matrix* a, 30180 /* Real */ ae_matrix* b, 30192 ae_assert(s->matrixtype==1, "SparseMTM: incorrect matrix
type (convert your matrix to CRS)
", _state); 30193 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMTM: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30194 ae_assert(a->rows>=s->m, "SparseMTM: Rows(A)<M
", _state); 30195 ae_assert(k>0, "SparseMTM:
K<=0
", _state); 30196 rmatrixsetlengthatleast(b, s->n, k, _state); 30197 for(i=0; i<=s->n-1; i++) 30199 for(j=0; j<=k-1; j++) 30201 b->ptr.pp_double[i][j] = 0; 30204 if( k<sparse_linalgswitch ) 30206 for(i=0; i<=s->m-1; i++) 30208 lt = s->ridx.ptr.p_int[i]; 30209 rt = s->ridx.ptr.p_int[i+1]; 30210 for(k0=lt; k0<=rt-1; k0++) 30212 v = s->vals.ptr.p_double[k0]; 30213 ct = s->idx.ptr.p_int[k0]; 30214 for(j=0; j<=k-1; j++) 30216 b->ptr.pp_double[ct][j] = b->ptr.pp_double[ct][j]+v*a->ptr.pp_double[i][j]; 30223 for(i=0; i<=s->m-1; i++) 30225 lt = s->ridx.ptr.p_int[i]; 30226 rt = s->ridx.ptr.p_int[i+1]; 30227 for(j=lt; j<=rt-1; j++) 30229 v = s->vals.ptr.p_double[j]; 30230 ct = s->idx.ptr.p_int[j]; 30231 ae_v_addd(&b->ptr.pp_double[ct][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v); 30238 /************************************************************************* 30239 This function simultaneously calculates two matrix-matrix products: 30241 S must be square (non-rectangular) matrix stored in CRS format (exception 30242 will be thrown otherwise). 30245 S - sparse N*N matrix in CRS format (you MUST convert it 30246 to CRS before calling this function). 30247 A - array[N][K], input dense matrix. For performance reasons 30248 we make only quick checks - we check that array size is 30249 at least N, but we do not check for NAN's or INF's. 30250 K - number of columns of matrix (A). 30251 B0 - output buffer, possibly preallocated. In case buffer 30252 size is too small to store result, this buffer is 30253 automatically resized. 30254 B1 - output buffer, possibly preallocated. In case buffer 30255 size is too small to store result, this buffer is 30256 automatically resized. 30259 B0 - array[N][K], S*A 30260 B1 - array[N][K], S^T*A 30262 NOTE: this function throws exception when called for non-CRS matrix. You 30263 must convert your matrix with SparseConvertToCRS() before using this 30264 function. It also throws exception when S is non-square. 30266 -- ALGLIB PROJECT -- 30267 Copyright 14.10.2011 by Bochkanov Sergey 30268 *************************************************************************/ 30269 void sparsemm2(sparsematrix* s, 30270 /* Real */ ae_matrix* a, 30272 /* Real */ ae_matrix* b0, 30273 /* Real */ ae_matrix* b1, 30286 ae_assert(s->matrixtype==1, "SparseMM2: incorrect matrix
type (convert your matrix to CRS)
", _state); 30287 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseMM2: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30288 ae_assert(s->m==s->n, "SparseMM2: matrix is non-square
", _state); 30289 ae_assert(a->rows>=s->n, "SparseMM2: Rows(A)<N
", _state); 30290 ae_assert(k>0, "SparseMM2:
K<=0
", _state); 30291 rmatrixsetlengthatleast(b0, s->m, k, _state); 30292 rmatrixsetlengthatleast(b1, s->n, k, _state); 30293 for(i=0; i<=s->n-1; i++) 30295 for(j=0; j<=k-1; j++) 30297 b1->ptr.pp_double[i][j] = 0; 30300 if( k<sparse_linalgswitch ) 30302 for(i=0; i<=s->m-1; i++) 30304 for(j=0; j<=k-1; j++) 30307 lt = s->ridx.ptr.p_int[i]; 30308 rt = s->ridx.ptr.p_int[i+1]; 30309 v = a->ptr.pp_double[i][j]; 30310 for(k0=lt; k0<=rt-1; k0++) 30312 ct = s->idx.ptr.p_int[k0]; 30313 b1->ptr.pp_double[ct][j] = b1->ptr.pp_double[ct][j]+s->vals.ptr.p_double[k0]*v; 30314 tval = tval+s->vals.ptr.p_double[k0]*a->ptr.pp_double[ct][j]; 30316 b0->ptr.pp_double[i][j] = tval; 30322 for(i=0; i<=s->m-1; i++) 30324 for(j=0; j<=k-1; j++) 30326 b0->ptr.pp_double[i][j] = 0; 30329 for(i=0; i<=s->m-1; i++) 30331 lt = s->ridx.ptr.p_int[i]; 30332 rt = s->ridx.ptr.p_int[i+1]; 30333 for(j=lt; j<=rt-1; j++) 30335 v = s->vals.ptr.p_double[j]; 30336 ct = s->idx.ptr.p_int[j]; 30337 ae_v_addd(&b0->ptr.pp_double[i][0], 1, &a->ptr.pp_double[ct][0], 1, ae_v_len(0,k-1), v); 30338 ae_v_addd(&b1->ptr.pp_double[ct][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v); 30345 /************************************************************************* 30346 This function calculates matrix-matrix product S*A, when S is symmetric 30347 matrix. Matrix S must be stored in CRS format (exception will be 30351 S - sparse M*M matrix in CRS format (you MUST convert it 30352 to CRS before calling this function). 30353 IsUpper - whether upper or lower triangle of S is given: 30354 * if upper triangle is given, only S[i,j] for j>=i 30355 are used, and lower triangle is ignored (it can be 30356 empty - these elements are not referenced at all). 30357 * if lower triangle is given, only S[i,j] for j<=i 30358 are used, and upper triangle is ignored. 30359 A - array[N][K], input dense matrix. For performance reasons 30360 we make only quick checks - we check that array size is 30361 at least N, but we do not check for NAN's or INF's. 30362 K - number of columns of matrix (A). 30363 B - output buffer, possibly preallocated. In case buffer 30364 size is too small to store result, this buffer is 30365 automatically resized. 30368 B - array[M][K], S*A 30370 NOTE: this function throws exception when called for non-CRS matrix. You 30371 must convert your matrix with SparseConvertToCRS() before using this 30374 -- ALGLIB PROJECT -- 30375 Copyright 14.10.2011 by Bochkanov Sergey 30376 *************************************************************************/ 30377 void sparsesmm(sparsematrix* s, 30379 /* Real */ ae_matrix* a, 30381 /* Real */ ae_matrix* b, 30395 ae_assert(s->matrixtype==1, "SparseSMM: incorrect matrix
type (convert your matrix to CRS)
", _state); 30396 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseSMM: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30397 ae_assert(a->rows>=s->n, "SparseSMM: Rows(X)<N
", _state); 30398 ae_assert(s->m==s->n, "SparseSMM: matrix is non-square
", _state); 30399 rmatrixsetlengthatleast(b, s->m, k, _state); 30400 for(i=0; i<=s->m-1; i++) 30402 for(j=0; j<=k-1; j++) 30404 b->ptr.pp_double[i][j] = 0; 30407 if( k>sparse_linalgswitch ) 30409 for(i=0; i<=s->m-1; i++) 30411 for(j=0; j<=k-1; j++) 30413 if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] ) 30415 id = s->didx.ptr.p_int[i]; 30416 b->ptr.pp_double[i][j] = b->ptr.pp_double[i][j]+s->vals.ptr.p_double[id]*a->ptr.pp_double[s->idx.ptr.p_int[id]][j]; 30420 lt = s->uidx.ptr.p_int[i]; 30421 rt = s->ridx.ptr.p_int[i+1]; 30423 va = a->ptr.pp_double[i][j]; 30424 for(k0=lt; k0<=rt-1; k0++) 30426 id = s->idx.ptr.p_int[k0]; 30427 v = s->vals.ptr.p_double[k0]; 30428 vb = vb+a->ptr.pp_double[id][j]*v; 30429 b->ptr.pp_double[id][j] = b->ptr.pp_double[id][j]+va*v; 30431 b->ptr.pp_double[i][j] = b->ptr.pp_double[i][j]+vb; 30435 lt = s->ridx.ptr.p_int[i]; 30436 rt = s->didx.ptr.p_int[i]; 30438 va = a->ptr.pp_double[i][j]; 30439 for(k0=lt; k0<=rt-1; k0++) 30441 id = s->idx.ptr.p_int[k0]; 30442 v = s->vals.ptr.p_double[k0]; 30443 vb = vb+a->ptr.pp_double[id][j]*v; 30444 b->ptr.pp_double[id][j] = b->ptr.pp_double[id][j]+va*v; 30446 b->ptr.pp_double[i][j] = b->ptr.pp_double[i][j]+vb; 30453 for(i=0; i<=s->m-1; i++) 30455 if( s->didx.ptr.p_int[i]!=s->uidx.ptr.p_int[i] ) 30457 id = s->didx.ptr.p_int[i]; 30458 v = s->vals.ptr.p_double[id]; 30459 ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[s->idx.ptr.p_int[id]][0], 1, ae_v_len(0,k-1), v); 30463 lt = s->uidx.ptr.p_int[i]; 30464 rt = s->ridx.ptr.p_int[i+1]; 30465 for(j=lt; j<=rt-1; j++) 30467 id = s->idx.ptr.p_int[j]; 30468 v = s->vals.ptr.p_double[j]; 30469 ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[id][0], 1, ae_v_len(0,k-1), v); 30470 ae_v_addd(&b->ptr.pp_double[id][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v); 30475 lt = s->ridx.ptr.p_int[i]; 30476 rt = s->didx.ptr.p_int[i]; 30477 for(j=lt; j<=rt-1; j++) 30479 id = s->idx.ptr.p_int[j]; 30480 v = s->vals.ptr.p_double[j]; 30481 ae_v_addd(&b->ptr.pp_double[i][0], 1, &a->ptr.pp_double[id][0], 1, ae_v_len(0,k-1), v); 30482 ae_v_addd(&b->ptr.pp_double[id][0], 1, &a->ptr.pp_double[i][0], 1, ae_v_len(0,k-1), v); 30490 /************************************************************************* 30491 This procedure resizes Hash-Table matrix. It can be called when you have 30492 deleted too many elements from the matrix, and you want to free unneeded 30495 -- ALGLIB PROJECT -- 30496 Copyright 14.10.2011 by Bochkanov Sergey 30497 *************************************************************************/ 30498 void sparseresizematrix(sparsematrix* s, ae_state *_state) 30500 ae_frame _frame_block; 30507 ae_frame_make(_state, &_frame_block); 30508 ae_vector_init(&tvals, 0, DT_REAL, _state, ae_true); 30509 ae_vector_init(&tidx, 0, DT_INT, _state, ae_true); 30511 ae_assert(s->matrixtype==0, "SparseResizeMatrix: incorrect matrix
type", _state); 30514 * Initialization for length and number of non-null elementd 30520 * Calculating number of non-null elements 30522 for(i=0; i<=k-1; i++) 30524 if( s->idx.ptr.p_int[2*i]>=0 ) 30531 * Initialization value for free space 30533 s->nfree = ae_round(k1/sparse_desiredloadfactor*sparse_growfactor+sparse_additional, _state)-k1; 30534 ae_vector_set_length(&tvals, s->nfree+k1, _state); 30535 ae_vector_set_length(&tidx, 2*(s->nfree+k1), _state); 30536 ae_swap_vectors(&s->vals, &tvals); 30537 ae_swap_vectors(&s->idx, &tidx); 30538 for(i=0; i<=s->nfree+k1-1; i++) 30540 s->idx.ptr.p_int[2*i] = -1; 30542 for(i=0; i<=k-1; i++) 30544 if( tidx.ptr.p_int[2*i]>=0 ) 30546 sparseset(s, tidx.ptr.p_int[2*i], tidx.ptr.p_int[2*i+1], tvals.ptr.p_double[i], _state); 30549 ae_frame_leave(_state); 30553 /************************************************************************* 30554 This function return average length of chain at hash-table. 30556 -- ALGLIB PROJECT -- 30557 Copyright 14.10.2011 by Bochkanov Sergey 30558 *************************************************************************/ 30559 double sparsegetaveragelengthofchain(sparsematrix* s, ae_state *_state) 30573 * If matrix represent in CRS then return zero and exit 30575 if( s->matrixtype==1 ) 30583 for(i=0; i<=l-1; i++) 30586 if( s->idx.ptr.p_int[ind0]!=-1 ) 30588 nchains = nchains+1; 30589 hashcode = sparse_hash(s->idx.ptr.p_int[ind0], s->idx.ptr.p_int[ind0+1], l, _state); 30594 if( s->idx.ptr.p_int[ind0]==s->idx.ptr.p_int[ind1]&&s->idx.ptr.p_int[ind0+1]==s->idx.ptr.p_int[ind1+1] ) 30598 hashcode = (hashcode+1)%l; 30608 result = (double)talc/(double)nchains; 30614 /************************************************************************* 30615 This function is used to enumerate all elements of the sparse matrix. 30616 Before first call user initializes T0 and T1 counters by zero. These 30617 counters are used to remember current position in a matrix; after each 30618 call they are updated by the function. 30620 Subsequent calls to this function return non-zero elements of the sparse 30621 matrix, one by one. If you enumerate CRS matrix, matrix is traversed from 30622 left to right, from top to bottom. In case you enumerate matrix stored as 30623 Hash table, elements are returned in random order. 30628 > while SparseEnumerate(S,T0,T1,I,J,V) do 30629 > ....do something with I,J,V 30632 S - sparse M*N matrix in Hash-Table or CRS representation. 30633 T0 - internal counter 30634 T1 - internal counter 30637 T0 - new value of the internal counter 30638 T1 - new value of the internal counter 30639 I - row index of non-zero element, 0<=I<M. 30640 J - column index of non-zero element, 0<=J<N 30641 V - value of the T-th element 30644 True in case of success (next non-zero element was retrieved) 30645 False in case all non-zero elements were enumerated 30647 -- ALGLIB PROJECT -- 30648 Copyright 14.03.2012 by Bochkanov Sergey 30649 *************************************************************************/ 30650 ae_bool sparseenumerate(sparsematrix* s, 30666 if( *t0<0||(s->matrixtype==1&&*t1<0) ) 30673 * Hash-table matrix 30675 if( s->matrixtype==0 ) 30678 for(i0=*t0; i0<=sz-1; i0++) 30680 if( s->idx.ptr.p_int[2*i0]==-1||s->idx.ptr.p_int[2*i0]==-2 ) 30686 *i = s->idx.ptr.p_int[2*i0]; 30687 *j = s->idx.ptr.p_int[2*i0+1]; 30688 *v = s->vals.ptr.p_double[i0]; 30702 if( s->matrixtype==1&&*t0<s->ninitialized ) 30704 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseEnumerate: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30705 while(*t0>s->ridx.ptr.p_int[*t1+1]-1&&*t1<s->m) 30710 *j = s->idx.ptr.p_int[*t0]; 30711 *v = s->vals.ptr.p_double[*t0]; 30723 /************************************************************************* 30724 This function rewrites existing (non-zero) element. It returns True if 30725 element exists or False, when it is called for non-existing (zero) 30728 The purpose of this function is to provide convenient thread-safe way to 30729 modify sparse matrix. Such modification (already existing element is 30730 rewritten) is guaranteed to be thread-safe without any synchronization, as 30731 long as different threads modify different elements. 30734 S - sparse M*N matrix in Hash-Table or CRS representation. 30735 I - row index of non-zero element to modify, 0<=I<M 30736 J - column index of non-zero element to modify, 0<=J<N 30737 V - value to rewrite, must be finite number 30740 S - modified matrix 30742 True in case when element exists 30743 False in case when element doesn't exist or it is zero 30745 -- ALGLIB PROJECT -- 30746 Copyright 14.03.2012 by Bochkanov Sergey 30747 *************************************************************************/ 30748 ae_bool sparserewriteexisting(sparsematrix* s, 30761 ae_assert(0<=i&&i<s->m, "SparseRewriteExisting: invalid argument I(either I<0 or I>=S.M)
", _state); 30762 ae_assert(0<=j&&j<s->n, "SparseRewriteExisting: invalid argument J(either J<0 or J>=S.N)
", _state); 30763 ae_assert(ae_isfinite(v, _state), "SparseRewriteExisting: invalid argument V(either V is infinite
or V is NaN)
", _state); 30767 * Hash-table matrix 30769 if( s->matrixtype==0 ) 30772 hashcode = sparse_hash(i, j, k, _state); 30775 if( s->idx.ptr.p_int[2*hashcode]==-1 ) 30779 if( s->idx.ptr.p_int[2*hashcode]==i&&s->idx.ptr.p_int[2*hashcode+1]==j ) 30781 s->vals.ptr.p_double[hashcode] = v; 30785 hashcode = (hashcode+1)%k; 30792 if( s->matrixtype==1 ) 30794 ae_assert(s->ninitialized==s->ridx.ptr.p_int[s->m], "SparseRewriteExisting: some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)
", _state); 30795 k0 = s->ridx.ptr.p_int[i]; 30796 k1 = s->ridx.ptr.p_int[i+1]-1; 30800 if( s->idx.ptr.p_int[k]==j ) 30802 s->vals.ptr.p_double[k] = v; 30806 if( s->idx.ptr.p_int[k]<j ) 30820 /************************************************************************* 30821 This function returns I-th row of the sparse matrix stored in CRS format. 30823 NOTE: when incorrect I (outside of [0,M-1]) or matrix (non-CRS) are 30824 passed, this function throws exception. 30827 S - sparse M*N matrix in CRS format 30828 I - row index, 0<=I<M 30829 IRow - output buffer, can be preallocated. In case buffer 30830 size is too small to store I-th row, it is 30831 automatically reallocated. 30834 IRow - array[M], I-th row. 30837 -- ALGLIB PROJECT -- 30838 Copyright 20.07.2012 by Bochkanov Sergey 30839 *************************************************************************/ 30840 void sparsegetrow(sparsematrix* s, 30842 /* Real */ ae_vector* irow, 30848 ae_assert(s->matrixtype==1, "SparseGetRow: S must be CRS-based matrix
", _state); 30849 ae_assert(i>=0&&i<s->m, "SparseGetRow: I<0 or I>=M
", _state); 30850 rvectorsetlengthatleast(irow, s->n, _state); 30851 for(i0=0; i0<=s->n-1; i0++) 30853 irow->ptr.p_double[i0] = 0; 30855 for(i0=s->ridx.ptr.p_int[i]; i0<=s->ridx.ptr.p_int[i+1]-1; i0++) 30857 irow->ptr.p_double[s->idx.ptr.p_int[i0]] = s->vals.ptr.p_double[i0]; 30862 /************************************************************************* 30863 This function performs in-place conversion from CRS format to Hash table 30867 S - sparse matrix in CRS format. 30870 S - sparse matrix in Hash table format. 30872 NOTE: this function has no effect when called with matrix which is 30873 already in Hash table mode. 30875 -- ALGLIB PROJECT -- 30876 Copyright 20.07.2012 by Bochkanov Sergey 30877 *************************************************************************/ 30878 void sparseconverttohash(sparsematrix* s, ae_state *_state) 30880 ae_frame _frame_block; 30889 ae_frame_make(_state, &_frame_block); 30890 ae_vector_init(&tidx, 0, DT_INT, _state, ae_true); 30891 ae_vector_init(&tridx, 0, DT_INT, _state, ae_true); 30892 ae_vector_init(&tvals, 0, DT_REAL, _state, ae_true); 30894 ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseConvertToHash: invalid matrix
type", _state); 30895 if( s->matrixtype==0 ) 30897 ae_frame_leave(_state); 30903 ae_swap_vectors(&s->idx, &tidx); 30904 ae_swap_vectors(&s->ridx, &tridx); 30905 ae_swap_vectors(&s->vals, &tvals); 30910 ae_vector_set_length(&s->ridx, 0, _state); 30911 sparsecreate(tm, tn, tridx.ptr.p_int[tm], s, _state); 30916 for(i=0; i<=tm-1; i++) 30918 for(j=tridx.ptr.p_int[i]; j<=tridx.ptr.p_int[i+1]-1; j++) 30920 sparseset(s, i, tidx.ptr.p_int[j], tvals.ptr.p_double[j], _state); 30923 ae_frame_leave(_state); 30927 /************************************************************************* 30928 This function performs out-of-place conversion to Hash table storage 30929 format. S0 is copied to S1 and converted on-the-fly. 30932 S0 - sparse matrix in any format. 30935 S1 - sparse matrix in Hash table format. 30937 NOTE: if S0 is stored as Hash-table, it is just copied without conversion. 30939 -- ALGLIB PROJECT -- 30940 Copyright 20.07.2012 by Bochkanov Sergey 30941 *************************************************************************/ 30942 void sparsecopytohash(sparsematrix* s0, 30952 _sparsematrix_clear(s1); 30954 ae_assert(s0->matrixtype==0||s0->matrixtype==1, "SparseCopyToHash: invalid matrix
type", _state); 30955 if( s0->matrixtype==0 ) 30957 sparsecopy(s0, s1, _state); 30963 sparsecreate(s0->m, s0->n, s0->ridx.ptr.p_int[s0->m], s1, _state); 30964 while(sparseenumerate(s0, &t0, &t1, &i, &j, &val, _state)) 30966 sparseset(s1, i, j, val, _state); 30972 /************************************************************************* 30973 This function performs out-of-place conversion to CRS format. S0 is 30974 copied to S1 and converted on-the-fly. 30977 S0 - sparse matrix in any format. 30980 S1 - sparse matrix in CRS format. 30982 NOTE: if S0 is stored as CRS, it is just copied without conversion. 30984 -- ALGLIB PROJECT -- 30985 Copyright 20.07.2012 by Bochkanov Sergey 30986 *************************************************************************/ 30987 void sparsecopytocrs(sparsematrix* s0, sparsematrix* s1, ae_state *_state) 30989 ae_frame _frame_block; 30995 ae_frame_make(_state, &_frame_block); 30996 _sparsematrix_clear(s1); 30997 ae_vector_init(&temp, 0, DT_INT, _state, ae_true); 30999 ae_assert(s0->matrixtype==0||s0->matrixtype==1, "SparseCopyToCRS: invalid matrix
type", _state); 31000 if( s0->matrixtype==1 ) 31002 sparsecopy(s0, s1, _state); 31008 * Done like ConvertToCRS function 31010 s1->matrixtype = 1; 31013 s1->nfree = s0->nfree; 31016 ae_vector_set_length(&s1->ridx, s1->m+1, _state); 31017 for(i=0; i<=s1->m; i++) 31019 s1->ridx.ptr.p_int[i] = 0; 31021 ae_vector_set_length(&temp, s1->m, _state); 31022 for(i=0; i<=s1->m-1; i++) 31024 temp.ptr.p_int[i] = 0; 31028 * Number of elements per row 31030 for(i=0; i<=k-1; i++) 31032 if( s0->idx.ptr.p_int[2*i]>=0 ) 31034 s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]+1] = s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]+1]+1; 31040 * Fill RIdx (offsets of rows) 31042 for(i=0; i<=s1->m-1; i++) 31044 s1->ridx.ptr.p_int[i+1] = s1->ridx.ptr.p_int[i+1]+s1->ridx.ptr.p_int[i]; 31050 ae_vector_set_length(&s1->vals, nonne, _state); 31051 ae_vector_set_length(&s1->idx, nonne, _state); 31052 for(i=0; i<=k-1; i++) 31054 if( s0->idx.ptr.p_int[2*i]>=0 ) 31056 s1->vals.ptr.p_double[s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]]+temp.ptr.p_int[s0->idx.ptr.p_int[2*i]]] = s0->vals.ptr.p_double[i]; 31057 s1->idx.ptr.p_int[s1->ridx.ptr.p_int[s0->idx.ptr.p_int[2*i]]+temp.ptr.p_int[s0->idx.ptr.p_int[2*i]]] = s0->idx.ptr.p_int[2*i+1]; 31058 temp.ptr.p_int[s0->idx.ptr.p_int[2*i]] = temp.ptr.p_int[s0->idx.ptr.p_int[2*i]]+1; 31065 s1->ninitialized = s1->ridx.ptr.p_int[s1->m]; 31068 * Sorting of elements 31070 for(i=0; i<=s1->m-1; i++) 31072 tagsortmiddleir(&s1->idx, &s1->vals, s1->ridx.ptr.p_int[i], s1->ridx.ptr.p_int[i+1]-s1->ridx.ptr.p_int[i], _state); 31076 * Initialization 'S.UIdx' and 'S.DIdx' 31078 sparse_sparseinitduidx(s1, _state); 31080 ae_frame_leave(_state); 31084 /************************************************************************* 31085 This function returns type of the matrix storage format. 31091 sparse storage format used by matrix: 31095 NOTE: future versions of ALGLIB may include additional sparse storage 31099 -- ALGLIB PROJECT -- 31100 Copyright 20.07.2012 by Bochkanov Sergey 31101 *************************************************************************/ 31102 ae_int_t sparsegetmatrixtype(sparsematrix* s, ae_state *_state) 31107 ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseGetMatrixType: invalid matrix
type", _state); 31108 result = s->matrixtype; 31113 /************************************************************************* 31114 This function checks matrix storage format and returns True when matrix is 31115 stored using Hash table representation. 31121 True if matrix type is Hash table 31122 False if matrix type is not Hash table 31124 -- ALGLIB PROJECT -- 31125 Copyright 20.07.2012 by Bochkanov Sergey 31126 *************************************************************************/ 31127 ae_bool sparseishash(sparsematrix* s, ae_state *_state) 31132 ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseIsHash: invalid matrix
type", _state); 31133 result = s->matrixtype==0; 31138 /************************************************************************* 31139 This function checks matrix storage format and returns True when matrix is 31140 stored using CRS representation. 31146 True if matrix type is CRS 31147 False if matrix type is not CRS 31149 -- ALGLIB PROJECT -- 31150 Copyright 20.07.2012 by Bochkanov Sergey 31151 *************************************************************************/ 31152 ae_bool sparseiscrs(sparsematrix* s, ae_state *_state) 31157 ae_assert(s->matrixtype==0||s->matrixtype==1, "SparseIsCRS: invalid matrix
type", _state); 31158 result = s->matrixtype==1; 31163 /************************************************************************* 31164 The function frees all memory occupied by sparse matrix. Sparse matrix 31165 structure becomes unusable after this call. 31168 S - sparse matrix to delete 31170 -- ALGLIB PROJECT -- 31171 Copyright 24.07.2012 by Bochkanov Sergey 31172 *************************************************************************/ 31173 void sparsefree(sparsematrix* s, ae_state *_state) 31176 _sparsematrix_clear(s); 31178 s->matrixtype = -1; 31182 s->ninitialized = 0; 31186 /************************************************************************* 31187 The function returns number of rows of a sparse matrix. 31189 RESULT: number of rows of a sparse matrix. 31191 -- ALGLIB PROJECT -- 31192 Copyright 23.08.2012 by Bochkanov Sergey 31193 *************************************************************************/ 31194 ae_int_t sparsegetnrows(sparsematrix* s, ae_state *_state) 31204 /************************************************************************* 31205 The function returns number of columns of a sparse matrix. 31207 RESULT: number of columns of a sparse matrix. 31209 -- ALGLIB PROJECT -- 31210 Copyright 23.08.2012 by Bochkanov Sergey 31211 *************************************************************************/ 31212 ae_int_t sparsegetncols(sparsematrix* s, ae_state *_state) 31222 /************************************************************************* 31223 Procedure for initialization 'S.DIdx' and 'S.UIdx' 31226 -- ALGLIB PROJECT -- 31227 Copyright 14.10.2011 by Bochkanov Sergey 31228 *************************************************************************/ 31229 static void sparse_sparseinitduidx(sparsematrix* s, ae_state *_state) 31237 ae_vector_set_length(&s->didx, s->m, _state); 31238 ae_vector_set_length(&s->uidx, s->m, _state); 31239 for(i=0; i<=s->m-1; i++) 31241 s->uidx.ptr.p_int[i] = -1; 31242 s->didx.ptr.p_int[i] = -1; 31243 lt = s->ridx.ptr.p_int[i]; 31244 rt = s->ridx.ptr.p_int[i+1]; 31245 for(j=lt; j<=rt-1; j++) 31247 if( i<s->idx.ptr.p_int[j]&&s->uidx.ptr.p_int[i]==-1 ) 31249 s->uidx.ptr.p_int[i] = j; 31254 if( i==s->idx.ptr.p_int[j] ) 31256 s->didx.ptr.p_int[i] = j; 31260 if( s->uidx.ptr.p_int[i]==-1 ) 31262 s->uidx.ptr.p_int[i] = s->ridx.ptr.p_int[i+1]; 31264 if( s->didx.ptr.p_int[i]==-1 ) 31266 s->didx.ptr.p_int[i] = s->uidx.ptr.p_int[i]; 31272 /************************************************************************* 31273 This is hash function. 31275 -- ALGLIB PROJECT -- 31276 Copyright 14.10.2011 by Bochkanov Sergey 31277 *************************************************************************/ 31278 static ae_int_t sparse_hash(ae_int_t i, 31283 ae_frame _frame_block; 31287 ae_frame_make(_state, &_frame_block); 31288 _hqrndstate_init(&r, _state, ae_true); 31290 hqrndseed(i, j, &r, _state); 31291 result = hqrnduniformi(&r, tabsize, _state); 31292 ae_frame_leave(_state); 31297 ae_bool _sparsematrix_init(void* _p, ae_state *_state, ae_bool make_automatic) 31299 sparsematrix *p = (sparsematrix*)_p; 31300 ae_touch_ptr((void*)p); 31301 if( !ae_vector_init(&p->vals, 0, DT_REAL, _state, make_automatic) ) 31303 if( !ae_vector_init(&p->idx, 0, DT_INT, _state, make_automatic) ) 31305 if( !ae_vector_init(&p->ridx, 0, DT_INT, _state, make_automatic) ) 31307 if( !ae_vector_init(&p->didx, 0, DT_INT, _state, make_automatic) ) 31309 if( !ae_vector_init(&p->uidx, 0, DT_INT, _state, make_automatic) ) 31315 ae_bool _sparsematrix_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic) 31317 sparsematrix *dst = (sparsematrix*)_dst; 31318 sparsematrix *src = (sparsematrix*)_src; 31319 if( !ae_vector_init_copy(&dst->vals, &src->vals, _state, make_automatic) ) 31321 if( !ae_vector_init_copy(&dst->idx, &src->idx, _state, make_automatic) ) 31323 if( !ae_vector_init_copy(&dst->ridx, &src->ridx, _state, make_automatic) ) 31325 if( !ae_vector_init_copy(&dst->didx, &src->didx, _state, make_automatic) ) 31327 if( !ae_vector_init_copy(&dst->uidx, &src->uidx, _state, make_automatic) ) 31329 dst->matrixtype = src->matrixtype; 31332 dst->nfree = src->nfree; 31333 dst->ninitialized = src->ninitialized; 31338 void _sparsematrix_clear(void* _p) 31340 sparsematrix *p = (sparsematrix*)_p; 31341 ae_touch_ptr((void*)p); 31342 ae_vector_clear(&p->vals); 31343 ae_vector_clear(&p->idx); 31344 ae_vector_clear(&p->ridx); 31345 ae_vector_clear(&p->didx); 31346 ae_vector_clear(&p->uidx); 31350 void _sparsematrix_destroy(void* _p) 31352 sparsematrix *p = (sparsematrix*)_p; 31353 ae_touch_ptr((void*)p); 31354 ae_vector_destroy(&p->vals); 31355 ae_vector_destroy(&p->idx); 31356 ae_vector_destroy(&p->ridx); 31357 ae_vector_destroy(&p->didx); 31358 ae_vector_destroy(&p->uidx); 31364 /************************************************************************* 31365 Basic Cholesky solver for ScaleA*Cholesky(A)'*x = y. 31367 This subroutine assumes that: 31368 * A*ScaleA is well scaled 31369 * A is well-conditioned, so no zero divisions or overflow may occur 31372 CHA - Cholesky decomposition of A 31373 SqrtScaleA- square root of scale factor ScaleA 31374 N - matrix size, N>=0. 31375 IsUpper - storage type 31377 Tmp - buffer; function automatically allocates it, if it is too 31378 small. It can be reused if function is called several 31384 NOTE 1: no assertion or tests are done during algorithm operation 31385 NOTE 2: N=0 will force algorithm to silently return 31388 Copyright 13.10.2010 by Bochkanov Sergey 31389 *************************************************************************/ 31390 void fblscholeskysolve(/* Real */ ae_matrix* cha, 31394 /* Real */ ae_vector* xb, 31395 /* Real */ ae_vector* tmp, 31408 ae_vector_set_length(tmp, n, _state); 31412 * A = L*L' or A=U'*U 31418 * Solve U'*y=b first. 31420 for(i=0; i<=n-1; i++) 31422 xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]); 31425 v = xb->ptr.p_double[i]; 31426 ae_v_moved(&tmp->ptr.p_double[i+1], 1, &cha->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1), sqrtscalea); 31427 ae_v_subd(&xb->ptr.p_double[i+1], 1, &tmp->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1), v); 31432 * Solve U*x=y then. 31434 for(i=n-1; i>=0; i--) 31438 ae_v_moved(&tmp->ptr.p_double[i+1], 1, &cha->ptr.pp_double[i][i+1], 1, ae_v_len(i+1,n-1), sqrtscalea); 31439 v = ae_v_dotproduct(&tmp->ptr.p_double[i+1], 1, &xb->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1)); 31440 xb->ptr.p_double[i] = xb->ptr.p_double[i]-v; 31442 xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]); 31449 * Solve L*y=b first 31451 for(i=0; i<=n-1; i++) 31455 ae_v_moved(&tmp->ptr.p_double[0], 1, &cha->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), sqrtscalea); 31456 v = ae_v_dotproduct(&tmp->ptr.p_double[0], 1, &xb->ptr.p_double[0], 1, ae_v_len(0,i-1)); 31457 xb->ptr.p_double[i] = xb->ptr.p_double[i]-v; 31459 xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]); 31463 * Solve L'*x=y then. 31465 for(i=n-1; i>=0; i--) 31467 xb->ptr.p_double[i] = xb->ptr.p_double[i]/(sqrtscalea*cha->ptr.pp_double[i][i]); 31470 v = xb->ptr.p_double[i]; 31471 ae_v_moved(&tmp->ptr.p_double[0], 1, &cha->ptr.pp_double[i][0], 1, ae_v_len(0,i-1), sqrtscalea); 31472 ae_v_subd(&xb->ptr.p_double[0], 1, &tmp->ptr.p_double[0], 1, ae_v_len(0,i-1), v); 31479 /************************************************************************* 31480 Fast basic linear solver: linear SPD CG 31482 Solves (A^T*A + alpha*I)*x = b where: 31484 * alpha>0 is a scalar 31485 * I is NxN identity matrix 31487 * X is Nx1 unknown vector. 31489 N iterations of linear conjugate gradient are used to solve problem. 31492 A - array[M,N], matrix 31494 N - number of unknowns 31495 B - array[N], right part 31496 X - initial approxumation, array[N] 31497 Buf - buffer; function automatically allocates it, if it is too 31498 small. It can be reused if function is called several times 31502 X - improved solution 31505 * solver checks quality of improved solution. If (because of problem 31506 condition number, numerical noise, etc.) new solution is WORSE than 31507 original approximation, then original approximation is returned. 31508 * solver assumes that both A, B, Alpha are well scaled (i.e. they are 31509 less than sqrt(overflow) and greater than sqrt(underflow)). 31512 Copyright 20.08.2009 by Bochkanov Sergey 31513 *************************************************************************/ 31514 void fblssolvecgx(/* Real */ ae_matrix* a, 31518 /* Real */ ae_vector* b, 31519 /* Real */ ae_vector* x, 31520 /* Real */ ae_vector* buf, 31546 * Test for special case: B=0 31548 v1 = ae_v_dotproduct(&b->ptr.p_double[0], 1, &b->ptr.p_double[0], 1, ae_v_len(0,n-1)); 31549 if( ae_fp_eq(v1,0) ) 31551 for(k=0; k<=n-1; k++) 31553 x->ptr.p_double[k] = 0; 31559 * Offsets inside Buf for: 31563 * * Tmp1 - array[M], Tmp2 - array[N] 31566 offsrk1 = offsrk+n; 31567 offsxk = offsrk1+n; 31568 offsxk1 = offsxk+n; 31569 offspk = offsxk1+n; 31570 offspk1 = offspk+n; 31571 offstmp1 = offspk1+n; 31572 offstmp2 = offstmp1+m; 31576 ae_vector_set_length(buf, bs, _state); 31582 ae_v_move(&buf->ptr.p_double[offsxk], 1, &x->ptr.p_double[0], 1, ae_v_len(offsxk,offsxk+n-1)); 31588 rmatrixmv(m, n, a, 0, 0, 0, buf, offsxk, buf, offstmp1, _state); 31589 rmatrixmv(n, m, a, 0, 0, 1, buf, offstmp1, buf, offstmp2, _state); 31590 ae_v_addd(&buf->ptr.p_double[offstmp2], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(offstmp2,offstmp2+n-1), alpha); 31591 ae_v_move(&buf->ptr.p_double[offsrk], 1, &b->ptr.p_double[0], 1, ae_v_len(offsrk,offsrk+n-1)); 31592 ae_v_sub(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offstmp2], 1, ae_v_len(offsrk,offsrk+n-1)); 31593 rk2 = ae_v_dotproduct(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offsrk,offsrk+n-1)); 31594 ae_v_move(&buf->ptr.p_double[offspk], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offspk,offspk+n-1)); 31595 e1 = ae_sqrt(rk2, _state); 31600 for(k=0; k<=n-1; k++) 31604 * Calculate A*p(k) - store in Buf[OffsTmp2:OffsTmp2+N-1] 31605 * and p(k)'*A*p(k) - store in PAP 31607 * If PAP=0, break (iteration is over) 31609 rmatrixmv(m, n, a, 0, 0, 0, buf, offspk, buf, offstmp1, _state); 31610 v1 = ae_v_dotproduct(&buf->ptr.p_double[offstmp1], 1, &buf->ptr.p_double[offstmp1], 1, ae_v_len(offstmp1,offstmp1+m-1)); 31611 v2 = ae_v_dotproduct(&buf->ptr.p_double[offspk], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offspk,offspk+n-1)); 31613 rmatrixmv(n, m, a, 0, 0, 1, buf, offstmp1, buf, offstmp2, _state); 31614 ae_v_addd(&buf->ptr.p_double[offstmp2], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offstmp2,offstmp2+n-1), alpha); 31615 if( ae_fp_eq(pap,0) ) 31621 * S = (r(k)'*r(k))/(p(k)'*A*p(k)) 31626 * x(k+1) = x(k) + S*p(k) 31628 ae_v_move(&buf->ptr.p_double[offsxk1], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(offsxk1,offsxk1+n-1)); 31629 ae_v_addd(&buf->ptr.p_double[offsxk1], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offsxk1,offsxk1+n-1), s); 31632 * r(k+1) = r(k) - S*A*p(k) 31633 * RK12 = r(k+1)'*r(k+1) 31635 * Break if r(k+1) small enough (when compared to r(k)) 31637 ae_v_move(&buf->ptr.p_double[offsrk1], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offsrk1,offsrk1+n-1)); 31638 ae_v_subd(&buf->ptr.p_double[offsrk1], 1, &buf->ptr.p_double[offstmp2], 1, ae_v_len(offsrk1,offsrk1+n-1), s); 31639 rk12 = ae_v_dotproduct(&buf->ptr.p_double[offsrk1], 1, &buf->ptr.p_double[offsrk1], 1, ae_v_len(offsrk1,offsrk1+n-1)); 31640 if( ae_fp_less_eq(ae_sqrt(rk12, _state),100*ae_machineepsilon*ae_sqrt(rk2, _state)) ) 31644 * X(k) = x(k+1) before exit - 31645 * - because we expect to find solution at x(k) 31647 ae_v_move(&buf->ptr.p_double[offsxk], 1, &buf->ptr.p_double[offsxk1], 1, ae_v_len(offsxk,offsxk+n-1)); 31653 * p(k+1) = r(k+1)+betak*p(k) 31656 ae_v_move(&buf->ptr.p_double[offspk1], 1, &buf->ptr.p_double[offsrk1], 1, ae_v_len(offspk1,offspk1+n-1)); 31657 ae_v_addd(&buf->ptr.p_double[offspk1], 1, &buf->ptr.p_double[offspk], 1, ae_v_len(offspk1,offspk1+n-1), betak); 31664 ae_v_move(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offsrk1], 1, ae_v_len(offsrk,offsrk+n-1)); 31665 ae_v_move(&buf->ptr.p_double[offsxk], 1, &buf->ptr.p_double[offsxk1], 1, ae_v_len(offsxk,offsxk+n-1)); 31666 ae_v_move(&buf->ptr.p_double[offspk], 1, &buf->ptr.p_double[offspk1], 1, ae_v_len(offspk,offspk+n-1)); 31673 rmatrixmv(m, n, a, 0, 0, 0, buf, offsxk, buf, offstmp1, _state); 31674 rmatrixmv(n, m, a, 0, 0, 1, buf, offstmp1, buf, offstmp2, _state); 31675 ae_v_addd(&buf->ptr.p_double[offstmp2], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(offstmp2,offstmp2+n-1), alpha); 31676 ae_v_move(&buf->ptr.p_double[offsrk], 1, &b->ptr.p_double[0], 1, ae_v_len(offsrk,offsrk+n-1)); 31677 ae_v_sub(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offstmp2], 1, ae_v_len(offsrk,offsrk+n-1)); 31678 v1 = ae_v_dotproduct(&buf->ptr.p_double[offsrk], 1, &buf->ptr.p_double[offsrk], 1, ae_v_len(offsrk,offsrk+n-1)); 31679 e2 = ae_sqrt(v1, _state); 31682 * Output result (if it was improved) 31684 if( ae_fp_less(e2,e1) ) 31686 ae_v_move(&x->ptr.p_double[0], 1, &buf->ptr.p_double[offsxk], 1, ae_v_len(0,n-1)); 31691 /************************************************************************* 31692 Construction of linear conjugate gradient solver. 31694 State parameter passed using "var
" semantics (i.e. previous state is NOT 31695 erased). When it is already initialized, we can reause prevously allocated 31699 X - initial solution 31702 State - structure; may be preallocated, if we want to reuse memory 31705 State - structure which is used by FBLSCGIteration() to store 31706 algorithm state between subsequent calls. 31708 NOTE: no error checking is done; caller must check all parameters, prevent 31709 overflows, and so on. 31712 Copyright 22.10.2009 by Bochkanov Sergey 31713 *************************************************************************/ 31714 void fblscgcreate(/* Real */ ae_vector* x, 31715 /* Real */ ae_vector* b, 31717 fblslincgstate* state, 31722 if( state->b.cnt<n ) 31724 ae_vector_set_length(&state->b, n, _state); 31726 if( state->rk.cnt<n ) 31728 ae_vector_set_length(&state->rk, n, _state); 31730 if( state->rk1.cnt<n ) 31732 ae_vector_set_length(&state->rk1, n, _state); 31734 if( state->xk.cnt<n ) 31736 ae_vector_set_length(&state->xk, n, _state); 31738 if( state->xk1.cnt<n ) 31740 ae_vector_set_length(&state->xk1, n, _state); 31742 if( state->pk.cnt<n ) 31744 ae_vector_set_length(&state->pk, n, _state); 31746 if( state->pk1.cnt<n ) 31748 ae_vector_set_length(&state->pk1, n, _state); 31750 if( state->tmp2.cnt<n ) 31752 ae_vector_set_length(&state->tmp2, n, _state); 31754 if( state->x.cnt<n ) 31756 ae_vector_set_length(&state->x, n, _state); 31758 if( state->ax.cnt<n ) 31760 ae_vector_set_length(&state->ax, n, _state); 31763 ae_v_move(&state->xk.ptr.p_double[0], 1, &x->ptr.p_double[0], 1, ae_v_len(0,n-1)); 31764 ae_v_move(&state->b.ptr.p_double[0], 1, &b->ptr.p_double[0], 1, ae_v_len(0,n-1)); 31765 ae_vector_set_length(&state->rstate.ia, 1+1, _state); 31766 ae_vector_set_length(&state->rstate.ra, 6+1, _state); 31767 state->rstate.stage = -1; 31771 /************************************************************************* 31772 Linear CG solver, function relying on reverse communication to calculate 31773 matrix-vector products. 31775 See comments for FBLSLinCGState structure for more info. 31778 Copyright 22.10.2009 by Bochkanov Sergey 31779 *************************************************************************/ 31780 ae_bool fblscgiteration(fblslincgstate* state, ae_state *_state) 31796 * Reverse communication preparations 31797 * I know it looks ugly, but it works the same way 31798 * anywhere from C++ to Python. 31800 * This code initializes locals by: 31801 * * random values determined during code 31802 * generation - on first subroutine call 31803 * * values from previous call - on subsequent calls 31805 if( state->rstate.stage>=0 ) 31807 n = state->rstate.ia.ptr.p_int[0]; 31808 k = state->rstate.ia.ptr.p_int[1]; 31809 rk2 = state->rstate.ra.ptr.p_double[0]; 31810 rk12 = state->rstate.ra.ptr.p_double[1]; 31811 pap = state->rstate.ra.ptr.p_double[2]; 31812 s = state->rstate.ra.ptr.p_double[3]; 31813 betak = state->rstate.ra.ptr.p_double[4]; 31814 v1 = state->rstate.ra.ptr.p_double[5]; 31815 v2 = state->rstate.ra.ptr.p_double[6]; 31829 if( state->rstate.stage==0 ) 31833 if( state->rstate.stage==1 ) 31837 if( state->rstate.stage==2 ) 31852 * Test for special case: B=0 31854 v1 = ae_v_dotproduct(&state->b.ptr.p_double[0], 1, &state->b.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31855 if( ae_fp_eq(v1,0) ) 31857 for(k=0; k<=n-1; k++) 31859 state->xk.ptr.p_double[k] = 0; 31869 ae_v_move(&state->x.ptr.p_double[0], 1, &state->xk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31870 state->rstate.stage = 0; 31873 ae_v_move(&state->rk.ptr.p_double[0], 1, &state->b.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31874 ae_v_sub(&state->rk.ptr.p_double[0], 1, &state->ax.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31875 rk2 = ae_v_dotproduct(&state->rk.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31876 ae_v_move(&state->pk.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31877 state->e1 = ae_sqrt(rk2, _state); 31890 * Calculate A*p(k) - store in State.Tmp2 31891 * and p(k)'*A*p(k) - store in PAP 31893 * If PAP=0, break (iteration is over) 31895 ae_v_move(&state->x.ptr.p_double[0], 1, &state->pk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31896 state->rstate.stage = 1; 31899 ae_v_move(&state->tmp2.ptr.p_double[0], 1, &state->ax.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31901 if( !ae_isfinite(pap, _state) ) 31905 if( ae_fp_less_eq(pap,0) ) 31911 * S = (r(k)'*r(k))/(p(k)'*A*p(k)) 31916 * x(k+1) = x(k) + S*p(k) 31918 ae_v_move(&state->xk1.ptr.p_double[0], 1, &state->xk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31919 ae_v_addd(&state->xk1.ptr.p_double[0], 1, &state->pk.ptr.p_double[0], 1, ae_v_len(0,n-1), s); 31922 * r(k+1) = r(k) - S*A*p(k) 31923 * RK12 = r(k+1)'*r(k+1) 31925 * Break if r(k+1) small enough (when compared to r(k)) 31927 ae_v_move(&state->rk1.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31928 ae_v_subd(&state->rk1.ptr.p_double[0], 1, &state->tmp2.ptr.p_double[0], 1, ae_v_len(0,n-1), s); 31929 rk12 = ae_v_dotproduct(&state->rk1.ptr.p_double[0], 1, &state->rk1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31930 if( ae_fp_less_eq(ae_sqrt(rk12, _state),100*ae_machineepsilon*state->e1) ) 31934 * X(k) = x(k+1) before exit - 31935 * - because we expect to find solution at x(k) 31937 ae_v_move(&state->xk.ptr.p_double[0], 1, &state->xk1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31943 * p(k+1) = r(k+1)+betak*p(k) 31945 * NOTE: we expect that BetaK won't overflow because of 31946 * "Sqrt(RK12)<=100*MachineEpsilon*E1
" test above. 31949 ae_v_move(&state->pk1.ptr.p_double[0], 1, &state->rk1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31950 ae_v_addd(&state->pk1.ptr.p_double[0], 1, &state->pk.ptr.p_double[0], 1, ae_v_len(0,n-1), betak); 31957 ae_v_move(&state->rk.ptr.p_double[0], 1, &state->rk1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31958 ae_v_move(&state->xk.ptr.p_double[0], 1, &state->xk1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31959 ae_v_move(&state->pk.ptr.p_double[0], 1, &state->pk1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31968 ae_v_move(&state->x.ptr.p_double[0], 1, &state->xk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31969 state->rstate.stage = 2; 31972 ae_v_move(&state->rk.ptr.p_double[0], 1, &state->b.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31973 ae_v_sub(&state->rk.ptr.p_double[0], 1, &state->ax.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31974 v1 = ae_v_dotproduct(&state->rk.ptr.p_double[0], 1, &state->rk.ptr.p_double[0], 1, ae_v_len(0,n-1)); 31975 state->e2 = ae_sqrt(v1, _state); 31984 state->rstate.ia.ptr.p_int[0] = n; 31985 state->rstate.ia.ptr.p_int[1] = k; 31986 state->rstate.ra.ptr.p_double[0] = rk2; 31987 state->rstate.ra.ptr.p_double[1] = rk12; 31988 state->rstate.ra.ptr.p_double[2] = pap; 31989 state->rstate.ra.ptr.p_double[3] = s; 31990 state->rstate.ra.ptr.p_double[4] = betak; 31991 state->rstate.ra.ptr.p_double[5] = v1; 31992 state->rstate.ra.ptr.p_double[6] = v2; 31997 /************************************************************************* 31998 Fast least squares solver, solves well conditioned system without 31999 performing any checks for degeneracy, and using user-provided buffers 32000 (which are automatically reallocated if too small). 32002 This function is intended for solution of moderately sized systems. It 32003 uses factorization algorithms based on Level 2 BLAS operations, thus it 32004 won't work efficiently on large scale systems. 32007 A - array[M,N], system matrix. 32008 Contents of A is destroyed during solution. 32009 B - array[M], right part 32010 M - number of equations 32011 N - number of variables, N<=M 32013 buffers; function automatically allocates them, if they are 32014 too small. They can be reused if function is called 32018 B - solution (first N components, next M-N are zero) 32021 Copyright 20.01.2012 by Bochkanov Sergey 32022 *************************************************************************/ 32023 void fblssolvels(/* Real */ ae_matrix* a, 32024 /* Real */ ae_vector* b, 32027 /* Real */ ae_vector* tmp0, 32028 /* Real */ ae_vector* tmp1, 32029 /* Real */ ae_vector* tmp2, 32037 ae_assert(n>0, "FBLSSolveLS: N<=0
", _state); 32038 ae_assert(m>=n, "FBLSSolveLS: M<N
", _state); 32039 ae_assert(a->rows>=m, "FBLSSolveLS: Rows(A)<M
", _state); 32040 ae_assert(a->cols>=n, "FBLSSolveLS: Cols(A)<N
", _state); 32041 ae_assert(b->cnt>=m, "FBLSSolveLS: Length(B)<M
", _state); 32044 * Allocate temporaries 32046 rvectorsetlengthatleast(tmp0, ae_maxint(m, n, _state)+1, _state); 32047 rvectorsetlengthatleast(tmp1, ae_maxint(m, n, _state)+1, _state); 32048 rvectorsetlengthatleast(tmp2, ae_minint(m, n, _state), _state); 32053 rmatrixqrbasecase(a, m, n, tmp0, tmp1, tmp2, _state); 32058 for(k=0; k<=n-1; k++) 32060 for(i=0; i<=k-1; i++) 32062 tmp0->ptr.p_double[i] = 0; 32064 ae_v_move(&tmp0->ptr.p_double[k], 1, &a->ptr.pp_double[k][k], a->stride, ae_v_len(k,m-1)); 32065 tmp0->ptr.p_double[k] = 1; 32066 v = ae_v_dotproduct(&tmp0->ptr.p_double[k], 1, &b->ptr.p_double[k], 1, ae_v_len(k,m-1)); 32067 v = v*tmp2->ptr.p_double[k]; 32068 ae_v_subd(&b->ptr.p_double[k], 1, &tmp0->ptr.p_double[k], 1, ae_v_len(k,m-1), v); 32072 * Solve triangular system 32074 b->ptr.p_double[n-1] = b->ptr.p_double[n-1]/a->ptr.pp_double[n-1][n-1]; 32075 for(i=n-2; i>=0; i--) 32077 v = ae_v_dotproduct(&a->ptr.pp_double[i][i+1], 1, &b->ptr.p_double[i+1], 1, ae_v_len(i+1,n-1)); 32078 b->ptr.p_double[i] = (b->ptr.p_double[i]-v)/a->ptr.pp_double[i][i]; 32080 for(i=n; i<=m-1; i++) 32082 b->ptr.p_double[i] = 0.0; 32087 ae_bool _fblslincgstate_init(void* _p, ae_state *_state, ae_bool make_automatic) 32089 fblslincgstate *p = (fblslincgstate*)_p; 32090 ae_touch_ptr((void*)p); 32091 if( !ae_vector_init(&p->x, 0, DT_REAL, _state, make_automatic) ) 32093 if( !ae_vector_init(&p->ax, 0, DT_REAL, _state, make_automatic) ) 32095 if( !ae_vector_init(&p->rk, 0, DT_REAL, _state, make_automatic) ) 32097 if( !ae_vector_init(&p->rk1, 0, DT_REAL, _state, make_automatic) ) 32099 if( !ae_vector_init(&p->xk, 0, DT_REAL, _state, make_automatic) ) 32101 if( !ae_vector_init(&p->xk1, 0, DT_REAL, _state, make_automatic) ) 32103 if( !ae_vector_init(&p->pk, 0, DT_REAL, _state, make_automatic) ) 32105 if( !ae_vector_init(&p->pk1, 0, DT_REAL, _state, make_automatic) ) 32107 if( !ae_vector_init(&p->b, 0, DT_REAL, _state, make_automatic) ) 32109 if( !_rcommstate_init(&p->rstate, _state, make_automatic) ) 32111 if( !ae_vector_init(&p->tmp2, 0, DT_REAL, _state, make_automatic) ) 32117 ae_bool _fblslincgstate_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic) 32119 fblslincgstate *dst = (fblslincgstate*)_dst; 32120 fblslincgstate *src = (fblslincgstate*)_src; 32123 if( !ae_vector_init_copy(&dst->x, &src->x, _state, make_automatic) ) 32125 if( !ae_vector_init_copy(&dst->ax, &src->ax, _state, make_automatic) ) 32127 dst->xax = src->xax; 32129 if( !ae_vector_init_copy(&dst->rk, &src->rk, _state, make_automatic) ) 32131 if( !ae_vector_init_copy(&dst->rk1, &src->rk1, _state, make_automatic) ) 32133 if( !ae_vector_init_copy(&dst->xk, &src->xk, _state, make_automatic) ) 32135 if( !ae_vector_init_copy(&dst->xk1, &src->xk1, _state, make_automatic) ) 32137 if( !ae_vector_init_copy(&dst->pk, &src->pk, _state, make_automatic) ) 32139 if( !ae_vector_init_copy(&dst->pk1, &src->pk1, _state, make_automatic) ) 32141 if( !ae_vector_init_copy(&dst->b, &src->b, _state, make_automatic) ) 32143 if( !_rcommstate_init_copy(&dst->rstate, &src->rstate, _state, make_automatic) ) 32145 if( !ae_vector_init_copy(&dst->tmp2, &src->tmp2, _state, make_automatic) ) 32151 void _fblslincgstate_clear(void* _p) 32153 fblslincgstate *p = (fblslincgstate*)_p; 32154 ae_touch_ptr((void*)p); 32155 ae_vector_clear(&p->x); 32156 ae_vector_clear(&p->ax); 32157 ae_vector_clear(&p->rk); 32158 ae_vector_clear(&p->rk1); 32159 ae_vector_clear(&p->xk); 32160 ae_vector_clear(&p->xk1); 32161 ae_vector_clear(&p->pk); 32162 ae_vector_clear(&p->pk1); 32163 ae_vector_clear(&p->b); 32164 _rcommstate_clear(&p->rstate); 32165 ae_vector_clear(&p->tmp2); 32169 void _fblslincgstate_destroy(void* _p) 32171 fblslincgstate *p = (fblslincgstate*)_p; 32172 ae_touch_ptr((void*)p); 32173 ae_vector_destroy(&p->x); 32174 ae_vector_destroy(&p->ax); 32175 ae_vector_destroy(&p->rk); 32176 ae_vector_destroy(&p->rk1); 32177 ae_vector_destroy(&p->xk); 32178 ae_vector_destroy(&p->xk1); 32179 ae_vector_destroy(&p->pk); 32180 ae_vector_destroy(&p->pk1); 32181 ae_vector_destroy(&p->b); 32182 _rcommstate_destroy(&p->rstate); 32183 ae_vector_destroy(&p->tmp2); 32189 /************************************************************************* 32190 This procedure initializes matrix norm estimator. 32193 1. User initializes algorithm state with NormEstimatorCreate() call 32194 2. User calls NormEstimatorEstimateSparse() (or NormEstimatorIteration()) 32195 3. User calls NormEstimatorResults() to get solution. 32198 M - number of rows in the matrix being estimated, M>0 32199 N - number of columns in the matrix being estimated, N>0 32200 NStart - number of random starting vectors 32201 recommended value - at least 5. 32202 NIts - number of iterations to do with best starting vector 32203 recommended value - at least 5. 32206 State - structure which stores algorithm state 32209 NOTE: this algorithm is effectively deterministic, i.e. it always returns 32210 same result when repeatedly called for the same matrix. In fact, algorithm 32211 uses randomized starting vectors, but internal random numbers generator 32212 always generates same sequence of the random values (it is a feature, not 32215 Algorithm can be made non-deterministic with NormEstimatorSetSeed(0) call. 32218 Copyright 06.12.2011 by Bochkanov Sergey 32219 *************************************************************************/ 32220 void normestimatorcreate(ae_int_t m, 32224 normestimatorstate* state, 32228 _normestimatorstate_clear(state); 32230 ae_assert(m>0, "NormEstimatorCreate: M<=0
", _state); 32231 ae_assert(n>0, "NormEstimatorCreate: N<=0
", _state); 32232 ae_assert(nstart>0, "NormEstimatorCreate: NStart<=0
", _state); 32233 ae_assert(nits>0, "NormEstimatorCreate: NIts<=0
", _state); 32236 state->nstart = nstart; 32237 state->nits = nits; 32238 state->seedval = 11; 32239 hqrndrandomize(&state->r, _state); 32240 ae_vector_set_length(&state->x0, state->n, _state); 32241 ae_vector_set_length(&state->t, state->m, _state); 32242 ae_vector_set_length(&state->x1, state->n, _state); 32243 ae_vector_set_length(&state->xbest, state->n, _state); 32244 ae_vector_set_length(&state->x, ae_maxint(state->n, state->m, _state), _state); 32245 ae_vector_set_length(&state->mv, state->m, _state); 32246 ae_vector_set_length(&state->mtv, state->n, _state); 32247 ae_vector_set_length(&state->rstate.ia, 3+1, _state); 32248 ae_vector_set_length(&state->rstate.ra, 2+1, _state); 32249 state->rstate.stage = -1; 32253 /************************************************************************* 32254 This function changes seed value used by algorithm. In some cases we need 32255 deterministic processing, i.e. subsequent calls must return equal results, 32256 in other cases we need non-deterministic algorithm which returns different 32257 results for the same matrix on every pass. 32259 Setting zero seed will lead to non-deterministic algorithm, while non-zero 32260 value will make our algorithm deterministic. 32263 State - norm estimator state, must be initialized with a call 32264 to NormEstimatorCreate() 32265 SeedVal - seed value, >=0. Zero value = non-deterministic algo. 32268 Copyright 06.12.2011 by Bochkanov Sergey 32269 *************************************************************************/ 32270 void normestimatorsetseed(normestimatorstate* state, 32276 ae_assert(seedval>=0, "NormEstimatorSetSeed: SeedVal<0
", _state); 32277 state->seedval = seedval; 32281 /************************************************************************* 32284 Copyright 06.12.2011 by Bochkanov Sergey 32285 *************************************************************************/ 32286 ae_bool normestimatoriteration(normestimatorstate* state, 32301 * Reverse communication preparations 32302 * I know it looks ugly, but it works the same way 32303 * anywhere from C++ to Python. 32305 * This code initializes locals by: 32306 * * random values determined during code 32307 * generation - on first subroutine call 32308 * * values from previous call - on subsequent calls 32310 if( state->rstate.stage>=0 ) 32312 n = state->rstate.ia.ptr.p_int[0]; 32313 m = state->rstate.ia.ptr.p_int[1]; 32314 i = state->rstate.ia.ptr.p_int[2]; 32315 itcnt = state->rstate.ia.ptr.p_int[3]; 32316 v = state->rstate.ra.ptr.p_double[0]; 32317 growth = state->rstate.ra.ptr.p_double[1]; 32318 bestgrowth = state->rstate.ra.ptr.p_double[2]; 32330 if( state->rstate.stage==0 ) 32334 if( state->rstate.stage==1 ) 32338 if( state->rstate.stage==2 ) 32342 if( state->rstate.stage==3 ) 32352 if( state->seedval>0 ) 32354 hqrndseed(state->seedval, state->seedval+2, &state->r, _state); 32357 state->xbest.ptr.p_double[0] = 1; 32358 for(i=1; i<=n-1; i++) 32360 state->xbest.ptr.p_double[i] = 0; 32364 if( itcnt>state->nstart-1 ) 32371 for(i=0; i<=n-1; i++) 32373 state->x0.ptr.p_double[i] = hqrndnormal(&state->r, _state); 32374 v = v+ae_sqr(state->x0.ptr.p_double[i], _state); 32377 while(ae_fp_eq(v,0)); 32378 v = 1/ae_sqrt(v, _state); 32379 ae_v_muld(&state->x0.ptr.p_double[0], 1, ae_v_len(0,n-1), v); 32380 ae_v_move(&state->x.ptr.p_double[0], 1, &state->x0.ptr.p_double[0], 1, ae_v_len(0,n-1)); 32381 state->needmv = ae_true; 32382 state->needmtv = ae_false; 32383 state->rstate.stage = 0; 32386 ae_v_move(&state->x.ptr.p_double[0], 1, &state->mv.ptr.p_double[0], 1, ae_v_len(0,m-1)); 32387 state->needmv = ae_false; 32388 state->needmtv = ae_true; 32389 state->rstate.stage = 1; 32392 ae_v_move(&state->x1.ptr.p_double[0], 1, &state->mtv.ptr.p_double[0], 1, ae_v_len(0,n-1)); 32394 for(i=0; i<=n-1; i++) 32396 v = v+ae_sqr(state->x1.ptr.p_double[i], _state); 32398 growth = ae_sqrt(ae_sqrt(v, _state), _state); 32399 if( ae_fp_greater(growth,bestgrowth) ) 32401 v = 1/ae_sqrt(v, _state); 32402 ae_v_moved(&state->xbest.ptr.p_double[0], 1, &state->x1.ptr.p_double[0], 1, ae_v_len(0,n-1), v); 32403 bestgrowth = growth; 32408 ae_v_move(&state->x0.ptr.p_double[0], 1, &state->xbest.ptr.p_double[0], 1, ae_v_len(0,n-1)); 32411 if( itcnt>state->nits-1 ) 32415 ae_v_move(&state->x.ptr.p_double[0], 1, &state->x0.ptr.p_double[0], 1, ae_v_len(0,n-1)); 32416 state->needmv = ae_true; 32417 state->needmtv = ae_false; 32418 state->rstate.stage = 2; 32421 ae_v_move(&state->x.ptr.p_double[0], 1, &state->mv.ptr.p_double[0], 1, ae_v_len(0,m-1)); 32422 state->needmv = ae_false; 32423 state->needmtv = ae_true; 32424 state->rstate.stage = 3; 32427 ae_v_move(&state->x1.ptr.p_double[0], 1, &state->mtv.ptr.p_double[0], 1, ae_v_len(0,n-1)); 32429 for(i=0; i<=n-1; i++) 32431 v = v+ae_sqr(state->x1.ptr.p_double[i], _state); 32433 state->repnorm = ae_sqrt(ae_sqrt(v, _state), _state); 32434 if( ae_fp_neq(v,0) ) 32436 v = 1/ae_sqrt(v, _state); 32437 ae_v_moved(&state->x0.ptr.p_double[0], 1, &state->x1.ptr.p_double[0], 1, ae_v_len(0,n-1), v); 32450 state->rstate.ia.ptr.p_int[0] = n; 32451 state->rstate.ia.ptr.p_int[1] = m; 32452 state->rstate.ia.ptr.p_int[2] = i; 32453 state->rstate.ia.ptr.p_int[3] = itcnt; 32454 state->rstate.ra.ptr.p_double[0] = v; 32455 state->rstate.ra.ptr.p_double[1] = growth; 32456 state->rstate.ra.ptr.p_double[2] = bestgrowth; 32461 /************************************************************************* 32462 This function estimates norm of the sparse M*N matrix A. 32465 State - norm estimator state, must be initialized with a call 32466 to NormEstimatorCreate() 32467 A - sparse M*N matrix, must be converted to CRS format 32468 prior to calling this function. 32470 After this function is over you can call NormEstimatorResults() to get 32471 estimate of the norm(A). 32474 Copyright 06.12.2011 by Bochkanov Sergey 32475 *************************************************************************/ 32476 void normestimatorestimatesparse(normestimatorstate* state, 32482 normestimatorrestart(state, _state); 32483 while(normestimatoriteration(state, _state)) 32485 if( state->needmv ) 32487 sparsemv(a, &state->x, &state->mv, _state); 32490 if( state->needmtv ) 32492 sparsemtv(a, &state->x, &state->mtv, _state); 32499 /************************************************************************* 32500 Matrix norm estimation results 32503 State - algorithm state 32506 Nrm - estimate of the matrix norm, Nrm>=0 32509 Copyright 06.12.2011 by Bochkanov Sergey 32510 *************************************************************************/ 32511 void normestimatorresults(normestimatorstate* state, 32518 *nrm = state->repnorm; 32522 /************************************************************************* 32523 This function restarts estimator and prepares it for the next estimation 32527 State - algorithm state 32529 Copyright 06.12.2011 by Bochkanov Sergey 32530 *************************************************************************/ 32531 void normestimatorrestart(normestimatorstate* state, ae_state *_state) 32535 ae_vector_set_length(&state->rstate.ia, 3+1, _state); 32536 ae_vector_set_length(&state->rstate.ra, 2+1, _state); 32537 state->rstate.stage = -1; 32541 ae_bool _normestimatorstate_init(void* _p, ae_state *_state, ae_bool make_automatic) 32543 normestimatorstate *p = (normestimatorstate*)_p; 32544 ae_touch_ptr((void*)p); 32545 if( !ae_vector_init(&p->x0, 0, DT_REAL, _state, make_automatic) ) 32547 if( !ae_vector_init(&p->x1, 0, DT_REAL, _state, make_automatic) ) 32549 if( !ae_vector_init(&p->t, 0, DT_REAL, _state, make_automatic) ) 32551 if( !ae_vector_init(&p->xbest, 0, DT_REAL, _state, make_automatic) ) 32553 if( !_hqrndstate_init(&p->r, _state, make_automatic) ) 32555 if( !ae_vector_init(&p->x, 0, DT_REAL, _state, make_automatic) ) 32557 if( !ae_vector_init(&p->mv, 0, DT_REAL, _state, make_automatic) ) 32559 if( !ae_vector_init(&p->mtv, 0, DT_REAL, _state, make_automatic) ) 32561 if( !_rcommstate_init(&p->rstate, _state, make_automatic) ) 32567 ae_bool _normestimatorstate_init_copy(void* _dst, void* _src, ae_state *_state, ae_bool make_automatic) 32569 normestimatorstate *dst = (normestimatorstate*)_dst; 32570 normestimatorstate *src = (normestimatorstate*)_src; 32573 dst->nstart = src->nstart; 32574 dst->nits = src->nits; 32575 dst->seedval = src->seedval; 32576 if( !ae_vector_init_copy(&dst->x0, &src->x0, _state, make_automatic) ) 32578 if( !ae_vector_init_copy(&dst->x1, &src->x1, _state, make_automatic) ) 32580 if( !ae_vector_init_copy(&dst->t, &src->t, _state, make_automatic) ) 32582 if( !ae_vector_init_copy(&dst->xbest, &src->xbest, _state, make_automatic) ) 32584 if( !_hqrndstate_init_copy(&dst->r, &src->r, _state, make_automatic) ) 32586 if( !ae_vector_init_copy(&dst->x, &src->x, _state, make_automatic) ) 32588 if( !ae_vector_init_copy(&dst->mv, &src->mv, _state, make_automatic) ) 32590 if( !ae_vector_init_copy(&dst->mtv, &src->mtv, _state, make_automatic) ) 32592 dst->needmv = src->needmv; 32593 dst->needmtv = src->needmtv; 32594 dst->repnorm = src->repnorm; 32595 if( !_rcommstate_init_copy(&dst->rstate, &src->rstate, _state, make_automatic) ) 32601 void _normestimatorstate_clear(void* _p) 32603 normestimatorstate *p = (normestimatorstate*)_p; 32604 ae_touch_ptr((void*)p); 32605 ae_vector_clear(&p->x0); 32606 ae_vector_clear(&p->x1); 32607 ae_vector_clear(&p->t); 32608 ae_vector_clear(&p->xbest); 32609 _hqrndstate_clear(&p->r); 32610 ae_vector_clear(&p->x); 32611 ae_vector_clear(&p->mv); 32612 ae_vector_clear(&p->mtv); 32613 _rcommstate_clear(&p->rstate); 32617 void _normestimatorstate_destroy(void* _p) 32619 normestimatorstate *p = (normestimatorstate*)_p; 32620 ae_touch_ptr((void*)p); 32621 ae_vector_destroy(&p->x0); 32622 ae_vector_destroy(&p->x1); 32623 ae_vector_destroy(&p->t); 32624 ae_vector_destroy(&p->xbest); 32625 _hqrndstate_destroy(&p->r); 32626 ae_vector_destroy(&p->x); 32627 ae_vector_destroy(&p->mv); 32628 ae_vector_destroy(&p->mtv); 32629 _rcommstate_destroy(&p->rstate); 32635 /************************************************************************* 32636 Determinant calculation of the matrix given by its LU decomposition. 32639 A - LU decomposition of the matrix (output of 32640 RMatrixLU subroutine). 32641 Pivots - table of permutations which were made during 32642 the LU decomposition. 32643 Output of RMatrixLU subroutine. 32644 N - (optional) size of matrix A: 32645 * if given, only principal NxN submatrix is processed and 32646 overwritten. other elements are unchanged. 32647 * if not given, automatically determined from matrix size 32648 (A must be square matrix) 32650 Result: matrix determinant. 32653 Copyright 2005 by Bochkanov Sergey 32654 *************************************************************************/ 32655 double rmatrixludet(/* Real */ ae_matrix* a, 32656 /* Integer */ ae_vector* pivots, 32665 ae_assert(n>=1, "RMatrixLUDet: N<1!
", _state); 32666 ae_assert(pivots->cnt>=n, "RMatrixLUDet: Pivots array is too
short!
", _state); 32667 ae_assert(a->rows>=n, "RMatrixLUDet: rows(A)<N!
", _state); 32668 ae_assert(a->cols>=n, "RMatrixLUDet: cols(A)<N!
", _state); 32669 ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixLUDet: A contains infinite
or NaN values!
", _state); 32672 for(i=0; i<=n-1; i++) 32674 result = result*a->ptr.pp_double[i][i]; 32675 if( pivots->ptr.p_int[i]!=i ) 32685 /************************************************************************* 32686 Calculation of the determinant of a general matrix 32689 A - matrix, array[0..N-1, 0..N-1] 32690 N - (optional) size of matrix A: 32691 * if given, only principal NxN submatrix is processed and 32692 overwritten. other elements are unchanged. 32693 * if not given, automatically determined from matrix size 32694 (A must be square matrix) 32696 Result: determinant of matrix A. 32699 Copyright 2005 by Bochkanov Sergey 32700 *************************************************************************/ 32701 double rmatrixdet(/* Real */ ae_matrix* a, 32705 ae_frame _frame_block; 32710 ae_frame_make(_state, &_frame_block); 32711 ae_matrix_init_copy(&_a, a, _state, ae_true); 32713 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 32715 ae_assert(n>=1, "RMatrixDet: N<1!
", _state); 32716 ae_assert(a->rows>=n, "RMatrixDet: rows(A)<N!
", _state); 32717 ae_assert(a->cols>=n, "RMatrixDet: cols(A)<N!
", _state); 32718 ae_assert(apservisfinitematrix(a, n, n, _state), "RMatrixDet: A contains infinite
or NaN values!
", _state); 32719 rmatrixlu(a, n, n, &pivots, _state); 32720 result = rmatrixludet(a, &pivots, n, _state); 32721 ae_frame_leave(_state); 32726 /************************************************************************* 32727 Determinant calculation of the matrix given by its LU decomposition. 32730 A - LU decomposition of the matrix (output of 32731 RMatrixLU subroutine). 32732 Pivots - table of permutations which were made during 32733 the LU decomposition. 32734 Output of RMatrixLU subroutine. 32735 N - (optional) size of matrix A: 32736 * if given, only principal NxN submatrix is processed and 32737 overwritten. other elements are unchanged. 32738 * if not given, automatically determined from matrix size 32739 (A must be square matrix) 32741 Result: matrix determinant. 32744 Copyright 2005 by Bochkanov Sergey 32745 *************************************************************************/ 32746 ae_complex cmatrixludet(/* Complex */ ae_matrix* a, 32747 /* Integer */ ae_vector* pivots, 32756 ae_assert(n>=1, "CMatrixLUDet: N<1!
", _state); 32757 ae_assert(pivots->cnt>=n, "CMatrixLUDet: Pivots array is too
short!
", _state); 32758 ae_assert(a->rows>=n, "CMatrixLUDet: rows(A)<N!
", _state); 32759 ae_assert(a->cols>=n, "CMatrixLUDet: cols(A)<N!
", _state); 32760 ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixLUDet: A contains infinite
or NaN values!
", _state); 32761 result = ae_complex_from_d(1); 32763 for(i=0; i<=n-1; i++) 32765 result = ae_c_mul(result,a->ptr.pp_complex[i][i]); 32766 if( pivots->ptr.p_int[i]!=i ) 32771 result = ae_c_mul_d(result,s); 32776 /************************************************************************* 32777 Calculation of the determinant of a general matrix 32780 A - matrix, array[0..N-1, 0..N-1] 32781 N - (optional) size of matrix A: 32782 * if given, only principal NxN submatrix is processed and 32783 overwritten. other elements are unchanged. 32784 * if not given, automatically determined from matrix size 32785 (A must be square matrix) 32787 Result: determinant of matrix A. 32790 Copyright 2005 by Bochkanov Sergey 32791 *************************************************************************/ 32792 ae_complex cmatrixdet(/* Complex */ ae_matrix* a, 32796 ae_frame _frame_block; 32801 ae_frame_make(_state, &_frame_block); 32802 ae_matrix_init_copy(&_a, a, _state, ae_true); 32804 ae_vector_init(&pivots, 0, DT_INT, _state, ae_true); 32806 ae_assert(n>=1, "CMatrixDet: N<1!
", _state); 32807 ae_assert(a->rows>=n, "CMatrixDet: rows(A)<N!
", _state); 32808 ae_assert(a->cols>=n, "CMatrixDet: cols(A)<N!
", _state); 32809 ae_assert(apservisfinitecmatrix(a, n, n, _state), "CMatrixDet: A contains infinite
or NaN values!
", _state); 32810 cmatrixlu(a, n, n, &pivots, _state); 32811 result = cmatrixludet(a, &pivots, n, _state); 32812 ae_frame_leave(_state); 32817 /************************************************************************* 32818 Determinant calculation of the matrix given by the Cholesky decomposition. 32821 A - Cholesky decomposition, 32822 output of SMatrixCholesky subroutine. 32823 N - (optional) size of matrix A: 32824 * if given, only principal NxN submatrix is processed and 32825 overwritten. other elements are unchanged. 32826 * if not given, automatically determined from matrix size 32827 (A must be square matrix) 32829 As the determinant is equal to the product of squares of diagonal elements, 32830 it’s not necessary to specify which triangle - lower or upper - the matrix 32834 matrix determinant. 32837 Copyright 2005-2008 by Bochkanov Sergey 32838 *************************************************************************/ 32839 double spdmatrixcholeskydet(/* Real */ ae_matrix* a, 32848 ae_assert(n>=1, "SPDMatrixCholeskyDet: N<1!
", _state); 32849 ae_assert(a->rows>=n, "SPDMatrixCholeskyDet: rows(A)<N!
", _state); 32850 ae_assert(a->cols>=n, "SPDMatrixCholeskyDet: cols(A)<N!
", _state); 32852 for(i=0; i<=n-1; i++) 32854 f = f&&ae_isfinite(a->ptr.pp_double[i][i], _state); 32856 ae_assert(f, "SPDMatrixCholeskyDet: A contains infinite
or NaN values!
", _state); 32858 for(i=0; i<=n-1; i++) 32860 result = result*ae_sqr(a->ptr.pp_double[i][i], _state); 32866 /************************************************************************* 32867 Determinant calculation of the symmetric positive definite matrix. 32870 A - matrix. Array with elements [0..N-1, 0..N-1]. 32871 N - (optional) size of matrix A: 32872 * if given, only principal NxN submatrix is processed and 32873 overwritten. other elements are unchanged. 32874 * if not given, automatically determined from matrix size 32875 (A must be square matrix) 32876 IsUpper - (optional) storage type: 32877 * if True, symmetric matrix A is given by its upper 32878 triangle, and the lower triangle isn’t used/changed by 32880 * if False, symmetric matrix A is given by its lower 32881 triangle, and the upper triangle isn’t used/changed by 32883 * if not given, both lower and upper triangles must be 32887 determinant of matrix A. 32888 If matrix A is not positive definite, exception is thrown. 32891 Copyright 2005-2008 by Bochkanov Sergey 32892 *************************************************************************/ 32893 double spdmatrixdet(/* Real */ ae_matrix* a, 32898 ae_frame _frame_block; 32903 ae_frame_make(_state, &_frame_block); 32904 ae_matrix_init_copy(&_a, a, _state, ae_true); 32907 ae_assert(n>=1, "SPDMatrixDet: N<1!
", _state); 32908 ae_assert(a->rows>=n, "SPDMatrixDet: rows(A)<N!
", _state); 32909 ae_assert(a->cols>=n, "SPDMatrixDet: cols(A)<N!
", _state); 32910 ae_assert(isfinitertrmatrix(a, n, isupper, _state), "SPDMatrixDet: A contains infinite
or NaN values!
", _state); 32911 b = spdmatrixcholesky(a, n, isupper, _state); 32912 ae_assert(b, "SPDMatrixDet: A is not SPD!
", _state); 32913 result = spdmatrixcholeskydet(a, n, _state); 32914 ae_frame_leave(_state); 32921 /************************************************************************* 32922 Algorithm for solving the following generalized symmetric positive-definite 32924 A*x = lambda*B*x (1) or 32925 A*B*x = lambda*x (2) or 32926 B*A*x = lambda*x (3). 32927 where A is a symmetric matrix, B - symmetric positive-definite matrix. 32928 The problem is solved by reducing it to an ordinary symmetric eigenvalue 32932 A - symmetric matrix which is given by its upper or lower 32934 Array whose indexes range within [0..N-1, 0..N-1]. 32935 N - size of matrices A and B. 32936 IsUpperA - storage format of matrix A. 32937 B - symmetric positive-definite matrix which is given by 32938 its upper or lower triangular part. 32939 Array whose indexes range within [0..N-1, 0..N-1]. 32940 IsUpperB - storage format of matrix B. 32941 ZNeeded - if ZNeeded is equal to: 32942 * 0, the eigenvectors are not returned; 32943 * 1, the eigenvectors are returned. 32944 ProblemType - if ProblemType is equal to: 32945 * 1, the following problem is solved: A*x = lambda*B*x; 32946 * 2, the following problem is solved: A*B*x = lambda*x; 32947 * 3, the following problem is solved: B*A*x = lambda*x. 32950 D - eigenvalues in ascending order. 32951 Array whose index ranges within [0..N-1]. 32952 Z - if ZNeeded is equal to: 32953 * 0, Z hasn’t changed; 32954 * 1, Z contains eigenvectors. 32955 Array whose indexes range within [0..N-1, 0..N-1]. 32956 The eigenvectors are stored in matrix columns. It should 32957 be noted that the eigenvectors in such problems do not 32958 form an orthogonal system. 32961 True, if the problem was solved successfully. 32962 False, if the error occurred during the Cholesky decomposition of matrix 32963 B (the matrix isn’t positive-definite) or during the work of the iterative 32964 algorithm for solving the symmetric eigenproblem. 32966 See also the GeneralizedSymmetricDefiniteEVDReduce subroutine. 32969 Copyright 1.28.2006 by Bochkanov Sergey 32970 *************************************************************************/ 32971 ae_bool smatrixgevd(/* Real */ ae_matrix* a, 32974 /* Real */ ae_matrix* b, 32977 ae_int_t problemtype, 32978 /* Real */ ae_vector* d, 32979 /* Real */ ae_matrix* z, 32982 ae_frame _frame_block; 32996 ae_frame_make(_state, &_frame_block); 32997 ae_matrix_init_copy(&_a, a, _state, ae_true); 32999 ae_vector_clear(d); 33000 ae_matrix_clear(z); 33001 ae_matrix_init(&r, 0, 0, DT_REAL, _state, ae_true); 33002 ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true); 33008 result = smatrixgevdreduce(a, n, isuppera, b, isupperb, problemtype, &r, &isupperr, _state); 33011 ae_frame_leave(_state); 33014 result = smatrixevd(a, n, zneeded, isuppera, d, &t, _state); 33017 ae_frame_leave(_state); 33022 * Transform eigenvectors if needed 33028 * fill Z with zeros 33030 ae_matrix_set_length(z, n-1+1, n-1+1, _state); 33031 for(j=0; j<=n-1; j++) 33033 z->ptr.pp_double[0][j] = 0.0; 33035 for(i=1; i<=n-1; i++) 33037 ae_v_move(&z->ptr.pp_double[i][0], 1, &z->ptr.pp_double[0][0], 1, ae_v_len(0,n-1)); 33041 * Setup R properties 33061 for(i=0; i<=n-1; i++) 33063 for(j=j1; j<=j2; j++) 33065 v = r.ptr.pp_double[i][j]; 33066 ae_v_addd(&z->ptr.pp_double[i][0], 1, &t.ptr.pp_double[j][0], 1, ae_v_len(0,n-1), v); 33072 ae_frame_leave(_state); 33077 /************************************************************************* 33078 Algorithm for reduction of the following generalized symmetric positive- 33079 definite eigenvalue problem: 33080 A*x = lambda*B*x (1) or 33081 A*B*x = lambda*x (2) or 33082 B*A*x = lambda*x (3) 33083 to the symmetric eigenvalues problem C*y = lambda*y (eigenvalues of this and 33084 the given problems are the same, and the eigenvectors of the given problem 33085 could be obtained by multiplying the obtained eigenvectors by the 33086 transformation matrix x = R*y). 33088 Here A is a symmetric matrix, B - symmetric positive-definite matrix. 33091 A - symmetric matrix which is given by its upper or lower 33093 Array whose indexes range within [0..N-1, 0..N-1]. 33094 N - size of matrices A and B. 33095 IsUpperA - storage format of matrix A. 33096 B - symmetric positive-definite matrix which is given by 33097 its upper or lower triangular part. 33098 Array whose indexes range within [0..N-1, 0..N-1]. 33099 IsUpperB - storage format of matrix B. 33100 ProblemType - if ProblemType is equal to: 33101 * 1, the following problem is solved: A*x = lambda*B*x; 33102 * 2, the following problem is solved: A*B*x = lambda*x; 33103 * 3, the following problem is solved: B*A*x = lambda*x. 33106 A - symmetric matrix which is given by its upper or lower 33107 triangle depending on IsUpperA. Contains matrix C. 33108 Array whose indexes range within [0..N-1, 0..N-1]. 33109 R - upper triangular or low triangular transformation matrix 33110 which is used to obtain the eigenvectors of a given problem 33111 as the product of eigenvectors of C (from the right) and 33112 matrix R (from the left). If the matrix is upper 33113 triangular, the elements below the main diagonal 33114 are equal to 0 (and vice versa). Thus, we can perform 33115 the multiplication without taking into account the 33116 internal structure (which is an easier though less 33118 Array whose indexes range within [0..N-1, 0..N-1]. 33119 IsUpperR - type of matrix R (upper or lower triangular). 33122 True, if the problem was reduced successfully. 33123 False, if the error occurred during the Cholesky decomposition of 33124 matrix B (the matrix is not positive-definite). 33127 Copyright 1.28.2006 by Bochkanov Sergey 33128 *************************************************************************/ 33129 ae_bool smatrixgevdreduce(/* Real */ ae_matrix* a, 33132 /* Real */ ae_matrix* b, 33134 ae_int_t problemtype, 33135 /* Real */ ae_matrix* r, 33139 ae_frame _frame_block; 33151 ae_frame_make(_state, &_frame_block); 33152 ae_matrix_clear(r); 33153 *isupperr = ae_false; 33154 ae_matrix_init(&t, 0, 0, DT_REAL, _state, ae_true); 33155 ae_vector_init(&w1, 0, DT_REAL, _state, ae_true); 33156 ae_vector_init(&w2, 0, DT_REAL, _state, ae_true); 33157 ae_vector_init(&w3, 0, DT_REAL, _state, ae_true); 33158 _matinvreport_init(&rep, _state, ae_true); 33160 ae_assert(n>0, "SMatrixGEVDReduce: N<=0!
", _state); 33161 ae_assert((problemtype==1||problemtype==2)||problemtype==3, "SMatrixGEVDReduce: incorrect ProblemType!
", _state); 33165 * Problem 1: A*x = lambda*B*x 33169 * C = L^(-1) * A * L^(-T) 33172 if( problemtype==1 ) 33176 * Factorize B in T: B = LL' 33178 ae_matrix_set_length(&t, n-1+1, n-1+1, _state); 33181 for(i=0; i<=n-1; i++) 33183 ae_v_move(&t.ptr.pp_double[i][i], t.stride, &b->ptr.pp_double[i][i], 1, ae_v_len(i,n-1)); 33188 for(i=0; i<=n-1; i++) 33190 ae_v_move(&t.ptr.pp_double[i][0], 1, &b->ptr.pp_double[i][0], 1, ae_v_len(0,i)); 33193 if( !spdmatrixcholesky(&t, n, ae_false, _state) ) 33196 ae_frame_leave(_state); 33203 rmatrixtrinverse(&t, n, ae_false, ae_false, &info, &rep, _state); 33207 ae_frame_leave(_state); 33212 * Build L^(-1) * A * L^(-T) in R 33214 ae_vector_set_length(&w1, n+1, _state); 33215 ae_vector_set_length(&w2, n+1, _state); 33216 ae_matrix_set_length(r, n-1+1, n-1+1, _state); 33217 for(j=1; j<=n; j++) 33221 * Form w2 = A * l'(j) (here l'(j) is j-th column of L^(-T)) 33223 ae_v_move(&w1.ptr.p_double[1], 1, &t.ptr.pp_double[j-1][0], 1, ae_v_len(1,j)); 33224 symmetricmatrixvectormultiply(a, isuppera, 0, j-1, &w1, 1.0, &w2, _state); 33227 matrixvectormultiply(a, 0, j-1, j, n-1, ae_true, &w1, 1, j, 1.0, &w2, j+1, n, 0.0, _state); 33231 matrixvectormultiply(a, j, n-1, 0, j-1, ae_false, &w1, 1, j, 1.0, &w2, j+1, n, 0.0, _state); 33235 * Form l(i)*w2 (here l(i) is i-th row of L^(-1)) 33237 for(i=1; i<=n; i++) 33239 v = ae_v_dotproduct(&t.ptr.pp_double[i-1][0], 1, &w2.ptr.p_double[1], 1, ae_v_len(0,i-1)); 33240 r->ptr.pp_double[i-1][j-1] = v; 33247 for(i=0; i<=n-1; i++) 33249 ae_v_move(&a->ptr.pp_double[i][0], 1, &r->ptr.pp_double[i][0], 1, ae_v_len(0,n-1)); 33253 * Copy L^(-1) from T to R and transpose 33255 *isupperr = ae_true; 33256 for(i=0; i<=n-1; i++) 33258 for(j=0; j<=i-1; j++) 33260 r->ptr.pp_double[i][j] = 0; 33263 for(i=0; i<=n-1; i++) 33265 ae_v_move(&r->ptr.pp_double[i][i], 1, &t.ptr.pp_double[i][i], t.stride, ae_v_len(i,n-1)); 33267 ae_frame_leave(_state); 33272 * Problem 2: A*B*x = lambda*x 33274 * problem 3: B*A*x = lambda*x 33281 if( problemtype==2||problemtype==3 ) 33285 * Factorize B in T: B = U'*U 33287 ae_matrix_set_length(&t, n-1+1, n-1+1, _state); 33290 for(i=0; i<=n-1; i++) 33292 ae_v_move(&t.ptr.pp_double[i][i], 1, &b->ptr.pp_double[i][i], 1, ae_v_len(i,n-1)); 33297 for(i=0; i<=n-1; i++) 33299 ae_v_move(&t.ptr.pp_double[i][i], 1, &b->ptr.pp_double[i][i], b->stride, ae_v_len(i,n-1)); 33302 if( !spdmatrixcholesky(&t, n, ae_true, _state) ) 33305 ae_frame_leave(_state); 33310 * Build U * A * U' in R 33312 ae_vector_set_length(&w1, n+1, _state); 33313 ae_vector_set_length(&w2, n+1, _state); 33314 ae_vector_set_length(&w3, n+1, _state); 33315 ae_matrix_set_length(r, n-1+1, n-1+1, _state); 33316 for(j=1; j<=n; j++) 33320 * Form w2 = A * u'(j) (here u'(j) is j-th column of U') 33322 ae_v_move(&w1.ptr.p_double[1], 1, &t.ptr.pp_double[j-1][j-1], 1, ae_v_len(1,n-j+1)); 33323 symmetricmatrixvectormultiply(a, isuppera, j-1, n-1, &w1, 1.0, &w3, _state); 33324 ae_v_move(&w2.ptr.p_double[j], 1, &w3.ptr.p_double[1], 1, ae_v_len(j,n)); 33325 ae_v_move(&w1.ptr.p_double[j], 1, &t.ptr.pp_double[j-1][j-1], 1, ae_v_len(j,n)); 33328 matrixvectormultiply(a, 0, j-2, j-1, n-1, ae_false, &w1, j, n, 1.0, &w2, 1, j-1, 0.0, _state); 33332 matrixvectormultiply(a, j-1, n-1, 0, j-2, ae_true, &w1, j, n, 1.0, &w2, 1, j-1, 0.0, _state); 33336 * Form u(i)*w2 (here u(i) is i-th row of U) 33338 for(i=1; i<=n; i++) 33340 v = ae_v_dotproduct(&t.ptr.pp_double[i-1][i-1], 1, &w2.ptr.p_double[i], 1, ae_v_len(i-1,n-1)); 33341 r->ptr.pp_double[i-1][j-1] = v; 33348 for(i=0; i<=n-1; i++) 33350 ae_v_move(&a->ptr.pp_double[i][0], 1, &r->ptr.pp_double[i][0], 1, ae_v_len(0,n-1)); 33352 if( problemtype==2 ) 33358 rmatrixtrinverse(&t, n, ae_true, ae_false, &info, &rep, _state); 33362 ae_frame_leave(_state); 33367 * Copy U^-1 from T to R 33369 *isupperr = ae_true; 33370 for(i=0; i<=n-1; i++) 33372 for(j=0; j<=i-1; j++) 33374 r->ptr.pp_double[i][j] = 0; 33377 for(i=0; i<=n-1; i++) 33379 ae_v_move(&r->ptr.pp_double[i][i], 1, &t.ptr.pp_double[i][i], 1, ae_v_len(i,n-1)); 33386 * Copy U from T to R and transpose 33388 *isupperr = ae_false; 33389 for(i=0; i<=n-1; i++) 33391 for(j=i+1; j<=n-1; j++) 33393 r->ptr.pp_double[i][j] = 0; 33396 for(i=0; i<=n-1; i++) 33398 ae_v_move(&r->ptr.pp_double[i][i], r->stride, &t.ptr.pp_double[i][i], 1, ae_v_len(i,n-1)); 33402 ae_frame_leave(_state); 33409 /************************************************************************* 33410 Inverse matrix update by the Sherman-Morrison formula 33412 The algorithm updates matrix A^-1 when adding a number to an element 33416 InvA - inverse of matrix A. 33417 Array whose indexes range within [0..N-1, 0..N-1]. 33418 N - size of matrix A. 33419 UpdRow - row where the element to be updated is stored. 33420 UpdColumn - column where the element to be updated is stored. 33421 UpdVal - a number to be added to the element. 33425 InvA - inverse of modified matrix A. 33428 Copyright 2005 by Bochkanov Sergey 33429 *************************************************************************/ 33430 void rmatrixinvupdatesimple(/* Real */ ae_matrix* inva, 33433 ae_int_t updcolumn, 33437 ae_frame _frame_block; 33444 ae_frame_make(_state, &_frame_block); 33445 ae_vector_init(&t1, 0, DT_REAL, _state, ae_true); 33446 ae_vector_init(&t2, 0, DT_REAL, _state, ae_true); 33448 ae_assert(updrow>=0&&updrow<n, "RMatrixInvUpdateSimple: incorrect UpdRow!
", _state); 33449 ae_assert(updcolumn>=0&&updcolumn<n, "RMatrixInvUpdateSimple: incorrect UpdColumn!
", _state); 33450 ae_vector_set_length(&t1, n-1+1, _state); 33451 ae_vector_set_length(&t2, n-1+1, _state); 33456 ae_v_move(&t1.ptr.p_double[0], 1, &inva->ptr.pp_double[0][updrow], inva->stride, ae_v_len(0,n-1)); 33461 ae_v_move(&t2.ptr.p_double[0], 1, &inva->ptr.pp_double[updcolumn][0], 1, ae_v_len(0,n-1)); 33464 * Lambda = v * InvA * U 33466 lambdav = updval*inva->ptr.pp_double[updcolumn][updrow]; 33469 * InvA = InvA - correction 33471 for(i=0; i<=n-1; i++) 33473 vt = updval*t1.ptr.p_double[i]; 33474 vt = vt/(1+lambdav); 33475 ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt); 33477 ae_frame_leave(_state); 33481 /************************************************************************* 33482 Inverse matrix update by the Sherman-Morrison formula 33484 The algorithm updates matrix A^-1 when adding a vector to a row 33488 InvA - inverse of matrix A. 33489 Array whose indexes range within [0..N-1, 0..N-1]. 33490 N - size of matrix A. 33491 UpdRow - the row of A whose vector V was added. 33493 V - the vector to be added to a row. 33494 Array whose index ranges within [0..N-1]. 33497 InvA - inverse of modified matrix A. 33500 Copyright 2005 by Bochkanov Sergey 33501 *************************************************************************/ 33502 void rmatrixinvupdaterow(/* Real */ ae_matrix* inva, 33505 /* Real */ ae_vector* v, 33508 ae_frame _frame_block; 33516 ae_frame_make(_state, &_frame_block); 33517 ae_vector_init(&t1, 0, DT_REAL, _state, ae_true); 33518 ae_vector_init(&t2, 0, DT_REAL, _state, ae_true); 33520 ae_vector_set_length(&t1, n-1+1, _state); 33521 ae_vector_set_length(&t2, n-1+1, _state); 33526 ae_v_move(&t1.ptr.p_double[0], 1, &inva->ptr.pp_double[0][updrow], inva->stride, ae_v_len(0,n-1)); 33530 * Lambda = v * InvA * U 33532 for(j=0; j<=n-1; j++) 33534 vt = ae_v_dotproduct(&v->ptr.p_double[0], 1, &inva->ptr.pp_double[0][j], inva->stride, ae_v_len(0,n-1)); 33535 t2.ptr.p_double[j] = vt; 33537 lambdav = t2.ptr.p_double[updrow]; 33540 * InvA = InvA - correction 33542 for(i=0; i<=n-1; i++) 33544 vt = t1.ptr.p_double[i]/(1+lambdav); 33545 ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt); 33547 ae_frame_leave(_state); 33551 /************************************************************************* 33552 Inverse matrix update by the Sherman-Morrison formula 33554 The algorithm updates matrix A^-1 when adding a vector to a column 33558 InvA - inverse of matrix A. 33559 Array whose indexes range within [0..N-1, 0..N-1]. 33560 N - size of matrix A. 33561 UpdColumn - the column of A whose vector U was added. 33562 0 <= UpdColumn <= N-1 33563 U - the vector to be added to a column. 33564 Array whose index ranges within [0..N-1]. 33567 InvA - inverse of modified matrix A. 33570 Copyright 2005 by Bochkanov Sergey 33571 *************************************************************************/ 33572 void rmatrixinvupdatecolumn(/* Real */ ae_matrix* inva, 33574 ae_int_t updcolumn, 33575 /* Real */ ae_vector* u, 33578 ae_frame _frame_block; 33585 ae_frame_make(_state, &_frame_block); 33586 ae_vector_init(&t1, 0, DT_REAL, _state, ae_true); 33587 ae_vector_init(&t2, 0, DT_REAL, _state, ae_true); 33589 ae_vector_set_length(&t1, n-1+1, _state); 33590 ae_vector_set_length(&t2, n-1+1, _state); 33594 * Lambda = v * InvA * U 33596 for(i=0; i<=n-1; i++) 33598 vt = ae_v_dotproduct(&inva->ptr.pp_double[i][0], 1, &u->ptr.p_double[0], 1, ae_v_len(0,n-1)); 33599 t1.ptr.p_double[i] = vt; 33601 lambdav = t1.ptr.p_double[updcolumn]; 33606 ae_v_move(&t2.ptr.p_double[0], 1, &inva->ptr.pp_double[updcolumn][0], 1, ae_v_len(0,n-1)); 33609 * InvA = InvA - correction 33611 for(i=0; i<=n-1; i++) 33613 vt = t1.ptr.p_double[i]/(1+lambdav); 33614 ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt); 33616 ae_frame_leave(_state); 33620 /************************************************************************* 33621 Inverse matrix update by the Sherman-Morrison formula 33623 The algorithm computes the inverse of matrix A+u*v’ by using the given matrix 33624 A^-1 and the vectors u and v. 33627 InvA - inverse of matrix A. 33628 Array whose indexes range within [0..N-1, 0..N-1]. 33629 N - size of matrix A. 33630 U - the vector modifying the matrix. 33631 Array whose index ranges within [0..N-1]. 33632 V - the vector modifying the matrix. 33633 Array whose index ranges within [0..N-1]. 33636 InvA - inverse of matrix A + u*v'. 33639 Copyright 2005 by Bochkanov Sergey 33640 *************************************************************************/ 33641 void rmatrixinvupdateuv(/* Real */ ae_matrix* inva, 33643 /* Real */ ae_vector* u, 33644 /* Real */ ae_vector* v, 33647 ae_frame _frame_block; 33655 ae_frame_make(_state, &_frame_block); 33656 ae_vector_init(&t1, 0, DT_REAL, _state, ae_true); 33657 ae_vector_init(&t2, 0, DT_REAL, _state, ae_true); 33659 ae_vector_set_length(&t1, n-1+1, _state); 33660 ae_vector_set_length(&t2, n-1+1, _state); 33666 for(i=0; i<=n-1; i++) 33668 vt = ae_v_dotproduct(&inva->ptr.pp_double[i][0], 1, &u->ptr.p_double[0], 1, ae_v_len(0,n-1)); 33669 t1.ptr.p_double[i] = vt; 33671 lambdav = ae_v_dotproduct(&v->ptr.p_double[0], 1, &t1.ptr.p_double[0], 1, ae_v_len(0,n-1)); 33676 for(j=0; j<=n-1; j++) 33678 vt = ae_v_dotproduct(&v->ptr.p_double[0], 1, &inva->ptr.pp_double[0][j], inva->stride, ae_v_len(0,n-1)); 33679 t2.ptr.p_double[j] = vt; 33683 * InvA = InvA - correction 33685 for(i=0; i<=n-1; i++) 33687 vt = t1.ptr.p_double[i]/(1+lambdav); 33688 ae_v_subd(&inva->ptr.pp_double[i][0], 1, &t2.ptr.p_double[0], 1, ae_v_len(0,n-1), vt); 33690 ae_frame_leave(_state); 33696 /************************************************************************* 33697 Subroutine performing the Schur decomposition of a general matrix by using 33698 the QR algorithm with multiple shifts. 33700 The source matrix A is represented as S'*A*S = T, where S is an orthogonal 33701 matrix (Schur vectors), T - upper quasi-triangular matrix (with blocks of 33702 sizes 1x1 and 2x2 on the main diagonal). 33705 A - matrix to be decomposed. 33706 Array whose indexes range within [0..N-1, 0..N-1]. 33707 N - size of A, N>=0. 33711 A - contains matrix T. 33712 Array whose indexes range within [0..N-1, 0..N-1]. 33713 S - contains Schur vectors. 33714 Array whose indexes range within [0..N-1, 0..N-1]. 33717 The block structure of matrix T can be easily recognized: since all 33718 the elements below the blocks are zeros, the elements a[i+1,i] which 33719 are equal to 0 show the block border. 33722 The algorithm performance depends on the value of the internal parameter 33723 NS of the InternalSchurDecomposition subroutine which defines the number 33724 of shifts in the QR algorithm (similarly to the block width in block-matrix 33725 algorithms in linear algebra). If you require maximum performance on 33726 your machine, it is recommended to adjust this parameter manually. 33730 if the algorithm has converged and parameters A and S contain the result. 33732 if the algorithm has not converged. 33734 Algorithm implemented on the basis of the DHSEQR subroutine (LAPACK 3.0 library). 33735 *************************************************************************/ 33736 ae_bool rmatrixschur(/* Real */ ae_matrix* a, 33738 /* Real */ ae_matrix* s, 33741 ae_frame _frame_block; 33752 ae_frame_make(_state, &_frame_block); 33753 ae_matrix_clear(s); 33754 ae_vector_init(&tau, 0, DT_REAL, _state, ae_true); 33755 ae_vector_init(&wi, 0, DT_REAL, _state, ae_true); 33756 ae_vector_init(&wr, 0, DT_REAL, _state, ae_true); 33757 ae_matrix_init(&a1, 0, 0, DT_REAL, _state, ae_true); 33758 ae_matrix_init(&s1, 0, 0, DT_REAL, _state, ae_true); 33762 * Upper Hessenberg form of the 0-based matrix 33764 rmatrixhessenberg(a, n, &tau, _state); 33765 rmatrixhessenbergunpackq(a, n, &tau, s, _state); 33768 * Convert from 0-based arrays to 1-based, 33769 * then call InternalSchurDecomposition 33770 * Awkward, of course, but Schur decompisiton subroutine 33771 * is too complex to fix it. 33774 ae_matrix_set_length(&a1, n+1, n+1, _state); 33775 ae_matrix_set_length(&s1, n+1, n+1, _state); 33776 for(i=1; i<=n; i++) 33778 for(j=1; j<=n; j++) 33780 a1.ptr.pp_double[i][j] = a->ptr.pp_double[i-1][j-1]; 33781 s1.ptr.pp_double[i][j] = s->ptr.pp_double[i-1][j-1]; 33784 internalschurdecomposition(&a1, n, 1, 1, &wr, &wi, &s1, &info, _state); 33788 * convert from 1-based arrays to -based 33790 for(i=1; i<=n; i++) 33792 for(j=1; j<=n; j++) 33794 a->ptr.pp_double[i-1][j-1] = a1.ptr.pp_double[i][j]; 33795 s->ptr.pp_double[i-1][j-1] = s1.ptr.pp_double[i][j]; 33798 ae_frame_leave(_state); void smp_rmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
void hpdmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
void cmatrixlu(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *pivots, ae_state *_state)
ae_bool spdmatrixcholesky(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
ae_int_t sparsegetncols(const sparsematrix &s)
void ae_v_cmove(ae_complex *vdst, ae_int_t stride_dst, const ae_complex *vsrc, ae_int_t stride_src, const char *conj_src, ae_int_t n)
void smp_cmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const alglib::complex alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const complex_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const alglib::complex beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc)
struct alglib_impl::ae_state ae_state
double rmatrixrcond1(ae_matrix *a, ae_int_t n, ae_state *_state)
void cmatrixinverse(complex_2d_array &a, const ae_int_t n, ae_int_t &info, matinvreport &rep)
double rmatrixrcondinf(ae_matrix *a, ae_int_t n, ae_state *_state)
ae_int_t ablasblocksize(ae_matrix *a, ae_state *_state)
double sparseget(sparsematrix *s, ae_int_t i, ae_int_t j, ae_state *_state)
double cmatrixtrrcondinf(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
void smp_rmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const real_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc)
alglib_impl::matinvreport * p_struct
void rmatrixlqunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qrows, ae_matrix *q, ae_state *_state)
void cmatrixtranspose(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_2d_array &b, const ae_int_t ib, const ae_int_t jb)
void rmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const real_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc)
void rmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
double spdmatrixcholeskydet(ae_matrix *a, ae_int_t n, ae_state *_state)
void sparsecopy(sparsematrix *s0, sparsematrix *s1, ae_state *_state)
void rmatrixmv(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t opa, const real_1d_array &x, const ae_int_t ix, real_1d_array &y, const ae_int_t iy)
void ablascomplexsplitlength(ae_matrix *a, ae_int_t n, ae_int_t *n1, ae_int_t *n2, ae_state *_state)
void sparsemm2(const sparsematrix &s, const real_2d_array &a, const ae_int_t k, real_2d_array &b0, real_2d_array &b1)
ae_int_t sparsegetnrows(sparsematrix *s, ae_state *_state)
void sparseconverttohash(const sparsematrix &s)
void cmatrixqr(complex_2d_array &a, const ae_int_t m, const ae_int_t n, complex_1d_array &tau)
void rmatrixqr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
void rmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
ae_bool rmatrixsyrkf(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void cmatrixlq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
void sparsemv(sparsematrix *s, ae_vector *x, ae_vector *y, ae_state *_state)
void rmatrixbdmultiplybyp(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *taup, ae_matrix *z, ae_int_t zrows, ae_int_t zcolumns, ae_bool fromtheright, ae_bool dotranspose, ae_state *_state)
void cmatrixlq(complex_2d_array &a, const ae_int_t m, const ae_int_t n, complex_1d_array &tau)
bool sparserewriteexisting(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
_matinvreport_owner & operator=(const _matinvreport_owner &rhs)
ae_bool ae_is_symmetric(ae_matrix *a)
double sparsegetdiagonal(const sparsematrix &s, const ae_int_t i)
void normestimatorsetseed(const normestimatorstate &state, const ae_int_t seedval)
void write(std::ostream &os, const datablock &db)
void ae_v_muld(double *vdst, ae_int_t stride_dst, ae_int_t n, double alpha)
void rmatrixbdunpackdiagonals(ae_matrix *b, ae_int_t m, ae_int_t n, ae_bool *isupper, ae_vector *d, ae_vector *e, ae_state *_state)
normestimatorstate & operator=(const normestimatorstate &rhs)
double sparseget(const sparsematrix &s, const ae_int_t i, const ae_int_t j)
void hmatrixtdunpackq(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_matrix *q, ae_state *_state)
void sparsegetrow(const sparsematrix &s, const ae_int_t i, real_1d_array &irow)
alglib_impl::normestimatorstate * c_ptr()
double spdmatrixcholeskydet(const real_2d_array &a, const ae_int_t n)
void smp_cmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
ae_bool rmatrixsyrkmkl(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void sparseresizematrix(sparsematrix *s, ae_state *_state)
void normestimatorsetseed(normestimatorstate *state, ae_int_t seedval, ae_state *_state)
ae_bool cmatrixrank1f(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
void cmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
ae_bool smatrixevdr(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, double b1, double b2, ae_int_t *m, ae_vector *w, ae_matrix *z, ae_state *_state)
void * ae_malloc(size_t size, ae_state *state)
void _normestimatorstate_clear(void *_p)
ae_bool hmatrixevdi(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_int_t i1, ae_int_t i2, ae_vector *w, ae_matrix *z, ae_state *_state)
sparsematrix & operator=(const sparsematrix &rhs)
ae_bool _sparsematrix_init(void *_p, ae_state *_state, ae_bool make_automatic)
double beta(const double a, const double b)
void _sparsematrix_clear(void *_p)
double rmatrixludet(const real_2d_array &a, const integer_1d_array &pivots, const ae_int_t n)
union alglib_impl::ae_matrix::@12 ptr
void cmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
void _pexec_rmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
_normestimatorstate_owner()
void ae_frame_make(ae_state *state, ae_frame *tmp)
bool smatrixgevd(const real_2d_array &a, const ae_int_t n, const bool isuppera, const real_2d_array &b, const bool isupperb, const ae_int_t zneeded, const ae_int_t problemtype, real_1d_array &d, real_2d_array &z)
void cmatrixcopy(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_2d_array &b, const ae_int_t ib, const ae_int_t jb)
void normestimatorresults(normestimatorstate *state, double *nrm, ae_state *_state)
void _pexec_rmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void cmatrixgemmk(ae_int_t m, ae_int_t n, ae_int_t k, ae_complex alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, ae_complex beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
ae_bool hpdmatrixcholesky(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
ae_int_t ablascomplexblocksize(ae_matrix *a, ae_state *_state)
ae_bool smatrixgevdreduce(ae_matrix *a, ae_int_t n, ae_bool isuppera, ae_matrix *b, ae_bool isupperb, ae_int_t problemtype, ae_matrix *r, ae_bool *isupperr, ae_state *_state)
alglib_impl::sparsematrix * p_struct
ae_complex ae_c_conj(ae_complex lhs, ae_state *state)
void smatrixrndmultiply(ae_matrix *a, ae_int_t n, ae_state *_state)
ae_complex ae_complex_from_d(double v)
void cmatrixtrinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit, ae_int_t &info, matinvreport &rep)
void sparsecopytocrs(const sparsematrix &s0, sparsematrix &s1)
ae_bool ae_force_hermitian(ae_matrix *a)
ae_bool rmatrixschur(ae_matrix *a, ae_int_t n, ae_matrix *s, ae_state *_state)
void cmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
double rmatrixdet(ae_matrix *a, ae_int_t n, ae_state *_state)
void cmatrixlqunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qrows, ae_matrix *q, ae_state *_state)
void rmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
void _pexec_rmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
void sparsemtv(sparsematrix *s, ae_vector *x, ae_vector *y, ae_state *_state)
ae_int_t sparsegetmatrixtype(const sparsematrix &s)
double cmatrixlurcond1(ae_matrix *lua, ae_int_t n, ae_state *_state)
void cmatrixqr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
ae_bool _matinvreport_init_copy(void *_dst, void *_src, ae_state *_state, ae_bool make_automatic)
void cmatrixmv(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
double spdmatrixdet(const real_2d_array &a, const ae_int_t n, const bool isupper)
void ae_state_clear(ae_state *state)
void rmatrixinvupdaterow(ae_matrix *inva, ae_int_t n, ae_int_t updrow, ae_vector *v, ae_state *_state)
const alglib_impl::ae_matrix * c_ptr() const
void sparsesmm(sparsematrix *s, ae_bool isupper, ae_matrix *a, ae_int_t k, ae_matrix *b, ae_state *_state)
void rmatrixgemmk(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
ae_bool ae_fp_eq(double v1, double v2)
double rmatrixludet(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_state *_state)
void sparsemtm(sparsematrix *s, ae_matrix *a, ae_int_t k, ae_matrix *b, ae_state *_state)
void rmatrixhessenberg(ae_matrix *a, ae_int_t n, ae_vector *tau, ae_state *_state)
ae_bool sparserewriteexisting(sparsematrix *s, ae_int_t i, ae_int_t j, double v, ae_state *_state)
void sparseconverttocrs(sparsematrix *s, ae_state *_state)
double spdmatrixdet(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
void ae_v_cmulc(ae_complex *vdst, ae_int_t stride_dst, ae_int_t n, ae_complex alpha)
void rmatrixinvupdateuv(real_2d_array &inva, const ae_int_t n, const real_1d_array &u, const real_1d_array &v)
void sparsecopytohash(const sparsematrix &s0, sparsematrix &s1)
void rmatrixinvupdatecolumn(real_2d_array &inva, const ae_int_t n, const ae_int_t updcolumn, const real_1d_array &u)
void cmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
void sparsemtv(const sparsematrix &s, const real_1d_array &x, real_1d_array &y)
ae_bool rmatrixlefttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_int_t sparsegetmatrixtype(sparsematrix *s, ae_state *_state)
void rmatrixenforcesymmetricity(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
ae_bool ae_matrix_init(ae_matrix *dst, ae_int_t rows, ae_int_t cols, ae_datatype datatype, ae_state *state, ae_bool make_automatic)
ql0001_ & k(htemp+1),(cvec+1),(atemp+1),(bj+1),(bl+1),(bu+1),(x+1),(clamda+1), &iout, infoqp, &zero,(w+1), &lenw,(iw+1), &leniw, &glob_grd.epsmac
void cmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
void sparsemv2(const sparsematrix &s, const real_1d_array &x, real_1d_array &y0, real_1d_array &y1)
bool smatrixgevdreduce(real_2d_array &a, const ae_int_t n, const bool isuppera, const real_2d_array &b, const bool isupperb, const ae_int_t problemtype, real_2d_array &r, bool &isupperr)
ae_complex cmatrixdet(ae_matrix *a, ae_int_t n, ae_state *_state)
void cmatrixrndorthogonalfromtheright(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
void sparseconverttohash(sparsematrix *s, ae_state *_state)
double hpdmatrixrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
void cmatrixlqunpackl(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *l, ae_state *_state)
void sparseset(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
void rmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void spdmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
void rmatrixrndorthogonal(ae_int_t n, ae_matrix *a, ae_state *_state)
ae_bool sparseishash(sparsematrix *s, ae_state *_state)
void hmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
void sparsemtm(const sparsematrix &s, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
void normestimatorcreate(const ae_int_t m, const ae_int_t n, const ae_int_t nstart, const ae_int_t nits, normestimatorstate &state)
void rmatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
void sparseset(sparsematrix *s, ae_int_t i, ae_int_t j, double v, ae_state *_state)
void rmatrixrndorthogonalfromtheleft(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
ae_int_t ae_v_len(ae_int_t a, ae_int_t b)
void rmatrixlqunpackl(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *l, ae_state *_state)
void rmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
ae_bool cmatrixsyrkf(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
bool rmatrixschur(real_2d_array &a, const ae_int_t n, real_2d_array &s)
void rmatrixtrinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_int_t *info, matinvreport *rep, ae_state *_state)
void rmatrixluinverse(real_2d_array &a, const integer_1d_array &pivots, const ae_int_t n, ae_int_t &info, matinvreport &rep)
void cmatrixqrunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qcolumns, ae_matrix *q, ae_state *_state)
matinvreport & operator=(const matinvreport &rhs)
void sparsemv(const sparsematrix &s, const real_1d_array &x, real_1d_array &y)
alglib::complex cmatrixdet(const complex_2d_array &a, const ae_int_t n)
void sparsesmm(const sparsematrix &s, const bool isupper, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
ae_bool _normestimatorstate_init_copy(void *_dst, void *_src, ae_state *_state, ae_bool make_automatic)
virtual ~_normestimatorstate_owner()
void sparsecreate(const ae_int_t m, const ae_int_t n, const ae_int_t k, sparsematrix &s)
void hpdmatrixinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
void smp_cmatrixlefttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
void sparsesmv(const sparsematrix &s, const bool isupper, const real_1d_array &x, real_1d_array &y)
void rmatrixcopy(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
void ae_v_move(double *vdst, ae_int_t stride_dst, const double *vsrc, ae_int_t stride_src, ae_int_t n)
void rmatrixtrinverse(real_2d_array &a, const ae_int_t n, const bool isupper, const bool isunit, ae_int_t &info, matinvreport &rep)
ae_complex ae_c_div(ae_complex lhs, ae_complex rhs)
void sparsemm(sparsematrix *s, ae_matrix *a, ae_int_t k, ae_matrix *b, ae_state *_state)
void rmatrixqrunpackq(const real_2d_array &a, const ae_int_t m, const ae_int_t n, const real_1d_array &tau, const ae_int_t qcolumns, real_2d_array &q)
double cmatrixtrrcond1(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
ae_complex ae_c_add(ae_complex lhs, ae_complex rhs)
void rmatrixbdunpackq(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *tauq, ae_int_t qcolumns, ae_matrix *q, ae_state *_state)
void cmatrixmv(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t opa, const complex_1d_array &x, const ae_int_t ix, complex_1d_array &y, const ae_int_t iy)
void ae_vector_clear(ae_vector *dst)
void ae_v_csubc(ae_complex *vdst, ae_int_t stride_dst, const ae_complex *vsrc, ae_int_t stride_src, const char *conj_src, ae_int_t n, ae_complex alpha)
void hpdmatrixcholeskyinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
ae_bool ae_force_symmetric(ae_matrix *a)
void smatrixrndcond(ae_int_t n, double c, ae_matrix *a, ae_state *_state)
void rmatrixcopy(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_2d_array &b, const ae_int_t ib, const ae_int_t jb)
void rmatrixqr(real_2d_array &a, const ae_int_t m, const ae_int_t n, real_1d_array &tau)
void rmatrixtranspose(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_2d_array &b, const ae_int_t ib, const ae_int_t jb)
void spdmatrixinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
void sparsecreatecrs(const ae_int_t m, const ae_int_t n, const integer_1d_array &ner, sparsematrix &s)
void cmatrixtrinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_int_t *info, matinvreport *rep, ae_state *_state)
void rmatrixinvupdaterow(real_2d_array &inva, const ae_int_t n, const ae_int_t updrow, const real_1d_array &v)
void sparsefree(sparsematrix &s)
ae_bool cmatrixmvf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
void sparsemv2(sparsematrix *s, ae_vector *x, ae_vector *y0, ae_vector *y1, ae_state *_state)
virtual ~_sparsematrix_owner()
double cmatrixrcondinf(ae_matrix *a, ae_int_t n, ae_state *_state)
void cmatrixrank1(const ae_int_t m, const ae_int_t n, complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, complex_1d_array &u, const ae_int_t iu, complex_1d_array &v, const ae_int_t iv)
void rmatrixinvupdatesimple(ae_matrix *inva, ae_int_t n, ae_int_t updrow, ae_int_t updcolumn, double updval, ae_state *_state)
void hmatrixtd(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_vector *d, ae_vector *e, ae_state *_state)
void sparsegetrow(sparsematrix *s, ae_int_t i, ae_vector *irow, ae_state *_state)
void ae_v_caddc(ae_complex *vdst, ae_int_t stride_dst, const ae_complex *vsrc, ae_int_t stride_src, const char *conj_src, ae_int_t n, ae_complex alpha)
void _pexec_cmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
void _pexec_cmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, ae_complex alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, ae_complex beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
void sparsecreatecrs(ae_int_t m, ae_int_t n, ae_vector *ner, sparsematrix *s, ae_state *_state)
void rmatrixhessenbergunpackh(ae_matrix *a, ae_int_t n, ae_matrix *h, ae_state *_state)
void rmatrixinvupdateuv(ae_matrix *inva, ae_int_t n, ae_vector *u, ae_vector *v, ae_state *_state)
void rmatrixlu(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *pivots, ae_state *_state)
ae_complex ae_c_sub(ae_complex lhs, ae_complex rhs)
ae_bool ae_fp_neq(double v1, double v2)
void _pexec_cmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_bool rmatrixmvf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
bool sparseishash(const sparsematrix &s)
void rmatrixtranspose(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
double rmatrixtrrcond1(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
void cmatrixrank1(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
void cmatrixinverse(ae_matrix *a, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
__host__ __device__ float length(float2 v)
void hpdmatrixcholeskyinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
void sparsecopytohash(sparsematrix *s0, sparsematrix *s1, ae_state *_state)
void rmatrixinverse(ae_matrix *a, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
void sparseadd(const sparsematrix &s, const ae_int_t i, const ae_int_t j, const double v)
void sparseadd(sparsematrix *s, ae_int_t i, ae_int_t j, double v, ae_state *_state)
void rmatrixinvupdatecolumn(ae_matrix *inva, ae_int_t n, ae_int_t updcolumn, ae_vector *u, ae_state *_state)
void rmatrixrank1(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
void rmatrixbdmultiplybyq(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *tauq, ae_matrix *z, ae_int_t zrows, ae_int_t zcolumns, ae_bool fromtheright, ae_bool dotranspose, ae_state *_state)
ae_complex ae_v_cdotproduct(const ae_complex *v0, ae_int_t stride0, const char *conj0, const ae_complex *v1, ae_int_t stride1, const char *conj1, ae_int_t n)
void rmatrixlq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_state *_state)
void rmatrixinvupdatesimple(real_2d_array &inva, const ae_int_t n, const ae_int_t updrow, const ae_int_t updcolumn, const double updval)
ae_bool sparseiscrs(sparsematrix *s, ae_state *_state)
ae_bool sparseenumerate(sparsematrix *s, ae_int_t *t0, ae_int_t *t1, ae_int_t *i, ae_int_t *j, double *v, ae_state *_state)
void rmatrixrank1(const ae_int_t m, const ae_int_t n, real_2d_array &a, const ae_int_t ia, const ae_int_t ja, real_1d_array &u, const ae_int_t iu, real_1d_array &v, const ae_int_t iv)
ae_bool ae_vector_set_length(ae_vector *dst, ae_int_t newsize, ae_state *state)
alglib_impl::ae_complex * c_ptr()
double cmatrixlurcondinf(ae_matrix *lua, ae_int_t n, ae_state *_state)
ae_int_t ablasmicroblocksize(ae_state *_state)
void applyreflectionfromtheleft(ae_matrix *c, double tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
ae_bool hmatrixevd(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_vector *d, ae_matrix *z, ae_state *_state)
ae_bool smatrixgevd(ae_matrix *a, ae_int_t n, ae_bool isuppera, ae_matrix *b, ae_bool isupperb, ae_int_t zneeded, ae_int_t problemtype, ae_vector *d, ae_matrix *z, ae_state *_state)
void applyreflectionfromtheright(ae_matrix *c, double tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
void normestimatorresults(const normestimatorstate &state, double &nrm)
void smp_rmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
ae_int_t sparsegetncols(sparsematrix *s, ae_state *_state)
void _matinvreport_clear(void *_p)
void normestimatorcreate(ae_int_t m, ae_int_t n, ae_int_t nstart, ae_int_t nits, normestimatorstate *state, ae_state *_state)
ae_bool smatrixtdevdi(ae_vector *d, ae_vector *e, ae_int_t n, ae_int_t zneeded, ae_int_t i1, ae_int_t i2, ae_matrix *z, ae_state *_state)
double rmatrixdet(const real_2d_array &a, const ae_int_t n)
double rmatrixlurcond1(ae_matrix *lua, ae_int_t n, ae_state *_state)
ae_complex cmatrixludet(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_state *_state)
double rmatrixtrrcondinf(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_bool isunit, ae_state *_state)
virtual ~normestimatorstate()
struct alglib_impl::ae_vector ae_vector
void ablassplitlength(ae_matrix *a, ae_int_t n, ae_int_t *n1, ae_int_t *n2, ae_state *_state)
const alglib_impl::ae_vector * c_ptr() const
void rmatrixmv(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t opa, ae_vector *x, ae_int_t ix, ae_vector *y, ae_int_t iy, ae_state *_state)
void rmatrixqrunpackr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *r, ae_state *_state)
ae_complex ae_c_d_div(double lhs, ae_complex rhs)
ae_bool rmatrixrighttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
void cmatrixgemm(const ae_int_t m, const ae_int_t n, const ae_int_t k, const alglib::complex alpha, const complex_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const complex_2d_array &b, const ae_int_t ib, const ae_int_t jb, const ae_int_t optypeb, const alglib::complex beta, const complex_2d_array &c, const ae_int_t ic, const ae_int_t jc)
void smp_rmatrixsyrk(const ae_int_t n, const ae_int_t k, const double alpha, const real_2d_array &a, const ae_int_t ia, const ae_int_t ja, const ae_int_t optypea, const double beta, const real_2d_array &c, const ae_int_t ic, const ae_int_t jc, const bool isupper)
void sparseresizematrix(const sparsematrix &s)
_sparsematrix_owner & operator=(const _sparsematrix_owner &rhs)
void spdmatrixinverse(real_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
double spdmatrixrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
ae_bool rmatrixevd(ae_matrix *a, ae_int_t n, ae_int_t vneeded, ae_vector *wr, ae_vector *wi, ae_matrix *vl, ae_matrix *vr, ae_state *_state)
void cmatrixgemm(ae_int_t m, ae_int_t n, ae_int_t k, ae_complex alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, ae_complex beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
void rmatrixqrunpackq(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tau, ae_int_t qcolumns, ae_matrix *q, ae_state *_state)
double cmatrixrcond1(ae_matrix *a, ae_int_t n, ae_state *_state)
struct alglib_impl::ae_matrix ae_matrix
ae_bool rmatrixbdsvd(ae_vector *d, ae_vector *e, ae_int_t n, ae_bool isupper, ae_bool isfractionalaccuracyrequired, ae_matrix *u, ae_int_t nru, ae_matrix *c, ae_int_t ncc, ae_matrix *vt, ae_int_t ncvt, ae_state *_state)
ae_bool smatrixtdevd(ae_vector *d, ae_vector *e, ae_int_t n, ae_int_t zneeded, ae_matrix *z, ae_state *_state)
void cmatrixlefttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_bool cmatrixlefttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_bool rmatrixsvd(ae_matrix *a, ae_int_t m, ae_int_t n, ae_int_t uneeded, ae_int_t vtneeded, ae_int_t additionalmemory, ae_vector *w, ae_matrix *u, ae_matrix *vt, ae_state *_state)
void ae_state_init(ae_state *state)
void rmatrixhessenbergunpackq(ae_matrix *a, ae_int_t n, ae_vector *tau, ae_matrix *q, ae_state *_state)
void cmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void rmatrixluinverse(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
void rmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const real_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const real_2d_array &x, const ae_int_t i2, const ae_int_t j2)
void ae_assert(ae_bool cond, const char *msg, ae_state *state)
union alglib_impl::ae_vector::@11 ptr
bool sparseenumerate(const sparsematrix &s, ae_int_t &t0, ae_int_t &t1, ae_int_t &i, ae_int_t &j, double &v)
double spdmatrixcholeskyrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
bool sparseiscrs(const sparsematrix &s)
void cmatrixtranspose(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
ae_bool smatrixevdi(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_int_t i1, ae_int_t i2, ae_vector *w, ae_matrix *z, ae_state *_state)
ae_int_t sparsegetnrows(const sparsematrix &s)
_normestimatorstate_owner & operator=(const _normestimatorstate_owner &rhs)
const char *volatile error_msg
void cmatrixrndorthogonalfromtheleft(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
void rmatrixenforcesymmetricity(const real_2d_array &a, const ae_int_t n, const bool isupper)
void sparseconverttocrs(const sparsematrix &s)
ae_bool hmatrixevdr(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, double b1, double b2, ae_int_t *m, ae_vector *w, ae_matrix *z, ae_state *_state)
void sparsemm(const sparsematrix &s, const real_2d_array &a, const ae_int_t k, real_2d_array &b)
void rmatrixbdunpackpt(ae_matrix *qp, ae_int_t m, ae_int_t n, ae_vector *taup, ae_int_t ptrows, ae_matrix *pt, ae_state *_state)
void cmatrixqrunpackr(ae_matrix *a, ae_int_t m, ae_int_t n, ae_matrix *r, ae_state *_state)
void complexapplyreflectionfromtheright(ae_matrix *c, ae_complex tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
void _pexec_rmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
void hpdmatrixinverse(complex_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
void ae_v_subd(double *vdst, ae_int_t stride_dst, const double *vsrc, ae_int_t stride_src, ae_int_t n, double alpha)
ae_bool ae_vector_init(ae_vector *dst, ae_int_t size, ae_datatype datatype, ae_state *state, ae_bool make_automatic)
ae_int_t ae_maxint(ae_int_t m1, ae_int_t m2, ae_state *state)
ae_complex ae_c_mul_d(ae_complex lhs, double rhs)
void sparsefree(sparsematrix *s, ae_state *_state)
void rmatrixlqbasecase(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *work, ae_vector *t, ae_vector *tau, ae_state *_state)
void cmatrixrndorthogonal(ae_int_t n, ae_matrix *a, ae_state *_state)
void complexapplyreflectionfromtheleft(ae_matrix *c, ae_complex tau, ae_vector *v, ae_int_t m1, ae_int_t m2, ae_int_t n1, ae_int_t n2, ae_vector *work, ae_state *_state)
void rmatrixinverse(real_2d_array &a, const ae_int_t n, ae_int_t &info, matinvreport &rep)
void sparsecreate(ae_int_t m, ae_int_t n, ae_int_t k, sparsematrix *s, ae_state *_state)
ae_bool _normestimatorstate_init(void *_p, ae_state *_state, ae_bool make_automatic)
void rmatrixbd(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *tauq, ae_vector *taup, ae_state *_state)
ae_bool smatrixtdevdr(ae_vector *d, ae_vector *e, ae_int_t n, ae_int_t zneeded, double a, double b, ae_int_t *m, ae_matrix *z, ae_state *_state)
void smp_cmatrixrighttrsm(const ae_int_t m, const ae_int_t n, const complex_2d_array &a, const ae_int_t i1, const ae_int_t j1, const bool isupper, const bool isunit, const ae_int_t optype, const complex_2d_array &x, const ae_int_t i2, const ae_int_t j2)
void ae_v_addd(double *vdst, ae_int_t stride_dst, const double *vsrc, ae_int_t stride_src, ae_int_t n, double alpha)
double rmatrixlurcondinf(ae_matrix *lua, ae_int_t n, ae_state *_state)
void ae_v_cmuld(ae_complex *vdst, ae_int_t stride_dst, ae_int_t n, double alpha)
ae_bool ae_is_hermitian(ae_matrix *a)
alglib::complex cmatrixludet(const complex_2d_array &a, const integer_1d_array &pivots, const ae_int_t n)
ae_bool rmatrixgemmmkl(ae_int_t m, ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_int_t optypeb, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_state *_state)
void cmatrixluinverse(ae_matrix *a, ae_vector *pivots, ae_int_t n, ae_int_t *info, matinvreport *rep, ae_state *_state)
void rmatrixqrbasecase(ae_matrix *a, ae_int_t m, ae_int_t n, ae_vector *work, ae_vector *t, ae_vector *tau, ae_state *_state)
void cmatrixluinverse(complex_2d_array &a, const integer_1d_array &pivots, const ae_int_t n, ae_int_t &info, matinvreport &rep)
void rmatrixlq(real_2d_array &a, const ae_int_t m, const ae_int_t n, real_1d_array &tau)
void spdmatrixcholeskyinverse(real_2d_array &a, const ae_int_t n, const bool isupper, ae_int_t &info, matinvreport &rep)
void smatrixtd(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_vector *d, ae_vector *e, ae_state *_state)
alglib_impl::ae_int_t ae_int_t
void sparsesmv(sparsematrix *s, ae_bool isupper, ae_vector *x, ae_vector *y, ae_state *_state)
void _pexec_cmatrixsyrk(ae_int_t n, ae_int_t k, double alpha, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_int_t optypea, double beta, ae_matrix *c, ae_int_t ic, ae_int_t jc, ae_bool isupper, ae_state *_state)
void ae_frame_leave(ae_state *state)
ae_bool cmatrixrighttrsmf(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
alglib_impl::sparsematrix * c_ptr()
void ae_matrix_clear(ae_matrix *dst)
ae_bool _sparsematrix_init_copy(void *_dst, void *_src, ae_state *_state, ae_bool make_automatic)
void hmatrixrndmultiply(ae_matrix *a, ae_int_t n, ae_state *_state)
alglib_impl::matinvreport * c_ptr()
double hpdmatrixcholeskyrcond(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_state *_state)
ae_bool ae_matrix_set_length(ae_matrix *dst, ae_int_t rows, ae_int_t cols, ae_state *state)
double sparsegetdiagonal(sparsematrix *s, ae_int_t i, ae_state *_state)
ql0001_ & zero(ctemp+1),(cvec+1),(a+1),(b+1),(bl+1),(bu+1),(x+1),(w+1), &iout, ifail, &zero,(w+3), &lwar2,(iw+1), &leniw, &glob_grd.epsmac
void spdmatrixcholeskyinverse(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_int_t *info, matinvreport *rep, ae_state *_state)
void sparsecopytocrs(sparsematrix *s0, sparsematrix *s1, ae_state *_state)
ae_bool rmatrixrank1f(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_vector *u, ae_int_t iu, ae_vector *v, ae_int_t iv, ae_state *_state)
ae_int_t ae_minint(ae_int_t m1, ae_int_t m2, ae_state *state)
void normestimatorestimatesparse(normestimatorstate *state, sparsematrix *a, ae_state *_state)
void smatrixtdunpackq(ae_matrix *a, ae_int_t n, ae_bool isupper, ae_vector *tau, ae_matrix *q, ae_state *_state)
void sparsecopy(const sparsematrix &s0, sparsematrix &s1)
void rmatrixrighttrsm(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t i1, ae_int_t j1, ae_bool isupper, ae_bool isunit, ae_int_t optype, ae_matrix *x, ae_int_t i2, ae_int_t j2, ae_state *_state)
ae_bool smatrixevd(ae_matrix *a, ae_int_t n, ae_int_t zneeded, ae_bool isupper, ae_vector *d, ae_matrix *z, ae_state *_state)
void normestimatorestimatesparse(const normestimatorstate &state, const sparsematrix &a)
ae_bool _matinvreport_init(void *_p, ae_state *_state, ae_bool make_automatic)
double ae_v_dotproduct(const double *v0, ae_int_t stride0, const double *v1, ae_int_t stride1, ae_int_t n)
void cmatrixcopy(ae_int_t m, ae_int_t n, ae_matrix *a, ae_int_t ia, ae_int_t ja, ae_matrix *b, ae_int_t ib, ae_int_t jb, ae_state *_state)
alglib_impl::normestimatorstate * p_struct
void rmatrixrndorthogonalfromtheright(ae_matrix *a, ae_int_t m, ae_int_t n, ae_state *_state)
void sparsemm2(sparsematrix *s, ae_matrix *a, ae_int_t k, ae_matrix *b0, ae_matrix *b1, ae_state *_state)