Пример #1
0
/**
 * @brief Creates the penalty matrix D tilde of order k.
 * Returns the matrix Dk premultipied by a diagonal
 * matrix of weights.
 *
 * @param n                    number of observations
 * @param k                    order of the trendfilter
 * @param x                    locations of the responses
 * @return pointer to a csparse matrix
 * @see tf_calc_dktil
 */
cs * tf_calc_dktil (int n, int k, const double * x)
{
  cs * delta_k;
  cs * delta_k_cp;
  cs * Dk;
  cs * Dktil;

  int i;

  Dk = tf_calc_dk(n, k, x);

  /* Deal with k=0 separately */
  if(k == 0)
    return Dk;

  /* Construct diagonal matrix of differences: */
  delta_k = cs_spalloc(n-k, n-k, (n-k), 1, 1);
  for(i = 0; i < n - k; i++)
  {
    delta_k->p[i] = i;
    delta_k->i[i] = i;
    delta_k->x[i] = k / (x[k + i] - x[i]);
  }
  delta_k->nz = n-k;
  delta_k_cp = cs_compress(delta_k);
  Dktil = cs_multiply(delta_k_cp, Dk);

  cs_spfree(Dk);
  cs_spfree(delta_k);
  cs_spfree(delta_k_cp);

  return Dktil;
}
Пример #2
0
cs *cs_rinvwishart(const cs *A, double nu, const css *As){
    
    int m, i, j, cnt;
    cs *T, *IW, *C, *W, *tC;
    csn *U;
    m = A->n;

    T = cs_spalloc (m, m, m*(m+1)/2, 1, 0) ;	 
    if (!T ) return (cs_done (T, NULL, NULL, 0));   

    double df = nu;
    cnt = 0;

    for(i = 0; i<m; i++){
      T->p[i] = cnt;  
      T->i[cnt] = i;    
      T->x[cnt] = sqrt(rchisq(df));
      cnt++;
      for(j = i+1; j<m; j++){
        T->i[cnt] = j;
        T->x[cnt] = rnorm(0.0,1.0);
        cnt++;
      } 
      df--;
    }
    T->p[m] = m*(m+1)/2;
    U = cs_chol(A, As);  
    if(U==NULL){
      PutRNGstate();
      error("ill-conditioned cross-product: can't form Cholesky factor\n");
    }

    C = cs_multiply(U->L,T);              // t(T)%*%chol(A)
    tC = cs_transpose(C, TRUE);            // t(CI)
    W  = cs_multiply(C,tC);   
    IW = cs_inv(W);                       // crossprod(t(CI))
    cs_spfree(T);
    cs_nfree(U);
    cs_spfree(C);
    cs_spfree(tC);
    cs_spfree(W);

    return (cs_done (IW, NULL, NULL, 1)) ;	/* success; free workspace, return C */

}
Пример #3
0
cs* cs_sorted_multiply2(const cs* a, const cs* b)
{
  cs* D = cs_multiply(a,b);
  cs* E = cs_transpose(D,1);
  cs_spfree(D);
  cs* C = cs_transpose(E,1);
  cs_spfree(E);
  return C;
}
Пример #4
0
cs* cs_sorted_multiply(const cs* a, const cs* b)
{
  cs* A = cs_transpose (a, 1) ;
  cs* B = cs_transpose (b, 1) ;
  cs* D = cs_multiply (B,A) ;   /* D = B'*A' */
  cs_spfree (A) ;
  cs_spfree (B) ;
  cs_dropzeros (D) ;      /* drop zeros from D */
  cs* C = cs_transpose (D, 1) ;   /* C = D', so that C is sorted */
  cs_spfree (D) ;
  return C;
}
Пример #5
0
void NM_gemm(const double alpha, NumericsMatrix* A, NumericsMatrix* B,
             const double beta, NumericsMatrix* C)
{
    switch(A->storageType)
    {
    case NM_DENSE:
    {
        cblas_dgemm(CblasColMajor, CblasNoTrans, CblasNoTrans, A->size0, B->size1, B->size1, alpha, A->matrix0, A->size0, B->matrix0, B->size0, beta, C->matrix0, A->size0);

        NM_clearSparseBlock(C);
        NM_clearSparseStorage(C);

        break;
    }
    case NM_SPARSE_BLOCK:
    {
        prodNumericsMatrixNumericsMatrix(alpha, A, B, beta, C);

        NM_clearDense(C);
        NM_clearSparseStorage(C);
        break;
    }
    case NM_SPARSE:
    {
        CSparseMatrix* result = cs_add(cs_multiply(NM_csc(A), NM_csc(B)),
                                       NM_csc(C), alpha, beta);

        NM_clearDense(C);
        NM_clearSparseBlock(C);
        NM_clearSparseStorage(C);

        NM_sparse(C)->csc = result;
        C->size0 = (int)C->matrix2->csc->m;
        C->size1 = (int)C->matrix2->csc->n;
        break;
    }
    }
}
Пример #6
0
/* p = amd(A+A') if symmetric is true, or amd(A'A) otherwise */
CS_INT *cs_amd (CS_INT order, const cs *A)  /* order 0:natural, 1:Chol, 2:LU, 3:QR */
{
    cs *C, *A2, *AT ;
    CS_INT *Cp, *Ci, *last, *W, *len, *nv, *next, *P, *head, *elen, *degree, *w,
        *hhead, *ATp, *ATi, d, dk, dext, lemax = 0, e, elenk, eln, i, j, k, k1,
        k2, k3, jlast, ln, dense, nzmax, mindeg = 0, nvi, nvj, nvk, mark, wnvi,
        ok, cnz, nel = 0, p, p1, p2, p3, p4, pj, pk, pk1, pk2, pn, q, n, m, t ;
    unsigned CS_INT h ;
    /* --- Construct matrix C ----------------------------------------------- */
    if (!CS_CSC (A) || order <= 0 || order > 3) return (NULL) ; /* check */
    AT = cs_transpose (A, 0) ;              /* compute A' */
    if (!AT) return (NULL) ;
    m = A->m ; n = A->n ;
    dense = CS_MAX (16, 10 * sqrt ((double) n)) ;   /* find dense threshold */
    dense = CS_MIN (n-2, dense) ;
    if (order == 1 && n == m)
    {
        C = cs_add (A, AT, 0, 0) ;          /* C = A+A' */
    }
    else if (order == 2)
    {
        ATp = AT->p ;                       /* drop dense columns from AT */
        ATi = AT->i ;
        for (p2 = 0, j = 0 ; j < m ; j++)
        {
            p = ATp [j] ;                   /* column j of AT starts here */
            ATp [j] = p2 ;                  /* new column j starts here */
            if (ATp [j+1] - p > dense) continue ;   /* skip dense col j */
            for ( ; p < ATp [j+1] ; p++) ATi [p2++] = ATi [p] ;
        }
        ATp [m] = p2 ;                      /* finalize AT */
        A2 = cs_transpose (AT, 0) ;         /* A2 = AT' */
        C = A2 ? cs_multiply (AT, A2) : NULL ;  /* C=A'*A with no dense rows */
        cs_spfree (A2) ;
    }
    else
    {
        C = cs_multiply (AT, A) ;           /* C=A'*A */
    }
    cs_spfree (AT) ;
    if (!C) return (NULL) ;
    cs_fkeep (C, &cs_diag, NULL) ;          /* drop diagonal entries */
    Cp = C->p ;
    cnz = Cp [n] ;
    P = cs_malloc (n+1, sizeof (CS_INT)) ;     /* allocate result */
    W = cs_malloc (8*(n+1), sizeof (CS_INT)) ; /* get workspace */
    t = cnz + cnz/5 + 2*n ;                 /* add elbow room to C */
    if (!P || !W || !cs_sprealloc (C, t)) return (cs_idone (P, C, W, 0)) ;
    len  = W           ; nv     = W +   (n+1) ; next   = W + 2*(n+1) ;
    head = W + 3*(n+1) ; elen   = W + 4*(n+1) ; degree = W + 5*(n+1) ;
    w    = W + 6*(n+1) ; hhead  = W + 7*(n+1) ;
    last = P ;                              /* use P as workspace for last */
    /* --- Initialize quotient graph ---------------------------------------- */
    for (k = 0 ; k < n ; k++) len [k] = Cp [k+1] - Cp [k] ;
    len [n] = 0 ;
    nzmax = C->nzmax ;
    Ci = C->i ;
    for (i = 0 ; i <= n ; i++)
    {
        head [i] = -1 ;                     /* degree list i is empty */
        last [i] = -1 ;
        next [i] = -1 ;
        hhead [i] = -1 ;                    /* hash list i is empty */
        nv [i] = 1 ;                        /* node i is just one node */
        w [i] = 1 ;                         /* node i is alive */
        elen [i] = 0 ;                      /* Ek of node i is empty */
        degree [i] = len [i] ;              /* degree of node i */
    }
    mark = cs_wclear (0, 0, w, n) ;         /* clear w */
    elen [n] = -2 ;                         /* n is a dead element */
    Cp [n] = -1 ;                           /* n is a root of assembly tree */
    w [n] = 0 ;                             /* n is a dead element */
    /* --- Initialize degree lists ------------------------------------------ */
    for (i = 0 ; i < n ; i++)
    {
        d = degree [i] ;
        if (d == 0)                         /* node i is empty */
        {
            elen [i] = -2 ;                 /* element i is dead */
            nel++ ;
            Cp [i] = -1 ;                   /* i is a root of assembly tree */
            w [i] = 0 ;
        }
        else if (d > dense)                 /* node i is dense */
        {
            nv [i] = 0 ;                    /* absorb i into element n */
            elen [i] = -1 ;                 /* node i is dead */
            nel++ ;
            Cp [i] = CS_FLIP (n) ;
            nv [n]++ ;
        }
        else
        {
            if (head [d] != -1) last [head [d]] = i ;
            next [i] = head [d] ;           /* put node i in degree list d */
            head [d] = i ;
        }
    }
    while (nel < n)                         /* while (selecting pivots) do */
    {
        /* --- Select node of minimum approximate degree -------------------- */
        for (k = -1 ; mindeg < n && (k = head [mindeg]) == -1 ; mindeg++) ;
        if (next [k] != -1) last [next [k]] = -1 ;
        head [mindeg] = next [k] ;          /* remove k from degree list */
        elenk = elen [k] ;                  /* elenk = |Ek| */
        nvk = nv [k] ;                      /* # of nodes k represents */
        nel += nvk ;                        /* nv[k] nodes of A eliminated */
        /* --- Garbage collection ------------------------------------------- */
        if (elenk > 0 && cnz + mindeg >= nzmax)
        {
            for (j = 0 ; j < n ; j++)
            {
                if ((p = Cp [j]) >= 0)      /* j is a live node or element */
                {
                    Cp [j] = Ci [p] ;       /* save first entry of object */
                    Ci [p] = CS_FLIP (j) ;  /* first entry is now CS_FLIP(j) */
                }
            }
            for (q = 0, p = 0 ; p < cnz ; ) /* scan all of memory */
            {
                if ((j = CS_FLIP (Ci [p++])) >= 0)  /* found object j */
                {
                    Ci [q] = Cp [j] ;       /* restore first entry of object */
                    Cp [j] = q++ ;          /* new pointer to object j */
                    for (k3 = 0 ; k3 < len [j]-1 ; k3++) Ci [q++] = Ci [p++] ;
                }
            }
            cnz = q ;                       /* Ci [cnz...nzmax-1] now free */
        }
        /* --- Construct new element ---------------------------------------- */
        dk = 0 ;
        nv [k] = -nvk ;                     /* flag k as in Lk */
        p = Cp [k] ;
        pk1 = (elenk == 0) ? p : cnz ;      /* do in place if elen[k] == 0 */
        pk2 = pk1 ;
        for (k1 = 1 ; k1 <= elenk + 1 ; k1++)
        {
            if (k1 > elenk)
            {
                e = k ;                     /* search the nodes in k */
                pj = p ;                    /* list of nodes starts at Ci[pj]*/
                ln = len [k] - elenk ;      /* length of list of nodes in k */
            }
            else
            {
                e = Ci [p++] ;              /* search the nodes in e */
                pj = Cp [e] ;
                ln = len [e] ;              /* length of list of nodes in e */
            }
            for (k2 = 1 ; k2 <= ln ; k2++)
            {
                i = Ci [pj++] ;
                if ((nvi = nv [i]) <= 0) continue ; /* node i dead, or seen */
                dk += nvi ;                 /* degree[Lk] += size of node i */
                nv [i] = -nvi ;             /* negate nv[i] to denote i in Lk*/
                Ci [pk2++] = i ;            /* place i in Lk */
                if (next [i] != -1) last [next [i]] = last [i] ;
                if (last [i] != -1)         /* remove i from degree list */
                {
                    next [last [i]] = next [i] ;
                }
                else
                {
                    head [degree [i]] = next [i] ;
                }
            }
            if (e != k)
            {
                Cp [e] = CS_FLIP (k) ;      /* absorb e into k */
                w [e] = 0 ;                 /* e is now a dead element */
            }
        }
        if (elenk != 0) cnz = pk2 ;         /* Ci [cnz...nzmax] is free */
        degree [k] = dk ;                   /* external degree of k - |Lk\i| */
        Cp [k] = pk1 ;                      /* element k is in Ci[pk1..pk2-1] */
        len [k] = pk2 - pk1 ;
        elen [k] = -2 ;                     /* k is now an element */
        /* --- Find set differences ----------------------------------------- */
        mark = cs_wclear (mark, lemax, w, n) ;  /* clear w if necessary */
        for (pk = pk1 ; pk < pk2 ; pk++)    /* scan 1: find |Le\Lk| */
        {
            i = Ci [pk] ;
            if ((eln = elen [i]) <= 0) continue ;/* skip if elen[i] empty */
            nvi = -nv [i] ;                      /* nv [i] was negated */
            wnvi = mark - nvi ;
            for (p = Cp [i] ; p <= Cp [i] + eln - 1 ; p++)  /* scan Ei */
            {
                e = Ci [p] ;
                if (w [e] >= mark)
                {
                    w [e] -= nvi ;          /* decrement |Le\Lk| */
                }
                else if (w [e] != 0)        /* ensure e is a live element */
                {
                    w [e] = degree [e] + wnvi ; /* 1st time e seen in scan 1 */
                }
            }
        }
        /* --- Degree update ------------------------------------------------ */
        for (pk = pk1 ; pk < pk2 ; pk++)    /* scan2: degree update */
        {
            i = Ci [pk] ;                   /* consider node i in Lk */
            p1 = Cp [i] ;
            p2 = p1 + elen [i] - 1 ;
            pn = p1 ;
            for (h = 0, d = 0, p = p1 ; p <= p2 ; p++)    /* scan Ei */
            {
                e = Ci [p] ;
                if (w [e] != 0)             /* e is an unabsorbed element */
                {
                    dext = w [e] - mark ;   /* dext = |Le\Lk| */
                    if (dext > 0)
                    {
                        d += dext ;         /* sum up the set differences */
                        Ci [pn++] = e ;     /* keep e in Ei */
                        h += e ;            /* compute the hash of node i */
                    }
                    else
                    {
                        Cp [e] = CS_FLIP (k) ;  /* aggressive absorb. e->k */
                        w [e] = 0 ;             /* e is a dead element */
                    }
                }
            }
            elen [i] = pn - p1 + 1 ;        /* elen[i] = |Ei| */
            p3 = pn ;
            p4 = p1 + len [i] ;
            for (p = p2 + 1 ; p < p4 ; p++) /* prune edges in Ai */
            {
                j = Ci [p] ;
                if ((nvj = nv [j]) <= 0) continue ; /* node j dead or in Lk */
                d += nvj ;                  /* degree(i) += |j| */
                Ci [pn++] = j ;             /* place j in node list of i */
                h += j ;                    /* compute hash for node i */
            }
            if (d == 0)                     /* check for mass elimination */
            {
                Cp [i] = CS_FLIP (k) ;      /* absorb i into k */
                nvi = -nv [i] ;
                dk -= nvi ;                 /* |Lk| -= |i| */
                nvk += nvi ;                /* |k| += nv[i] */
                nel += nvi ;
                nv [i] = 0 ;
                elen [i] = -1 ;             /* node i is dead */
            }
            else
            {
                degree [i] = CS_MIN (degree [i], d) ;   /* update degree(i) */
                Ci [pn] = Ci [p3] ;         /* move first node to end */
                Ci [p3] = Ci [p1] ;         /* move 1st el. to end of Ei */
                Ci [p1] = k ;               /* add k as 1st element in of Ei */
                len [i] = pn - p1 + 1 ;     /* new len of adj. list of node i */
                h %= n ;                    /* finalize hash of i */
                next [i] = hhead [h] ;      /* place i in hash bucket */
                hhead [h] = i ;
                last [i] = h ;              /* save hash of i in last[i] */
            }
        }                                   /* scan2 is done */
        degree [k] = dk ;                   /* finalize |Lk| */
        lemax = CS_MAX (lemax, dk) ;
        mark = cs_wclear (mark+lemax, lemax, w, n) ;    /* clear w */
        /* --- Supernode detection ------------------------------------------ */
        for (pk = pk1 ; pk < pk2 ; pk++)
        {
            i = Ci [pk] ;
            if (nv [i] >= 0) continue ;         /* skip if i is dead */
            h = last [i] ;                      /* scan hash bucket of node i */
            i = hhead [h] ;
            hhead [h] = -1 ;                    /* hash bucket will be empty */
            for ( ; i != -1 && next [i] != -1 ; i = next [i], mark++)
            {
                ln = len [i] ;
                eln = elen [i] ;
                for (p = Cp [i]+1 ; p <= Cp [i] + ln-1 ; p++) w [Ci [p]] = mark;
                jlast = i ;
                for (j = next [i] ; j != -1 ; ) /* compare i with all j */
                {
                    ok = (len [j] == ln) && (elen [j] == eln) ;
                    for (p = Cp [j] + 1 ; ok && p <= Cp [j] + ln - 1 ; p++)
                    {
                        if (w [Ci [p]] != mark) ok = 0 ;    /* compare i and j*/
                    }
                    if (ok)                     /* i and j are identical */
                    {
                        Cp [j] = CS_FLIP (i) ;  /* absorb j into i */
                        nv [i] += nv [j] ;
                        nv [j] = 0 ;
                        elen [j] = -1 ;         /* node j is dead */
                        j = next [j] ;          /* delete j from hash bucket */
                        next [jlast] = j ;
                    }
                    else
                    {
                        jlast = j ;             /* j and i are different */
                        j = next [j] ;
                    }
                }
            }
        }
        /* --- Finalize new element------------------------------------------ */
        for (p = pk1, pk = pk1 ; pk < pk2 ; pk++)   /* finalize Lk */
        {
            i = Ci [pk] ;
            if ((nvi = -nv [i]) <= 0) continue ;/* skip if i is dead */
            nv [i] = nvi ;                      /* restore nv[i] */
            d = degree [i] + dk - nvi ;         /* compute external degree(i) */
            d = CS_MIN (d, n - nel - nvi) ;
            if (head [d] != -1) last [head [d]] = i ;
            next [i] = head [d] ;               /* put i back in degree list */
            last [i] = -1 ;
            head [d] = i ;
            mindeg = CS_MIN (mindeg, d) ;       /* find new minimum degree */
            degree [i] = d ;
            Ci [p++] = i ;                      /* place i in Lk */
        }
        nv [k] = nvk ;                      /* # nodes absorbed into k */
        if ((len [k] = p-pk1) == 0)         /* length of adj list of element k*/
        {
            Cp [k] = -1 ;                   /* k is a root of the tree */
            w [k] = 0 ;                     /* k is now a dead element */
        }
        if (elenk != 0) cnz = p ;           /* free unused space in Lk */
    }
    /* --- Postordering ----------------------------------------------------- */
    for (i = 0 ; i < n ; i++) Cp [i] = CS_FLIP (Cp [i]) ;/* fix assembly tree */
    for (j = 0 ; j <= n ; j++) head [j] = -1 ;
    for (j = n ; j >= 0 ; j--)              /* place unordered nodes in lists */
    {
        if (nv [j] > 0) continue ;          /* skip if j is an element */
        next [j] = head [Cp [j]] ;          /* place j in list of its parent */
        head [Cp [j]] = j ;
    }
    for (e = n ; e >= 0 ; e--)              /* place elements in lists */
    {
        if (nv [e] <= 0) continue ;         /* skip unless e is an element */
        if (Cp [e] != -1)
        {
            next [e] = head [Cp [e]] ;      /* place e in list of its parent */
            head [Cp [e]] = e ;
        }
    }
    for (k = 0, i = 0 ; i <= n ; i++)       /* postorder the assembly tree */
    {
        if (Cp [i] == -1) k = cs_tdfs (i, k, head, next, P, w) ;
    }
    return (cs_idone (P, C, W, 1)) ;
}
/* Cholesky update/downdate */
int demo3 (problem *Prob)
{
    cs *A, *C, *W = NULL, *WW, *WT, *E = NULL, *W2 ;
    int n, k, *Li, *Lp, *Wi, *Wp, p1, p2, *p = NULL, ok ;
    double *b, *x, *resid, *y = NULL, *Lx, *Wx, s,  t, t1 ;
    css *S = NULL ;
    csn *N = NULL ;
    if (!Prob || !Prob->sym || Prob->A->n == 0) return (0) ;
    A = Prob->A ; C = Prob->C ; b = Prob->b ; x = Prob->x ; resid = Prob->resid;
    n = A->n ;
    if (!Prob->sym || n == 0) return (1) ;
    rhs (x, b, n) ;                             /* compute right-hand side */
    printf ("\nchol then update/downdate ") ;
    print_order (1) ;
    y = cs_malloc (n, sizeof (double)) ;
    t = tic () ;
    S = cs_schol (1, C) ;                       /* symbolic Chol, amd(A+A') */
    printf ("\nsymbolic chol time %8.2f\n", toc (t)) ;
    t = tic () ;
    N = cs_chol (C, S) ;                        /* numeric Cholesky */
    printf ("numeric  chol time %8.2f\n", toc (t)) ;
    if (!S || !N || !y) return (done3 (0, S, N, y, W, E, p)) ;
    t = tic () ;
    cs_ipvec (S->pinv, b, y, n) ;               /* y = P*b */
    cs_lsolve (N->L, y) ;                       /* y = L\y */
    cs_ltsolve (N->L, y) ;                      /* y = L'\y */
    cs_pvec (S->pinv, y, x, n) ;                /* x = P'*y */
    printf ("solve    chol time %8.2f\n", toc (t)) ;
    printf ("original: ") ;
    print_resid (1, C, x, b, resid) ;           /* print residual */
    k = n/2 ;                                   /* construct W  */
    W = cs_spalloc (n, 1, n, 1, 0) ;
    if (!W) return (done3 (0, S, N, y, W, E, p)) ;
    Lp = N->L->p ; Li = N->L->i ; Lx = N->L->x ;
    Wp = W->p ; Wi = W->i ; Wx = W->x ;
    Wp [0] = 0 ;
    p1 = Lp [k] ;
    Wp [1] = Lp [k+1] - p1 ;
    s = Lx [p1] ;
    srand (1) ;
    for ( ; p1 < Lp [k+1] ; p1++)
    {
        p2 = p1 - Lp [k] ;
        Wi [p2] = Li [p1] ;
        Wx [p2] = s * rand () / ((double) RAND_MAX) ;
    }
    t = tic () ;
    ok = cs_updown (N->L, +1, W, S->parent) ;   /* update: L*L'+W*W' */
    t1 = toc (t) ;
    printf ("update:   time: %8.2f\n", t1) ;
    if (!ok) return (done3 (0, S, N, y, W, E, p)) ;
    t = tic () ;
    cs_ipvec (S->pinv, b, y, n) ;               /* y = P*b */
    cs_lsolve (N->L, y) ;                       /* y = L\y */
    cs_ltsolve (N->L, y) ;                      /* y = L'\y */
    cs_pvec (S->pinv, y, x, n) ;                /* x = P'*y */
    t = toc (t) ;
    p = cs_pinv (S->pinv, n) ;
    W2 = cs_permute (W, p, NULL, 1) ;           /* E = C + (P'W)*(P'W)' */
    WT = cs_transpose (W2,1) ;
    WW = cs_multiply (W2, WT) ;
    cs_spfree (WT) ;
    cs_spfree (W2) ;
    E = cs_add (C, WW, 1, 1) ;
    cs_spfree (WW) ;
    if (!E || !p) return (done3 (0, S, N, y, W, E, p)) ;
    printf ("update:   time: %8.2f (incl solve) ", t1+t) ;
    print_resid (1, E, x, b, resid) ;           /* print residual */
    cs_nfree (N) ;                              /* clear N */
    t = tic () ;
    N = cs_chol (E, S) ;                        /* numeric Cholesky */
    if (!N) return (done3 (0, S, N, y, W, E, p)) ;
    cs_ipvec (S->pinv, b, y, n) ;               /* y = P*b */
    cs_lsolve (N->L, y) ;                       /* y = L\y */
    cs_ltsolve (N->L, y) ;                      /* y = L'\y */
    cs_pvec (S->pinv, y, x, n) ;                /* x = P'*y */
    t = toc (t) ;
    printf ("rechol:   time: %8.2f (incl solve) ", t) ;
    print_resid (1, E, x, b, resid) ;           /* print residual */
    t = tic () ;
    ok = cs_updown (N->L, -1, W, S->parent) ;   /* downdate: L*L'-W*W' */
    t1 = toc (t) ;
    if (!ok) return (done3 (0, S, N, y, W, E, p)) ;
    printf ("downdate: time: %8.2f\n", t1) ;
    t = tic () ;
    cs_ipvec (S->pinv, b, y, n) ;               /* y = P*b */
    cs_lsolve (N->L, y) ;                       /* y = L\y */
    cs_ltsolve (N->L, y) ;                      /* y = L'\y */
    cs_pvec (S->pinv, y, x, n) ;                /* x = P'*y */
    t = toc (t) ;
    printf ("downdate: time: %8.2f (incl solve) ", t1+t) ;
    print_resid (1, C, x, b, resid) ;           /* print residual */
    return (done3 (1, S, N, y, W, E, p)) ;
} 
Пример #8
0
/**
 * @brief Creates the penalty matrix of order k.
 * Returns the matrix Dk as a suite sparse style matrix.
 *
 * @param n                    number of observations
 * @param k                    order of the trendfilter
 * @param x                    locations of the responses
 * @return pointer to a csparse matrix
 * @see tf_calc_dktil
 */
cs * tf_calc_dk (int n, int k, const double * x)
{
  long int i;

  int tk = 1; /* "this k" - will iterate until ts = k */

  cs * D1;
  cs * D1_cp;
  cs * Dk;
  cs * Dk_cp;
  cs * delta_k;
  cs * delta_k_cp;
  cs * D1_x_delta;
  cs * Dk_next;
  cs * T;
  cs * eye;

  /* Deal with k=0 separately */
  if(k == 0)
  {
    T = cs_spalloc (n, n, n, 1, 1) ;
    for (i = 0 ; i < n; i++) cs_entry (T, i, i, 1);
    eye = cs_compress (T);
    cs_spfree (T);
    return eye;
  }

  /* Contruct one 'full D1', which persists throughout
     and another copy as Dk */
  D1 = cs_spalloc(n-tk, n, (n-tk)*2, 1, 1);
  Dk = cs_spalloc(n-tk, n, (n-tk)*2, 1, 1);
  D1->nz = (n-tk)*2;
  Dk->nz = (n-tk)*2;
  for (i = 0; i < (n-tk)*2; i++)
  {
    D1->p[i] = (i+1) / 2;
    Dk->p[i] = D1->p[i];
    D1->i[i] = i / 2;
    Dk->i[i] = D1->i[i];
    D1->x[i] = -1 + 2*(i % 2);
    Dk->x[i] = D1->x[i];
  }

  /* Create a column compressed version of Dk, and
     delete the old copy */
  Dk_cp = cs_compress(Dk);
  cs_spfree(Dk);

  for (tk = 1; tk < k; tk++)
  {
    /* 'reduce' the virtual size of D1 to: (n-tk-1) x (n-tk),
       compress into compressed column, saving as D1_cp */
    D1->nz = (n-tk-1)*2;
    D1->m = n-tk-1;
    D1->n = n-tk;
    D1_cp = cs_compress(D1);

    /* Construct diagonal matrix of differences: */
    delta_k = cs_spalloc(n-tk, n-tk, (n-tk), 1, 1);
    for(i = 0; i < n - tk; i++)
    {
      delta_k->p[i] = i;
      delta_k->i[i] = i;
      delta_k->x[i] = tk / (x[tk + i] - x[i]);
    }
    delta_k->nz = n-tk;
    delta_k_cp = cs_compress(delta_k);
    D1_x_delta = cs_multiply(D1_cp, delta_k_cp);

    /* Execute the matrix multiplication */
    Dk_next = cs_multiply(D1_x_delta, Dk_cp);

    /* Free temporary cs matricies created in each loop */
    cs_spfree(D1_cp);
    cs_spfree(delta_k);
    cs_spfree(delta_k_cp);
    cs_spfree(D1_x_delta);
    cs_spfree(Dk_cp);
    Dk_cp = Dk_next;
  }

  cs_spfree(D1);
  return Dk_cp;
}
Пример #9
0
/**
 * @brief Main wrapper for fitting a trendfilter model.
 * Takes as input either a sequence of lambda tuning parameters, or the number
 * of desired lambda values. In the latter case the function will also calculate
 * a lambda sequence. The user must supply allocated memory to store the output,
 * with the function itself returning only @c void. For default values, and an
 * example of how to call the function, see the function tf_admm_default.
 *
 * @param y                    a vector of responses
 * @param x                    a vector of response locations; must be in increasing order
 * @param w                    a vector of sample weights
 * @param n                    the length of y, x, and w
 * @param k                    degree of the trendfilter; i.e., k=1 linear
 * @param family               family code for the type of fit; family=0 for OLS
 * @param max_iter             maximum number of ADMM interations; ignored for k=0
 * @param lam_flag             0/1 flag for whether lambda sequence needs to be estimated
 * @param lambda               either a sequence of lambda when lam_flag=0, or empty
 *                             allocated space if lam_flag=1
 * @param nlambda              number of lambda values; need for both lam_flag=0 and 1
 * @param lambda_min_ratio     minimum ratio between min and max lambda; ignored for lam_flag=0
 * @param beta                 allocated space of size n*nlambda to store the output coefficents
 * @param obj                  allocated space of size max_iter*nlambda to store the objective
 * @param iter                 allocated space of size nlambda to store the number of iterations
 * @param status               allocated space of size nlambda to store the status of each run
 * @param rho                  tuning parameter for the ADMM algorithm
 * @param obj_tol              stopping criteria tolerance
 * @param alpha_ls             for family != 0, line search tuning parameter
 * @param gamma_ls             for family != 0, line search tuning parameter
 * @param max_iter_ls          for family != 0, max number of iterations in line search
 * @param max_iter_newton      for family != 0, max number of iterations in inner ADMM
 * @param verbose              0/1 flag for printing progress
 * @return void
 * @see tf_admm_default
 */
void tf_admm (double * y, double * x, double * w, int n, int k, int family,
              int max_iter, int lam_flag, double * lambda,
              int nlambda, double lambda_min_ratio, double * beta,
              double * obj, int * iter, int * status, double rho,
              double obj_tol, double alpha_ls, double gamma_ls,
              int max_iter_ls, int max_iter_newton, int verbose)
{
  int i;
  int j;
  double max_lam;
  double min_lam;
  double * temp_n;
  double * beta_max;
  double * alpha;
  double * u;

  cs * D;
  cs * Dt;
  cs * Dk;
  cs * Dkt;
  cs * DktDk;
  gqr * Dt_qr;
  gqr * Dkt_qr;

  beta_max = (double *) malloc(n * sizeof(double));
  temp_n   = (double *) malloc(n * sizeof(double));
  alpha    = (double *) malloc(n * sizeof(double)); /* we use extra buffer (n vs n-k) */
  u        = (double *) malloc(n * sizeof(double)); /* we use extra buffer (n vs n-k) */

  /* Assume w does not have zeros */
  for(i = 0; i < n; i++) temp_n[i] = 1/sqrt(w[i]);

  D = tf_calc_dk(n, k+1, x);
  Dk = tf_calc_dktil(n, k, x);
  Dt = cs_transpose(D, 1);
  diag_times_sparse(Dt, temp_n); /* Dt = W^{-1/2} Dt */
  Dkt = cs_transpose(Dk, 1);
  Dt_qr = glmgen_qr(Dt);
  Dkt_qr = glmgen_qr(Dkt);
  DktDk = cs_multiply(Dkt,Dk);

  /* Determine the maximum lambda in the path, and initiate the path if needed
   * using the input lambda_min_ratio and equally spaced log points.
   */
  max_lam = tf_maxlam(n, y, Dt_qr, w);
  if (!lam_flag)
  {
    min_lam = max_lam * lambda_min_ratio;
    lambda[0] = max_lam;
    for (i = 1; i < nlambda; i++)
      lambda[i] = exp((log(max_lam) * (nlambda - i -1) + log(min_lam) * i) / (nlambda-1));

  }

  rho = rho * pow( (x[n-1] - x[0])/n, (double)k);

  /* Initiate alpha and u for a warm start */
  if (lambda[0] < max_lam * 1e-5)
  {
    for (i = 0; i < n - k; i++)
    {
      alpha[i] = 0;
      u[i] = 0;
    }
  } else {

    /* beta_max */
    for (i = 0; i < n; i++) temp_n[i] = -sqrt(w[i]) * y[i];
    glmgen_qrsol (Dt_qr, temp_n);
    for (i = 0; i < n; i++) beta_max[i] = 0;
    cs_gaxpy(Dt, temp_n, beta_max);
    /* Dt has a W^{-1/2}, so in the next step divide by sqrt(w) instead of w. */
    for (i = 0; i < n; i++) beta_max[i] = y[i] - beta_max[i]/sqrt(w[i]);

    /* alpha_max */
    tf_dxtil(x, n, k, beta_max, alpha);

    /* u_max */
    switch (family)
    {
    case FAMILY_GAUSSIAN:
      for (i = 0; i < n; i++) u[i] = w[i] * (beta_max[i] - y[i]) / (rho * lambda[0]);
      break;

    case FAMILY_LOGISTIC:
      for (i = 0; i < n; i++) {
        u[i] = logi_b2(beta_max[i]) * w[i] * (beta_max[i] - y[i]) / (rho * lambda[0]);
      }
      break;

    case FAMILY_POISSON:
      for (i = 0; i < n; i++) {
        u[i] = pois_b2(beta_max[i]) * w[i] *(beta_max[i] - y[i]) / (rho * lambda[0]);
      }
      break;

    default:
      for (i = 0; i < nlambda; i++) status[i] = 2;
      return;
    }

    glmgen_qrsol (Dkt_qr, u);
  }

  /* Iterate lower level functions over all lambda values;
   * the alpha and u vectors get used each time of subsequent
   * warm starts
   */
  for (i = 0; i < nlambda; i++)
  {
    /* warm start */
    double * beta_init = (i == 0) ? beta_max : beta + (i-1)*n;
    for(j = 0; j < n; j++) beta[i*n + j] = beta_init[j];

    switch (family)
    {
      case FAMILY_GAUSSIAN:
        tf_admm_gauss(y, x, w, n, k, max_iter, lambda[i], beta+i*n, alpha,
                      u, obj+i*max_iter, iter+i, rho * lambda[i], obj_tol,
                      DktDk, verbose);
        break;

      case FAMILY_LOGISTIC:
        tf_admm_glm(y, x, w, n, k, max_iter, lambda[i], beta+i*n, alpha, u, obj+i*max_iter, iter+i,
                    rho * lambda[i], obj_tol, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
                    DktDk, &logi_b, &logi_b1, &logi_b2, verbose);
        break;

      case FAMILY_POISSON:
        tf_admm_glm(y, x, w, n, k, max_iter, lambda[i], beta+i*n, alpha, u, obj+i*max_iter, iter+i,
                    rho * lambda[i], obj_tol, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
                    DktDk, &pois_b, &pois_b1, &pois_b2, verbose);
        break;
    }

    /* If there any NaNs in beta: reset beta, alpha, u */
    if(has_nan(beta + i * n, n))
    {
      for(j = 0; j < n; j++) beta[i*n + j] = 0;
      for(j = 0; j < n-k; j++) { alpha[j] = 0; u[j] = 0; }
      status[i] = 1;
      printf("Numerical error in lambda[%d]=%f",i,lambda[i]);
    }
  }

  cs_spfree(D);
  cs_spfree(Dt);
  cs_spfree(Dk);
  cs_spfree(Dkt);
  cs_spfree(DktDk);
  glmgen_gqr_free(Dt_qr);
  glmgen_gqr_free(Dkt_qr);

  free(temp_n);
  free(beta_max);
  free(alpha);
  free(u);
}
Пример #10
0
/**
 * @brief Main wrapper for fitting a trendfilter model.
 * Takes as input either a sequence of lambda tuning parameters, or the number
 * of desired lambda values. In the latter case the function will also calculate
 * a lambda sequence. The user must supply allocated memory to store the output,
 * with the function itself returning only @c void. For default values, and an
 * example of how to call the function, see the function tf_admm_default.
 *
 * @param x                    a vector of data locations; must be in increasing order
 * @param y                    a vector of responses
 * @param w                    a vector of sample weights
 * @param n                    the length of x, y, and w
 * @param k                    polynomial degree of the fitted trend; i.e., k=1 for linear
 * @param family               family code for the type of fit; family=0 for OLS
 * @param max_iter             maximum number of ADMM interations; ignored for k=0
 * @param beta0                initialization value of beta for first lambda; ignored if NULL
 * @param lam_flag             0/1 flag for whether lambda sequence needs to be estimated
 * @param lambda               either a sequence of lambda when lam_flag=0, or empty
 *                             allocated space if lam_flag=1
 * @param nlambda              number of lambda values; need for both lam_flag=0 and 1
 * @param lambda_min_ratio     minimum ratio between min and max lambda; ignored for lam_flag=0
 * @param df                   allocated space of nlambda to store the output df values
 * @param beta                 allocated space of size n*nlambda to store the output coefficents
 * @param obj                  allocated space of size max_iter*nlambda to store the objective
 * @param iter                 allocated space of size nlambda to store the number of iterations
 * @param status               allocated space of size nlambda to store the status of each run
 * @param rho                  tuning parameter for the ADMM algorithm
 * @param obj_tol              stopping criteria tolerance
 * @param obj_tol_newton       for family != 0, stopping criteria tolerance for prox Newton
 * @param alpha_ls             for family != 0, line search tuning parameter
 * @param gamma_ls             for family != 0, line search tuning parameter
 * @param max_iter_ls          for family != 0, max number of iterations in line search
 * @param max_iter_newton       for family != 0, max number of iterations in inner ADMM
 * @param verbose              0/1 flag for printing progress
 * @return void
 * @see tf_admm_default
 */
void tf_admm ( double * x, double * y, double * w, int n, int k, int family,
    int max_iter, double * beta0, int lam_flag, double * lambda,
    int nlambda, double lambda_min_ratio, int tridiag, int * df,
    double * beta, double * obj, int * iter, int * status,
    double rho, double obj_tol, double obj_tol_newton, double alpha_ls, double gamma_ls,
    int max_iter_ls, int max_iter_newton, int verbose)
{
  int i;
  int j;
  int numDualVars;
  double max_lam;
  double min_lam;
  double * temp_n;
  double * beta_max;
  double * alpha;
  double * u;
  double * A0;
  double * A1;
  double * v;

  cs * D;
  cs * Dt;
  cs * Dk;
  cs * Dkt;
  cs * DktDk;
  gqr * Dt_qr;
  gqr * Dkt_qr;

  beta_max = (double *) malloc(n * sizeof(double));
  temp_n   = (double *) malloc(n * sizeof(double));
  v        = (double *) malloc(n * sizeof(double));

  numDualVars = tridiag ? k : 1;

  /* we use extra buffer below (n vs n-k) */
  alpha    = (double *) malloc(n * numDualVars * sizeof(double)); 
  u        = (double *) malloc(n * numDualVars * sizeof(double)); 

  /* Assume w does not have zeros */
  for (i = 0; i < n; i++) temp_n[i] = 1/sqrt(w[i]);

  D 	= tf_calc_dk(n, k+1, x);
  Dk 	= tf_calc_dktil(n, k, x);
  Dt 	= cs_transpose(D, 1);

  diag_times_sparse(Dt, temp_n); /* Dt = W^{-1/2} Dt */

  Dkt 	 = cs_transpose(Dk, 1);
  Dt_qr  = glmgen_qr(Dt);
  Dkt_qr = glmgen_qr(Dkt);
  DktDk  = cs_multiply(Dkt,Dk);


  /* Determine the maximum lambda in the path */
  max_lam = tf_maxlam(n, y, Dt_qr, w);
  /* and if it is too small, return a trivial solution for Gaussian case */
  if (family == FAMILY_GAUSSIAN) {
    if (max_lam < 1e-12) {
      for (i=0; i<nlambda; i++) {
        for (j=0; j<n; j++) beta[i*n+j] = y[j];
        obj[i*(max_iter+1)] = 0;
        df[i] = n;
      }
      cs_spfree(D);
      cs_spfree(Dt);
      cs_spfree(Dk);
      cs_spfree(Dkt);
      cs_spfree(DktDk);
      glmgen_gqr_free(Dt_qr);
      glmgen_gqr_free(Dkt_qr);
      free(temp_n);
      free(beta_max);
      free(alpha);
      free(u);
      return;
    }
  }
  else {		
    max_lam += 1;
  }

  /* Initiate the path if needed using the input lambda_min_ratio and 
   * equally spaced points in log space. */
  if (!lam_flag) seq_logspace(max_lam,lambda_min_ratio,nlambda,lambda);

  /* Augmented Lagrangian parameter */
  rho = rho * pow((x[n-1] - x[0])/(double)(n-1), (double)k);
  
  /* Initiate alpha and u for a warm start */
  if (lambda[0] < max_lam * 1e-5)  
    for (i = 0; i < n - k; i++) alpha[i] = u[i] = 0;    
  else {
    /* beta_max */
    if (beta0 == NULL)
      calc_beta_max(y,w,n,Dt_qr,Dt,temp_n,beta_max);
    else
      memcpy(beta_max, beta0, n*sizeof(double));

    /* Check if beta = weighted mean(y) is better than beta */
    double yc = weighted_mean(y,w,n);
    for (i = 0; i < n; i++) temp_n[i] = yc;
    double obj1 = tf_obj(x,y,w,n,k,max_lam,family,beta_max,v);
    double obj2 = tf_obj(x,y,w,n,k,max_lam,family,temp_n,v);
    if(obj2 < obj1) memcpy(beta_max, temp_n, n*sizeof(double));

    /* alpha_max */

    if (tridiag && k>0)
    {
      tf_dx1(x, n, 1, beta_max, alpha + (n*k-n));
      for (j=k-1; j >= 1; j--)
        tf_dx1(x, n, k-j+1, alpha + (n*j), alpha + (n*j-n));      
    }
    else if (k>0)
      tf_dxtil(x, n, k, beta_max, alpha);

    /* u_max */    

    if (tridiag)
      for (j=0; j<k; j++) memset(u + (n*j), 0, (n-k+j) * sizeof(double)); 
    else {
      for (i = 0; i < n; i++) 
          u[i] = w[i] * (beta_max[i] - y[i]) / (rho * lambda[0]);

      if(family == FAMILY_LOGISTIC)
        for (i = 0; i < n; i++) u[i] *= logi_b2(beta_max[i]);
      else if(family == FAMILY_POISSON)
        for (i = 0; i < n; i++) u[i] *= pois_b2(beta_max[i]);
      glmgen_qrsol (Dkt_qr, u);
      // for (i = 0; i < n-k; i++) u[i] = 0;
    }
  }

  if (tridiag && k>0)
  {
    /* Setup tridiagonal systems */  
    A0 = (double*) malloc(n*k*sizeof(double));
    A1 = (double*) malloc(n*k*sizeof(double));

    for (j=2; j <= k; j++)
    {
      form_tridiag(x, n, k-j+2, 1, 1, A0+(n*j-n), A1+(n*j-n));
    }
  }  

  /* Iterate lower level functions over all lambda values;
   * the alpha and u vectors get used each time of subsequent
   * warm starts */
  for (i = 0; i < nlambda; i++)
  {    
    /* warm start */
    double *beta_init = (i == 0) ? beta_max : beta + (i-1)*n;
    for(j = 0; j < n; j++) beta[i*n + j] = beta_init[j];

    if (tridiag)
    {
      form_tridiag(x, n, 1, rho * lambda[i], 0, A0, A1);
      for (j=0; j < n; j++) A0[j] = A0[j] + w[j];
    }

    switch (family) {
      case FAMILY_GAUSSIAN:
        if (tridiag)        
          tf_admm_gauss_tri(x, y, w, n, k, max_iter, lambda[i], df+i, beta+i*n,
              alpha, u, obj+i*(1+max_iter), iter+i, rho * lambda[i],
              obj_tol, A0, A1, verbose);        
        else
          tf_admm_gauss(x, y, w, n, k, max_iter, lambda[i], df+i, beta+i*n,
              alpha, u, obj+i*(1+max_iter), iter+i, rho * lambda[i],
              obj_tol, DktDk, verbose);

        break;

      case FAMILY_LOGISTIC:
        tf_admm_glm(x, y, w, n, k, max_iter, lambda[i], tridiag, df+i, beta+i*n,
            alpha, u, obj+i*(1+max_iter_newton), iter+i, rho * lambda[i], obj_tol,
            obj_tol_newton, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
            DktDk, A0, A1, &logi_b, &logi_b1, &logi_b2, verbose);
        break;

      case FAMILY_POISSON:
        tf_admm_glm(x, y, w, n, k, max_iter, lambda[i], tridiag, df+i, beta+i*n,
            alpha, u, obj+i*(1+max_iter_newton), iter+i, rho * lambda[i], obj_tol,
            obj_tol_newton, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
            DktDk, A0, A1, &pois_b, &pois_b1, &pois_b2, verbose);
        break;

      default:
        printf("Unknown family, stopping calculation.\n");
        status[i] = 2;
    }
    

    /* If there any NaNs in beta: reset beta, alpha, u */
    if (has_nan(beta + i*n, n))
    {
      double yc = weighted_mean(y,w,n);
      switch(family) {
        case FAMILY_POISSON:
          yc = (yc > 0) ? log(yc) : -DBL_MAX;
          break;
        case FAMILY_LOGISTIC:
          yc = (yc > 0) ? ( yc < 1 ? log(yc/(1-yc)) : DBL_MAX) : -DBL_MAX;
          break;
        default: break;
      }
      for (j = 0; j < n; j++) beta[i*n + j] = yc;
      for (j = 0; j < n-k; j++) alpha[j] = 0;
      for (j = 0; j < n; j++) u[j] = w[j] * (beta[i*n+j] - y[j]) / (rho * lambda[i]);
      glmgen_qrsol (Dkt_qr, u);
      if (tridiag) for (j = 0; j < n*k; j++) alpha[j] = u[j] = 0;
      status[i] = 1;
    }
  }

  cs_spfree(D);
  cs_spfree(Dt);
  cs_spfree(Dk);
  cs_spfree(Dkt);
  cs_spfree(DktDk);
  glmgen_gqr_free(Dt_qr);
  glmgen_gqr_free(Dkt_qr);

  free(beta_max);
  free(temp_n);
  free(alpha);
  free(u);
  free(v);

  if (tridiag && k>0)
  {
    free(A0);
    free(A1);
  }
}
Пример #11
0
int main ( void )
{
  cs *A;
  cs *AT;
  cs *C;
  cs *D;
  cs *Eye;
  int i;
  int m;
  cs *T;

  printf ( "\n" );
  printf ( "CS_DEMO1:\n" );
  printf ( "  Demonstration of the CSPARSE package.\n" );
/* 
  Load the triplet matrix T from standard input.
*/
  T = cs_load ( stdin );	
/*
  Print T.
*/
  printf ( "T:\n" ); 
  cs_print ( T, 0 );
/*
  A = compressed-column form of T.
*/
  A = cs_triplet ( T );
  printf ( "A:\n" ); 
  cs_print ( A, 0 );
/*
  Clear T.
*/
  cs_spfree ( T );
/*
  AT = A'.
*/ 
  AT = cs_transpose ( A, 1 );
  printf ( "AT:\n" ); 
  cs_print ( AT, 0 );
/*
  M = number of rows of A.
*/
  m = A->m;
/*
  Create triplet identity matrix.
*/
  T = cs_spalloc ( m, m, m, 1, 1 );

  for ( i = 0; i < m; i++ ) 
  {
    cs_entry ( T, i, i, 1 );
  }
/* 
  Eye = speye ( m ) 
*/
  Eye = cs_triplet ( T );
  cs_spfree ( T );
/* 
  Compute C = A * A'.
*/
  C = cs_multiply ( A, AT );		
/* 
  Compute D = C + Eye * norm (C,1).
*/
  D = cs_add ( C, Eye, 1, cs_norm ( C ) );   

  printf ( "D:\n" ); 
  cs_print ( D, 0 );
/* 
  Clear A, AT, C, D, Eye, 
*/
  cs_spfree ( A );			
  cs_spfree ( AT );
  cs_spfree ( C );
  cs_spfree ( D );
  cs_spfree ( Eye );
/*
  Terminate.
*/
  printf ( "\n" );
  printf ( "CS_DEMO1:\n" );
  printf ( "  Normal end of execution.\n" );

  return ( 0 );
}