Ejemplo n.º 1
0
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;
}
Ejemplo n.º 2
0
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);
    }
  }
}
Ejemplo n.º 3
0
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);
    }
  }
}
Ejemplo n.º 4
0
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);
}
Ejemplo n.º 5
0
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
}
Ejemplo n.º 6
0
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;
}
Ejemplo n.º 7
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);
	}
      }
    }
  }
}
Ejemplo n.º 8
0
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);
}