void
c_linalg_LU_1up (c_matrix *l, c_matrix *u, c_vector_int *p, c_vector *s, c_vector *t)
{
int m;
int n;
int ldl;
int ldu;
double *w;
if (c_matrix_is_empty (l)) c_error ("c_linalg_LU_1up", "matrix is empty.");
if (c_matrix_is_empty (u)) c_error ("c_linalg_LU_1up", "matrix is empty.");
if (c_vector_is_empty (s)) c_error ("c_linalg_LU_1up", "vector *s is empty.");
if (c_vector_is_empty (t)) c_error ("c_linalg_LU_1up", "vector *t is empty.");
if (c_vector_int_is_empty (p)) c_error ("c_linalg_LU_1up", "permulation is empty.");
if (s->size != l->size1) c_error ("c_linalg_LU_1up", "vector and matrix size dose not match.");
if (t->size != u->size2) c_error ("c_linalg_LU_1up", "vector and matrix size dose not match.");
if (s->stride != 1 || t->stride != 1) c_error ("c_linalg_LU_1up", "cannot tread vector with stride.");
m = (int) l->size1;
n = (int) u->size2;
ldl = (int) l->lda;
ldu = (int) u->lda;
w = (double *) malloc (l->size1 * sizeof (double));
F77CALL (dlup1up) (&m, &n, l->data, &ldl, u->data, &ldu, p->data, s->data, t->data, w);
free (w);
return;
}
void d_toe_mv(finteger N,finteger first,finteger last,fdouble *alpha,
fdouble *a,fdouble *x,fdouble *beta,fdouble *y)
/* preforms a matrix vector multiplication:
y = beta * y + alpha * A * x
where A is represented by the first line and first column
stored in the array a */
{
finteger i;
finteger length;
finteger index_t,index_x;
static finteger inc1=1;
static finteger incm1=-1;
if (*beta==0.0)
{
for(i=0;i<N;i++)
{
length=N;
index_t=max(i-N+1,first);
length+=i-N+1-index_t;
index_x=index_t+length-1-min(index_t+length-1,last);
length-=index_x;
length=max(length,0);
y[i]=(*alpha)*F77CALL (ddot) (&length,&a[index_t],&inc1,
&x[index_x],&incm1);
}
}
else
{
if (*beta!=1.0)
F77CALL (dscal) (&N,beta,y,&inc1);
for(i=0;i<N;i++)
{
length=N;
index_t=max(i-N+1,first);
length+=i-N+1-index_t;
index_x=index_t+length-1-min(index_t+length-1,last);
length-=index_x;
length=max(length,0);
y[i]+=(*alpha)*F77CALL (ddot) (&length,&a[index_t],&inc1,
&x[index_x],&incm1);
}
}
}
void mult_by_z_up_k(polynom *res,polynom *p,fdouble *alpha,finteger k)
/* copys the polynomial q into res and multiplies it with alpha * z^k */
{
static finteger inc1=1;
static finteger inc0=0;
static fdouble zero=0.0;
res->length=k+p->length;
if (*alpha==0.0)
F77CALL (dcopy) (&res->length,&zero,&inc0,res->data,&inc1);
else
{
if (p->stdinc==1)
{
F77CALL (dcopy) (&k,&zero,&inc0,res->data,&inc1);
F77CALL (dcopy) (&p->length,p->data,&inc1,&res->data[k],&inc1);
F77CALL (dscal) (&p->length,alpha,&res->data[k],&inc1);
}
else
{
F77CALL (dcopy) (&p->length,p->data,&inc1,res->data,&inc1);
F77CALL (dcopy) (&k,&zero,&inc0,&res->data[p->length],&inc1);
F77CALL (dscal) (&p->length,alpha,res->data,&inc1);
}
}
}
void polynomaxpy(fdouble *alpha,polynom *x,polynom *y)
/* performs y = alpha * x + y for polynomials similar to daxpy */
{
if (y->stdinc==1)
F77CALL (daxpy) (&x->length,alpha,x->data,&x->stdinc,y->data,&y->stdinc);
else
{
if (x->length > y->length)
{
printf("polynomaxpy: can not add these polynomials.\n");
return;
}
else
F77CALL (daxpy) (&x->length,alpha,x->data,&x->stdinc,
&y->data[y->length - x->length],&y->stdinc);
}
y->length=max(y->length,x->length);
}
void d_toe2full(finteger N,fdouble *to,fdouble *fu,finteger *ld)
/* converts a toeplitz matrix a into a full matrix fu */
{
finteger i;
static finteger inc1=1;
#define Fu(I,J) fu[(I) + (J) * (*ld)]
for(i=0;i<N;i++)
F77CALL (dcopy) (&N,&to[-i],&inc1,&Fu(0,i),&inc1);
#undef Fu
}
fdouble lau_coef(toeplitz *h,polynom *q,finteger k)
/* returns the k - th coefficient of the laurent row which is the result
of the product of the laurent row represetned by the toeplitz matrix h
and the polynomial q.
*/
{
static finteger incm1=-1;
finteger h_begin = max(k - q->length , - h->N ) + 1;
finteger first = max(0,k - h->N + 1);
finteger length = min(q->length,h->N + k)-first;
if (q->stdinc==-1)
first=q->length-length;
if (length > 0)
return(F77CALL (ddot) (&length,&h->data[h_begin],&incm1,
&q->data[first],&q->stdinc));
else
return 0.0;
}
void polynommult(polynom *res,polynom *x,polynom *y)
/* multiplies x with y and writes the result into res */
{
finteger i,length;
finteger smaller_length = min(x->length,y->length);
finteger revinc = - y->stdinc;
res->length = x->length + y->length - 1;
if (1 == res->stdinc)
{
if (1 == x->stdinc)
{
if (1 == y->stdinc)
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(i-y->length+1,0)],
&x->stdinc,&y->data[max(i-x->length+1,0)],&revinc);
}
}
else
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(i-y->length+1,0)],
&x->stdinc,&y->data[max(y->length-1-i,0)],&revinc);
}
}
}
else
{
if (1 == y->stdinc)
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(x->length-1-i,0)],
&x->stdinc,&y->data[max(i-x->length+1,0)],&revinc);
}
}
else
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(x->length-1-i,0)],
&x->stdinc,&y->data[max(y->length-1-i,0)],&revinc);
}
}
}
}
else
{
if (1 == x->stdinc)
{
if (1 == y->stdinc)
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(x->length-1-i,0)],
&x->stdinc,&y->data[max(y->length-1-i,0)],&revinc);
}
}
else
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(x->length-1-i,0)],
&x->stdinc,&y->data[max(1-x->length+i,0)],&revinc);
}
}
}
else
{
if (1 == y->stdinc)
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(1-y->length+i,0)],
&x->stdinc,&y->data[max(y->length-1-i,0)],&revinc);
}
}
else
{
for (i=0;i<res->length;i++)
{
length = min(smaller_length,i+1);
length = min(length,res->length-i);
res->data[i] = F77CALL (ddot) (&length,
&x->data[max(1-y->length+i,0)],
&x->stdinc,&y->data[max(1-x->length+i,0)],&revinc);
}
}
}
}
}
int d_lev_cl(fdouble *x,fdouble *mu,finteger N,fdouble *b)
/* classical levinson algorithem
x pointer to the array for the solution.
mu pointer to the diagonal element of the toeplitz matrix.
N the dimension of the toeplitz matrix mu.
b pointer to the righthandside. */
{
extern fdouble lau_coef(toeplitz *h,polynom *q,finteger k);
/* finteger help variables */
finteger n=1;
finteger ihelp;
finteger success=1;
/* static increments for blas */
static finteger inc1=1;
static finteger inc0=0;
static finteger incm1=-1;
/* tolerance for singular matrix */
const fdouble col_tol=0.0;
/* help variables */
fdouble help;
fdouble *temp;
/* variables for the method */
polynom q_up,q;
toeplitz h;
fdouble p_up,p;
fdouble v_up,v;
fdouble e;
/* initialize q,q_up,h */
h.data=mu;
h.N=N;
q.length=0;
q.stdinc=1;
q_up.length=0;
q_up.stdinc=-1;
/* memory management */
q.data=(fdouble *)malloc(3*N*sizeof(fdouble));
if (q.data==NULL)
{
printf("error can't allocate memory for working!\nAbort ...\n");
return(0);
}
q_up.data=&q.data[N];
temp=&q_up.data[N];
/* initialize memory */
help=0.0;
ihelp=2*N;
F77CALL (dcopy) (&ihelp,&help,&inc0,q.data,&inc1);
F77CALL (dcopy) (&N,&help,&inc0,x,&inc1);
/* LDU decompostion of a scalar */
p=h.data[0];
q.data[0]=1.0;
q.length++;
q_up.data[0]=1.0;
q_up.length++;
/* update the solution */
x[0]=b[0]/p;
/* calculating the pi ... */
e=h.data[1];
p_up=h.data[-1];
while (n<N)
{
/* calculating the gammas */
v=-e/p;
v_up=-p_up/p;
/* calculating new q and new q_up */
/* saving q_up into temp */
F77CALL (dcopy) (&q_up.length,q_up.data,&q_up.stdinc,temp,&inc1);
/* q_up = [0 q_up] + v_up * [q 0] */
F77CALL (daxpy) (&q_up.length,&v_up,q.data,&q.stdinc,&q_up.data[1],
&q_up.stdinc);
q_up.length++;
/* q = [0 q_up] * v + [q 0] */
F77CALL (daxpy) (&q.length,&v,temp,&inc1,&q.data[1],&q.stdinc);
q.length++;
/* updating epsilon */
p*=(1.0-v_up*v);
/* if matrix is singular abort */
if (fabs(p)<=col_tol)
{
printf("Matrix is singular\n");
success=0;
break;
}
n++;
/* updating the solution x (Here b with incm1 because
q=[rho_n rho_n-1 ... rho_0] but the columns of the matrix U in the
LDU decomposition of the inverse of the toeplitz matrix are:
[rho_0 rho_1 ... rho_n]. So you have to increment q in the other
direction as the stdinc says. That is the same as incrementing
q with stdinc and b with incm1.). */
help=F77CALL (ddot) (&q.length,q.data,&q.stdinc,b,&incm1)/p;
F77CALL (daxpy) (&q_up.length,&help,q_up.data,&q_up.stdinc,x,&inc1);
/* calculating the pi's ... */
p_up=lau_coef (&h,&q_up,-1);
e=lau_coef (&h,&q,n);
}
free (q.data);
return (success);
}
