/* zQsolve -- solves Qx = b, Q is an orthogonal matrix stored in compact
form a la QRfactor()
-- may be in-situ */
ZVEC *_zQsolve(ZMAT* QR, ZVEC* diag, ZVEC* b, ZVEC *x, ZVEC *tmp)
{
unsigned int dynamic;
int k, limit;
Real beta, r_ii, tmp_val;
limit = min(QR->m,QR->n);
dynamic = FALSE;
if ( ! QR || ! diag || ! b )
error(E_NULL,"_zQsolve");
if ( diag->dim < limit || b->dim != QR->m )
error(E_SIZES,"_zQsolve");
x = zv_resize(x,QR->m);
if ( tmp == ZVNULL )
dynamic = TRUE;
tmp = zv_resize(tmp,QR->m);
/* apply H/holder transforms in normal order */
x = zv_copy(b,x);
for ( k = 0 ; k < limit ; k++ )
{
zget_col(QR,k,tmp);
r_ii = zabs(tmp->ve[k]);
tmp->ve[k] = diag->ve[k];
tmp_val = (r_ii*zabs(diag->ve[k]));
beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val;
/* hhtrvec(tmp,beta->ve[k],k,x,x); */
zhhtrvec(tmp,beta,k,x,x);
}
if ( dynamic )
ZV_FREE(tmp);
return (x);
}
/* zQRfactor -- forms the QR factorisation of A
-- factorisation stored in compact form as described above
(not quite standard format) */
ZMAT *zQRfactor(ZMAT* A, ZVEC* diag)
{
unsigned int k,limit;
Real beta;
STATIC ZVEC *tmp1=ZVNULL, *w=ZVNULL;
if ( ! A || ! diag )
error(E_NULL,"zQRfactor");
limit = min(A->m,A->n);
if ( diag->dim < limit )
error(E_SIZES,"zQRfactor");
tmp1 = zv_resize(tmp1,A->m);
w = zv_resize(w, A->n);
MEM_STAT_REG(tmp1,TYPE_ZVEC);
MEM_STAT_REG(w, TYPE_ZVEC);
for ( k=0; k<limit; k++ )
{
/* get H/holder vector for the k-th column */
zget_col(A,k,tmp1);
zhhvec(tmp1,k,&beta,tmp1,&A->me[k][k]);
diag->ve[k] = tmp1->ve[k];
/* apply H/holder vector to remaining columns */
tracecatch(_zhhtrcols(A,k,k+1,tmp1,beta,w),"zQRfactor");
}
#ifdef THREADSAFE
ZV_FREE(tmp1); ZV_FREE(w);
#endif
return (A);
}
/* zmakeQ -- constructs orthogonal matrix from Householder vectors stored in
compact QR form */
ZMAT *zmakeQ(ZMAT *QR, ZVEC *diag, ZMAT *Qout)
{
STATIC ZVEC *tmp1=ZVNULL,*tmp2=ZVNULL;
unsigned int i, limit;
Real beta, r_ii, tmp_val;
int j;
limit = min(QR->m,QR->n);
if ( ! QR || ! diag )
error(E_NULL,"zmakeQ");
if ( diag->dim < limit )
error(E_SIZES,"zmakeQ");
Qout = zm_resize(Qout,QR->m,QR->m);
tmp1 = zv_resize(tmp1,QR->m); /* contains basis vec & columns of Q */
tmp2 = zv_resize(tmp2,QR->m); /* contains H/holder vectors */
MEM_STAT_REG(tmp1,TYPE_ZVEC);
MEM_STAT_REG(tmp2,TYPE_ZVEC);
for ( i=0; i<QR->m ; i++ )
{ /* get i-th column of Q */
/* set up tmp1 as i-th basis vector */
for ( j=0; j<QR->m ; j++ )
tmp1->ve[j].re = tmp1->ve[j].im = 0.0;
tmp1->ve[i].re = 1.0;
/* apply H/h transforms in reverse order */
for ( j=limit-1; j>=0; j-- )
{
zget_col(QR,j,tmp2);
r_ii = zabs(tmp2->ve[j]);
tmp2->ve[j] = diag->ve[j];
tmp_val = (r_ii*zabs(diag->ve[j]));
beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val;
/* hhtrvec(tmp2,beta->ve[j],j,tmp1,tmp1); */
zhhtrvec(tmp2,beta,j,tmp1,tmp1);
}
/* insert into Q */
zset_col(Qout,i,tmp1);
}
#ifdef THREADSAFE
ZV_FREE(tmp1); ZV_FREE(tmp2);
#endif
return (Qout);
}
ZVEC *pxinv_zvec(PERM *px, ZVEC *x, ZVEC *out)
#endif
{
unsigned int i, size;
if ( ! px || ! x )
error(E_NULL,"pxinv_zvec");
if ( px->size > x->dim )
error(E_SIZES,"pxinv_zvec");
if ( ! out || out->dim < x->dim )
out = zv_resize(out,x->dim);
size = px->size;
if ( size == 0 )
return zv_copy(x,out);
if ( out != x )
{
for ( i=0; i<size; i++ )
if ( px->pe[i] >= size )
error(E_BOUNDS,"pxinv_vec");
else
out->ve[px->pe[i]] = x->ve[i];
}
else
{ /* in situ algorithm --- cheat's way out */
px_inv(px,px);
px_zvec(px,x,out);
px_inv(px,px);
}
return out;
}
ZVEC *zv_slash(const ZVEC *x1, const ZVEC *x2, ZVEC *out)
#endif
{
int i;
Real r2, t_re, t_im;
complex tmp;
if ( ! x1 || ! x2 )
error(E_NULL,"zv_slash");
if ( x1->dim != x2->dim )
error(E_SIZES,"zv_slash");
out = zv_resize(out,x1->dim);
for ( i = 0; i < x1->dim; i++ )
{
r2 = x1->ve[i].re*x1->ve[i].re + x1->ve[i].im*x1->ve[i].im;
if ( r2 == 0.0 )
error(E_SING,"zv_slash");
tmp.re = x1->ve[i].re / r2;
tmp.im = - x1->ve[i].im / r2;
t_re = tmp.re*x2->ve[i].re - tmp.im*x2->ve[i].im;
t_im = tmp.re*x2->ve[i].im + tmp.im*x2->ve[i].re;
out->ve[i].re = t_re;
out->ve[i].im = t_im;
}
return out;
}
/* zQRAsolve -- solves the system (Q.R)*.x = b
-- Q & R are stored in compact form
-- returns x, which is created if necessary */
ZVEC *zQRAsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x)
{
int j, limit;
Real beta, r_ii, tmp_val;
STATIC ZVEC *tmp = ZVNULL;
if ( ! QR || ! diag || ! b )
error(E_NULL,"zQRAsolve");
limit = min(QR->m,QR->n);
if ( diag->dim < limit || b->dim != QR->n )
error(E_SIZES,"zQRAsolve");
x = zv_resize(x,QR->m);
x = zUAsolve(QR,b,x,0.0);
x = zv_resize(x,QR->m);
tmp = zv_resize(tmp,x->dim);
MEM_STAT_REG(tmp,TYPE_ZVEC);
/* printf("zQRAsolve: tmp->dim = %d, x->dim = %d\n", tmp->dim, x->dim); */
/* apply H/h transforms in reverse order */
for ( j=limit-1; j>=0; j-- )
{
zget_col(QR,j,tmp);
tmp = zv_resize(tmp,QR->m);
r_ii = zabs(tmp->ve[j]);
tmp->ve[j] = diag->ve[j];
tmp_val = (r_ii*zabs(diag->ve[j]));
beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val;
zhhtrvec(tmp,beta,j,x,x);
}
#ifdef THREADSAFE
ZV_FREE(tmp);
#endif
return x;
}
int zv_resize_vars(int new_dim, ...) {
va_list ap;
int i = 0;
ZVEC **par;
va_start(ap, new_dim);
while ((par = va_arg(ap, ZVEC **))) { /* NULL ends the list*/
*par = zv_resize(*par, new_dim);
i++;
}
va_end(ap);
return i;
}
/* zQRsolve -- solves the system Q.R.x=b where Q & R are stored in compact form
-- returns x, which is created if necessary */
ZVEC *zQRsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x)
{
int limit;
STATIC ZVEC *tmp = ZVNULL;
if ( ! QR || ! diag || ! b )
error(E_NULL,"zQRsolve");
limit = min(QR->m,QR->n);
if ( diag->dim < limit || b->dim != QR->m )
error(E_SIZES,"zQRsolve");
tmp = zv_resize(tmp,limit);
MEM_STAT_REG(tmp,TYPE_ZVEC);
x = zv_resize(x,QR->n);
_zQsolve(QR,diag,b,x,tmp);
x = zUsolve(QR,x,x,0.0);
x = zv_resize(x,QR->n);
#ifdef THREADSAFE
ZV_FREE(tmp);
#endif
return x;
}
ZVEC *zv_add(const ZVEC *vec1, const ZVEC *vec2, ZVEC *out)
#endif
{
unsigned int dim;
if ( vec1==ZVNULL || vec2==ZVNULL )
error(E_NULL,"zv_add");
if ( vec1->dim != vec2->dim )
error(E_SIZES,"zv_add");
if ( out==ZVNULL || out->dim != vec1->dim )
out = zv_resize(out,vec1->dim);
dim = vec1->dim;
__zadd__(vec1->ve,vec2->ve,out->ve,(int)dim);
return (out);
}
/* zUmlt -- compute out = upper_triang(U).x
-- may be in situ */
ZVEC *zUmlt(ZMAT *U, ZVEC* x, ZVEC *out)
{
int i, limit;
if ( U == ZMNULL || x == ZVNULL )
error(E_NULL,"zUmlt");
limit = min(U->m,U->n);
if ( limit != x->dim )
error(E_SIZES,"zUmlt");
if ( out == ZVNULL || out->dim < limit )
out = zv_resize(out,limit);
for ( i = 0; i < limit; i++ )
out->ve[i] = __zip__(&(x->ve[i]),&(U->me[i][i]),limit - i,Z_NOCONJ);
return out;
}
ZVEC *zv_map(complex (*f)(complex), const ZVEC *x, ZVEC *out)
#endif
{
complex *x_ve, *out_ve;
int i, dim;
if ( ! x || ! f )
error(E_NULL,"zv_map");
if ( ! out || out->dim != x->dim )
out = zv_resize(out,x->dim);
dim = x->dim; x_ve = x->ve; out_ve = out->ve;
for ( i = 0; i < dim; i++ )
out_ve[i] = (*f)(x_ve[i]);
return out;
}
ZVEC *zv_sub(const ZVEC *vec1, const ZVEC *vec2, ZVEC *out)
#endif
{
/* unsigned int i, dim; */
/* complex *out_ve, *vec1_ve, *vec2_ve; */
if ( vec1==ZVNULL || vec2==ZVNULL )
error(E_NULL,"zv_sub");
if ( vec1->dim != vec2->dim )
error(E_SIZES,"zv_sub");
if ( out==ZVNULL || out->dim != vec1->dim )
out = zv_resize(out,vec1->dim);
__zsub__(vec1->ve,vec2->ve,out->ve,(int)(vec1->dim));
return (out);
}
ZVEC *zv_mlt(complex scalar, const ZVEC *vector, ZVEC *out)
#endif
{
/* unsigned int dim, i; */
/* complex *out_ve, *vec_ve; */
if ( vector==ZVNULL )
error(E_NULL,"zv_mlt");
if ( out==ZVNULL || out->dim != vector->dim )
out = zv_resize(out,vector->dim);
if ( scalar.re == 0.0 && scalar.im == 0.0 )
return zv_zero(out);
if ( scalar.re == 1.0 && scalar.im == 0.0 )
return zv_copy(vector,out);
__zmlt__(vector->ve,scalar,out->ve,(int)(vector->dim));
return (out);
}
/* zUAmlt -- returns out = upper_triang(U)^T.x */
ZVEC *zUAmlt(ZMAT *U, ZVEC *x, ZVEC *out)
{
/* complex sum; */
complex tmp;
int i, limit;
if ( U == ZMNULL || x == ZVNULL )
error(E_NULL,"zUAmlt");
limit = min(U->m,U->n);
if ( out == ZVNULL || out->dim < limit )
out = zv_resize(out,limit);
for ( i = limit-1; i >= 0; i-- )
{
tmp = x->ve[i];
out->ve[i].re = out->ve[i].im = 0.0;
__zmltadd__(&(out->ve[i]),&(U->me[i][i]),tmp,limit-i-1,Z_CONJ);
}
return out;
}
ZVEC *zv_star(const ZVEC *x1, const ZVEC *x2, ZVEC *out)
#endif
{
int i;
Real t_re, t_im;
if ( ! x1 || ! x2 )
error(E_NULL,"zv_star");
if ( x1->dim != x2->dim )
error(E_SIZES,"zv_star");
out = zv_resize(out,x1->dim);
for ( i = 0; i < x1->dim; i++ )
{
/* out->ve[i] = x1->ve[i] * x2->ve[i]; */
t_re = x1->ve[i].re*x2->ve[i].re - x1->ve[i].im*x2->ve[i].im;
t_im = x1->ve[i].re*x2->ve[i].im + x1->ve[i].im*x2->ve[i].re;
out->ve[i].re = t_re;
out->ve[i].im = t_im;
}
return out;
}
ZVEC *px_zvec(PERM *px, ZVEC *vector, ZVEC *out)
#endif
{
unsigned int old_i, i, size, start;
complex tmp;
if ( px==PNULL || vector==ZVNULL )
error(E_NULL,"px_zvec");
if ( px->size > vector->dim )
error(E_SIZES,"px_zvec");
if ( out==ZVNULL || out->dim < vector->dim )
out = zv_resize(out,vector->dim);
size = px->size;
if ( size == 0 )
return zv_copy(vector,out);
if ( out != vector )
{
for ( i=0; i<size; i++ )
if ( px->pe[i] >= size )
error(E_BOUNDS,"px_vec");
else
out->ve[i] = vector->ve[px->pe[i]];
}
else
{ /* in situ algorithm */
start = 0;
while ( start < size )
{
old_i = start;
i = px->pe[old_i];
if ( i >= size )
{
start++;
continue;
}
tmp = vector->ve[start];
while ( TRUE )
{
vector->ve[old_i] = vector->ve[i];
px->pe[old_i] = i+size;
old_i = i;
i = px->pe[old_i];
if ( i >= size )
break;
if ( i == start )
{
vector->ve[old_i] = tmp;
px->pe[old_i] = i+size;
break;
}
}
start++;
}
for ( i = 0; i < size; i++ )
if ( px->pe[i] < size )
error(E_BOUNDS,"px_vec");
else
px->pe[i] = px->pe[i]-size;
}
return out;
}
/* zQRCPfactor -- forms the QR factorisation of A with column pivoting
-- factorisation stored in compact form as described above
( not quite standard format ) */
ZMAT *zQRCPfactor(ZMAT *A, ZVEC* diag, PERM *px)
{
unsigned int i, i_max, j, k, limit;
STATIC ZVEC *tmp1=ZVNULL, *tmp2=ZVNULL, *w=ZVNULL;
STATIC VEC *gamma=VNULL;
Real beta;
Real maxgamma, sum, tmp;
complex ztmp;
if ( ! A || ! diag || ! px )
error(E_NULL,"QRCPfactor");
limit = min(A->m,A->n);
if ( diag->dim < limit || px->size != A->n )
error(E_SIZES,"QRCPfactor");
tmp1 = zv_resize(tmp1,A->m);
tmp2 = zv_resize(tmp2,A->m);
gamma = v_resize(gamma,A->n);
w = zv_resize(w,A->n);
MEM_STAT_REG(tmp1,TYPE_ZVEC);
MEM_STAT_REG(tmp2,TYPE_ZVEC);
MEM_STAT_REG(gamma,TYPE_VEC);
MEM_STAT_REG(w, TYPE_ZVEC);
/* initialise gamma and px */
for ( j=0; j<A->n; j++ )
{
px->pe[j] = j;
sum = 0.0;
for ( i=0; i<A->m; i++ )
sum += square(A->me[i][j].re) + square(A->me[i][j].im);
gamma->ve[j] = sum;
}
for ( k=0; k<limit; k++ )
{
/* find "best" column to use */
i_max = k; maxgamma = gamma->ve[k];
for ( i=k+1; i<A->n; i++ )
/* Loop invariant:maxgamma=gamma[i_max]
>=gamma[l];l=k,...,i-1 */
if ( gamma->ve[i] > maxgamma )
{ maxgamma = gamma->ve[i]; i_max = i; }
/* swap columns if necessary */
if ( i_max != k )
{
/* swap gamma values */
tmp = gamma->ve[k];
gamma->ve[k] = gamma->ve[i_max];
gamma->ve[i_max] = tmp;
/* update column permutation */
px_transp(px,k,i_max);
/* swap columns of A */
for ( i=0; i<A->m; i++ )
{
ztmp = A->me[i][k];
A->me[i][k] = A->me[i][i_max];
A->me[i][i_max] = ztmp;
}
}
/* get H/holder vector for the k-th column */
zget_col(A,k,tmp1);
/* hhvec(tmp1,k,&beta->ve[k],tmp1,&A->me[k][k]); */
zhhvec(tmp1,k,&beta,tmp1,&A->me[k][k]);
diag->ve[k] = tmp1->ve[k];
/* apply H/holder vector to remaining columns */
_zhhtrcols(A,k,k+1,tmp1,beta,w);
/* update gamma values */
for ( j=k+1; j<A->n; j++ )
gamma->ve[j] -= square(A->me[k][j].re)+square(A->me[k][j].im);
}
#ifdef THREADSAFE
ZV_FREE(tmp1); ZV_FREE(tmp2); V_FREE(gamma); ZV_FREE(w);
#endif
return (A);
}
/* zQRcondest -- returns an estimate of the 2-norm condition number of the
matrix factorised by QRfactor() or QRCPfactor()
-- note that as Q does not affect the 2-norm condition number,
it is not necessary to pass the diag, beta (or pivot) vectors
-- generates a lower bound on the true condition number
-- if the matrix is exactly singular, HUGE_VAL is returned
-- note that QRcondest() is likely to be more reliable for
matrices factored using QRCPfactor() */
double zQRcondest(ZMAT *QR)
{
STATIC ZVEC *y=ZVNULL;
Real norm, norm1, norm2, tmp1, tmp2;
complex sum, tmp;
int i, j, limit;
if ( QR == ZMNULL )
error(E_NULL,"zQRcondest");
limit = min(QR->m,QR->n);
for ( i = 0; i < limit; i++ )
/* if ( QR->me[i][i] == 0.0 ) */
if ( is_zero(QR->me[i][i]) )
return HUGE_VAL;
y = zv_resize(y,limit);
MEM_STAT_REG(y,TYPE_ZVEC);
/* use the trick for getting a unit vector y with ||R.y||_inf small
from the LU condition estimator */
for ( i = 0; i < limit; i++ )
{
sum.re = sum.im = 0.0;
for ( j = 0; j < i; j++ )
/* sum -= QR->me[j][i]*y->ve[j]; */
sum = zsub(sum,zmlt(QR->me[j][i],y->ve[j]));
/* sum -= (sum < 0.0) ? 1.0 : -1.0; */
norm1 = zabs(sum);
if ( norm1 == 0.0 )
sum.re = 1.0;
else
{
sum.re += sum.re / norm1;
sum.im += sum.im / norm1;
}
/* y->ve[i] = sum / QR->me[i][i]; */
y->ve[i] = zdiv(sum,QR->me[i][i]);
}
zUAmlt(QR,y,y);
/* now apply inverse power method to R*.R */
for ( i = 0; i < 3; i++ )
{
tmp1 = zv_norm2(y);
zv_mlt(zmake(1.0/tmp1,0.0),y,y);
zUAsolve(QR,y,y,0.0);
tmp2 = zv_norm2(y);
zv_mlt(zmake(1.0/tmp2,0.0),y,y);
zUsolve(QR,y,y,0.0);
}
/* now compute approximation for ||R^{-1}||_2 */
norm1 = sqrt(tmp1)*sqrt(tmp2);
/* now use complementary approach to compute approximation to ||R||_2 */
for ( i = limit-1; i >= 0; i-- )
{
sum.re = sum.im = 0.0;
for ( j = i+1; j < limit; j++ )
sum = zadd(sum,zmlt(QR->me[i][j],y->ve[j]));
if ( is_zero(QR->me[i][i]) )
return HUGE_VAL;
tmp = zdiv(sum,QR->me[i][i]);
if ( is_zero(tmp) )
{
y->ve[i].re = 1.0;
y->ve[i].im = 0.0;
}
else
{
norm = zabs(tmp);
y->ve[i].re = sum.re / norm;
y->ve[i].im = sum.im / norm;
}
/* y->ve[i] = (sum >= 0.0) ? 1.0 : -1.0; */
/* y->ve[i] = (QR->me[i][i] >= 0.0) ? y->ve[i] : - y->ve[i]; */
}
/* now apply power method to R*.R */
for ( i = 0; i < 3; i++ )
{
tmp1 = zv_norm2(y);
zv_mlt(zmake(1.0/tmp1,0.0),y,y);
zUmlt(QR,y,y);
tmp2 = zv_norm2(y);
zv_mlt(zmake(1.0/tmp2,0.0),y,y);
zUAmlt(QR,y,y);
}
norm2 = sqrt(tmp1)*sqrt(tmp2);
/* printf("QRcondest: norm1 = %g, norm2 = %g\n",norm1,norm2); */
#ifdef THREADSAFE
ZV_FREE(y);
#endif
return norm1*norm2;
}
