Add graph references
This commit is contained in:
Abdelrahman Said
@@ -0,0 +1,9 @@
|
||||
add_subdirectory(cs)
|
||||
add_subdirectory(f2c)
|
||||
add_subdirectory(glpk)
|
||||
add_subdirectory(infomap)
|
||||
add_subdirectory(lapack)
|
||||
add_subdirectory(mini-gmp)
|
||||
add_subdirectory(pcg)
|
||||
add_subdirectory(plfit)
|
||||
add_subdirectory(qhull)
|
||||
@@ -0,0 +1,93 @@
|
||||
# Declare the files needed to compile our vendored CXSparse copy
|
||||
add_library(
|
||||
cxsparse_vendored
|
||||
OBJECT
|
||||
EXCLUDE_FROM_ALL
|
||||
cs_add.c
|
||||
cs_amd.c
|
||||
cs_chol.c
|
||||
cs_cholsol.c
|
||||
cs_compress.c
|
||||
cs_counts.c
|
||||
cs_cumsum.c
|
||||
cs_dfs.c
|
||||
cs_dmperm.c
|
||||
cs_droptol.c
|
||||
cs_dropzeros.c
|
||||
cs_dupl.c
|
||||
cs_entry.c
|
||||
cs_ereach.c
|
||||
cs_etree.c
|
||||
cs_fkeep.c
|
||||
cs_gaxpy.c
|
||||
cs_happly.c
|
||||
cs_house.c
|
||||
cs_ipvec.c
|
||||
cs_leaf.c
|
||||
cs_load.c
|
||||
cs_lsolve.c
|
||||
cs_ltsolve.c
|
||||
cs_lu.c
|
||||
cs_lusol.c
|
||||
cs_malloc.c
|
||||
cs_maxtrans.c
|
||||
cs_multiply.c
|
||||
cs_norm.c
|
||||
cs_permute.c
|
||||
cs_pinv.c
|
||||
cs_post.c
|
||||
cs_pvec.c
|
||||
cs_qr.c
|
||||
cs_qrsol.c
|
||||
cs_randperm.c
|
||||
cs_reach.c
|
||||
cs_scatter.c
|
||||
cs_scc.c
|
||||
cs_schol.c
|
||||
cs_spsolve.c
|
||||
cs_sqr.c
|
||||
cs_symperm.c
|
||||
cs_tdfs.c
|
||||
cs_transpose.c
|
||||
cs_updown.c
|
||||
cs_usolve.c
|
||||
cs_util.c
|
||||
cs_utsolve.c
|
||||
# the following files are not needed - they contain no symbols
|
||||
# cs_print.c
|
||||
)
|
||||
|
||||
target_include_directories(
|
||||
cxsparse_vendored
|
||||
PRIVATE
|
||||
${PROJECT_SOURCE_DIR}/include
|
||||
${PROJECT_BINARY_DIR}/include
|
||||
)
|
||||
|
||||
if (BUILD_SHARED_LIBS)
|
||||
set_property(TARGET cxsparse_vendored PROPERTY POSITION_INDEPENDENT_CODE ON)
|
||||
endif()
|
||||
|
||||
# Disable complex number support for CXSparse because:
|
||||
# - It is necessary to compile with MSVC
|
||||
# - igraph does not need complex number support from CXSparse on any platform
|
||||
target_compile_definitions(cxsparse_vendored PUBLIC NCOMPLEX)
|
||||
|
||||
# Since these are included as object files, they should call the
|
||||
# function as is (without a visibility specification)
|
||||
target_compile_definitions(cxsparse_vendored PRIVATE IGRAPH_STATIC)
|
||||
|
||||
use_all_warnings(cxsparse_vendored)
|
||||
|
||||
if (MSVC)
|
||||
target_compile_options(
|
||||
cxsparse_vendored PRIVATE
|
||||
/wd4100
|
||||
) # disable unreferenced parameter warning
|
||||
else()
|
||||
target_compile_options(
|
||||
cxsparse_vendored PRIVATE
|
||||
$<$<C_COMPILER_ID:GCC,Clang,AppleClang,IntelLLVM>:-Wno-unused-variable>
|
||||
)
|
||||
endif()
|
||||
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
CXSparse: a Concise Sparse matrix package - Extended.
|
||||
Copyright (c) 2006, Timothy A. Davis.
|
||||
http://www.suitesparse.com
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
CXSparse is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
CXSparse is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with this Module; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
+315
@@ -0,0 +1,315 @@
|
||||
/* This is a MODIFIED version of the original CXSparse/Include/cs.h file from
|
||||
* SuiteSparse 5.12.0 (CXSparse version 3.2.0). The modifications are outlined
|
||||
* here:
|
||||
*
|
||||
* - Dependency on SuiteSparse_long was removed
|
||||
* - CXSparse is configured to use igraph_int_t as cs_long_t
|
||||
* - CXSparse function prefix is set to cs_igraph instead of cs_igraph
|
||||
* - Unneeded CXSparse function variants are removed
|
||||
*
|
||||
* The remaining comments below are from the original cs.h header */
|
||||
|
||||
/* ========================================================================== */
|
||||
/* CXSparse/Include/cs.h file */
|
||||
/* ========================================================================== */
|
||||
|
||||
/* This is the CXSparse/Include/cs.h file. It has the same name (cs.h) as
|
||||
the CSparse/Include/cs.h file. The 'make install' for SuiteSparse installs
|
||||
CXSparse, and this file, instead of CSparse. The two packages have the same
|
||||
cs.h include filename, because CXSparse is a superset of CSparse. Any user
|
||||
program that uses CSparse can rely on CXSparse instead, with no change to the
|
||||
user code. The #include "cs.h" line will work for both versions, in user
|
||||
code, and the function names and user-visible typedefs from CSparse all
|
||||
appear in CXSparse. For experimenting and changing the package itself, I
|
||||
recommend using CSparse since it's simpler and easier to modify. For
|
||||
using the package in production codes, I recommend CXSparse since it has
|
||||
more features (support for complex matrices, and both int and long
|
||||
versions).
|
||||
*/
|
||||
|
||||
/* ========================================================================== */
|
||||
|
||||
#ifndef _CXS_H
|
||||
#define _CXS_H
|
||||
#include <stdlib.h>
|
||||
#include <limits.h>
|
||||
#include <math.h>
|
||||
#include <stdio.h>
|
||||
#ifdef MATLAB_MEX_FILE
|
||||
#include "mex.h"
|
||||
#endif
|
||||
|
||||
#include "igraph_types.h"
|
||||
|
||||
#ifdef __cplusplus
|
||||
#ifndef NCOMPLEX
|
||||
#include <complex>
|
||||
typedef std::complex<double> cs_complex_t ;
|
||||
#endif
|
||||
extern "C" {
|
||||
#else
|
||||
#ifndef NCOMPLEX
|
||||
#include <complex.h>
|
||||
#define cs_complex_t double _Complex
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#define CS_VER 3 /* CXSparse Version */
|
||||
#define CS_SUBVER 2
|
||||
#define CS_SUBSUB 0
|
||||
#define CS_DATE "Sept 12, 2017" /* CSparse release date */
|
||||
#define CS_COPYRIGHT "Copyright (c) Timothy A. Davis, 2006-2016"
|
||||
#define CXSPARSE
|
||||
|
||||
#define cs_long_t igraph_int_t
|
||||
#define cs_long_t_id "%" IGRAPH_PRId
|
||||
#define cs_long_t_max IGRAPH_INTEGER_MAX
|
||||
|
||||
/* -------------------------------------------------------------------------- */
|
||||
/* double/cs_long_t version of CXSparse */
|
||||
/* -------------------------------------------------------------------------- */
|
||||
|
||||
/* --- primary CSparse routines and data structures ------------------------- */
|
||||
|
||||
typedef struct cs_igraph_sparse /* matrix in compressed-column or triplet form */
|
||||
{
|
||||
cs_long_t nzmax ; /* maximum number of entries */
|
||||
cs_long_t m ; /* number of rows */
|
||||
cs_long_t n ; /* number of columns */
|
||||
cs_long_t *p ; /* column pointers (size n+1) or col indlces (size nzmax) */
|
||||
cs_long_t *i ; /* row indices, size nzmax */
|
||||
double *x ; /* numerical values, size nzmax */
|
||||
cs_long_t nz ; /* # of entries in triplet matrix, -1 for compressed-col */
|
||||
} cs_igraph ;
|
||||
|
||||
cs_igraph *cs_igraph_add (const cs_igraph *A, const cs_igraph *B, double alpha, double beta) ;
|
||||
cs_long_t cs_igraph_cholsol (cs_long_t order, const cs_igraph *A, double *b) ;
|
||||
cs_long_t cs_igraph_dupl (cs_igraph *A) ;
|
||||
cs_long_t cs_igraph_entry (cs_igraph *T, cs_long_t i, cs_long_t j, double x) ;
|
||||
cs_long_t cs_igraph_lusol (cs_long_t order, const cs_igraph *A, double *b, double tol) ;
|
||||
cs_long_t cs_igraph_gaxpy (const cs_igraph *A, const double *x, double *y) ;
|
||||
cs_igraph *cs_igraph_multiply (const cs_igraph *A, const cs_igraph *B) ;
|
||||
cs_long_t cs_igraph_qrsol (cs_long_t order, const cs_igraph *A, double *b) ;
|
||||
cs_igraph *cs_igraph_transpose (const cs_igraph *A, cs_long_t values) ;
|
||||
cs_igraph *cs_igraph_compress (const cs_igraph *T) ;
|
||||
double cs_igraph_norm (const cs_igraph *A) ;
|
||||
/*cs_long_t cs_igraph_print (const cs_igraph *A, cs_long_t brief) ;*/
|
||||
cs_igraph *cs_igraph_load (FILE *f) ;
|
||||
|
||||
/* utilities */
|
||||
void *cs_igraph_calloc (cs_long_t n, size_t size) ;
|
||||
void *cs_igraph_free (void *p) ;
|
||||
void *cs_igraph_realloc (void *p, cs_long_t n, size_t size, cs_long_t *ok) ;
|
||||
cs_igraph *cs_igraph_spalloc (cs_long_t m, cs_long_t n, cs_long_t nzmax, cs_long_t values,
|
||||
cs_long_t t) ;
|
||||
cs_igraph *cs_igraph_spfree (cs_igraph *A) ;
|
||||
cs_long_t cs_igraph_sprealloc (cs_igraph *A, cs_long_t nzmax) ;
|
||||
void *cs_igraph_malloc (cs_long_t n, size_t size) ;
|
||||
|
||||
/* --- secondary CSparse routines and data structures ----------------------- */
|
||||
|
||||
typedef struct cs_igraph_symbolic /* symbolic Cholesky, LU, or QR analysis */
|
||||
{
|
||||
cs_long_t *pinv ; /* inverse row perm. for QR, fill red. perm for Chol */
|
||||
cs_long_t *q ; /* fill-reducing column permutation for LU and QR */
|
||||
cs_long_t *parent ; /* elimination tree for Cholesky and QR */
|
||||
cs_long_t *cp ; /* column pointers for Cholesky, row counts for QR */
|
||||
cs_long_t *leftmost ; /* leftmost[i] = min(find(A(i,:))), for QR */
|
||||
cs_long_t m2 ; /* # of rows for QR, after adding fictitious rows */
|
||||
double lnz ; /* # entries in L for LU or Cholesky; in V for QR */
|
||||
double unz ; /* # entries in U for LU; in R for QR */
|
||||
} cs_igraphs ;
|
||||
|
||||
typedef struct cs_igraph_numeric /* numeric Cholesky, LU, or QR factorization */
|
||||
{
|
||||
cs_igraph *L ; /* L for LU and Cholesky, V for QR */
|
||||
cs_igraph *U ; /* U for LU, r for QR, not used for Cholesky */
|
||||
cs_long_t *pinv ; /* partial pivoting for LU */
|
||||
double *B ; /* beta [0..n-1] for QR */
|
||||
} cs_igraphn ;
|
||||
|
||||
typedef struct cs_igraph_dmperm_results /* cs_igraph_dmperm or cs_igraph_scc output */
|
||||
{
|
||||
cs_long_t *p ; /* size m, row permutation */
|
||||
cs_long_t *q ; /* size n, column permutation */
|
||||
cs_long_t *r ; /* size nb+1, block k is rows r[k] to r[k+1]-1 in A(p,q) */
|
||||
cs_long_t *s ; /* size nb+1, block k is cols s[k] to s[k+1]-1 in A(p,q) */
|
||||
cs_long_t nb ; /* # of blocks in fine dmperm decomposition */
|
||||
cs_long_t rr [5] ; /* coarse row decomposition */
|
||||
cs_long_t cc [5] ; /* coarse column decomposition */
|
||||
} cs_igraphd ;
|
||||
|
||||
cs_long_t *cs_igraph_amd (cs_long_t order, const cs_igraph *A) ;
|
||||
cs_igraphn *cs_igraph_chol (const cs_igraph *A, const cs_igraphs *S) ;
|
||||
cs_igraphd *cs_igraph_dmperm (const cs_igraph *A, cs_long_t seed) ;
|
||||
cs_long_t cs_igraph_droptol (cs_igraph *A, double tol) ;
|
||||
cs_long_t cs_igraph_dropzeros (cs_igraph *A) ;
|
||||
cs_long_t cs_igraph_happly (const cs_igraph *V, cs_long_t i, double beta, double *x) ;
|
||||
cs_long_t cs_igraph_ipvec (const cs_long_t *p, const double *b, double *x, cs_long_t n) ;
|
||||
cs_long_t cs_igraph_lsolve (const cs_igraph *L, double *x) ;
|
||||
cs_long_t cs_igraph_ltsolve (const cs_igraph *L, double *x) ;
|
||||
cs_igraphn *cs_igraph_lu (const cs_igraph *A, const cs_igraphs *S, double tol) ;
|
||||
cs_igraph *cs_igraph_permute (const cs_igraph *A, const cs_long_t *pinv, const cs_long_t *q,
|
||||
cs_long_t values) ;
|
||||
cs_long_t *cs_igraph_pinv (const cs_long_t *p, cs_long_t n) ;
|
||||
cs_long_t cs_igraph_pvec (const cs_long_t *p, const double *b, double *x, cs_long_t n) ;
|
||||
cs_igraphn *cs_igraph_qr (const cs_igraph *A, const cs_igraphs *S) ;
|
||||
cs_igraphs *cs_igraph_schol (cs_long_t order, const cs_igraph *A) ;
|
||||
cs_igraphs *cs_igraph_sqr (cs_long_t order, const cs_igraph *A, cs_long_t qr) ;
|
||||
cs_igraph *cs_igraph_symperm (const cs_igraph *A, const cs_long_t *pinv, cs_long_t values) ;
|
||||
cs_long_t cs_igraph_usolve (const cs_igraph *U, double *x) ;
|
||||
cs_long_t cs_igraph_utsolve (const cs_igraph *U, double *x) ;
|
||||
cs_long_t cs_igraph_updown (cs_igraph *L, cs_long_t sigma, const cs_igraph *C,
|
||||
const cs_long_t *parent) ;
|
||||
|
||||
/* utilities */
|
||||
cs_igraphs *cs_igraph_sfree (cs_igraphs *S) ;
|
||||
cs_igraphn *cs_igraph_nfree (cs_igraphn *N) ;
|
||||
cs_igraphd *cs_igraph_dfree (cs_igraphd *D) ;
|
||||
|
||||
/* --- tertiary CSparse routines -------------------------------------------- */
|
||||
|
||||
cs_long_t *cs_igraph_counts (const cs_igraph *A, const cs_long_t *parent,
|
||||
const cs_long_t *post, cs_long_t ata) ;
|
||||
double cs_igraph_cumsum (cs_long_t *p, cs_long_t *c, cs_long_t n) ;
|
||||
cs_long_t cs_igraph_dfs (cs_long_t j, cs_igraph *G, cs_long_t top, cs_long_t *xi,
|
||||
cs_long_t *pstack, const cs_long_t *pinv) ;
|
||||
cs_long_t *cs_igraph_etree (const cs_igraph *A, cs_long_t ata) ;
|
||||
cs_long_t cs_igraph_fkeep (cs_igraph *A,
|
||||
cs_long_t (*fkeep) (cs_long_t, cs_long_t, double, void *), void *other) ;
|
||||
double cs_igraph_house (double *x, double *beta, cs_long_t n) ;
|
||||
cs_long_t *cs_igraph_maxtrans (const cs_igraph *A, cs_long_t seed) ;
|
||||
cs_long_t *cs_igraph_post (const cs_long_t *parent, cs_long_t n) ;
|
||||
cs_igraphd *cs_igraph_scc (cs_igraph *A) ;
|
||||
cs_long_t cs_igraph_scatter (const cs_igraph *A, cs_long_t j, double beta, cs_long_t *w,
|
||||
double *x, cs_long_t mark,cs_igraph *C, cs_long_t nz) ;
|
||||
cs_long_t cs_igraph_tdfs (cs_long_t j, cs_long_t k, cs_long_t *head, const cs_long_t *next,
|
||||
cs_long_t *post, cs_long_t *stack) ;
|
||||
cs_long_t cs_igraph_leaf (cs_long_t i, cs_long_t j, const cs_long_t *first,
|
||||
cs_long_t *maxfirst, cs_long_t *prevleaf, cs_long_t *ancestor, cs_long_t *jleaf) ;
|
||||
cs_long_t cs_igraph_reach (cs_igraph *G, const cs_igraph *B, cs_long_t k, cs_long_t *xi,
|
||||
const cs_long_t *pinv) ;
|
||||
cs_long_t cs_igraph_spsolve (cs_igraph *L, const cs_igraph *B, cs_long_t k, cs_long_t *xi,
|
||||
double *x, const cs_long_t *pinv, cs_long_t lo) ;
|
||||
cs_long_t cs_igraph_ereach (const cs_igraph *A, cs_long_t k, const cs_long_t *parent,
|
||||
cs_long_t *s, cs_long_t *w) ;
|
||||
cs_long_t *cs_igraph_randperm (cs_long_t n, cs_long_t seed) ;
|
||||
|
||||
/* utilities */
|
||||
cs_igraphd *cs_igraph_dalloc (cs_long_t m, cs_long_t n) ;
|
||||
cs_igraph *cs_igraph_done (cs_igraph *C, void *w, void *x, cs_long_t ok) ;
|
||||
cs_long_t *cs_igraph_idone (cs_long_t *p, cs_igraph *C, void *w, cs_long_t ok) ;
|
||||
cs_igraphn *cs_igraph_ndone (cs_igraphn *N, cs_igraph *C, void *w, void *x, cs_long_t ok) ;
|
||||
cs_igraphd *cs_igraph_ddone (cs_igraphd *D, cs_igraph *C, void *w, cs_long_t ok) ;
|
||||
|
||||
/* -------------------------------------------------------------------------- */
|
||||
/* Macros for constructing each version of CSparse */
|
||||
/* -------------------------------------------------------------------------- */
|
||||
|
||||
#define CS_INT cs_long_t
|
||||
#define CS_INT_MAX cs_long_t_max
|
||||
#define CS_ID cs_long_t_id
|
||||
#define CS_ENTRY double
|
||||
#define CS_NAME(nm) cs_igraph ## nm
|
||||
#define cs cs_igraph
|
||||
|
||||
#define CS_REAL(x) (x)
|
||||
#define CS_IMAG(x) (0.)
|
||||
#define CS_CONJ(x) (x)
|
||||
#define CS_ABS(x) fabs(x)
|
||||
|
||||
#define CS_MAX(a,b) (((a) > (b)) ? (a) : (b))
|
||||
#define CS_MIN(a,b) (((a) < (b)) ? (a) : (b))
|
||||
#define CS_FLIP(i) (-(i)-2)
|
||||
#define CS_UNFLIP(i) (((i) < 0) ? CS_FLIP(i) : (i))
|
||||
#define CS_MARKED(w,j) (w [j] < 0)
|
||||
#define CS_MARK(w,j) { w [j] = CS_FLIP (w [j]) ; }
|
||||
#define CS_CSC(A) (A && (A->nz == -1))
|
||||
#define CS_TRIPLET(A) (A && (A->nz >= 0))
|
||||
|
||||
/* --- primary CSparse routines and data structures ------------------------- */
|
||||
|
||||
#define cs_add CS_NAME (_add)
|
||||
#define cs_cholsol CS_NAME (_cholsol)
|
||||
#define cs_dupl CS_NAME (_dupl)
|
||||
#define cs_entry CS_NAME (_entry)
|
||||
#define cs_lusol CS_NAME (_lusol)
|
||||
#define cs_gaxpy CS_NAME (_gaxpy)
|
||||
#define cs_multiply CS_NAME (_multiply)
|
||||
#define cs_qrsol CS_NAME (_qrsol)
|
||||
#define cs_transpose CS_NAME (_transpose)
|
||||
#define cs_compress CS_NAME (_compress)
|
||||
#define cs_norm CS_NAME (_norm)
|
||||
/*#define cs_print CS_NAME (_print)*/
|
||||
#define cs_load CS_NAME (_load)
|
||||
|
||||
/* utilities */
|
||||
#define cs_calloc CS_NAME (_calloc)
|
||||
#define cs_free CS_NAME (_free)
|
||||
#define cs_realloc CS_NAME (_realloc)
|
||||
#define cs_spalloc CS_NAME (_spalloc)
|
||||
#define cs_spfree CS_NAME (_spfree)
|
||||
#define cs_sprealloc CS_NAME (_sprealloc)
|
||||
#define cs_malloc CS_NAME (_malloc)
|
||||
|
||||
/* --- secondary CSparse routines and data structures ----------------------- */
|
||||
#define css CS_NAME (s)
|
||||
#define csn CS_NAME (n)
|
||||
#define csd CS_NAME (d)
|
||||
|
||||
#define cs_amd CS_NAME (_amd)
|
||||
#define cs_chol CS_NAME (_chol)
|
||||
#define cs_dmperm CS_NAME (_dmperm)
|
||||
#define cs_droptol CS_NAME (_droptol)
|
||||
#define cs_dropzeros CS_NAME (_dropzeros)
|
||||
#define cs_happly CS_NAME (_happly)
|
||||
#define cs_ipvec CS_NAME (_ipvec)
|
||||
#define cs_lsolve CS_NAME (_lsolve)
|
||||
#define cs_ltsolve CS_NAME (_ltsolve)
|
||||
#define cs_lu CS_NAME (_lu)
|
||||
#define cs_permute CS_NAME (_permute)
|
||||
#define cs_pinv CS_NAME (_pinv)
|
||||
#define cs_pvec CS_NAME (_pvec)
|
||||
#define cs_qr CS_NAME (_qr)
|
||||
#define cs_schol CS_NAME (_schol)
|
||||
#define cs_sqr CS_NAME (_sqr)
|
||||
#define cs_symperm CS_NAME (_symperm)
|
||||
#define cs_usolve CS_NAME (_usolve)
|
||||
#define cs_utsolve CS_NAME (_utsolve)
|
||||
#define cs_updown CS_NAME (_updown)
|
||||
|
||||
/* utilities */
|
||||
#define cs_sfree CS_NAME (_sfree)
|
||||
#define cs_nfree CS_NAME (_nfree)
|
||||
#define cs_dfree CS_NAME (_dfree)
|
||||
|
||||
/* --- tertiary CSparse routines -------------------------------------------- */
|
||||
#define cs_counts CS_NAME (_counts)
|
||||
#define cs_cumsum CS_NAME (_cumsum)
|
||||
#define cs_dfs CS_NAME (_dfs)
|
||||
#define cs_etree CS_NAME (_etree)
|
||||
#define cs_fkeep CS_NAME (_fkeep)
|
||||
#define cs_house CS_NAME (_house)
|
||||
#define cs_invmatch CS_NAME (_invmatch)
|
||||
#define cs_maxtrans CS_NAME (_maxtrans)
|
||||
#define cs_post CS_NAME (_post)
|
||||
#define cs_scc CS_NAME (_scc)
|
||||
#define cs_scatter CS_NAME (_scatter)
|
||||
#define cs_tdfs CS_NAME (_tdfs)
|
||||
#define cs_reach CS_NAME (_reach)
|
||||
#define cs_spsolve CS_NAME (_spsolve)
|
||||
#define cs_ereach CS_NAME (_ereach)
|
||||
#define cs_randperm CS_NAME (_randperm)
|
||||
#define cs_leaf CS_NAME (_leaf)
|
||||
|
||||
/* utilities */
|
||||
#define cs_dalloc CS_NAME (_dalloc)
|
||||
#define cs_done CS_NAME (_done)
|
||||
#define cs_idone CS_NAME (_idone)
|
||||
#define cs_ndone CS_NAME (_ndone)
|
||||
#define cs_ddone CS_NAME (_ddone)
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
+28
@@ -0,0 +1,28 @@
|
||||
#include "cs.h"
|
||||
/* C = alpha*A + beta*B */
|
||||
cs *cs_add (const cs *A, const cs *B, CS_ENTRY alpha, CS_ENTRY beta)
|
||||
{
|
||||
CS_INT p, j, nz = 0, anz, *Cp, *Ci, *Bp, m, n, bnz, *w, values ;
|
||||
CS_ENTRY *x, *Bx, *Cx ;
|
||||
cs *C ;
|
||||
if (!CS_CSC (A) || !CS_CSC (B)) return (NULL) ; /* check inputs */
|
||||
if (A->m != B->m || A->n != B->n) return (NULL) ;
|
||||
m = A->m ; anz = A->p [A->n] ;
|
||||
n = B->n ; Bp = B->p ; Bx = B->x ; bnz = Bp [n] ;
|
||||
w = cs_calloc (m, sizeof (CS_INT)) ; /* get workspace */
|
||||
values = (A->x != NULL) && (Bx != NULL) ;
|
||||
x = values ? cs_malloc (m, sizeof (CS_ENTRY)) : NULL ; /* get workspace */
|
||||
C = cs_spalloc (m, n, anz + bnz, values, 0) ; /* allocate result*/
|
||||
if (!C || !w || (values && !x)) return (cs_done (C, w, x, 0)) ;
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
Cp [j] = nz ; /* column j of C starts here */
|
||||
nz = cs_scatter (A, j, alpha, w, x, j+1, C, nz) ; /* alpha*A(:,j)*/
|
||||
nz = cs_scatter (B, j, beta, w, x, j+1, C, nz) ; /* beta*B(:,j) */
|
||||
if (values) for (p = Cp [j] ; p < nz ; p++) Cx [p] = x [Ci [p]] ;
|
||||
}
|
||||
Cp [n] = nz ; /* finalize the last column of C */
|
||||
cs_sprealloc (C, 0) ; /* remove extra space from C */
|
||||
return (cs_done (C, w, x, 1)) ; /* success; free workspace, return C */
|
||||
}
|
||||
+364
@@ -0,0 +1,364 @@
|
||||
#include "cs.h"
|
||||
/* clear w */
|
||||
static CS_INT cs_wclear (CS_INT mark, CS_INT lemax, CS_INT *w, CS_INT n)
|
||||
{
|
||||
CS_INT k ;
|
||||
if (mark < 2 || (mark + lemax < 0))
|
||||
{
|
||||
for (k = 0 ; k < n ; k++) if (w [k] != 0) w [k] = 1 ;
|
||||
mark = 2 ;
|
||||
}
|
||||
return (mark) ; /* at this point, w [0..n-1] < mark holds */
|
||||
}
|
||||
|
||||
/* keep off-diagonal entries; drop diagonal entries */
|
||||
static CS_INT cs_diag (CS_INT i, CS_INT j, CS_ENTRY aij, void *other) { return (i != j) ; }
|
||||
|
||||
/* 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 ;
|
||||
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 = ((h<0) ? (-h):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)) ;
|
||||
}
|
||||
+59
@@ -0,0 +1,59 @@
|
||||
#include "cs.h"
|
||||
/* L = chol (A, [pinv parent cp]), pinv is optional */
|
||||
csn *cs_chol (const cs *A, const css *S)
|
||||
{
|
||||
CS_ENTRY d, lki, *Lx, *x, *Cx ;
|
||||
CS_INT top, i, p, k, n, *Li, *Lp, *cp, *pinv, *s, *c, *parent, *Cp, *Ci ;
|
||||
cs *L, *C, *E ;
|
||||
csn *N ;
|
||||
if (!CS_CSC (A) || !S || !S->cp || !S->parent) return (NULL) ;
|
||||
n = A->n ;
|
||||
N = cs_calloc (1, sizeof (csn)) ; /* allocate result */
|
||||
c = cs_malloc (2*n, sizeof (CS_INT)) ; /* get CS_INT workspace */
|
||||
x = cs_malloc (n, sizeof (CS_ENTRY)) ; /* get CS_ENTRY workspace */
|
||||
cp = S->cp ; pinv = S->pinv ; parent = S->parent ;
|
||||
C = pinv ? cs_symperm (A, pinv, 1) : ((cs *) A) ;
|
||||
E = pinv ? C : NULL ; /* E is alias for A, or a copy E=A(p,p) */
|
||||
if (!N || !c || !x || !C) return (cs_ndone (N, E, c, x, 0)) ;
|
||||
s = c + n ;
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
N->L = L = cs_spalloc (n, n, cp [n], 1, 0) ; /* allocate result */
|
||||
if (!L) return (cs_ndone (N, E, c, x, 0)) ;
|
||||
Lp = L->p ; Li = L->i ; Lx = L->x ;
|
||||
for (k = 0 ; k < n ; k++) Lp [k] = c [k] = cp [k] ;
|
||||
for (k = 0 ; k < n ; k++) /* compute L(k,:) for L*L' = C */
|
||||
{
|
||||
/* --- Nonzero pattern of L(k,:) ------------------------------------ */
|
||||
top = cs_ereach (C, k, parent, s, c) ; /* find pattern of L(k,:) */
|
||||
x [k] = 0 ; /* x (0:k) is now zero */
|
||||
for (p = Cp [k] ; p < Cp [k+1] ; p++) /* x = full(triu(C(:,k))) */
|
||||
{
|
||||
if (Ci [p] <= k) x [Ci [p]] = Cx [p] ;
|
||||
}
|
||||
d = x [k] ; /* d = C(k,k) */
|
||||
x [k] = 0 ; /* clear x for k+1st iteration */
|
||||
/* --- Triangular solve --------------------------------------------- */
|
||||
for ( ; top < n ; top++) /* solve L(0:k-1,0:k-1) * x = C(:,k) */
|
||||
{
|
||||
i = s [top] ; /* s [top..n-1] is pattern of L(k,:) */
|
||||
lki = x [i] / Lx [Lp [i]] ; /* L(k,i) = x (i) / L(i,i) */
|
||||
x [i] = 0 ; /* clear x for k+1st iteration */
|
||||
for (p = Lp [i] + 1 ; p < c [i] ; p++)
|
||||
{
|
||||
x [Li [p]] -= Lx [p] * lki ;
|
||||
}
|
||||
d -= lki * CS_CONJ (lki) ; /* d = d - L(k,i)*L(k,i) */
|
||||
p = c [i]++ ;
|
||||
Li [p] = k ; /* store L(k,i) in column i */
|
||||
Lx [p] = CS_CONJ (lki) ;
|
||||
}
|
||||
/* --- Compute L(k,k) ----------------------------------------------- */
|
||||
if (CS_REAL (d) <= 0 || CS_IMAG (d) != 0)
|
||||
return (cs_ndone (N, E, c, x, 0)) ; /* not pos def */
|
||||
p = c [k]++ ;
|
||||
Li [p] = k ; /* store L(k,k) = sqrt (d) in column k */
|
||||
Lx [p] = sqrt (d) ;
|
||||
}
|
||||
Lp [n] = cp [n] ; /* finalize L */
|
||||
return (cs_ndone (N, E, c, x, 1)) ; /* success: free E,s,x; return N */
|
||||
}
|
||||
+26
@@ -0,0 +1,26 @@
|
||||
#include "cs.h"
|
||||
/* x=A\b where A is symmetric positive definite; b overwritten with solution */
|
||||
CS_INT cs_cholsol (CS_INT order, const cs *A, CS_ENTRY *b)
|
||||
{
|
||||
CS_ENTRY *x ;
|
||||
css *S ;
|
||||
csn *N ;
|
||||
CS_INT n, ok ;
|
||||
if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
|
||||
n = A->n ;
|
||||
S = cs_schol (order, A) ; /* ordering and symbolic analysis */
|
||||
N = cs_chol (A, S) ; /* numeric Cholesky factorization */
|
||||
x = cs_malloc (n, sizeof (CS_ENTRY)) ; /* get workspace */
|
||||
ok = (S && N && x) ;
|
||||
if (ok)
|
||||
{
|
||||
cs_ipvec (S->pinv, b, x, n) ; /* x = P*b */
|
||||
cs_lsolve (N->L, x) ; /* x = L\x */
|
||||
cs_ltsolve (N->L, x) ; /* x = L'\x */
|
||||
cs_pvec (S->pinv, x, b, n) ; /* b = P'*x */
|
||||
}
|
||||
cs_free (x) ;
|
||||
cs_sfree (S) ;
|
||||
cs_nfree (N) ;
|
||||
return (ok) ;
|
||||
}
|
||||
+22
@@ -0,0 +1,22 @@
|
||||
#include "cs.h"
|
||||
/* C = compressed-column form of a triplet matrix T */
|
||||
cs *cs_compress (const cs *T)
|
||||
{
|
||||
CS_INT m, n, nz, p, k, *Cp, *Ci, *w, *Ti, *Tj ;
|
||||
CS_ENTRY *Cx, *Tx ;
|
||||
cs *C ;
|
||||
if (!CS_TRIPLET (T)) return (NULL) ; /* check inputs */
|
||||
m = T->m ; n = T->n ; Ti = T->i ; Tj = T->p ; Tx = T->x ; nz = T->nz ;
|
||||
C = cs_spalloc (m, n, nz, Tx != NULL, 0) ; /* allocate result */
|
||||
w = cs_calloc (n, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!C || !w) return (cs_done (C, w, NULL, 0)) ; /* out of memory */
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
for (k = 0 ; k < nz ; k++) w [Tj [k]]++ ; /* column counts */
|
||||
cs_cumsum (Cp, w, n) ; /* column pointers */
|
||||
for (k = 0 ; k < nz ; k++)
|
||||
{
|
||||
Ci [p = w [Tj [k]]++] = Ti [k] ; /* A(i,j) is the pth entry in C */
|
||||
if (Cx) Cx [p] = Tx [k] ;
|
||||
}
|
||||
return (cs_done (C, w, NULL, 1)) ; /* success; free w and return C */
|
||||
}
|
||||
+61
@@ -0,0 +1,61 @@
|
||||
#include "cs.h"
|
||||
/* column counts of LL'=A or LL'=A'A, given parent & post ordering */
|
||||
#define HEAD(k,j) (ata ? head [k] : j)
|
||||
#define NEXT(J) (ata ? next [J] : -1)
|
||||
static void init_ata (cs *AT, const CS_INT *post, CS_INT *w, CS_INT **head, CS_INT **next)
|
||||
{
|
||||
CS_INT i, k, p, m = AT->n, n = AT->m, *ATp = AT->p, *ATi = AT->i ;
|
||||
*head = w+4*n, *next = w+5*n+1 ;
|
||||
for (k = 0 ; k < n ; k++) w [post [k]] = k ; /* invert post */
|
||||
for (i = 0 ; i < m ; i++)
|
||||
{
|
||||
for (k = n, p = ATp[i] ; p < ATp[i+1] ; p++) k = CS_MIN (k, w [ATi[p]]);
|
||||
(*next) [i] = (*head) [k] ; /* place row i in linked list k */
|
||||
(*head) [k] = i ;
|
||||
}
|
||||
}
|
||||
CS_INT *cs_counts (const cs *A, const CS_INT *parent, const CS_INT *post, CS_INT ata)
|
||||
{
|
||||
CS_INT i, j, k, n, m, J, s, p, q, jleaf, *ATp, *ATi, *maxfirst, *prevleaf,
|
||||
*ancestor, *head = NULL, *next = NULL, *colcount, *w, *first, *delta ;
|
||||
cs *AT ;
|
||||
if (!CS_CSC (A) || !parent || !post) return (NULL) ; /* check inputs */
|
||||
m = A->m ; n = A->n ;
|
||||
s = 4*n + (ata ? (n+m+1) : 0) ;
|
||||
delta = colcount = cs_malloc (n, sizeof (CS_INT)) ; /* allocate result */
|
||||
w = cs_malloc (s, sizeof (CS_INT)) ; /* get workspace */
|
||||
AT = cs_transpose (A, 0) ; /* AT = A' */
|
||||
if (!AT || !colcount || !w) return (cs_idone (colcount, AT, w, 0)) ;
|
||||
ancestor = w ; maxfirst = w+n ; prevleaf = w+2*n ; first = w+3*n ;
|
||||
for (k = 0 ; k < s ; k++) w [k] = -1 ; /* clear workspace w [0..s-1] */
|
||||
for (k = 0 ; k < n ; k++) /* find first [j] */
|
||||
{
|
||||
j = post [k] ;
|
||||
delta [j] = (first [j] == -1) ? 1 : 0 ; /* delta[j]=1 if j is a leaf */
|
||||
for ( ; j != -1 && first [j] == -1 ; j = parent [j]) first [j] = k ;
|
||||
}
|
||||
ATp = AT->p ; ATi = AT->i ;
|
||||
if (ata) init_ata (AT, post, w, &head, &next) ;
|
||||
for (i = 0 ; i < n ; i++) ancestor [i] = i ; /* each node in its own set */
|
||||
for (k = 0 ; k < n ; k++)
|
||||
{
|
||||
j = post [k] ; /* j is the kth node in postordered etree */
|
||||
if (parent [j] != -1) delta [parent [j]]-- ; /* j is not a root */
|
||||
for (J = HEAD (k,j) ; J != -1 ; J = NEXT (J)) /* J=j for LL'=A case */
|
||||
{
|
||||
for (p = ATp [J] ; p < ATp [J+1] ; p++)
|
||||
{
|
||||
i = ATi [p] ;
|
||||
q = cs_leaf (i, j, first, maxfirst, prevleaf, ancestor, &jleaf);
|
||||
if (jleaf >= 1) delta [j]++ ; /* A(i,j) is in skeleton */
|
||||
if (jleaf == 2) delta [q]-- ; /* account for overlap in q */
|
||||
}
|
||||
}
|
||||
if (parent [j] != -1) ancestor [j] = parent [j] ;
|
||||
}
|
||||
for (j = 0 ; j < n ; j++) /* sum up delta's of each child */
|
||||
{
|
||||
if (parent [j] != -1) colcount [parent [j]] += colcount [j] ;
|
||||
}
|
||||
return (cs_idone (colcount, AT, w, 1)) ; /* success: free workspace */
|
||||
}
|
||||
+17
@@ -0,0 +1,17 @@
|
||||
#include "cs.h"
|
||||
/* p [0..n] = cumulative sum of c [0..n-1], and then copy p [0..n-1] into c */
|
||||
double cs_cumsum (CS_INT *p, CS_INT *c, CS_INT n)
|
||||
{
|
||||
CS_INT i, nz = 0 ;
|
||||
double nz2 = 0 ;
|
||||
if (!p || !c) return (-1) ; /* check inputs */
|
||||
for (i = 0 ; i < n ; i++)
|
||||
{
|
||||
p [i] = nz ;
|
||||
nz += c [i] ;
|
||||
nz2 += c [i] ; /* also in double to avoid CS_INT overflow */
|
||||
c [i] = p [i] ; /* also copy p[0..n-1] back into c[0..n-1]*/
|
||||
}
|
||||
p [n] = nz ;
|
||||
return (nz2) ; /* return sum (c [0..n-1]) */
|
||||
}
|
||||
+36
@@ -0,0 +1,36 @@
|
||||
#include "cs.h"
|
||||
/* depth-first-search of the graph of a matrix, starting at node j */
|
||||
CS_INT cs_dfs (CS_INT j, cs *G, CS_INT top, CS_INT *xi, CS_INT *pstack, const CS_INT *pinv)
|
||||
{
|
||||
CS_INT i, p, p2, done, jnew, head = 0, *Gp, *Gi ;
|
||||
if (!CS_CSC (G) || !xi || !pstack) return (-1) ; /* check inputs */
|
||||
Gp = G->p ; Gi = G->i ;
|
||||
xi [0] = j ; /* initialize the recursion stack */
|
||||
while (head >= 0)
|
||||
{
|
||||
j = xi [head] ; /* get j from the top of the recursion stack */
|
||||
jnew = pinv ? (pinv [j]) : j ;
|
||||
if (!CS_MARKED (Gp, j))
|
||||
{
|
||||
CS_MARK (Gp, j) ; /* mark node j as visited */
|
||||
pstack [head] = (jnew < 0) ? 0 : CS_UNFLIP (Gp [jnew]) ;
|
||||
}
|
||||
done = 1 ; /* node j done if no unvisited neighbors */
|
||||
p2 = (jnew < 0) ? 0 : CS_UNFLIP (Gp [jnew+1]) ;
|
||||
for (p = pstack [head] ; p < p2 ; p++) /* examine all neighbors of j */
|
||||
{
|
||||
i = Gi [p] ; /* consider neighbor node i */
|
||||
if (CS_MARKED (Gp, i)) continue ; /* skip visited node i */
|
||||
pstack [head] = p ; /* pause depth-first search of node j */
|
||||
xi [++head] = i ; /* start dfs at node i */
|
||||
done = 0 ; /* node j is not done */
|
||||
break ; /* break, to start dfs (i) */
|
||||
}
|
||||
if (done) /* depth-first search at node j is done */
|
||||
{
|
||||
head-- ; /* remove j from the recursion stack */
|
||||
xi [--top] = j ; /* and place in the output stack */
|
||||
}
|
||||
}
|
||||
return (top) ;
|
||||
}
|
||||
+144
@@ -0,0 +1,144 @@
|
||||
#include "cs.h"
|
||||
/* breadth-first search for coarse decomposition (C0,C1,R1 or R0,R3,C3) */
|
||||
static CS_INT cs_bfs (const cs *A, CS_INT n, CS_INT *wi, CS_INT *wj, CS_INT *queue,
|
||||
const CS_INT *imatch, const CS_INT *jmatch, CS_INT mark)
|
||||
{
|
||||
CS_INT *Ap, *Ai, head = 0, tail = 0, j, i, p, j2 ;
|
||||
cs *C ;
|
||||
for (j = 0 ; j < n ; j++) /* place all unmatched nodes in queue */
|
||||
{
|
||||
if (imatch [j] >= 0) continue ; /* skip j if matched */
|
||||
wj [j] = 0 ; /* j in set C0 (R0 if transpose) */
|
||||
queue [tail++] = j ; /* place unmatched col j in queue */
|
||||
}
|
||||
if (tail == 0) return (1) ; /* quick return if no unmatched nodes */
|
||||
C = (mark == 1) ? ((cs *) A) : cs_transpose (A, 0) ;
|
||||
if (!C) return (0) ; /* bfs of C=A' to find R3,C3 from R0 */
|
||||
Ap = C->p ; Ai = C->i ;
|
||||
while (head < tail) /* while queue is not empty */
|
||||
{
|
||||
j = queue [head++] ; /* get the head of the queue */
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ;
|
||||
if (wi [i] >= 0) continue ; /* skip if i is marked */
|
||||
wi [i] = mark ; /* i in set R1 (C3 if transpose) */
|
||||
j2 = jmatch [i] ; /* traverse alternating path to j2 */
|
||||
if (wj [j2] >= 0) continue ;/* skip j2 if it is marked */
|
||||
wj [j2] = mark ; /* j2 in set C1 (R3 if transpose) */
|
||||
queue [tail++] = j2 ; /* add j2 to queue */
|
||||
}
|
||||
}
|
||||
if (mark != 1) cs_spfree (C) ; /* free A' if it was created */
|
||||
return (1) ;
|
||||
}
|
||||
|
||||
/* collect matched rows and columns into p and q */
|
||||
static void cs_matched (CS_INT n, const CS_INT *wj, const CS_INT *imatch, CS_INT *p, CS_INT *q,
|
||||
CS_INT *cc, CS_INT *rr, CS_INT set, CS_INT mark)
|
||||
{
|
||||
CS_INT kc = cc [set], j ;
|
||||
CS_INT kr = rr [set-1] ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
if (wj [j] != mark) continue ; /* skip if j is not in C set */
|
||||
p [kr++] = imatch [j] ;
|
||||
q [kc++] = j ;
|
||||
}
|
||||
cc [set+1] = kc ;
|
||||
rr [set] = kr ;
|
||||
}
|
||||
|
||||
/* collect unmatched rows into the permutation vector p */
|
||||
static void cs_unmatched (CS_INT m, const CS_INT *wi, CS_INT *p, CS_INT *rr, CS_INT set)
|
||||
{
|
||||
CS_INT i, kr = rr [set] ;
|
||||
for (i = 0 ; i < m ; i++) if (wi [i] == 0) p [kr++] = i ;
|
||||
rr [set+1] = kr ;
|
||||
}
|
||||
|
||||
/* return 1 if row i is in R2 */
|
||||
static CS_INT cs_rprune (CS_INT i, CS_INT j, CS_ENTRY aij, void *other)
|
||||
{
|
||||
CS_INT *rr = (CS_INT *) other ;
|
||||
return (i >= rr [1] && i < rr [2]) ;
|
||||
}
|
||||
|
||||
/* Given A, compute coarse and then fine dmperm */
|
||||
csd *cs_dmperm (const cs *A, CS_INT seed)
|
||||
{
|
||||
CS_INT m, n, i, j, k, cnz, nc, *jmatch, *imatch, *wi, *wj, *pinv, *Cp, *Ci,
|
||||
*ps, *rs, nb1, nb2, *p, *q, *cc, *rr, *r, *s, ok ;
|
||||
cs *C ;
|
||||
csd *D, *scc ;
|
||||
/* --- Maximum matching ------------------------------------------------- */
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
m = A->m ; n = A->n ;
|
||||
D = cs_dalloc (m, n) ; /* allocate result */
|
||||
if (!D) return (NULL) ;
|
||||
p = D->p ; q = D->q ; r = D->r ; s = D->s ; cc = D->cc ; rr = D->rr ;
|
||||
jmatch = cs_maxtrans (A, seed) ; /* max transversal */
|
||||
imatch = jmatch + m ; /* imatch = inverse of jmatch */
|
||||
if (!jmatch) return (cs_ddone (D, NULL, jmatch, 0)) ;
|
||||
/* --- Coarse decomposition --------------------------------------------- */
|
||||
wi = r ; wj = s ; /* use r and s as workspace */
|
||||
for (j = 0 ; j < n ; j++) wj [j] = -1 ; /* unmark all cols for bfs */
|
||||
for (i = 0 ; i < m ; i++) wi [i] = -1 ; /* unmark all rows for bfs */
|
||||
cs_bfs (A, n, wi, wj, q, imatch, jmatch, 1) ; /* find C1, R1 from C0*/
|
||||
ok = cs_bfs (A, m, wj, wi, p, jmatch, imatch, 3) ; /* find R3, C3 from R0*/
|
||||
if (!ok) return (cs_ddone (D, NULL, jmatch, 0)) ;
|
||||
cs_unmatched (n, wj, q, cc, 0) ; /* unmatched set C0 */
|
||||
cs_matched (n, wj, imatch, p, q, cc, rr, 1, 1) ; /* set R1 and C1 */
|
||||
cs_matched (n, wj, imatch, p, q, cc, rr, 2, -1) ; /* set R2 and C2 */
|
||||
cs_matched (n, wj, imatch, p, q, cc, rr, 3, 3) ; /* set R3 and C3 */
|
||||
cs_unmatched (m, wi, p, rr, 3) ; /* unmatched set R0 */
|
||||
cs_free (jmatch) ;
|
||||
/* --- Fine decomposition ----------------------------------------------- */
|
||||
pinv = cs_pinv (p, m) ; /* pinv=p' */
|
||||
if (!pinv) return (cs_ddone (D, NULL, NULL, 0)) ;
|
||||
C = cs_permute (A, pinv, q, 0) ;/* C=A(p,q) (it will hold A(R2,C2)) */
|
||||
cs_free (pinv) ;
|
||||
if (!C) return (cs_ddone (D, NULL, NULL, 0)) ;
|
||||
Cp = C->p ;
|
||||
nc = cc [3] - cc [2] ; /* delete cols C0, C1, and C3 from C */
|
||||
if (cc [2] > 0) for (j = cc [2] ; j <= cc [3] ; j++) Cp [j-cc[2]] = Cp [j] ;
|
||||
C->n = nc ;
|
||||
if (rr [2] - rr [1] < m) /* delete rows R0, R1, and R3 from C */
|
||||
{
|
||||
cs_fkeep (C, cs_rprune, rr) ;
|
||||
cnz = Cp [nc] ;
|
||||
Ci = C->i ;
|
||||
if (rr [1] > 0) for (k = 0 ; k < cnz ; k++) Ci [k] -= rr [1] ;
|
||||
}
|
||||
C->m = nc ;
|
||||
scc = cs_scc (C) ; /* find strongly connected components of C*/
|
||||
if (!scc) return (cs_ddone (D, C, NULL, 0)) ;
|
||||
/* --- Combine coarse and fine decompositions --------------------------- */
|
||||
ps = scc->p ; /* C(ps,ps) is the permuted matrix */
|
||||
rs = scc->r ; /* kth block is rs[k]..rs[k+1]-1 */
|
||||
nb1 = scc->nb ; /* # of blocks of A(R2,C2) */
|
||||
for (k = 0 ; k < nc ; k++) wj [k] = q [ps [k] + cc [2]] ;
|
||||
for (k = 0 ; k < nc ; k++) q [k + cc [2]] = wj [k] ;
|
||||
for (k = 0 ; k < nc ; k++) wi [k] = p [ps [k] + rr [1]] ;
|
||||
for (k = 0 ; k < nc ; k++) p [k + rr [1]] = wi [k] ;
|
||||
nb2 = 0 ; /* create the fine block partitions */
|
||||
r [0] = s [0] = 0 ;
|
||||
if (cc [2] > 0) nb2++ ; /* leading coarse block A (R1, [C0 C1]) */
|
||||
for (k = 0 ; k < nb1 ; k++) /* coarse block A (R2,C2) */
|
||||
{
|
||||
r [nb2] = rs [k] + rr [1] ; /* A (R2,C2) splits into nb1 fine blocks */
|
||||
s [nb2] = rs [k] + cc [2] ;
|
||||
nb2++ ;
|
||||
}
|
||||
if (rr [2] < m)
|
||||
{
|
||||
r [nb2] = rr [2] ; /* trailing coarse block A ([R3 R0], C3) */
|
||||
s [nb2] = cc [3] ;
|
||||
nb2++ ;
|
||||
}
|
||||
r [nb2] = m ;
|
||||
s [nb2] = n ;
|
||||
D->nb = nb2 ;
|
||||
cs_dfree (scc) ;
|
||||
return (cs_ddone (D, C, NULL, 1)) ;
|
||||
}
|
||||
@@ -0,0 +1,9 @@
|
||||
#include "cs.h"
|
||||
static CS_INT cs_tol (CS_INT i, CS_INT j, CS_ENTRY aij, void *tol)
|
||||
{
|
||||
return (CS_ABS (aij) > *((double *) tol)) ;
|
||||
}
|
||||
CS_INT cs_droptol (cs *A, double tol)
|
||||
{
|
||||
return (cs_fkeep (A, &cs_tol, &tol)) ; /* keep all large entries */
|
||||
}
|
||||
@@ -0,0 +1,9 @@
|
||||
#include "cs.h"
|
||||
static CS_INT cs_nonzero (CS_INT i, CS_INT j, CS_ENTRY aij, void *other)
|
||||
{
|
||||
return (aij != 0) ;
|
||||
}
|
||||
CS_INT cs_dropzeros (cs *A)
|
||||
{
|
||||
return (cs_fkeep (A, &cs_nonzero, NULL)) ; /* keep all nonzero entries */
|
||||
}
|
||||
+34
@@ -0,0 +1,34 @@
|
||||
#include "cs.h"
|
||||
/* remove duplicate entries from A */
|
||||
CS_INT cs_dupl (cs *A)
|
||||
{
|
||||
CS_INT i, j, p, q, nz = 0, n, m, *Ap, *Ai, *w ;
|
||||
CS_ENTRY *Ax ;
|
||||
if (!CS_CSC (A)) return (0) ; /* check inputs */
|
||||
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
w = cs_malloc (m, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!w) return (0) ; /* out of memory */
|
||||
for (i = 0 ; i < m ; i++) w [i] = -1 ; /* row i not yet seen */
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
q = nz ; /* column j will start at q */
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ; /* A(i,j) is nonzero */
|
||||
if (w [i] >= q)
|
||||
{
|
||||
Ax [w [i]] += Ax [p] ; /* A(i,j) is a duplicate */
|
||||
}
|
||||
else
|
||||
{
|
||||
w [i] = nz ; /* record where row i occurs */
|
||||
Ai [nz] = i ; /* keep A(i,j) */
|
||||
Ax [nz++] = Ax [p] ;
|
||||
}
|
||||
}
|
||||
Ap [j] = q ; /* record start of column j */
|
||||
}
|
||||
Ap [n] = nz ; /* finalize A */
|
||||
cs_free (w) ; /* free workspace */
|
||||
return (cs_sprealloc (A, 0)) ; /* remove extra space from A */
|
||||
}
|
||||
+13
@@ -0,0 +1,13 @@
|
||||
#include "cs.h"
|
||||
/* add an entry to a triplet matrix; return 1 if ok, 0 otherwise */
|
||||
CS_INT cs_entry (cs *T, CS_INT i, CS_INT j, CS_ENTRY x)
|
||||
{
|
||||
if (!CS_TRIPLET (T) || i < 0 || j < 0) return (0) ; /* check inputs */
|
||||
if (T->nz >= T->nzmax && !cs_sprealloc (T,2*(T->nzmax))) return (0) ;
|
||||
if (T->x) T->x [T->nz] = x ;
|
||||
T->i [T->nz] = i ;
|
||||
T->p [T->nz++] = j ;
|
||||
T->m = CS_MAX (T->m, i+1) ;
|
||||
T->n = CS_MAX (T->n, j+1) ;
|
||||
return (1) ;
|
||||
}
|
||||
+23
@@ -0,0 +1,23 @@
|
||||
#include "cs.h"
|
||||
/* find nonzero pattern of Cholesky L(k,1:k-1) using etree and triu(A(:,k)) */
|
||||
CS_INT cs_ereach (const cs *A, CS_INT k, const CS_INT *parent, CS_INT *s, CS_INT *w)
|
||||
{
|
||||
CS_INT i, p, n, len, top, *Ap, *Ai ;
|
||||
if (!CS_CSC (A) || !parent || !s || !w) return (-1) ; /* check inputs */
|
||||
top = n = A->n ; Ap = A->p ; Ai = A->i ;
|
||||
CS_MARK (w, k) ; /* mark node k as visited */
|
||||
for (p = Ap [k] ; p < Ap [k+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ; /* A(i,k) is nonzero */
|
||||
if (i > k) continue ; /* only use upper triangular part of A */
|
||||
for (len = 0 ; !CS_MARKED (w,i) ; i = parent [i]) /* traverse up etree*/
|
||||
{
|
||||
s [len++] = i ; /* L(k,i) is nonzero */
|
||||
CS_MARK (w, i) ; /* mark i as visited */
|
||||
}
|
||||
while (len > 0) s [--top] = s [--len] ; /* push path onto stack */
|
||||
}
|
||||
for (p = top ; p < n ; p++) CS_MARK (w, s [p]) ; /* unmark all nodes */
|
||||
CS_MARK (w, k) ; /* unmark node k */
|
||||
return (top) ; /* s [top..n-1] contains pattern of L(k,:)*/
|
||||
}
|
||||
+30
@@ -0,0 +1,30 @@
|
||||
#include "cs.h"
|
||||
/* compute the etree of A (using triu(A), or A'A without forming A'A */
|
||||
CS_INT *cs_etree (const cs *A, CS_INT ata)
|
||||
{
|
||||
CS_INT i, k, p, m, n, inext, *Ap, *Ai, *w, *parent, *ancestor, *prev ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ;
|
||||
parent = cs_malloc (n, sizeof (CS_INT)) ; /* allocate result */
|
||||
w = cs_malloc (n + (ata ? m : 0), sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!w || !parent) return (cs_idone (parent, NULL, w, 0)) ;
|
||||
ancestor = w ; prev = w + n ;
|
||||
if (ata) for (i = 0 ; i < m ; i++) prev [i] = -1 ;
|
||||
for (k = 0 ; k < n ; k++)
|
||||
{
|
||||
parent [k] = -1 ; /* node k has no parent yet */
|
||||
ancestor [k] = -1 ; /* nor does k have an ancestor */
|
||||
for (p = Ap [k] ; p < Ap [k+1] ; p++)
|
||||
{
|
||||
i = ata ? (prev [Ai [p]]) : (Ai [p]) ;
|
||||
for ( ; i != -1 && i < k ; i = inext) /* traverse from i to k */
|
||||
{
|
||||
inext = ancestor [i] ; /* inext = ancestor of i */
|
||||
ancestor [i] = k ; /* path compression */
|
||||
if (inext == -1) parent [i] = k ; /* no anc., parent is k */
|
||||
}
|
||||
if (ata) prev [Ai [p]] = k ;
|
||||
}
|
||||
}
|
||||
return (cs_idone (parent, NULL, w, 1)) ;
|
||||
}
|
||||
+25
@@ -0,0 +1,25 @@
|
||||
#include "cs.h"
|
||||
/* drop entries for which fkeep(A(i,j)) is false; return nz if OK, else -1 */
|
||||
CS_INT cs_fkeep (cs *A, CS_INT (*fkeep) (CS_INT, CS_INT, CS_ENTRY, void *), void *other)
|
||||
{
|
||||
CS_INT j, p, nz = 0, n, *Ap, *Ai ;
|
||||
CS_ENTRY *Ax ;
|
||||
if (!CS_CSC (A) || !fkeep) return (-1) ; /* check inputs */
|
||||
n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
p = Ap [j] ; /* get current location of col j */
|
||||
Ap [j] = nz ; /* record new location of col j */
|
||||
for ( ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
if (fkeep (Ai [p], j, Ax ? Ax [p] : 1, other))
|
||||
{
|
||||
if (Ax) Ax [nz] = Ax [p] ; /* keep A(i,j) */
|
||||
Ai [nz++] = Ai [p] ;
|
||||
}
|
||||
}
|
||||
}
|
||||
Ap [n] = nz ; /* finalize A */
|
||||
cs_sprealloc (A, 0) ; /* remove extra space from A */
|
||||
return (nz) ;
|
||||
}
|
||||
+17
@@ -0,0 +1,17 @@
|
||||
#include "cs.h"
|
||||
/* y = A*x+y */
|
||||
CS_INT cs_gaxpy (const cs *A, const CS_ENTRY *x, CS_ENTRY *y)
|
||||
{
|
||||
CS_INT p, j, n, *Ap, *Ai ;
|
||||
CS_ENTRY *Ax ;
|
||||
if (!CS_CSC (A) || !x || !y) return (0) ; /* check inputs */
|
||||
n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
y [Ai [p]] += Ax [p] * x [j] ;
|
||||
}
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "cs.h"
|
||||
/* apply the ith Householder vector to x */
|
||||
CS_INT cs_happly (const cs *V, CS_INT i, double beta, CS_ENTRY *x)
|
||||
{
|
||||
CS_INT p, *Vp, *Vi ;
|
||||
CS_ENTRY *Vx, tau = 0 ;
|
||||
if (!CS_CSC (V) || !x) return (0) ; /* check inputs */
|
||||
Vp = V->p ; Vi = V->i ; Vx = V->x ;
|
||||
for (p = Vp [i] ; p < Vp [i+1] ; p++) /* tau = v'*x */
|
||||
{
|
||||
tau += CS_CONJ (Vx [p]) * x [Vi [p]] ;
|
||||
}
|
||||
tau *= beta ; /* tau = beta*(v'*x) */
|
||||
for (p = Vp [i] ; p < Vp [i+1] ; p++) /* x = x - v*tau */
|
||||
{
|
||||
x [Vi [p]] -= Vx [p] * tau ;
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
+30
@@ -0,0 +1,30 @@
|
||||
#include "cs.h"
|
||||
/* create a Householder reflection [v,beta,s]=house(x), overwrite x with v,
|
||||
* where (I-beta*v*v')*x = s*e1 and e1 = [1 0 ... 0]'.
|
||||
* Note that this CXSparse version is different than CSparse. See Higham,
|
||||
* Accuracy & Stability of Num Algorithms, 2nd ed, 2002, page 357. */
|
||||
CS_ENTRY cs_house (CS_ENTRY *x, double *beta, CS_INT n)
|
||||
{
|
||||
CS_ENTRY s = 0 ;
|
||||
CS_INT i ;
|
||||
if (!x || !beta) return (-1) ; /* check inputs */
|
||||
/* s = norm(x) */
|
||||
for (i = 0 ; i < n ; i++) s += x [i] * CS_CONJ (x [i]) ;
|
||||
s = sqrt (s) ;
|
||||
if (s == 0)
|
||||
{
|
||||
(*beta) = 0 ;
|
||||
x [0] = 1 ;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* s = sign(x[0]) * norm (x) ; */
|
||||
if (x [0] != 0)
|
||||
{
|
||||
s *= x [0] / CS_ABS (x [0]) ;
|
||||
}
|
||||
x [0] += s ;
|
||||
(*beta) = 1. / CS_REAL (CS_CONJ (s) * x [0]) ;
|
||||
}
|
||||
return (-s) ;
|
||||
}
|
||||
@@ -0,0 +1,9 @@
|
||||
#include "cs.h"
|
||||
/* x(p) = b, for dense vectors x and b; p=NULL denotes identity */
|
||||
CS_INT cs_ipvec (const CS_INT *p, const CS_ENTRY *b, CS_ENTRY *x, CS_INT n)
|
||||
{
|
||||
CS_INT k ;
|
||||
if (!x || !b) return (0) ; /* check inputs */
|
||||
for (k = 0 ; k < n ; k++) x [p ? p [k] : k] = b [k] ;
|
||||
return (1) ;
|
||||
}
|
||||
+22
@@ -0,0 +1,22 @@
|
||||
#include "cs.h"
|
||||
/* consider A(i,j), node j in ith row subtree and return lca(jprev,j) */
|
||||
CS_INT cs_leaf (CS_INT i, CS_INT j, const CS_INT *first, CS_INT *maxfirst, CS_INT *prevleaf,
|
||||
CS_INT *ancestor, CS_INT *jleaf)
|
||||
{
|
||||
CS_INT q, s, sparent, jprev ;
|
||||
if (!first || !maxfirst || !prevleaf || !ancestor || !jleaf) return (-1) ;
|
||||
*jleaf = 0 ;
|
||||
if (i <= j || first [j] <= maxfirst [i]) return (-1) ; /* j not a leaf */
|
||||
maxfirst [i] = first [j] ; /* update max first[j] seen so far */
|
||||
jprev = prevleaf [i] ; /* jprev = previous leaf of ith subtree */
|
||||
prevleaf [i] = j ;
|
||||
*jleaf = (jprev == -1) ? 1: 2 ; /* j is first or subsequent leaf */
|
||||
if (*jleaf == 1) return (i) ; /* if 1st leaf, q = root of ith subtree */
|
||||
for (q = jprev ; q != ancestor [q] ; q = ancestor [q]) ;
|
||||
for (s = jprev ; s != q ; s = sparent)
|
||||
{
|
||||
sparent = ancestor [s] ; /* path compression */
|
||||
ancestor [s] = q ;
|
||||
}
|
||||
return (q) ; /* q = least common ancester (jprev,j) */
|
||||
}
|
||||
+26
@@ -0,0 +1,26 @@
|
||||
#include "cs.h"
|
||||
/* load a triplet matrix from a file */
|
||||
cs *cs_load (FILE *f)
|
||||
{
|
||||
double i, j ; /* use double for integers to avoid csi conflicts */
|
||||
double x ;
|
||||
#ifdef CS_COMPLEX
|
||||
double xi ;
|
||||
#endif
|
||||
cs *T ;
|
||||
if (!f) return (NULL) ; /* check inputs */
|
||||
T = cs_spalloc (0, 0, 1, 1, 1) ; /* allocate result */
|
||||
#ifdef CS_COMPLEX
|
||||
while (fscanf (f, "%lg %lg %lg %lg\n", &i, &j, &x, &xi) == 4)
|
||||
#else
|
||||
while (fscanf (f, "%lg %lg %lg\n", &i, &j, &x) == 3)
|
||||
#endif
|
||||
{
|
||||
#ifdef CS_COMPLEX
|
||||
if (!cs_entry (T, (CS_INT) i, (CS_INT) j, x + xi*I)) return (cs_spfree (T)) ;
|
||||
#else
|
||||
if (!cs_entry (T, (CS_INT) i, (CS_INT) j, x)) return (cs_spfree (T)) ;
|
||||
#endif
|
||||
}
|
||||
return (T) ;
|
||||
}
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
#include "cs.h"
|
||||
/* solve Lx=b where x and b are dense. x=b on input, solution on output. */
|
||||
CS_INT cs_lsolve (const cs *L, CS_ENTRY *x)
|
||||
{
|
||||
CS_INT p, j, n, *Lp, *Li ;
|
||||
CS_ENTRY *Lx ;
|
||||
if (!CS_CSC (L) || !x) return (0) ; /* check inputs */
|
||||
n = L->n ; Lp = L->p ; Li = L->i ; Lx = L->x ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
x [j] /= Lx [Lp [j]] ;
|
||||
for (p = Lp [j]+1 ; p < Lp [j+1] ; p++)
|
||||
{
|
||||
x [Li [p]] -= Lx [p] * x [j] ;
|
||||
}
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
#include "cs.h"
|
||||
/* solve L'x=b where x and b are dense. x=b on input, solution on output. */
|
||||
CS_INT cs_ltsolve (const cs *L, CS_ENTRY *x)
|
||||
{
|
||||
CS_INT p, j, n, *Lp, *Li ;
|
||||
CS_ENTRY *Lx ;
|
||||
if (!CS_CSC (L) || !x) return (0) ; /* check inputs */
|
||||
n = L->n ; Lp = L->p ; Li = L->i ; Lx = L->x ;
|
||||
for (j = n-1 ; j >= 0 ; j--)
|
||||
{
|
||||
for (p = Lp [j]+1 ; p < Lp [j+1] ; p++)
|
||||
{
|
||||
x [j] -= CS_CONJ (Lx [p]) * x [Li [p]] ;
|
||||
}
|
||||
x [j] /= CS_CONJ (Lx [Lp [j]]) ;
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
+88
@@ -0,0 +1,88 @@
|
||||
#include "cs.h"
|
||||
/* [L,U,pinv]=lu(A, [q lnz unz]). lnz and unz can be guess */
|
||||
csn *cs_lu (const cs *A, const css *S, double tol)
|
||||
{
|
||||
cs *L, *U ;
|
||||
csn *N ;
|
||||
CS_ENTRY pivot, *Lx, *Ux, *x ;
|
||||
double a, t ;
|
||||
CS_INT *Lp, *Li, *Up, *Ui, *pinv, *xi, *q, n, ipiv, k, top, p, i, col, lnz,unz;
|
||||
if (!CS_CSC (A) || !S) return (NULL) ; /* check inputs */
|
||||
n = A->n ;
|
||||
q = S->q ; lnz = S->lnz ; unz = S->unz ;
|
||||
x = cs_malloc (n, sizeof (CS_ENTRY)) ; /* get CS_ENTRY workspace */
|
||||
xi = cs_malloc (2*n, sizeof (CS_INT)) ; /* get CS_INT workspace */
|
||||
N = cs_calloc (1, sizeof (csn)) ; /* allocate result */
|
||||
if (!x || !xi || !N) return (cs_ndone (N, NULL, xi, x, 0)) ;
|
||||
N->L = L = cs_spalloc (n, n, lnz, 1, 0) ; /* allocate result L */
|
||||
N->U = U = cs_spalloc (n, n, unz, 1, 0) ; /* allocate result U */
|
||||
N->pinv = pinv = cs_malloc (n, sizeof (CS_INT)) ; /* allocate result pinv */
|
||||
if (!L || !U || !pinv) return (cs_ndone (N, NULL, xi, x, 0)) ;
|
||||
Lp = L->p ; Up = U->p ;
|
||||
for (i = 0 ; i < n ; i++) x [i] = 0 ; /* clear workspace */
|
||||
for (i = 0 ; i < n ; i++) pinv [i] = -1 ; /* no rows pivotal yet */
|
||||
for (k = 0 ; k <= n ; k++) Lp [k] = 0 ; /* no cols of L yet */
|
||||
lnz = unz = 0 ;
|
||||
for (k = 0 ; k < n ; k++) /* compute L(:,k) and U(:,k) */
|
||||
{
|
||||
/* --- Triangular solve --------------------------------------------- */
|
||||
Lp [k] = lnz ; /* L(:,k) starts here */
|
||||
Up [k] = unz ; /* U(:,k) starts here */
|
||||
if ((lnz + n > L->nzmax && !cs_sprealloc (L, 2*L->nzmax + n)) ||
|
||||
(unz + n > U->nzmax && !cs_sprealloc (U, 2*U->nzmax + n)))
|
||||
{
|
||||
return (cs_ndone (N, NULL, xi, x, 0)) ;
|
||||
}
|
||||
Li = L->i ; Lx = L->x ; Ui = U->i ; Ux = U->x ;
|
||||
col = q ? (q [k]) : k ;
|
||||
top = cs_spsolve (L, A, col, xi, x, pinv, 1) ; /* x = L\A(:,col) */
|
||||
/* --- Find pivot --------------------------------------------------- */
|
||||
ipiv = -1 ;
|
||||
a = -1 ;
|
||||
for (p = top ; p < n ; p++)
|
||||
{
|
||||
i = xi [p] ; /* x(i) is nonzero */
|
||||
if (pinv [i] < 0) /* row i is not yet pivotal */
|
||||
{
|
||||
if ((t = CS_ABS (x [i])) > a)
|
||||
{
|
||||
a = t ; /* largest pivot candidate so far */
|
||||
ipiv = i ;
|
||||
}
|
||||
}
|
||||
else /* x(i) is the entry U(pinv[i],k) */
|
||||
{
|
||||
Ui [unz] = pinv [i] ;
|
||||
Ux [unz++] = x [i] ;
|
||||
}
|
||||
}
|
||||
if (ipiv == -1 || a <= 0) return (cs_ndone (N, NULL, xi, x, 0)) ;
|
||||
/* tol=1 for partial pivoting; tol<1 gives preference to diagonal */
|
||||
if (pinv [col] < 0 && CS_ABS (x [col]) >= a*tol) ipiv = col ;
|
||||
/* --- Divide by pivot ---------------------------------------------- */
|
||||
pivot = x [ipiv] ; /* the chosen pivot */
|
||||
Ui [unz] = k ; /* last entry in U(:,k) is U(k,k) */
|
||||
Ux [unz++] = pivot ;
|
||||
pinv [ipiv] = k ; /* ipiv is the kth pivot row */
|
||||
Li [lnz] = ipiv ; /* first entry in L(:,k) is L(k,k) = 1 */
|
||||
Lx [lnz++] = 1 ;
|
||||
for (p = top ; p < n ; p++) /* L(k+1:n,k) = x / pivot */
|
||||
{
|
||||
i = xi [p] ;
|
||||
if (pinv [i] < 0) /* x(i) is an entry in L(:,k) */
|
||||
{
|
||||
Li [lnz] = i ; /* save unpermuted row in L */
|
||||
Lx [lnz++] = x [i] / pivot ; /* scale pivot column */
|
||||
}
|
||||
x [i] = 0 ; /* x [0..n-1] = 0 for next k */
|
||||
}
|
||||
}
|
||||
/* --- Finalize L and U ------------------------------------------------- */
|
||||
Lp [n] = lnz ;
|
||||
Up [n] = unz ;
|
||||
Li = L->i ; /* fix row indices of L for final pinv */
|
||||
for (p = 0 ; p < lnz ; p++) Li [p] = pinv [Li [p]] ;
|
||||
cs_sprealloc (L, 0) ; /* remove extra space from L and U */
|
||||
cs_sprealloc (U, 0) ;
|
||||
return (cs_ndone (N, NULL, xi, x, 1)) ; /* success */
|
||||
}
|
||||
+26
@@ -0,0 +1,26 @@
|
||||
#include "cs.h"
|
||||
/* x=A\b where A is unsymmetric; b overwritten with solution */
|
||||
CS_INT cs_lusol (CS_INT order, const cs *A, CS_ENTRY *b, double tol)
|
||||
{
|
||||
CS_ENTRY *x ;
|
||||
css *S ;
|
||||
csn *N ;
|
||||
CS_INT n, ok ;
|
||||
if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
|
||||
n = A->n ;
|
||||
S = cs_sqr (order, A, 0) ; /* ordering and symbolic analysis */
|
||||
N = cs_lu (A, S, tol) ; /* numeric LU factorization */
|
||||
x = cs_malloc (n, sizeof (CS_ENTRY)) ; /* get workspace */
|
||||
ok = (S && N && x) ;
|
||||
if (ok)
|
||||
{
|
||||
cs_ipvec (N->pinv, b, x, n) ; /* x = b(p) */
|
||||
cs_lsolve (N->L, x) ; /* x = L\x */
|
||||
cs_usolve (N->U, x) ; /* x = U\x */
|
||||
cs_ipvec (S->q, x, b, n) ; /* b(q) = x */
|
||||
}
|
||||
cs_free (x) ;
|
||||
cs_sfree (S) ;
|
||||
cs_nfree (N) ;
|
||||
return (ok) ;
|
||||
}
|
||||
+35
@@ -0,0 +1,35 @@
|
||||
#include "cs.h"
|
||||
#ifdef MATLAB_MEX_FILE
|
||||
#define malloc mxMalloc
|
||||
#define free mxFree
|
||||
#define realloc mxRealloc
|
||||
#define calloc mxCalloc
|
||||
#endif
|
||||
|
||||
/* wrapper for malloc */
|
||||
void *cs_malloc (CS_INT n, size_t size)
|
||||
{
|
||||
return (malloc (CS_MAX (n,1) * size)) ;
|
||||
}
|
||||
|
||||
/* wrapper for calloc */
|
||||
void *cs_calloc (CS_INT n, size_t size)
|
||||
{
|
||||
return (calloc (CS_MAX (n,1), size)) ;
|
||||
}
|
||||
|
||||
/* wrapper for free */
|
||||
void *cs_free (void *p)
|
||||
{
|
||||
if (p) free (p) ; /* free p if it is not already NULL */
|
||||
return (NULL) ; /* return NULL to simplify the use of cs_free */
|
||||
}
|
||||
|
||||
/* wrapper for realloc */
|
||||
void *cs_realloc (void *p, CS_INT n, size_t size, CS_INT *ok)
|
||||
{
|
||||
void *pnew ;
|
||||
pnew = realloc (p, CS_MAX (n,1) * size) ; /* realloc the block */
|
||||
*ok = (pnew != NULL) ; /* realloc fails if pnew is NULL */
|
||||
return ((*ok) ? pnew : p) ; /* return original p if failure */
|
||||
}
|
||||
+92
@@ -0,0 +1,92 @@
|
||||
#include "cs.h"
|
||||
/* find an augmenting path starting at column k and extend the match if found */
|
||||
static void cs_augment (CS_INT k, const cs *A, CS_INT *jmatch, CS_INT *cheap, CS_INT *w,
|
||||
CS_INT *js, CS_INT *is, CS_INT *ps)
|
||||
{
|
||||
CS_INT found = 0, p, i = -1, *Ap = A->p, *Ai = A->i, head = 0, j ;
|
||||
js [0] = k ; /* start with just node k in jstack */
|
||||
while (head >= 0)
|
||||
{
|
||||
/* --- Start (or continue) depth-first-search at node j ------------- */
|
||||
j = js [head] ; /* get j from top of jstack */
|
||||
if (w [j] != k) /* 1st time j visited for kth path */
|
||||
{
|
||||
w [j] = k ; /* mark j as visited for kth path */
|
||||
for (p = cheap [j] ; p < Ap [j+1] && !found ; p++)
|
||||
{
|
||||
i = Ai [p] ; /* try a cheap assignment (i,j) */
|
||||
found = (jmatch [i] == -1) ;
|
||||
}
|
||||
cheap [j] = p ; /* start here next time j is traversed*/
|
||||
if (found)
|
||||
{
|
||||
is [head] = i ; /* column j matched with row i */
|
||||
break ; /* end of augmenting path */
|
||||
}
|
||||
ps [head] = Ap [j] ; /* no cheap match: start dfs for j */
|
||||
}
|
||||
/* --- Depth-first-search of neighbors of j ------------------------- */
|
||||
for (p = ps [head] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ; /* consider row i */
|
||||
if (w [jmatch [i]] == k) continue ; /* skip jmatch [i] if marked */
|
||||
ps [head] = p + 1 ; /* pause dfs of node j */
|
||||
is [head] = i ; /* i will be matched with j if found */
|
||||
js [++head] = jmatch [i] ; /* start dfs at column jmatch [i] */
|
||||
break ;
|
||||
}
|
||||
if (p == Ap [j+1]) head-- ; /* node j is done; pop from stack */
|
||||
} /* augment the match if path found: */
|
||||
if (found) for (p = head ; p >= 0 ; p--) jmatch [is [p]] = js [p] ;
|
||||
}
|
||||
|
||||
/* find a maximum transveral */
|
||||
CS_INT *cs_maxtrans (const cs *A, CS_INT seed) /*[jmatch [0..m-1]; imatch [0..n-1]]*/
|
||||
{
|
||||
CS_INT i, j, k, n, m, p, n2 = 0, m2 = 0, *Ap, *jimatch, *w, *cheap, *js, *is,
|
||||
*ps, *Ai, *Cp, *jmatch, *imatch, *q ;
|
||||
cs *C ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
n = A->n ; m = A->m ; Ap = A->p ; Ai = A->i ;
|
||||
w = jimatch = cs_calloc (m+n, sizeof (CS_INT)) ; /* allocate result */
|
||||
if (!jimatch) return (NULL) ;
|
||||
for (k = 0, j = 0 ; j < n ; j++) /* count nonempty rows and columns */
|
||||
{
|
||||
n2 += (Ap [j] < Ap [j+1]) ;
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
w [Ai [p]] = 1 ;
|
||||
k += (j == Ai [p]) ; /* count entries already on diagonal */
|
||||
}
|
||||
}
|
||||
if (k == CS_MIN (m,n)) /* quick return if diagonal zero-free */
|
||||
{
|
||||
jmatch = jimatch ; imatch = jimatch + m ;
|
||||
for (i = 0 ; i < k ; i++) jmatch [i] = i ;
|
||||
for ( ; i < m ; i++) jmatch [i] = -1 ;
|
||||
for (j = 0 ; j < k ; j++) imatch [j] = j ;
|
||||
for ( ; j < n ; j++) imatch [j] = -1 ;
|
||||
return (cs_idone (jimatch, NULL, NULL, 1)) ;
|
||||
}
|
||||
for (i = 0 ; i < m ; i++) m2 += w [i] ;
|
||||
C = (m2 < n2) ? cs_transpose (A,0) : ((cs *) A) ; /* transpose if needed */
|
||||
if (!C) return (cs_idone (jimatch, (m2 < n2) ? C : NULL, NULL, 0)) ;
|
||||
n = C->n ; m = C->m ; Cp = C->p ;
|
||||
jmatch = (m2 < n2) ? jimatch + n : jimatch ;
|
||||
imatch = (m2 < n2) ? jimatch : jimatch + m ;
|
||||
w = cs_malloc (5*n, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!w) return (cs_idone (jimatch, (m2 < n2) ? C : NULL, w, 0)) ;
|
||||
cheap = w + n ; js = w + 2*n ; is = w + 3*n ; ps = w + 4*n ;
|
||||
for (j = 0 ; j < n ; j++) cheap [j] = Cp [j] ; /* for cheap assignment */
|
||||
for (j = 0 ; j < n ; j++) w [j] = -1 ; /* all columns unflagged */
|
||||
for (i = 0 ; i < m ; i++) jmatch [i] = -1 ; /* nothing matched yet */
|
||||
q = cs_randperm (n, seed) ; /* q = random permutation */
|
||||
for (k = 0 ; k < n ; k++) /* augment, starting at column q[k] */
|
||||
{
|
||||
cs_augment (q ? q [k]: k, C, jmatch, cheap, w, js, is, ps) ;
|
||||
}
|
||||
cs_free (q) ;
|
||||
for (j = 0 ; j < n ; j++) imatch [j] = -1 ; /* find row match */
|
||||
for (i = 0 ; i < m ; i++) if (jmatch [i] >= 0) imatch [jmatch [i]] = i ;
|
||||
return (cs_idone (jimatch, (m2 < n2) ? C : NULL, w, 1)) ;
|
||||
}
|
||||
+35
@@ -0,0 +1,35 @@
|
||||
#include "cs.h"
|
||||
/* C = A*B */
|
||||
cs *cs_multiply (const cs *A, const cs *B)
|
||||
{
|
||||
CS_INT p, j, nz = 0, anz, *Cp, *Ci, *Bp, m, n, bnz, *w, values, *Bi ;
|
||||
CS_ENTRY *x, *Bx, *Cx ;
|
||||
cs *C ;
|
||||
if (!CS_CSC (A) || !CS_CSC (B)) return (NULL) ; /* check inputs */
|
||||
if (A->n != B->m) return (NULL) ;
|
||||
m = A->m ; anz = A->p [A->n] ;
|
||||
n = B->n ; Bp = B->p ; Bi = B->i ; Bx = B->x ; bnz = Bp [n] ;
|
||||
w = cs_calloc (m, sizeof (CS_INT)) ; /* get workspace */
|
||||
values = (A->x != NULL) && (Bx != NULL) ;
|
||||
x = values ? cs_malloc (m, sizeof (CS_ENTRY)) : NULL ; /* get workspace */
|
||||
C = cs_spalloc (m, n, anz + bnz, values, 0) ; /* allocate result */
|
||||
if (!C || !w || (values && !x)) return (cs_done (C, w, x, 0)) ;
|
||||
Cp = C->p ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
if (nz + m > C->nzmax && !cs_sprealloc (C, 2*(C->nzmax)+m))
|
||||
{
|
||||
return (cs_done (C, w, x, 0)) ; /* out of memory */
|
||||
}
|
||||
Ci = C->i ; Cx = C->x ; /* C->i and C->x may be reallocated */
|
||||
Cp [j] = nz ; /* column j of C starts here */
|
||||
for (p = Bp [j] ; p < Bp [j+1] ; p++)
|
||||
{
|
||||
nz = cs_scatter (A, Bi [p], Bx ? Bx [p] : 1, w, x, j+1, C, nz) ;
|
||||
}
|
||||
if (values) for (p = Cp [j] ; p < nz ; p++) Cx [p] = x [Ci [p]] ;
|
||||
}
|
||||
Cp [n] = nz ; /* finalize the last column of C */
|
||||
cs_sprealloc (C, 0) ; /* remove extra space from C */
|
||||
return (cs_done (C, w, x, 1)) ; /* success; free workspace, return C */
|
||||
}
|
||||
+16
@@ -0,0 +1,16 @@
|
||||
#include "cs.h"
|
||||
/* 1-norm of a sparse matrix = max (sum (abs (A))), largest column sum */
|
||||
double cs_norm (const cs *A)
|
||||
{
|
||||
CS_INT p, j, n, *Ap ;
|
||||
CS_ENTRY *Ax ;
|
||||
double norm = 0, s ;
|
||||
if (!CS_CSC (A) || !A->x) return (-1) ; /* check inputs */
|
||||
n = A->n ; Ap = A->p ; Ax = A->x ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
for (s = 0, p = Ap [j] ; p < Ap [j+1] ; p++) s += CS_ABS (Ax [p]) ;
|
||||
norm = CS_MAX (norm, s) ;
|
||||
}
|
||||
return (norm) ;
|
||||
}
|
||||
+25
@@ -0,0 +1,25 @@
|
||||
#include "cs.h"
|
||||
/* C = A(p,q) where p and q are permutations of 0..m-1 and 0..n-1. */
|
||||
cs *cs_permute (const cs *A, const CS_INT *pinv, const CS_INT *q, CS_INT values)
|
||||
{
|
||||
CS_INT t, j, k, nz = 0, m, n, *Ap, *Ai, *Cp, *Ci ;
|
||||
CS_ENTRY *Cx, *Ax ;
|
||||
cs *C ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
C = cs_spalloc (m, n, Ap [n], values && Ax != NULL, 0) ; /* alloc result */
|
||||
if (!C) return (cs_done (C, NULL, NULL, 0)) ; /* out of memory */
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
for (k = 0 ; k < n ; k++)
|
||||
{
|
||||
Cp [k] = nz ; /* column k of C is column q[k] of A */
|
||||
j = q ? (q [k]) : k ;
|
||||
for (t = Ap [j] ; t < Ap [j+1] ; t++)
|
||||
{
|
||||
if (Cx) Cx [nz] = Ax [t] ; /* row i of A is row pinv[i] of C */
|
||||
Ci [nz++] = pinv ? (pinv [Ai [t]]) : Ai [t] ;
|
||||
}
|
||||
}
|
||||
Cp [n] = nz ; /* finalize the last column of C */
|
||||
return (cs_done (C, NULL, NULL, 1)) ;
|
||||
}
|
||||
+11
@@ -0,0 +1,11 @@
|
||||
#include "cs.h"
|
||||
/* pinv = p', or p = pinv' */
|
||||
CS_INT *cs_pinv (CS_INT const *p, CS_INT n)
|
||||
{
|
||||
CS_INT k, *pinv ;
|
||||
if (!p) return (NULL) ; /* p = NULL denotes identity */
|
||||
pinv = cs_malloc (n, sizeof (CS_INT)) ; /* allocate result */
|
||||
if (!pinv) return (NULL) ; /* out of memory */
|
||||
for (k = 0 ; k < n ; k++) pinv [p [k]] = k ;/* invert the permutation */
|
||||
return (pinv) ; /* return result */
|
||||
}
|
||||
+24
@@ -0,0 +1,24 @@
|
||||
#include "cs.h"
|
||||
/* post order a forest */
|
||||
CS_INT *cs_post (const CS_INT *parent, CS_INT n)
|
||||
{
|
||||
CS_INT j, k = 0, *post, *w, *head, *next, *stack ;
|
||||
if (!parent) return (NULL) ; /* check inputs */
|
||||
post = cs_malloc (n, sizeof (CS_INT)) ; /* allocate result */
|
||||
w = cs_malloc (3*n, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!w || !post) return (cs_idone (post, NULL, w, 0)) ;
|
||||
head = w ; next = w + n ; stack = w + 2*n ;
|
||||
for (j = 0 ; j < n ; j++) head [j] = -1 ; /* empty linked lists */
|
||||
for (j = n-1 ; j >= 0 ; j--) /* traverse nodes in reverse order*/
|
||||
{
|
||||
if (parent [j] == -1) continue ; /* j is a root */
|
||||
next [j] = head [parent [j]] ; /* add j to list of its parent */
|
||||
head [parent [j]] = j ;
|
||||
}
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
if (parent [j] != -1) continue ; /* skip j if it is not a root */
|
||||
k = cs_tdfs (j, k, head, next, post, stack) ;
|
||||
}
|
||||
return (cs_idone (post, NULL, w, 1)) ; /* success; free w, return post */
|
||||
}
|
||||
+55
@@ -0,0 +1,55 @@
|
||||
#include "cs.h"
|
||||
/* print a sparse matrix; use %g for integers to avoid differences with CS_INT */
|
||||
|
||||
/* Disabled for igraph as it prints to stdio */
|
||||
#if 0
|
||||
CS_INT cs_print (const cs *A, CS_INT brief)
|
||||
{
|
||||
CS_INT p, j, m, n, nzmax, nz, *Ap, *Ai ;
|
||||
CS_ENTRY *Ax ;
|
||||
if (!A) { printf ("(null)\n") ; return (0) ; }
|
||||
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
nzmax = A->nzmax ; nz = A->nz ;
|
||||
printf ("CXSparse Version %d.%d.%d, %s. %s\n", CS_VER, CS_SUBVER,
|
||||
CS_SUBSUB, CS_DATE, CS_COPYRIGHT) ;
|
||||
if (nz < 0)
|
||||
{
|
||||
printf ("%g-by-%g, nzmax: %g nnz: %g, 1-norm: %g\n", (double) m,
|
||||
(double) n, (double) nzmax, (double) (Ap [n]), cs_norm (A)) ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
printf (" col %g : locations %g to %g\n", (double) j,
|
||||
(double) (Ap [j]), (double) (Ap [j+1]-1)) ;
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
printf (" %g : ", (double) (Ai [p])) ;
|
||||
#ifdef CS_COMPLEX
|
||||
printf ("(%g, %g)\n",
|
||||
Ax ? CS_REAL (Ax [p]) : 1, Ax ? CS_IMAG (Ax [p]) : 0) ;
|
||||
#else
|
||||
printf ("%g\n", Ax ? Ax [p] : 1) ;
|
||||
#endif
|
||||
if (brief && p > 20) { printf (" ...\n") ; return (1) ; }
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
printf ("triplet: %g-by-%g, nzmax: %g nnz: %g\n", (double) m,
|
||||
(double) n, (double) nzmax, (double) nz) ;
|
||||
for (p = 0 ; p < nz ; p++)
|
||||
{
|
||||
|
||||
printf (" %g %g : ", (double) (Ai [p]), (double) (Ap [p])) ;
|
||||
#ifdef CS_COMPLEX
|
||||
printf ("(%g, %g)\n",
|
||||
Ax ? CS_REAL (Ax [p]) : 1, Ax ? CS_IMAG (Ax [p]) : 0) ;
|
||||
#else
|
||||
printf ("%g\n", Ax ? Ax [p] : 1) ;
|
||||
#endif
|
||||
if (brief && p > 20) { printf (" ...\n") ; return (1) ; }
|
||||
}
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
#endif
|
||||
+9
@@ -0,0 +1,9 @@
|
||||
#include "cs.h"
|
||||
/* x = b(p), for dense vectors x and b; p=NULL denotes identity */
|
||||
CS_INT cs_pvec (const CS_INT *p, const CS_ENTRY *b, CS_ENTRY *x, CS_INT n)
|
||||
{
|
||||
CS_INT k ;
|
||||
if (!x || !b) return (0) ; /* check inputs */
|
||||
for (k = 0 ; k < n ; k++) x [k] = b [p ? p [k] : k] ;
|
||||
return (1) ;
|
||||
}
|
||||
+74
@@ -0,0 +1,74 @@
|
||||
#include "cs.h"
|
||||
/* sparse QR factorization [V,beta,pinv,R] = qr (A) */
|
||||
csn *cs_qr (const cs *A, const css *S)
|
||||
{
|
||||
CS_ENTRY *Rx, *Vx, *Ax, *x ;
|
||||
double *Beta ;
|
||||
CS_INT i, k, p, n, vnz, p1, top, m2, len, col, rnz, *s, *leftmost, *Ap, *Ai,
|
||||
*parent, *Rp, *Ri, *Vp, *Vi, *w, *pinv, *q ;
|
||||
cs *R, *V ;
|
||||
csn *N ;
|
||||
if (!CS_CSC (A) || !S) return (NULL) ;
|
||||
n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
q = S->q ; parent = S->parent ; pinv = S->pinv ; m2 = S->m2 ;
|
||||
vnz = S->lnz ; rnz = S->unz ; leftmost = S->leftmost ;
|
||||
w = cs_malloc (m2+n, sizeof (CS_INT)) ; /* get CS_INT workspace */
|
||||
x = cs_malloc (m2, sizeof (CS_ENTRY)) ; /* get CS_ENTRY workspace */
|
||||
N = cs_calloc (1, sizeof (csn)) ; /* allocate result */
|
||||
if (!w || !x || !N) return (cs_ndone (N, NULL, w, x, 0)) ;
|
||||
s = w + m2 ; /* s is size n */
|
||||
for (k = 0 ; k < m2 ; k++) x [k] = 0 ; /* clear workspace x */
|
||||
N->L = V = cs_spalloc (m2, n, vnz, 1, 0) ; /* allocate result V */
|
||||
N->U = R = cs_spalloc (m2, n, rnz, 1, 0) ; /* allocate result R */
|
||||
N->B = Beta = cs_malloc (n, sizeof (double)) ; /* allocate result Beta */
|
||||
if (!R || !V || !Beta) return (cs_ndone (N, NULL, w, x, 0)) ;
|
||||
Rp = R->p ; Ri = R->i ; Rx = R->x ;
|
||||
Vp = V->p ; Vi = V->i ; Vx = V->x ;
|
||||
for (i = 0 ; i < m2 ; i++) w [i] = -1 ; /* clear w, to mark nodes */
|
||||
rnz = 0 ; vnz = 0 ;
|
||||
for (k = 0 ; k < n ; k++) /* compute V and R */
|
||||
{
|
||||
Rp [k] = rnz ; /* R(:,k) starts here */
|
||||
Vp [k] = p1 = vnz ; /* V(:,k) starts here */
|
||||
w [k] = k ; /* add V(k,k) to pattern of V */
|
||||
Vi [vnz++] = k ;
|
||||
top = n ;
|
||||
col = q ? q [k] : k ;
|
||||
for (p = Ap [col] ; p < Ap [col+1] ; p++) /* find R(:,k) pattern */
|
||||
{
|
||||
i = leftmost [Ai [p]] ; /* i = min(find(A(i,q))) */
|
||||
for (len = 0 ; w [i] != k ; i = parent [i]) /* traverse up to k */
|
||||
{
|
||||
s [len++] = i ;
|
||||
w [i] = k ;
|
||||
}
|
||||
while (len > 0) s [--top] = s [--len] ; /* push path on stack */
|
||||
i = pinv [Ai [p]] ; /* i = permuted row of A(:,col) */
|
||||
x [i] = Ax [p] ; /* x (i) = A(:,col) */
|
||||
if (i > k && w [i] < k) /* pattern of V(:,k) = x (k+1:m) */
|
||||
{
|
||||
Vi [vnz++] = i ; /* add i to pattern of V(:,k) */
|
||||
w [i] = k ;
|
||||
}
|
||||
}
|
||||
for (p = top ; p < n ; p++) /* for each i in pattern of R(:,k) */
|
||||
{
|
||||
i = s [p] ; /* R(i,k) is nonzero */
|
||||
cs_happly (V, i, Beta [i], x) ; /* apply (V(i),Beta(i)) to x */
|
||||
Ri [rnz] = i ; /* R(i,k) = x(i) */
|
||||
Rx [rnz++] = x [i] ;
|
||||
x [i] = 0 ;
|
||||
if (parent [i] == k) vnz = cs_scatter (V, i, 0, w, NULL, k, V, vnz);
|
||||
}
|
||||
for (p = p1 ; p < vnz ; p++) /* gather V(:,k) = x */
|
||||
{
|
||||
Vx [p] = x [Vi [p]] ;
|
||||
x [Vi [p]] = 0 ;
|
||||
}
|
||||
Ri [rnz] = k ; /* R(k,k) = norm (x) */
|
||||
Rx [rnz++] = cs_house (Vx+p1, Beta+k, vnz-p1) ; /* [v,beta]=house(x) */
|
||||
}
|
||||
Rp [n] = rnz ; /* finalize R */
|
||||
Vp [n] = vnz ; /* finalize V */
|
||||
return (cs_ndone (N, NULL, w, x, 1)) ; /* success */
|
||||
}
|
||||
+53
@@ -0,0 +1,53 @@
|
||||
#include "cs.h"
|
||||
/* x=A\b where A can be rectangular; b overwritten with solution */
|
||||
CS_INT cs_qrsol (CS_INT order, const cs *A, CS_ENTRY *b)
|
||||
{
|
||||
CS_ENTRY *x ;
|
||||
css *S ;
|
||||
csn *N ;
|
||||
cs *AT = NULL ;
|
||||
CS_INT k, m, n, ok ;
|
||||
if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
|
||||
n = A->n ;
|
||||
m = A->m ;
|
||||
if (m >= n)
|
||||
{
|
||||
S = cs_sqr (order, A, 1) ; /* ordering and symbolic analysis */
|
||||
N = cs_qr (A, S) ; /* numeric QR factorization */
|
||||
x = cs_calloc (S ? S->m2 : 1, sizeof (CS_ENTRY)) ; /* get workspace */
|
||||
ok = (S && N && x) ;
|
||||
if (ok)
|
||||
{
|
||||
cs_ipvec (S->pinv, b, x, m) ; /* x(0:m-1) = b(p(0:m-1) */
|
||||
for (k = 0 ; k < n ; k++) /* apply Householder refl. to x */
|
||||
{
|
||||
cs_happly (N->L, k, N->B [k], x) ;
|
||||
}
|
||||
cs_usolve (N->U, x) ; /* x = R\x */
|
||||
cs_ipvec (S->q, x, b, n) ; /* b(q(0:n-1)) = x(0:n-1) */
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
AT = cs_transpose (A, 1) ; /* Ax=b is underdetermined */
|
||||
S = cs_sqr (order, AT, 1) ; /* ordering and symbolic analysis */
|
||||
N = cs_qr (AT, S) ; /* numeric QR factorization of A' */
|
||||
x = cs_calloc (S ? S->m2 : 1, sizeof (CS_ENTRY)) ; /* get workspace */
|
||||
ok = (AT && S && N && x) ;
|
||||
if (ok)
|
||||
{
|
||||
cs_pvec (S->q, b, x, m) ; /* x(q(0:m-1)) = b(0:m-1) */
|
||||
cs_utsolve (N->U, x) ; /* x = R'\x */
|
||||
for (k = m-1 ; k >= 0 ; k--) /* apply Householder refl. to x */
|
||||
{
|
||||
cs_happly (N->L, k, N->B [k], x) ;
|
||||
}
|
||||
cs_pvec (S->pinv, x, b, n) ; /* b(0:n-1) = x(p(0:n-1)) */
|
||||
}
|
||||
}
|
||||
cs_free (x) ;
|
||||
cs_sfree (S) ;
|
||||
cs_nfree (N) ;
|
||||
cs_spfree (AT) ;
|
||||
return (ok) ;
|
||||
}
|
||||
+26
@@ -0,0 +1,26 @@
|
||||
#include "cs.h"
|
||||
|
||||
#include "igraph_random.h"
|
||||
|
||||
/* return a random permutation vector, the identity perm, or p = n-1:-1:0.
|
||||
* seed = -1 means p = n-1:-1:0. seed = 0 means p = identity. otherwise
|
||||
* p = random permutation. */
|
||||
CS_INT *cs_randperm (CS_INT n, CS_INT seed)
|
||||
{
|
||||
CS_INT *p, k, j, t ;
|
||||
if (seed == 0) return (NULL) ; /* return p = NULL (identity) */
|
||||
p = cs_malloc (n, sizeof (CS_INT)) ; /* allocate result */
|
||||
if (!p) return (NULL) ; /* out of memory */
|
||||
for (k = 0 ; k < n ; k++) p [k] = n-k-1 ;
|
||||
if (seed == -1) return (p) ; /* return reverse permutation */
|
||||
/* srand (seed) ; /\* get new random number seed *\/ */
|
||||
for (k = 0 ; k < n ; k++)
|
||||
{
|
||||
/* j = k + (rand ( ) % (n-k)) ; /\* j = rand CS_INT in range k to n-1 *\/ */
|
||||
j = RNG_INTEGER(k, n-1) ;
|
||||
t = p [j] ; /* swap p[k] and p[j] */
|
||||
p [j] = p [k] ;
|
||||
p [k] = t ;
|
||||
}
|
||||
return (p) ;
|
||||
}
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "cs.h"
|
||||
/* xi [top...n-1] = nodes reachable from graph of G*P' via nodes in B(:,k).
|
||||
* xi [n...2n-1] used as workspace */
|
||||
CS_INT cs_reach (cs *G, const cs *B, CS_INT k, CS_INT *xi, const CS_INT *pinv)
|
||||
{
|
||||
CS_INT p, n, top, *Bp, *Bi, *Gp ;
|
||||
if (!CS_CSC (G) || !CS_CSC (B) || !xi) return (-1) ; /* check inputs */
|
||||
n = G->n ; Bp = B->p ; Bi = B->i ; Gp = G->p ;
|
||||
top = n ;
|
||||
for (p = Bp [k] ; p < Bp [k+1] ; p++)
|
||||
{
|
||||
if (!CS_MARKED (Gp, Bi [p])) /* start a dfs at unmarked node i */
|
||||
{
|
||||
top = cs_dfs (Bi [p], G, top, xi, xi+n, pinv) ;
|
||||
}
|
||||
}
|
||||
for (p = top ; p < n ; p++) CS_MARK (Gp, xi [p]) ; /* restore G */
|
||||
return (top) ;
|
||||
}
|
||||
+22
@@ -0,0 +1,22 @@
|
||||
#include "cs.h"
|
||||
/* x = x + beta * A(:,j), where x is a dense vector and A(:,j) is sparse */
|
||||
CS_INT cs_scatter (const cs *A, CS_INT j, CS_ENTRY beta, CS_INT *w, CS_ENTRY *x, CS_INT mark,
|
||||
cs *C, CS_INT nz)
|
||||
{
|
||||
CS_INT i, p, *Ap, *Ai, *Ci ;
|
||||
CS_ENTRY *Ax ;
|
||||
if (!CS_CSC (A) || !w || !CS_CSC (C)) return (-1) ; /* check inputs */
|
||||
Ap = A->p ; Ai = A->i ; Ax = A->x ; Ci = C->i ;
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ; /* A(i,j) is nonzero */
|
||||
if (w [i] < mark)
|
||||
{
|
||||
w [i] = mark ; /* i is new entry in column j */
|
||||
Ci [nz++] = i ; /* add i to pattern of C(:,j) */
|
||||
if (x) x [i] = beta * Ax [p] ; /* x(i) = beta*A(i,j) */
|
||||
}
|
||||
else if (x) x [i] += beta * Ax [p] ; /* i exists in C(:,j) already */
|
||||
}
|
||||
return (nz) ;
|
||||
}
|
||||
+41
@@ -0,0 +1,41 @@
|
||||
#include "cs.h"
|
||||
/* find the strongly connected components of a square matrix */
|
||||
csd *cs_scc (cs *A) /* matrix A temporarily modified, then restored */
|
||||
{
|
||||
CS_INT n, i, k, b, nb = 0, top, *xi, *pstack, *p, *r, *Ap, *ATp, *rcopy, *Blk ;
|
||||
cs *AT ;
|
||||
csd *D ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
n = A->n ; Ap = A->p ;
|
||||
D = cs_dalloc (n, 0) ; /* allocate result */
|
||||
AT = cs_transpose (A, 0) ; /* AT = A' */
|
||||
xi = cs_malloc (2*n+1, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!D || !AT || !xi) return (cs_ddone (D, AT, xi, 0)) ;
|
||||
Blk = xi ; rcopy = pstack = xi + n ;
|
||||
p = D->p ; r = D->r ; ATp = AT->p ;
|
||||
top = n ;
|
||||
for (i = 0 ; i < n ; i++) /* first dfs(A) to find finish times (xi) */
|
||||
{
|
||||
if (!CS_MARKED (Ap, i)) top = cs_dfs (i, A, top, xi, pstack, NULL) ;
|
||||
}
|
||||
for (i = 0 ; i < n ; i++) CS_MARK (Ap, i) ; /* restore A; unmark all nodes*/
|
||||
top = n ;
|
||||
nb = n ;
|
||||
for (k = 0 ; k < n ; k++) /* dfs(A') to find strongly connnected comp */
|
||||
{
|
||||
i = xi [k] ; /* get i in reverse order of finish times */
|
||||
if (CS_MARKED (ATp, i)) continue ; /* skip node i if already ordered */
|
||||
r [nb--] = top ; /* node i is the start of a component in p */
|
||||
top = cs_dfs (i, AT, top, p, pstack, NULL) ;
|
||||
}
|
||||
r [nb] = 0 ; /* first block starts at zero; shift r up */
|
||||
for (k = nb ; k <= n ; k++) r [k-nb] = r [k] ;
|
||||
D->nb = nb = n-nb ; /* nb = # of strongly connected components */
|
||||
for (b = 0 ; b < nb ; b++) /* sort each block in natural order */
|
||||
{
|
||||
for (k = r [b] ; k < r [b+1] ; k++) Blk [p [k]] = b ;
|
||||
}
|
||||
for (b = 0 ; b <= nb ; b++) rcopy [b] = r [b] ;
|
||||
for (i = 0 ; i < n ; i++) p [rcopy [Blk [i]]++] = i ;
|
||||
return (cs_ddone (D, AT, xi, 1)) ;
|
||||
}
|
||||
+26
@@ -0,0 +1,26 @@
|
||||
#include "cs.h"
|
||||
/* ordering and symbolic analysis for a Cholesky factorization */
|
||||
css *cs_schol (CS_INT order, const cs *A)
|
||||
{
|
||||
CS_INT n, *c, *post, *P ;
|
||||
cs *C ;
|
||||
css *S ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
n = A->n ;
|
||||
S = cs_calloc (1, sizeof (css)) ; /* allocate result S */
|
||||
if (!S) return (NULL) ; /* out of memory */
|
||||
P = cs_amd (order, A) ; /* P = amd(A+A'), or natural */
|
||||
S->pinv = cs_pinv (P, n) ; /* find inverse permutation */
|
||||
cs_free (P) ;
|
||||
if (order && !S->pinv) return (cs_sfree (S)) ;
|
||||
C = cs_symperm (A, S->pinv, 0) ; /* C = spones(triu(A(P,P))) */
|
||||
S->parent = cs_etree (C, 0) ; /* find etree of C */
|
||||
post = cs_post (S->parent, n) ; /* postorder the etree */
|
||||
c = cs_counts (C, S->parent, post, 0) ; /* find column counts of chol(C) */
|
||||
cs_free (post) ;
|
||||
cs_spfree (C) ;
|
||||
S->cp = cs_malloc (n+1, sizeof (CS_INT)) ; /* allocate result S->cp */
|
||||
S->unz = S->lnz = cs_cumsum (S->cp, c, n) ; /* find column pointers for L */
|
||||
cs_free (c) ;
|
||||
return ((S->lnz >= 0) ? S : cs_sfree (S)) ;
|
||||
}
|
||||
+28
@@ -0,0 +1,28 @@
|
||||
#include "cs.h"
|
||||
/* solve Gx=b(:,k), where G is either upper (lo=0) or lower (lo=1) triangular */
|
||||
CS_INT cs_spsolve (cs *G, const cs *B, CS_INT k, CS_INT *xi, CS_ENTRY *x, const CS_INT *pinv,
|
||||
CS_INT lo)
|
||||
{
|
||||
CS_INT j, J, p, q, px, top, n, *Gp, *Gi, *Bp, *Bi ;
|
||||
CS_ENTRY *Gx, *Bx ;
|
||||
if (!CS_CSC (G) || !CS_CSC (B) || !xi || !x) return (-1) ;
|
||||
Gp = G->p ; Gi = G->i ; Gx = G->x ; n = G->n ;
|
||||
Bp = B->p ; Bi = B->i ; Bx = B->x ;
|
||||
top = cs_reach (G, B, k, xi, pinv) ; /* xi[top..n-1]=Reach(B(:,k)) */
|
||||
for (p = top ; p < n ; p++) x [xi [p]] = 0 ; /* clear x */
|
||||
for (p = Bp [k] ; p < Bp [k+1] ; p++) x [Bi [p]] = Bx [p] ; /* scatter B */
|
||||
for (px = top ; px < n ; px++)
|
||||
{
|
||||
j = xi [px] ; /* x(j) is nonzero */
|
||||
J = pinv ? (pinv [j]) : j ; /* j maps to col J of G */
|
||||
if (J < 0) continue ; /* column J is empty */
|
||||
x [j] /= Gx [lo ? (Gp [J]) : (Gp [J+1]-1)] ;/* x(j) /= G(j,j) */
|
||||
p = lo ? (Gp [J]+1) : (Gp [J]) ; /* lo: L(j,j) 1st entry */
|
||||
q = lo ? (Gp [J+1]) : (Gp [J+1]-1) ; /* up: U(j,j) last entry */
|
||||
for ( ; p < q ; p++)
|
||||
{
|
||||
x [Gi [p]] -= Gx [p] * x [j] ; /* x(i) -= G(i,j) * x(j) */
|
||||
}
|
||||
}
|
||||
return (top) ; /* return top of stack */
|
||||
}
|
||||
+87
@@ -0,0 +1,87 @@
|
||||
#include "cs.h"
|
||||
/* compute nnz(V) = S->lnz, S->pinv, S->leftmost, S->m2 from A and S->parent */
|
||||
static CS_INT cs_vcount (const cs *A, css *S)
|
||||
{
|
||||
CS_INT i, k, p, pa, n = A->n, m = A->m, *Ap = A->p, *Ai = A->i, *next, *head,
|
||||
*tail, *nque, *pinv, *leftmost, *w, *parent = S->parent ;
|
||||
S->pinv = pinv = cs_malloc (m+n, sizeof (CS_INT)) ; /* allocate pinv, */
|
||||
S->leftmost = leftmost = cs_malloc (m, sizeof (CS_INT)) ; /* and leftmost */
|
||||
w = cs_malloc (m+3*n, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!pinv || !w || !leftmost)
|
||||
{
|
||||
cs_free (w) ; /* pinv and leftmost freed later */
|
||||
return (0) ; /* out of memory */
|
||||
}
|
||||
next = w ; head = w + m ; tail = w + m + n ; nque = w + m + 2*n ;
|
||||
for (k = 0 ; k < n ; k++) head [k] = -1 ; /* queue k is empty */
|
||||
for (k = 0 ; k < n ; k++) tail [k] = -1 ;
|
||||
for (k = 0 ; k < n ; k++) nque [k] = 0 ;
|
||||
for (i = 0 ; i < m ; i++) leftmost [i] = -1 ;
|
||||
for (k = n-1 ; k >= 0 ; k--)
|
||||
{
|
||||
for (p = Ap [k] ; p < Ap [k+1] ; p++)
|
||||
{
|
||||
leftmost [Ai [p]] = k ; /* leftmost[i] = min(find(A(i,:)))*/
|
||||
}
|
||||
}
|
||||
for (i = m-1 ; i >= 0 ; i--) /* scan rows in reverse order */
|
||||
{
|
||||
pinv [i] = -1 ; /* row i is not yet ordered */
|
||||
k = leftmost [i] ;
|
||||
if (k == -1) continue ; /* row i is empty */
|
||||
if (nque [k]++ == 0) tail [k] = i ; /* first row in queue k */
|
||||
next [i] = head [k] ; /* put i at head of queue k */
|
||||
head [k] = i ;
|
||||
}
|
||||
S->lnz = 0 ;
|
||||
S->m2 = m ;
|
||||
for (k = 0 ; k < n ; k++) /* find row permutation and nnz(V)*/
|
||||
{
|
||||
i = head [k] ; /* remove row i from queue k */
|
||||
S->lnz++ ; /* count V(k,k) as nonzero */
|
||||
if (i < 0) i = S->m2++ ; /* add a fictitious row */
|
||||
pinv [i] = k ; /* associate row i with V(:,k) */
|
||||
if (--nque [k] <= 0) continue ; /* skip if V(k+1:m,k) is empty */
|
||||
S->lnz += nque [k] ; /* nque [k] is nnz (V(k+1:m,k)) */
|
||||
if ((pa = parent [k]) != -1) /* move all rows to parent of k */
|
||||
{
|
||||
if (nque [pa] == 0) tail [pa] = tail [k] ;
|
||||
next [tail [k]] = head [pa] ;
|
||||
head [pa] = next [i] ;
|
||||
nque [pa] += nque [k] ;
|
||||
}
|
||||
}
|
||||
for (i = 0 ; i < m ; i++) if (pinv [i] < 0) pinv [i] = k++ ;
|
||||
cs_free (w) ;
|
||||
return (1) ;
|
||||
}
|
||||
|
||||
/* symbolic ordering and analysis for QR or LU */
|
||||
css *cs_sqr (CS_INT order, const cs *A, CS_INT qr)
|
||||
{
|
||||
CS_INT n, k, ok = 1, *post ;
|
||||
css *S ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
n = A->n ;
|
||||
S = cs_calloc (1, sizeof (css)) ; /* allocate result S */
|
||||
if (!S) return (NULL) ; /* out of memory */
|
||||
S->q = cs_amd (order, A) ; /* fill-reducing ordering */
|
||||
if (order && !S->q) return (cs_sfree (S)) ;
|
||||
if (qr) /* QR symbolic analysis */
|
||||
{
|
||||
cs *C = order ? cs_permute (A, NULL, S->q, 0) : ((cs *) A) ;
|
||||
S->parent = cs_etree (C, 1) ; /* etree of C'*C, where C=A(:,q) */
|
||||
post = cs_post (S->parent, n) ;
|
||||
S->cp = cs_counts (C, S->parent, post, 1) ; /* col counts chol(C'*C) */
|
||||
cs_free (post) ;
|
||||
ok = C && S->parent && S->cp && cs_vcount (C, S) ;
|
||||
if (ok) for (S->unz = 0, k = 0 ; k < n ; k++) S->unz += S->cp [k] ;
|
||||
if (order) cs_spfree (C) ;
|
||||
}
|
||||
else
|
||||
{
|
||||
S->unz = 4*(A->p [n]) + n ; /* for LU factorization only, */
|
||||
S->lnz = S->unz ; /* guess nnz(L) and nnz(U) */
|
||||
}
|
||||
return (ok ? S : cs_sfree (S)) ; /* return result S */
|
||||
}
|
||||
+39
@@ -0,0 +1,39 @@
|
||||
#include "cs.h"
|
||||
/* C = A(p,p) where A and C are symmetric the upper part stored; pinv not p */
|
||||
cs *cs_symperm (const cs *A, const CS_INT *pinv, CS_INT values)
|
||||
{
|
||||
CS_INT i, j, p, q, i2, j2, n, *Ap, *Ai, *Cp, *Ci, *w ;
|
||||
CS_ENTRY *Cx, *Ax ;
|
||||
cs *C ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
C = cs_spalloc (n, n, Ap [n], values && (Ax != NULL), 0) ; /* alloc result*/
|
||||
w = cs_calloc (n, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!C || !w) return (cs_done (C, w, NULL, 0)) ; /* out of memory */
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
for (j = 0 ; j < n ; j++) /* count entries in each column of C */
|
||||
{
|
||||
j2 = pinv ? pinv [j] : j ; /* column j of A is column j2 of C */
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ;
|
||||
if (i > j) continue ; /* skip lower triangular part of A */
|
||||
i2 = pinv ? pinv [i] : i ; /* row i of A is row i2 of C */
|
||||
w [CS_MAX (i2, j2)]++ ; /* column count of C */
|
||||
}
|
||||
}
|
||||
cs_cumsum (Cp, w, n) ; /* compute column pointers of C */
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
j2 = pinv ? pinv [j] : j ; /* column j of A is column j2 of C */
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
i = Ai [p] ;
|
||||
if (i > j) continue ; /* skip lower triangular part of A*/
|
||||
i2 = pinv ? pinv [i] : i ; /* row i of A is row i2 of C */
|
||||
Ci [q = w [CS_MAX (i2, j2)]++] = CS_MIN (i2, j2) ;
|
||||
if (Cx) Cx [q] = (i2 <= j2) ? Ax [p] : CS_CONJ (Ax [p]) ;
|
||||
}
|
||||
}
|
||||
return (cs_done (C, w, NULL, 1)) ; /* success; free workspace, return C */
|
||||
}
|
||||
+24
@@ -0,0 +1,24 @@
|
||||
#include "cs.h"
|
||||
/* depth-first search and postorder of a tree rooted at node j */
|
||||
CS_INT cs_tdfs (CS_INT j, CS_INT k, CS_INT *head, const CS_INT *next, CS_INT *post, CS_INT *stack)
|
||||
{
|
||||
CS_INT i, p, top = 0 ;
|
||||
if (!head || !next || !post || !stack) return (-1) ; /* check inputs */
|
||||
stack [0] = j ; /* place j on the stack */
|
||||
while (top >= 0) /* while (stack is not empty) */
|
||||
{
|
||||
p = stack [top] ; /* p = top of stack */
|
||||
i = head [p] ; /* i = youngest child of p */
|
||||
if (i == -1)
|
||||
{
|
||||
top-- ; /* p has no unordered children left */
|
||||
post [k++] = p ; /* node p is the kth postordered node */
|
||||
}
|
||||
else
|
||||
{
|
||||
head [p] = next [i] ; /* remove i from children of p */
|
||||
stack [++top] = i ; /* start dfs on child node i */
|
||||
}
|
||||
}
|
||||
return (k) ;
|
||||
}
|
||||
@@ -0,0 +1,25 @@
|
||||
#include "cs.h"
|
||||
/* C = A' */
|
||||
cs *cs_transpose (const cs *A, CS_INT values)
|
||||
{
|
||||
CS_INT p, q, j, *Cp, *Ci, n, m, *Ap, *Ai, *w ;
|
||||
CS_ENTRY *Cx, *Ax ;
|
||||
cs *C ;
|
||||
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
|
||||
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
|
||||
C = cs_spalloc (n, m, Ap [n], values && Ax, 0) ; /* allocate result */
|
||||
w = cs_calloc (m, sizeof (CS_INT)) ; /* get workspace */
|
||||
if (!C || !w) return (cs_done (C, w, NULL, 0)) ; /* out of memory */
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
for (p = 0 ; p < Ap [n] ; p++) w [Ai [p]]++ ; /* row counts */
|
||||
cs_cumsum (Cp, w, m) ; /* row pointers */
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
for (p = Ap [j] ; p < Ap [j+1] ; p++)
|
||||
{
|
||||
Ci [q = w [Ai [p]]++] = j ; /* place A(i,j) as entry C(j,i) */
|
||||
if (Cx) Cx [q] = (values > 0) ? CS_CONJ (Ax [p]) : Ax [p] ;
|
||||
}
|
||||
}
|
||||
return (cs_done (C, w, NULL, 1)) ; /* success; free w and return C */
|
||||
}
|
||||
+48
@@ -0,0 +1,48 @@
|
||||
#include "cs.h"
|
||||
/* sparse Cholesky update/downdate, L*L' + sigma*w*w' (sigma = +1 or -1) */
|
||||
CS_INT cs_updown (cs *L, CS_INT sigma, const cs *C, const CS_INT *parent)
|
||||
{
|
||||
CS_INT n, p, f, j, *Lp, *Li, *Cp, *Ci ;
|
||||
CS_ENTRY *Lx, *Cx, alpha, gamma, w1, w2, *w ;
|
||||
double beta = 1, beta2 = 1, delta ;
|
||||
#ifdef CS_COMPLEX
|
||||
cs_complex_t phase ;
|
||||
#endif
|
||||
if (!CS_CSC (L) || !CS_CSC (C) || !parent) return (0) ; /* check inputs */
|
||||
Lp = L->p ; Li = L->i ; Lx = L->x ; n = L->n ;
|
||||
Cp = C->p ; Ci = C->i ; Cx = C->x ;
|
||||
if ((p = Cp [0]) >= Cp [1]) return (1) ; /* return if C empty */
|
||||
w = cs_malloc (n, sizeof (CS_ENTRY)) ; /* get workspace */
|
||||
if (!w) return (0) ; /* out of memory */
|
||||
f = Ci [p] ;
|
||||
for ( ; p < Cp [1] ; p++) f = CS_MIN (f, Ci [p]) ; /* f = min (find (C)) */
|
||||
for (j = f ; j != -1 ; j = parent [j]) w [j] = 0 ; /* clear workspace w */
|
||||
for (p = Cp [0] ; p < Cp [1] ; p++) w [Ci [p]] = Cx [p] ; /* w = C */
|
||||
for (j = f ; j != -1 ; j = parent [j]) /* walk path f up to root */
|
||||
{
|
||||
p = Lp [j] ;
|
||||
alpha = w [j] / Lx [p] ; /* alpha = w(j) / L(j,j) */
|
||||
beta2 = beta*beta + sigma*alpha*CS_CONJ(alpha) ;
|
||||
if (beta2 <= 0) break ; /* not positive definite */
|
||||
beta2 = sqrt (beta2) ;
|
||||
delta = (sigma > 0) ? (beta / beta2) : (beta2 / beta) ;
|
||||
gamma = sigma * CS_CONJ(alpha) / (beta2 * beta) ;
|
||||
Lx [p] = delta * Lx [p] + ((sigma > 0) ? (gamma * w [j]) : 0) ;
|
||||
beta = beta2 ;
|
||||
#ifdef CS_COMPLEX
|
||||
phase = CS_ABS (Lx [p]) / Lx [p] ; /* phase = abs(L(j,j))/L(j,j)*/
|
||||
Lx [p] *= phase ; /* L(j,j) = L(j,j) * phase */
|
||||
#endif
|
||||
for (p++ ; p < Lp [j+1] ; p++)
|
||||
{
|
||||
w1 = w [Li [p]] ;
|
||||
w [Li [p]] = w2 = w1 - alpha * Lx [p] ;
|
||||
Lx [p] = delta * Lx [p] + gamma * ((sigma > 0) ? w1 : w2) ;
|
||||
#ifdef CS_COMPLEX
|
||||
Lx [p] *= phase ; /* L(i,j) = L(i,j) * phase */
|
||||
#endif
|
||||
}
|
||||
}
|
||||
cs_free (w) ;
|
||||
return (beta2 > 0) ;
|
||||
}
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
#include "cs.h"
|
||||
/* solve Ux=b where x and b are dense. x=b on input, solution on output. */
|
||||
CS_INT cs_usolve (const cs *U, CS_ENTRY *x)
|
||||
{
|
||||
CS_INT p, j, n, *Up, *Ui ;
|
||||
CS_ENTRY *Ux ;
|
||||
if (!CS_CSC (U) || !x) return (0) ; /* check inputs */
|
||||
n = U->n ; Up = U->p ; Ui = U->i ; Ux = U->x ;
|
||||
for (j = n-1 ; j >= 0 ; j--)
|
||||
{
|
||||
x [j] /= Ux [Up [j+1]-1] ;
|
||||
for (p = Up [j] ; p < Up [j+1]-1 ; p++)
|
||||
{
|
||||
x [Ui [p]] -= Ux [p] * x [j] ;
|
||||
}
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
+120
@@ -0,0 +1,120 @@
|
||||
#include "cs.h"
|
||||
/* allocate a sparse matrix (triplet form or compressed-column form) */
|
||||
cs *cs_spalloc (CS_INT m, CS_INT n, CS_INT nzmax, CS_INT values, CS_INT triplet)
|
||||
{
|
||||
cs *A = cs_calloc (1, sizeof (cs)) ; /* allocate the cs struct */
|
||||
if (!A) return (NULL) ; /* out of memory */
|
||||
A->m = m ; /* define dimensions and nzmax */
|
||||
A->n = n ;
|
||||
A->nzmax = nzmax = CS_MAX (nzmax, 1) ;
|
||||
A->nz = triplet ? 0 : -1 ; /* allocate triplet or comp.col */
|
||||
A->p = cs_malloc (triplet ? nzmax : n+1, sizeof (CS_INT)) ;
|
||||
A->i = cs_malloc (nzmax, sizeof (CS_INT)) ;
|
||||
A->x = values ? cs_malloc (nzmax, sizeof (CS_ENTRY)) : NULL ;
|
||||
return ((!A->p || !A->i || (values && !A->x)) ? cs_spfree (A) : A) ;
|
||||
}
|
||||
|
||||
/* change the max # of entries sparse matrix */
|
||||
CS_INT cs_sprealloc (cs *A, CS_INT nzmax)
|
||||
{
|
||||
CS_INT ok, oki, okj = 1, okx = 1 ;
|
||||
if (!A) return (0) ;
|
||||
if (nzmax <= 0) nzmax = (CS_CSC (A)) ? (A->p [A->n]) : A->nz ;
|
||||
nzmax = CS_MAX (nzmax, 1) ;
|
||||
A->i = cs_realloc (A->i, nzmax, sizeof (CS_INT), &oki) ;
|
||||
if (CS_TRIPLET (A)) A->p = cs_realloc (A->p, nzmax, sizeof (CS_INT), &okj) ;
|
||||
if (A->x) A->x = cs_realloc (A->x, nzmax, sizeof (CS_ENTRY), &okx) ;
|
||||
ok = (oki && okj && okx) ;
|
||||
if (ok) A->nzmax = nzmax ;
|
||||
return (ok) ;
|
||||
}
|
||||
|
||||
/* free a sparse matrix */
|
||||
cs *cs_spfree (cs *A)
|
||||
{
|
||||
if (!A) return (NULL) ; /* do nothing if A already NULL */
|
||||
cs_free (A->p) ;
|
||||
cs_free (A->i) ;
|
||||
cs_free (A->x) ;
|
||||
return ((cs *) cs_free (A)) ; /* free the cs struct and return NULL */
|
||||
}
|
||||
|
||||
/* free a numeric factorization */
|
||||
csn *cs_nfree (csn *N)
|
||||
{
|
||||
if (!N) return (NULL) ; /* do nothing if N already NULL */
|
||||
cs_spfree (N->L) ;
|
||||
cs_spfree (N->U) ;
|
||||
cs_free (N->pinv) ;
|
||||
cs_free (N->B) ;
|
||||
return ((csn *) cs_free (N)) ; /* free the csn struct and return NULL */
|
||||
}
|
||||
|
||||
/* free a symbolic factorization */
|
||||
css *cs_sfree (css *S)
|
||||
{
|
||||
if (!S) return (NULL) ; /* do nothing if S already NULL */
|
||||
cs_free (S->pinv) ;
|
||||
cs_free (S->q) ;
|
||||
cs_free (S->parent) ;
|
||||
cs_free (S->cp) ;
|
||||
cs_free (S->leftmost) ;
|
||||
return ((css *) cs_free (S)) ; /* free the css struct and return NULL */
|
||||
}
|
||||
|
||||
/* allocate a cs_dmperm or cs_scc result */
|
||||
csd *cs_dalloc (CS_INT m, CS_INT n)
|
||||
{
|
||||
csd *D ;
|
||||
D = cs_calloc (1, sizeof (csd)) ;
|
||||
if (!D) return (NULL) ;
|
||||
D->p = cs_malloc (m, sizeof (CS_INT)) ;
|
||||
D->r = cs_malloc (m+6, sizeof (CS_INT)) ;
|
||||
D->q = cs_malloc (n, sizeof (CS_INT)) ;
|
||||
D->s = cs_malloc (n+6, sizeof (CS_INT)) ;
|
||||
return ((!D->p || !D->r || !D->q || !D->s) ? cs_dfree (D) : D) ;
|
||||
}
|
||||
|
||||
/* free a cs_dmperm or cs_scc result */
|
||||
csd *cs_dfree (csd *D)
|
||||
{
|
||||
if (!D) return (NULL) ; /* do nothing if D already NULL */
|
||||
cs_free (D->p) ;
|
||||
cs_free (D->q) ;
|
||||
cs_free (D->r) ;
|
||||
cs_free (D->s) ;
|
||||
return ((csd *) cs_free (D)) ; /* free the csd struct and return NULL */
|
||||
}
|
||||
|
||||
/* free workspace and return a sparse matrix result */
|
||||
cs *cs_done (cs *C, void *w, void *x, CS_INT ok)
|
||||
{
|
||||
cs_free (w) ; /* free workspace */
|
||||
cs_free (x) ;
|
||||
return (ok ? C : cs_spfree (C)) ; /* return result if OK, else free it */
|
||||
}
|
||||
|
||||
/* free workspace and return CS_INT array result */
|
||||
CS_INT *cs_idone (CS_INT *p, cs *C, void *w, CS_INT ok)
|
||||
{
|
||||
cs_spfree (C) ; /* free temporary matrix */
|
||||
cs_free (w) ; /* free workspace */
|
||||
return (ok ? p : (CS_INT *) cs_free (p)) ; /* return result, or free it */
|
||||
}
|
||||
|
||||
/* free workspace and return a numeric factorization (Cholesky, LU, or QR) */
|
||||
csn *cs_ndone (csn *N, cs *C, void *w, void *x, CS_INT ok)
|
||||
{
|
||||
cs_spfree (C) ; /* free temporary matrix */
|
||||
cs_free (w) ; /* free workspace */
|
||||
cs_free (x) ;
|
||||
return (ok ? N : cs_nfree (N)) ; /* return result if OK, else free it */
|
||||
}
|
||||
|
||||
/* free workspace and return a csd result */
|
||||
csd *cs_ddone (csd *D, cs *C, void *w, CS_INT ok)
|
||||
{
|
||||
cs_spfree (C) ; /* free temporary matrix */
|
||||
cs_free (w) ; /* free workspace */
|
||||
return (ok ? D : cs_dfree (D)) ; /* return result if OK, else free it */
|
||||
}
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
#include "cs.h"
|
||||
/* solve U'x=b where x and b are dense. x=b on input, solution on output. */
|
||||
CS_INT cs_utsolve (const cs *U, CS_ENTRY *x)
|
||||
{
|
||||
CS_INT p, j, n, *Up, *Ui ;
|
||||
CS_ENTRY *Ux ;
|
||||
if (!CS_CSC (U) || !x) return (0) ; /* check inputs */
|
||||
n = U->n ; Up = U->p ; Ui = U->i ; Ux = U->x ;
|
||||
for (j = 0 ; j < n ; j++)
|
||||
{
|
||||
for (p = Up [j] ; p < Up [j+1]-1 ; p++)
|
||||
{
|
||||
x [j] -= CS_CONJ (Ux [p]) * x [Ui [p]] ;
|
||||
}
|
||||
x [j] /= CS_CONJ (Ux [Up [j+1]-1]) ;
|
||||
}
|
||||
return (1) ;
|
||||
}
|
||||
+144
@@ -0,0 +1,144 @@
|
||||
# arith.h is built during compilation using arithchk.c
|
||||
add_executable(arithchk EXCLUDE_FROM_ALL arithchk.c)
|
||||
target_compile_definitions(arithchk PRIVATE NO_FPINIT) # maybe also NO_LONG_LONG?
|
||||
if (NOT MSVC)
|
||||
target_link_libraries(arithchk PRIVATE m)
|
||||
endif()
|
||||
|
||||
# Provide an option for the user to provide an external arith.h for
|
||||
# cross-compilation
|
||||
set(
|
||||
F2C_EXTERNAL_ARITH_HEADER "" CACHE FILEPATH
|
||||
"Path to an external arith.h to use for compiling f2c, typically for cross-compilation"
|
||||
)
|
||||
|
||||
if(F2C_EXTERNAL_ARITH_HEADER)
|
||||
configure_file(${F2C_EXTERNAL_ARITH_HEADER} arith.h COPYONLY)
|
||||
else()
|
||||
if (CMAKE_CROSSCOMPILING AND NOT CMAKE_CROSSCOMPILING_EMULATOR)
|
||||
# Warn only, as in some circumstances, such as macOS with Rosetta,
|
||||
# arithchk can still be run through emulation and the build with not fail.
|
||||
message(WARNING
|
||||
"Cross-compiling with internal ARPACK, BLAS or LAPACK, but "
|
||||
"F2C_EXTERNAL_ARITH_HEADER was not set and no cross-compiling "
|
||||
"emulator was provided in CMAKE_CROSSCOMPILING_EMULATOR either. "
|
||||
"The build is likely to fail. See igraph's installation instructions "
|
||||
"for more information.")
|
||||
endif()
|
||||
add_custom_command(
|
||||
OUTPUT arith.h
|
||||
COMMENT "Generating arith.h for f2c..."
|
||||
COMMAND arithchk > ${CMAKE_CURRENT_BINARY_DIR}/arith.h
|
||||
DEPENDS arithchk
|
||||
VERBATIM
|
||||
)
|
||||
endif()
|
||||
|
||||
# Hidden CMake option for Szabolcs so he can collect arith.h headers from
|
||||
# multiple systems in CI
|
||||
option(IGRAPH_PRINT_ARITH_HEADER "Print the contents of the generated arith.h for debugging purposes")
|
||||
mark_as_advanced(IGRAPH_PRINT_ARITH_HEADER)
|
||||
if(IGRAPH_PRINT_ARITH_HEADER)
|
||||
add_custom_command(
|
||||
TARGET arithchk POST_BUILD
|
||||
COMMENT "Printing contents of arith.h..."
|
||||
COMMAND arithchk
|
||||
VERBATIM USES_TERMINAL
|
||||
)
|
||||
endif()
|
||||
|
||||
# Declare the files needed to compile our vendored f2c copy
|
||||
add_library(
|
||||
f2c_vendored
|
||||
OBJECT
|
||||
EXCLUDE_FROM_ALL
|
||||
abort_.c dolio.c r_sin.c
|
||||
dummy.c dtime_.c iio.c r_sinh.c
|
||||
backspac.c due.c ilnw.c r_sqrt.c
|
||||
c_abs.c ef1asc_.c inquire.c r_tan.c
|
||||
c_cos.c ef1cmc_.c l_ge.c r_tanh.c
|
||||
c_div.c endfile.c l_gt.c rdfmt.c
|
||||
c_exp.c erf_.c l_le.c rewind.c
|
||||
c_log.c erfc_.c l_lt.c rsfe.c
|
||||
c_sin.c err.c lbitbits.c rsli.c
|
||||
c_sqrt.c etime_.c lbitshft.c rsne.c
|
||||
cabs.c exit_.c lread.c s_cat.c
|
||||
close.c f77_aloc.c lwrite.c s_cmp.c
|
||||
ctype.c f77vers.c s_copy.c
|
||||
d_abs.c fmt.c open.c s_paus.c
|
||||
d_acos.c fmtlib.c pow_ci.c s_rnge.c
|
||||
d_asin.c ftell_.c pow_dd.c s_stop.c
|
||||
d_atan.c pow_di.c sfe.c
|
||||
d_atn2.c getenv_.c pow_hh.c sig_die.c
|
||||
d_cnjg.c h_abs.c pow_ii.c signal_.c
|
||||
d_cos.c h_dim.c pow_ri.c signbit.c
|
||||
d_cosh.c h_dnnt.c pow_zi.c sue.c
|
||||
d_dim.c h_indx.c pow_zz.c system_.c
|
||||
d_exp.c h_len.c r_abs.c typesize.c
|
||||
d_imag.c h_mod.c r_acos.c uio.c
|
||||
d_int.c h_nint.c r_asin.c uninit.c
|
||||
d_lg10.c h_sign.c r_atan.c util.c
|
||||
d_log.c hl_ge.c r_atn2.c wref.c
|
||||
d_mod.c hl_gt.c r_cnjg.c wrtfmt.c
|
||||
d_nint.c hl_le.c r_cos.c wsfe.c
|
||||
d_prod.c hl_lt.c r_cosh.c wsle.c
|
||||
d_sign.c i77vers.c r_dim.c wsne.c
|
||||
d_sin.c i_abs.c r_exp.c xwsne.c
|
||||
d_sinh.c i_dim.c r_imag.c z_abs.c
|
||||
d_sqrt.c i_dnnt.c r_int.c z_cos.c
|
||||
d_tan.c i_indx.c r_lg10.c z_div.c
|
||||
d_tanh.c i_len.c r_log.c z_exp.c
|
||||
derf_.c i_mod.c r_mod.c z_log.c
|
||||
derfc_.c i_nint.c r_nint.c z_sin.c
|
||||
dfe.c i_sign.c r_sign.c z_sqrt.c
|
||||
${CMAKE_CURRENT_BINARY_DIR}/arith.h
|
||||
)
|
||||
target_include_directories(
|
||||
f2c_vendored
|
||||
PUBLIC
|
||||
${PROJECT_SOURCE_DIR}/include
|
||||
${PROJECT_BINARY_DIR}/include
|
||||
${PROJECT_SOURCE_DIR}/src
|
||||
${PROJECT_BINARY_DIR}/src
|
||||
PRIVATE
|
||||
${CMAKE_CURRENT_SOURCE_DIR}
|
||||
${CMAKE_CURRENT_BINARY_DIR}
|
||||
)
|
||||
|
||||
# Since these are included as object files, they should call the
|
||||
# function as is (without visibility specification)
|
||||
target_compile_definitions(f2c_vendored PRIVATE IGRAPH_STATIC)
|
||||
|
||||
if (WIN32)
|
||||
target_compile_definitions(f2c_vendored PRIVATE MSDOS)
|
||||
endif()
|
||||
|
||||
if (MSVC)
|
||||
target_include_directories(
|
||||
f2c_vendored
|
||||
PUBLIC
|
||||
${PROJECT_SOURCE_DIR}/msvc/include
|
||||
)
|
||||
endif()
|
||||
|
||||
if (BUILD_SHARED_LIBS)
|
||||
set_property(TARGET f2c_vendored PROPERTY POSITION_INDEPENDENT_CODE ON)
|
||||
endif()
|
||||
|
||||
# Suppress some warnings that occur in the output because we do not want to
|
||||
# mess around with the source of f2c too much to fix these
|
||||
if(MSVC)
|
||||
target_compile_options(f2c_vendored PRIVATE
|
||||
/wd4005 # macro redefinition: f2c redefines max and min
|
||||
/wd4311 # pointer truncation; f2c does some magic with signals in signal_.c
|
||||
)
|
||||
else()
|
||||
target_compile_options(arithchk PRIVATE
|
||||
$<$<C_COMPILER_ID:GCC,Clang,AppleClang,IntelLLVM>:-Wno-format-zero-length>
|
||||
)
|
||||
target_compile_options(
|
||||
f2c_vendored PRIVATE
|
||||
$<$<C_COMPILER_ID:GCC,Clang,AppleClang,IntelLLVM>:-Wno-parentheses -Wno-pointer-to-int-cast -Wno-implicit-function-declaration -Wno-format-zero-length>
|
||||
$<$<C_COMPILER_ID:Intel>:-Wno-parentheses -Wno-pointer-to-int-cast -Wno-implicit-function-declaration>
|
||||
)
|
||||
endif()
|
||||
+23
@@ -0,0 +1,23 @@
|
||||
/****************************************************************
|
||||
Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
|
||||
|
||||
Permission to use, copy, modify, and distribute this software
|
||||
and its documentation for any purpose and without fee is hereby
|
||||
granted, provided that the above copyright notice appear in all
|
||||
copies and that both that the copyright notice and this
|
||||
permission notice and warranty disclaimer appear in supporting
|
||||
documentation, and that the names of AT&T, Bell Laboratories,
|
||||
Lucent or Bellcore or any of their entities not be used in
|
||||
advertising or publicity pertaining to distribution of the
|
||||
software without specific, written prior permission.
|
||||
|
||||
AT&T, Lucent and Bellcore disclaim all warranties with regard to
|
||||
this software, including all implied warranties of
|
||||
merchantability and fitness. In no event shall AT&T, Lucent or
|
||||
Bellcore be liable for any special, indirect or consequential
|
||||
damages or any damages whatsoever resulting from loss of use,
|
||||
data or profits, whether in an action of contract, negligence or
|
||||
other tortious action, arising out of or in connection with the
|
||||
use or performance of this software.
|
||||
****************************************************************/
|
||||
|
||||
+374
@@ -0,0 +1,374 @@
|
||||
As shipped, "makefile" is a copy of "makefile.u", a Unix makefile.
|
||||
Variants for other systems have names of the form makefile.* and
|
||||
have initial comments saying how to invoke them. You may wish to
|
||||
copy one of the other makefile.* files to makefile.
|
||||
|
||||
If you use a C++ compiler, first say
|
||||
|
||||
make hadd
|
||||
|
||||
to create a suitable f2c.h from f2c.h0 and f2ch.add. Otherwise,
|
||||
|
||||
make f2c.h
|
||||
|
||||
will just copy f2c.h0 to f2c.h .
|
||||
|
||||
If your compiler does not recognize ANSI C headers,
|
||||
compile with KR_headers defined: either add -DKR_headers
|
||||
to the definition of CFLAGS in the makefile, or insert
|
||||
|
||||
#define KR_headers
|
||||
|
||||
at the top of f2c.h .
|
||||
|
||||
If your system lacks onexit() and you are not using an ANSI C
|
||||
compiler, then you should compile main.c with NO_ONEXIT defined.
|
||||
See the comments about onexit in makefile.u.
|
||||
|
||||
If your system has a double drem() function such that drem(a,b)
|
||||
is the IEEE remainder function (with double a, b), then you may
|
||||
wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
|
||||
|
||||
To check for transmission errors, issue the command
|
||||
make check
|
||||
or
|
||||
make -f makefile.u check
|
||||
|
||||
This assumes you have the xsum program whose source, xsum.c,
|
||||
is distributed as part of "all from f2c/src", and that it
|
||||
is installed somewhere in your search path. If you do not
|
||||
have xsum, you can obtain xsum.c by sending the following E-mail
|
||||
message to netlib@netlib.org
|
||||
send xsum.c from f2c/src
|
||||
|
||||
For convenience, the f2c.h0 in this directory is a copy of netlib's
|
||||
"f2c.h from f2c". It is best to install f2c.h in a standard place,
|
||||
so "include f2c.h" will work in any directory without further ado.
|
||||
Beware that the makefiles do not cause recompilation when f2c.h is
|
||||
changed.
|
||||
|
||||
On machines, such as those using a DEC Alpha processor, on which
|
||||
sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and
|
||||
sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by
|
||||
removing the first occurrence of "long " on each line containing
|
||||
"long ". On Unix systems, you can do this by issuing the commands
|
||||
mv f2c.h f2c.h0
|
||||
sed 's/long int /int /' f2c.h0 >f2c.h
|
||||
On such machines, one can enable INTEGER*8 by uncommenting the typedefs
|
||||
of longint and ulongint in f2c.h and adjusting them, so they read
|
||||
typedef long longint;
|
||||
typedef unsigned long ulongint;
|
||||
and by compiling libf2c with -DAllow_TYQUAD, as discussed below.
|
||||
|
||||
|
||||
Most of the routines in libf2c are support routines for Fortran
|
||||
intrinsic functions or for operations that f2c chooses not
|
||||
to do "in line". There are a few exceptions, summarized below --
|
||||
functions and subroutines that appear to your program as ordinary
|
||||
external Fortran routines.
|
||||
|
||||
If you use the REAL valued functions listed below (ERF, ERFC,
|
||||
DTIME, and ETIME) with "f2c -R", then you need to compile the
|
||||
corresponding source files with -DREAL=float. To do this, it is
|
||||
perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile.
|
||||
|
||||
1. CALL ABORT prints a message and causes a core dump.
|
||||
|
||||
2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION
|
||||
error functions (with x REAL and d DOUBLE PRECISION);
|
||||
DERF must be declared DOUBLE PRECISION in your program.
|
||||
Both ERF and DERF assume your C library provides the
|
||||
underlying erf() function (which not all systems do).
|
||||
|
||||
3. ERFC(r) and DERFC(d) are the complementary error functions:
|
||||
ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d)
|
||||
(except that their results may be more accurate than
|
||||
explicitly evaluating the above formulae would give).
|
||||
Again, ERFC and r are REAL, and DERFC and d are DOUBLE
|
||||
PRECISION (and must be declared as such in your program),
|
||||
and ERFC and DERFC rely on your system's erfc().
|
||||
|
||||
4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER
|
||||
variable, sets s to the n-th command-line argument (or to
|
||||
all blanks if there are fewer than n command-line arguments);
|
||||
CALL GETARG(0,s) sets s to the name of the program (on systems
|
||||
that support this feature). See IARGC below.
|
||||
|
||||
5. CALL GETENV(name, value), where name and value are of type
|
||||
CHARACTER, sets value to the environment value, $name, of
|
||||
name (or to blanks if $name has not been set).
|
||||
|
||||
6. NARGS = IARGC() sets NARGS to the number of command-line
|
||||
arguments (an INTEGER value).
|
||||
|
||||
7. CALL SIGNAL(n,func), where n is an INTEGER and func is an
|
||||
EXTERNAL procedure, arranges for func to be invoked when n
|
||||
occurs (on systems where this makes sense).
|
||||
|
||||
If your compiler complains about the signal calls in main.c, s_paus.c,
|
||||
and signal_.c, you may need to adjust signal1.h suitably. See the
|
||||
comments in signal1.h.
|
||||
|
||||
8. ETIME(ARR) and DTIME(ARR) are REAL functions that return
|
||||
execution times. ARR is declared REAL ARR(2). The elapsed
|
||||
user and system CPU times are stored in ARR(1) and ARR(2),
|
||||
respectively. ETIME returns the total elapsed CPU time,
|
||||
i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU
|
||||
time since the previous call on DTIME.
|
||||
|
||||
9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes
|
||||
cmd to the system's command processor (on systems where
|
||||
this can be done).
|
||||
|
||||
10. CALL FLUSH flushes all buffers.
|
||||
|
||||
11. FTELL(i) is an INTEGER function that returns the current
|
||||
offset of Fortran unit i (or -1 if unit i is not open).
|
||||
|
||||
12. CALL FSEEK(i, offset, whence, *errlab) attemps to move
|
||||
Fortran unit i to the specified offset: absolute offset
|
||||
if whence = 0; relative to the current offset if whence = 1;
|
||||
relative to the end of the file if whence = 2. It branches
|
||||
to label errlab if unit i is not open or if the call
|
||||
otherwise fails.
|
||||
|
||||
The routines whose objects are makefile.u's $(I77) are for I/O.
|
||||
The following comments apply to them.
|
||||
|
||||
If your system lacks /usr/include/local.h ,
|
||||
then you should create an appropriate local.h in
|
||||
this directory. An appropriate local.h may simply
|
||||
be empty, or it may #define VAX or #define CRAY
|
||||
(or whatever else you must do to make fp.h work right).
|
||||
Alternatively, edit fp.h to suite your machine.
|
||||
|
||||
If your system lacks /usr/include/fcntl.h , then you
|
||||
should simply create an empty fcntl.h in this directory.
|
||||
If your compiler then complains about creat and open not
|
||||
having a prototype, compile with OPEN_DECL defined.
|
||||
On many systems, open and creat are declared in fcntl.h .
|
||||
|
||||
If your system's sprintf does not work the way ANSI C
|
||||
specifies -- specifically, if it does not return the
|
||||
number of characters transmitted -- then insert the line
|
||||
|
||||
#define USE_STRLEN
|
||||
|
||||
at the end of fmt.h . This is necessary with
|
||||
at least some versions of Sun software.
|
||||
In particular, if you get a warning about an improper
|
||||
pointer/integer combination in compiling wref.c, then
|
||||
you need to compile with -DUSE_STRLEN .
|
||||
|
||||
If your system's fopen does not like the ANSI binary
|
||||
reading and writing modes "rb" and "wb", then you should
|
||||
compile open.c with NON_ANSI_RW_MODES #defined.
|
||||
|
||||
If you get error messages about references to cf->_ptr
|
||||
and cf->_base when compiling wrtfmt.c and wsfe.c or to
|
||||
stderr->_flag when compiling err.c, then insert the line
|
||||
|
||||
#define NON_UNIX_STDIO
|
||||
|
||||
at the beginning of fio.h, and recompile everything (or
|
||||
at least those modules that contain NON_UNIX_STDIO).
|
||||
|
||||
Unformatted sequential records consist of a length of record
|
||||
contents, the record contents themselves, and the length of
|
||||
record contents again (for backspace). Prior to 17 Oct. 1991,
|
||||
the length was of type int; now it is of type long, but you
|
||||
can change it back to int by inserting
|
||||
|
||||
#define UIOLEN_int
|
||||
|
||||
at the beginning of fio.h. This affects only sue.c and uio.c .
|
||||
|
||||
If you have a really ancient K&R C compiler that does not understand
|
||||
void, add -Dvoid=int to the definition of CFLAGS in the makefile.
|
||||
|
||||
On VAX, Cray, or Research Tenth-Edition Unix systems, you may
|
||||
need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS
|
||||
to make fp.h work correctly. Alternatively, you may need to
|
||||
edit fp.h to suit your machine.
|
||||
|
||||
If your compiler complains about the signal calls in main.c, s_paus.c,
|
||||
and signal_.c, you may need to adjust signal1.h suitably. See the
|
||||
comments in signal1.h.
|
||||
|
||||
You may need to supply the following non-ANSI routines:
|
||||
|
||||
fstat(int fileds, struct stat *buf) is similar
|
||||
to stat(char *name, struct stat *buf), except that
|
||||
the first argument, fileds, is the file descriptor
|
||||
returned by open rather than the name of the file.
|
||||
fstat is used in the system-dependent routine
|
||||
canseek (in the libf2c source file err.c), which
|
||||
is supposed to return 1 if it's possible to issue
|
||||
seeks on the file in question, 0 if it's not; you may
|
||||
need to suitably modify err.c . On non-UNIX systems,
|
||||
you can avoid references to fstat and stat by compiling
|
||||
with NON_UNIX_STDIO defined; in that case, you may need
|
||||
to supply access(char *Name,0), which is supposed to
|
||||
return 0 if file Name exists, nonzero otherwise.
|
||||
|
||||
char * mktemp(char *buf) is supposed to replace the
|
||||
6 trailing X's in buf with a unique number and then
|
||||
return buf. The idea is to get a unique name for
|
||||
a temporary file.
|
||||
|
||||
On non-UNIX systems, you may need to change a few other,
|
||||
e.g.: the form of name computed by mktemp() in endfile.c and
|
||||
open.c; the use of the open(), close(), and creat() system
|
||||
calls in endfile.c, err.c, open.c; and the modes in calls on
|
||||
fopen() and fdopen() (and perhaps the use of fdopen() itself
|
||||
-- it's supposed to return a FILE* corresponding to a given
|
||||
an integer file descriptor) in err.c and open.c (component ufmt
|
||||
of struct unit is 1 for formatted I/O -- text mode on some systems
|
||||
-- and 0 for unformatted I/O -- binary mode on some systems).
|
||||
Compiling with -DNON_UNIX_STDIO omits all references to creat()
|
||||
and almost all references to open() and close(), the exception
|
||||
being in the function f__isdev() (in open.c).
|
||||
|
||||
If you wish to use translated Fortran that has funny notions
|
||||
of record length for direct unformatted I/O (i.e., that assumes
|
||||
RECL= values in OPEN statements are not bytes but rather counts
|
||||
of some other units -- e.g., 4-character words for VMS), then you
|
||||
should insert an appropriate #define for url_Adjust at the
|
||||
beginning of open.c . For VMS Fortran, for example,
|
||||
#define url_Adjust(x) x *= 4
|
||||
would suffice.
|
||||
|
||||
By default, Fortran I/O units 5, 6, and 0 are pre-connected to
|
||||
stdin, stdout, and stderr, respectively. You can change this
|
||||
behavior by changing f_init() in err.c to suit your needs.
|
||||
Note that f2c assumes READ(*... means READ(5... and WRITE(*...
|
||||
means WRITE(6... . Moreover, an OPEN(n,... statement that does
|
||||
not specify a file name (and does not specify STATUS='SCRATCH')
|
||||
assumes FILE='fort.n' . You can change this by editing open.c
|
||||
and endfile.c suitably.
|
||||
|
||||
Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units
|
||||
0, 1, ..., 99 are available, i.e., the highest allowed unit number
|
||||
is MXUNIT - 1.
|
||||
|
||||
Lines protected from compilation by #ifdef Allow_TYQUAD
|
||||
are for a possible extension to 64-bit integers in which
|
||||
integer = int = 32 bits and longint = long = 64 bits.
|
||||
|
||||
The makefile does not attempt to compile pow_qq.c, qbitbits.c,
|
||||
and qbitshft.c, which are meant for use with INTEGER*8. To use
|
||||
INTEGER*8, you must modify f2c.h to declare longint and ulongint
|
||||
appropriately; then add $(QINT) to the end of the makefile's
|
||||
dependency list for libf2c.a (if makefile is a copy of makefile.u;
|
||||
for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj
|
||||
to the library's dependency list and adjust libf2c.lbc or libf2c.sy
|
||||
accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS
|
||||
assignment. To make longint and ulongint available, it may suffice
|
||||
to add -DINTEGER_STAR_8 to the CFLAGS assignment.
|
||||
|
||||
Following Fortran 90, s_cat.c and s_copy.c allow the target of a
|
||||
(character string) assignment to be appear on its right-hand, at
|
||||
the cost of some extra overhead for all run-time concatenations.
|
||||
If you prefer the extra efficiency that comes with the Fortran 77
|
||||
requirement that the left-hand side of a character assignment not
|
||||
be involved in the right-hand side, compile s_cat.c and s_copy.c
|
||||
with -DNO_OVERWRITE .
|
||||
|
||||
Extensions (Feb. 1993) to NAMELIST processing:
|
||||
1. Reading a ? instead of &name (the start of a namelist) causes
|
||||
the namelist being sought to be written to stdout (unit 6);
|
||||
to omit this feature, compile rsne.c with -DNo_Namelist_Questions.
|
||||
2. Reading the wrong namelist name now leads to an error message
|
||||
and an attempt to skip input until the right namelist name is found;
|
||||
to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip.
|
||||
3. Namelist writes now insert newlines before each variable; to omit
|
||||
this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines.
|
||||
4. (Sept. 1995) When looking for the &name that starts namelist
|
||||
input, lines whose first non-blank character is something other
|
||||
than &, $, or ? are treated as comment lines and ignored, unless
|
||||
rsne.c is compiled with -DNo_Namelist_Comments.
|
||||
|
||||
Nonstandard extension (Feb. 1993) to open: for sequential files,
|
||||
ACCESS='APPEND' (or access='anything else starting with "A" or "a"')
|
||||
causes the file to be positioned at end-of-file, so a write will
|
||||
append to the file.
|
||||
|
||||
Some buggy Fortran programs use unformatted direct I/O to write
|
||||
an incomplete record and later read more from that record than
|
||||
they have written. For records other than the last, the unwritten
|
||||
portion of the record reads as binary zeros. The last record is
|
||||
a special case: attempting to read more from it than was written
|
||||
gives end-of-file -- which may help one find a bug. Some other
|
||||
Fortran I/O libraries treat the last record no differently than
|
||||
others and thus give no help in finding the bug of reading more
|
||||
than was written. If you wish to have this behavior, compile
|
||||
uio.c with -DPad_UDread .
|
||||
|
||||
If you want to be able to catch write failures (e.g., due to a
|
||||
disk being full) with an ERR= specifier, compile dfe.c, due.c,
|
||||
sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to
|
||||
slower execution and more I/O, but should make ERR= work as
|
||||
expected, provided fflush returns an error return when its
|
||||
physical write fails.
|
||||
|
||||
Carriage controls are meant to be interpreted by the UNIX col
|
||||
program (or a similar program). Sometimes it's convenient to use
|
||||
only ' ' as the carriage control character (normal single spacing).
|
||||
If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted
|
||||
external output lines will have an initial ' ' quietly omitted,
|
||||
making use of the col program unnecessary with output that only
|
||||
has ' ' for carriage control.
|
||||
|
||||
The Fortran 77 Standard leaves it up to the implementation whether
|
||||
formatted writes of floating-point numbers of absolute value < 1 have
|
||||
a zero before the decimal point. By default, libI77 omits such
|
||||
superfluous zeros, but you can cause them to appear by compiling
|
||||
lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 .
|
||||
|
||||
If your (Unix) system lacks a ranlib command, you don't need it.
|
||||
Either comment out the makefile's ranlib invocation, or install
|
||||
a harmless "ranlib" command somewhere in your PATH, such as the
|
||||
one-line shell script
|
||||
|
||||
exit 0
|
||||
|
||||
or (on some systems)
|
||||
|
||||
exec /usr/bin/ar lts $1 >/dev/null
|
||||
|
||||
By default, the routines that implement complex and double complex
|
||||
division, c_div.c and z_div.c, call sig_die to print an error message
|
||||
and exit if they see a divisor of 0, as this is sometimes helpful for
|
||||
debugging. On systems with IEEE arithmetic, compiling c_div.c and
|
||||
z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both
|
||||
the real and imaginary parts of the result to +INFINITY if the
|
||||
numerator is nonzero, or to NaN if it vanishes.
|
||||
|
||||
Nowadays most Unix and Linux systems have function
|
||||
int ftruncate(int fildes, off_t len);
|
||||
defined in system header file unistd.h that adjusts the length of file
|
||||
descriptor fildes to length len. Unless endfile.c is compiled with
|
||||
-DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if
|
||||
necessary to shorten files. If your system lacks ftruncate(), compile
|
||||
endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more
|
||||
portable scheme of shortening a file by copying to a temporary file
|
||||
and back again.
|
||||
|
||||
The initializations for "f2c -trapuv" are done by _uninit_f2c(),
|
||||
whose source is uninit.c, introduced June 2001. On IEEE-arithmetic
|
||||
systems, _uninit_f2c should initialize floating-point variables to
|
||||
signaling NaNs and, at its first invocation, should enable the
|
||||
invalid operation exception. Alas, the rules for distinguishing
|
||||
signaling from quiet NaNs were not specified in the IEEE P754 standard,
|
||||
nor were the precise means of enabling and disabling IEEE-arithmetic
|
||||
exceptions, and these details are thus system dependent. There are
|
||||
#ifdef's in uninit.c that specify them for some popular systems. If
|
||||
yours is not one of these systems, it may take some detective work to
|
||||
discover the appropriate details for your system. Sometimes it helps
|
||||
to look in the standard include directories for header files with
|
||||
relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and
|
||||
it may be simplest to run experiments to see what distinguishes a
|
||||
signaling from a quiet NaN. (If x is initialized to a signaling
|
||||
NaN and the invalid operation exception is masked off, as it should
|
||||
be by default on IEEE-arithmetic systems, then computing, say,
|
||||
y = x + 1 will yield a quiet NaN.)
|
||||
+22
@@ -0,0 +1,22 @@
|
||||
#include "stdio.h"
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
extern VOID sig_die();
|
||||
|
||||
int abort_()
|
||||
#else
|
||||
extern void sig_die(const char*,int);
|
||||
|
||||
int abort_(void)
|
||||
#endif
|
||||
{
|
||||
sig_die("Fortran abort routine called", 1);
|
||||
return 0; /* not reached */
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+268
@@ -0,0 +1,268 @@
|
||||
/****************************************************************
|
||||
Copyright (C) 1997, 1998, 2000 Lucent Technologies
|
||||
All Rights Reserved
|
||||
|
||||
Permission to use, copy, modify, and distribute this software and
|
||||
its documentation for any purpose and without fee is hereby
|
||||
granted, provided that the above copyright notice appear in all
|
||||
copies and that both that the copyright notice and this
|
||||
permission notice and warranty disclaimer appear in supporting
|
||||
documentation, and that the name of Lucent or any of its entities
|
||||
not be used in advertising or publicity pertaining to
|
||||
distribution of the software without specific, written prior
|
||||
permission.
|
||||
|
||||
LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
|
||||
INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
|
||||
IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
|
||||
SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
||||
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
|
||||
IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
|
||||
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
|
||||
THIS SOFTWARE.
|
||||
****************************************************************/
|
||||
|
||||
/* Try to deduce arith.h from arithmetic properties. */
|
||||
|
||||
#include <stdio.h>
|
||||
#include <math.h>
|
||||
#include <errno.h>
|
||||
|
||||
#ifdef NO_FPINIT
|
||||
#define fpinit_ASL()
|
||||
#else
|
||||
#ifndef KR_headers
|
||||
extern
|
||||
#ifdef __cplusplus
|
||||
"C"
|
||||
#endif
|
||||
void fpinit_ASL(void);
|
||||
#endif /*KR_headers*/
|
||||
#endif /*NO_FPINIT*/
|
||||
|
||||
static int dalign;
|
||||
typedef struct
|
||||
Akind {
|
||||
char *name;
|
||||
int kind;
|
||||
} Akind;
|
||||
|
||||
typedef struct
|
||||
ErrnoTest {
|
||||
double (*f)(double);
|
||||
double *x;
|
||||
} ErrnoTest;
|
||||
|
||||
static double Big = 1e10, Two = 2., t_nan;
|
||||
|
||||
static ErrnoTest Entest[] = {
|
||||
{ log, &t_nan },
|
||||
{ exp, &Big },
|
||||
{ asin, &Two },
|
||||
{ acos, &Two },
|
||||
{ sqrt, &t_nan }};
|
||||
|
||||
static int nEntest = sizeof(Entest)/sizeof(ErrnoTest);
|
||||
|
||||
static Akind
|
||||
IEEE_8087 = { "IEEE_8087", 1 },
|
||||
IEEE_MC68k = { "IEEE_MC68k", 2 },
|
||||
IBM = { "IBM", 3 },
|
||||
VAX = { "VAX", 4 },
|
||||
CRAY = { "CRAY", 5};
|
||||
|
||||
static Akind *
|
||||
Lcheck(void)
|
||||
{
|
||||
union {
|
||||
double d;
|
||||
long L[2];
|
||||
} u;
|
||||
struct {
|
||||
double d;
|
||||
long L;
|
||||
} x[2];
|
||||
|
||||
if (sizeof(x) > 2*(sizeof(double) + sizeof(long)))
|
||||
dalign = 1;
|
||||
u.L[0] = u.L[1] = 0;
|
||||
u.d = 1e13;
|
||||
if (u.L[0] == 1117925532 && u.L[1] == -448790528)
|
||||
return &IEEE_MC68k;
|
||||
if (u.L[1] == 1117925532 && u.L[0] == -448790528)
|
||||
return &IEEE_8087;
|
||||
if (u.L[0] == -2065213935 && u.L[1] == 10752)
|
||||
return &VAX;
|
||||
if (u.L[0] == 1267827943 && u.L[1] == 704643072)
|
||||
return &IBM;
|
||||
return 0;
|
||||
}
|
||||
|
||||
static Akind *
|
||||
icheck(void)
|
||||
{
|
||||
union {
|
||||
double d;
|
||||
int L[2];
|
||||
} u;
|
||||
struct {
|
||||
double d;
|
||||
int L;
|
||||
} x[2];
|
||||
|
||||
if (sizeof(x) > 2*(sizeof(double) + sizeof(int)))
|
||||
dalign = 1;
|
||||
u.L[0] = u.L[1] = 0;
|
||||
u.d = 1e13;
|
||||
if (u.L[0] == 1117925532 && u.L[1] == -448790528)
|
||||
return &IEEE_MC68k;
|
||||
if (u.L[1] == 1117925532 && u.L[0] == -448790528)
|
||||
return &IEEE_8087;
|
||||
if (u.L[0] == -2065213935 && u.L[1] == 10752)
|
||||
return &VAX;
|
||||
if (u.L[0] == 1267827943 && u.L[1] == 704643072)
|
||||
return &IBM;
|
||||
return 0;
|
||||
}
|
||||
|
||||
static Akind *
|
||||
ccheck(int ac, char **av)
|
||||
{
|
||||
union {
|
||||
double d;
|
||||
long L;
|
||||
} u;
|
||||
long Cray1;
|
||||
|
||||
/* Cray1 = 4617762693716115456 -- without overflow on non-Crays */
|
||||
/* The next three tests should always be true. */
|
||||
Cray1 = ac >= -2 ? 4617762 : 0;
|
||||
if (ac >= -1)
|
||||
Cray1 = 1000000*Cray1 + 693716;
|
||||
if (av || ac >= 0)
|
||||
Cray1 = 1000000*Cray1 + 115456;
|
||||
u.d = 1e13;
|
||||
if (u.L == Cray1)
|
||||
return &CRAY;
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int
|
||||
fzcheck(void)
|
||||
{
|
||||
double a, b;
|
||||
int i;
|
||||
|
||||
a = 1.;
|
||||
b = .1;
|
||||
for(i = 155;; b *= b, i >>= 1) {
|
||||
if (i & 1) {
|
||||
a *= b;
|
||||
if (i == 1)
|
||||
break;
|
||||
}
|
||||
}
|
||||
b = a * a;
|
||||
return b == 0.;
|
||||
}
|
||||
|
||||
void
|
||||
get_nanbits(unsigned int *b, int k)
|
||||
{
|
||||
union { double d; unsigned int z[2]; } u, u1, u2;
|
||||
|
||||
k = 2 - k;
|
||||
u1.z[k] = u2.z[k] = 0x7ff00000;
|
||||
u1.z[1-k] = u2.z[1-k] = 0;
|
||||
u.d = u1.d - u2.d; /* Infinity - Infinity */
|
||||
b[0] = u.z[0];
|
||||
b[1] = u.z[1];
|
||||
}
|
||||
|
||||
int
|
||||
main(int argc, char **argv)
|
||||
{
|
||||
FILE *f;
|
||||
Akind *a;
|
||||
ErrnoTest *et, *ete;
|
||||
int Ldef, goodbits, gooderrno, w0;
|
||||
union { double d; unsigned int u[2]; } u;
|
||||
unsigned int nanbits[2];
|
||||
|
||||
a = 0;
|
||||
Ldef = 0;
|
||||
fpinit_ASL();
|
||||
#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */
|
||||
f = fopen("arith.h", "w");
|
||||
if (!f) {
|
||||
printf("Cannot open arith.h\n");
|
||||
return 1;
|
||||
}
|
||||
#else
|
||||
f = stdout;
|
||||
#endif
|
||||
|
||||
if (sizeof(double) == 2*sizeof(long))
|
||||
a = Lcheck();
|
||||
else if (sizeof(double) == 2*sizeof(int)) {
|
||||
Ldef = 1;
|
||||
a = icheck();
|
||||
}
|
||||
else if (sizeof(double) == sizeof(long))
|
||||
a = ccheck(argc, argv);
|
||||
if (a) {
|
||||
fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n",
|
||||
a->name, a->kind);
|
||||
if (Ldef)
|
||||
fprintf(f, "#define Long int\n#define Intcast (int)(long)\n");
|
||||
if (dalign)
|
||||
fprintf(f, "#define Double_Align\n");
|
||||
if (sizeof(char*) == 8)
|
||||
fprintf(f, "#define X64_bit_pointers\n");
|
||||
#ifndef NO_LONG_LONG
|
||||
if (sizeof(long long) > sizeof(long)
|
||||
&& sizeof(long long) == sizeof(void*))
|
||||
fprintf(f, "#define LONG_LONG_POINTERS\n");
|
||||
if (sizeof(long long) < 8)
|
||||
#endif
|
||||
fprintf(f, "#define NO_LONG_LONG\n");
|
||||
|
||||
if (a->kind <= 2) {
|
||||
if (fzcheck())
|
||||
fprintf(f, "#define Sudden_Underflow\n");
|
||||
t_nan = -a->kind;
|
||||
if (sizeof(double) == 2*sizeof(unsigned int)) {
|
||||
get_nanbits(nanbits, a->kind);
|
||||
fprintf(f, "#define QNaN0 0x%x\n", nanbits[0]);
|
||||
fprintf(f, "#define QNaN1 0x%x\n", nanbits[1]);
|
||||
}
|
||||
w0 = 2 - a->kind;
|
||||
goodbits = gooderrno = 0;
|
||||
ete = Entest + nEntest;
|
||||
for(et = Entest; et < ete; ++et) {
|
||||
errno = 0;
|
||||
u.d = et->f(*et->x);
|
||||
if (errno)
|
||||
++gooderrno;
|
||||
if ((u.u[w0] & 0x7ff00000) == 0x7ff00000)
|
||||
++goodbits;
|
||||
}
|
||||
if (goodbits) {
|
||||
if (goodbits < nEntest && gooderrno)
|
||||
fprintf(f, "#define ALSO_CHECK_ERRNO\n");
|
||||
}
|
||||
else if (gooderrno)
|
||||
fprintf(f, "#define CHECK_ERRNO\n");
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
fprintf(f, "/* Unknown arithmetic */\n");
|
||||
return 1;
|
||||
}
|
||||
|
||||
#ifdef __sun
|
||||
#ifdef __i386
|
||||
/* kludge for Intel Solaris */
|
||||
void fpsetprec(int x) { }
|
||||
#endif
|
||||
#endif
|
||||
+76
@@ -0,0 +1,76 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#ifdef KR_headers
|
||||
integer f_back(a) alist *a;
|
||||
#else
|
||||
integer f_back(alist *a)
|
||||
#endif
|
||||
{ unit *b;
|
||||
OFF_T v, w, x, y, z;
|
||||
uiolen n;
|
||||
FILE *f;
|
||||
|
||||
f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
|
||||
if(a->aunit >= MXUNIT || a->aunit < 0)
|
||||
err(a->aerr,101,"backspace")
|
||||
if(b->useek==0) err(a->aerr,106,"backspace")
|
||||
if(b->ufd == NULL) {
|
||||
fk_open(1, 1, a->aunit);
|
||||
return(0);
|
||||
}
|
||||
if(b->uend==1)
|
||||
{ b->uend=0;
|
||||
return(0);
|
||||
}
|
||||
if(b->uwrt) {
|
||||
t_runc(a);
|
||||
if (f__nowreading(b))
|
||||
err(a->aerr,errno,"backspace")
|
||||
}
|
||||
f = b->ufd; /* may have changed in t_runc() */
|
||||
if(b->url>0)
|
||||
{
|
||||
x=FTELL(f);
|
||||
y = x % b->url;
|
||||
if(y == 0) x--;
|
||||
x /= b->url;
|
||||
x *= b->url;
|
||||
(void) FSEEK(f,x,SEEK_SET);
|
||||
return(0);
|
||||
}
|
||||
|
||||
if(b->ufmt==0)
|
||||
{ FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR);
|
||||
fread((char *)&n,sizeof(uiolen),1,f);
|
||||
FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR);
|
||||
return(0);
|
||||
}
|
||||
w = x = FTELL(f);
|
||||
z = 0;
|
||||
loop:
|
||||
while(x) {
|
||||
x -= x < 64 ? x : 64;
|
||||
FSEEK(f,x,SEEK_SET);
|
||||
for(y = x; y < w; y++) {
|
||||
if (getc(f) != '\n')
|
||||
continue;
|
||||
v = FTELL(f);
|
||||
if (v == w) {
|
||||
if (z)
|
||||
goto break2;
|
||||
goto loop;
|
||||
}
|
||||
z = v;
|
||||
}
|
||||
err(a->aerr,(EOF),"backspace")
|
||||
}
|
||||
break2:
|
||||
FSEEK(f, z, SEEK_SET);
|
||||
return 0;
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+20
@@ -0,0 +1,20 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
extern double f__cabs();
|
||||
|
||||
double c_abs(z) f2c_complex *z;
|
||||
#else
|
||||
extern double f__cabs(double, double);
|
||||
|
||||
double c_abs(f2c_complex *z)
|
||||
#endif
|
||||
{
|
||||
return( f__cabs( z->r, z->i ) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+23
@@ -0,0 +1,23 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern double sin(), cos(), sinh(), cosh();
|
||||
|
||||
VOID c_cos(r, z) f2c_complex *r, *z;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
void c_cos(f2c_complex *r, f2c_complex *z)
|
||||
#endif
|
||||
{
|
||||
double zi = z->i, zr = z->r;
|
||||
r->r = cos(zr) * cosh(zi);
|
||||
r->i = - sin(zr) * sinh(zi);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+53
@@ -0,0 +1,53 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
extern VOID sig_die();
|
||||
VOID c_div(c, a, b)
|
||||
f2c_complex *a, *b, *c;
|
||||
#else
|
||||
extern void sig_die(const char*,int);
|
||||
void c_div(f2c_complex *c, f2c_complex *a, f2c_complex *b)
|
||||
#endif
|
||||
{
|
||||
double ratio, den;
|
||||
double abr, abi, cr;
|
||||
|
||||
if( (abr = b->r) < 0.)
|
||||
abr = - abr;
|
||||
if( (abi = b->i) < 0.)
|
||||
abi = - abi;
|
||||
if( abr <= abi )
|
||||
{
|
||||
if(abi == 0) {
|
||||
#ifdef IEEE_COMPLEX_DIVIDE
|
||||
float af, bf;
|
||||
af = bf = abr;
|
||||
if (a->i != 0 || a->r != 0)
|
||||
af = 1.;
|
||||
c->i = c->r = af / bf;
|
||||
return;
|
||||
#else
|
||||
sig_die("complex division by zero", 1);
|
||||
#endif
|
||||
}
|
||||
ratio = (double)b->r / b->i ;
|
||||
den = b->i * (1 + ratio*ratio);
|
||||
cr = (a->r*ratio + a->i) / den;
|
||||
c->i = (a->i*ratio - a->r) / den;
|
||||
}
|
||||
|
||||
else
|
||||
{
|
||||
ratio = (double)b->i / b->r ;
|
||||
den = b->r * (1 + ratio*ratio);
|
||||
cr = (a->r + a->i*ratio) / den;
|
||||
c->i = (a->i - a->r*ratio) / den;
|
||||
}
|
||||
c->r = cr;
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+25
@@ -0,0 +1,25 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern double exp(), cos(), sin();
|
||||
|
||||
VOID c_exp(r, z) f2c_complex *r, *z;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
void c_exp(f2c_complex *r, f2c_complex *z)
|
||||
#endif
|
||||
{
|
||||
double expx, zi = z->i;
|
||||
|
||||
expx = exp(z->r);
|
||||
r->r = expx * cos(zi);
|
||||
r->i = expx * sin(zi);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+23
@@ -0,0 +1,23 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern double log(), f__cabs(), atan2();
|
||||
VOID c_log(r, z) f2c_complex *r, *z;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
extern double f__cabs(double, double);
|
||||
|
||||
void c_log(f2c_complex *r, f2c_complex *z)
|
||||
#endif
|
||||
{
|
||||
double zi, zr;
|
||||
r->i = atan2(zi = z->i, zr = z->r);
|
||||
r->r = log( f__cabs(zr, zi) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+23
@@ -0,0 +1,23 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern double sin(), cos(), sinh(), cosh();
|
||||
|
||||
VOID c_sin(r, z) f2c_complex *r, *z;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
void c_sin(f2c_complex *r, f2c_complex *z)
|
||||
#endif
|
||||
{
|
||||
double zi = z->i, zr = z->r;
|
||||
r->r = sin(zr) * cosh(zi);
|
||||
r->i = cos(zr) * sinh(zi);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+41
@@ -0,0 +1,41 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
extern double sqrt(), f__cabs();
|
||||
|
||||
VOID c_sqrt(r, z) f2c_complex *r, *z;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
extern double f__cabs(double, double);
|
||||
|
||||
void c_sqrt(f2c_complex *r, f2c_complex *z)
|
||||
#endif
|
||||
{
|
||||
double mag, t;
|
||||
double zi = z->i, zr = z->r;
|
||||
|
||||
if( (mag = f__cabs(zr, zi)) == 0.)
|
||||
r->r = r->i = 0.;
|
||||
else if(zr > 0)
|
||||
{
|
||||
r->r = t = sqrt(0.5 * (mag + zr) );
|
||||
t = zi / t;
|
||||
r->i = 0.5 * t;
|
||||
}
|
||||
else
|
||||
{
|
||||
t = sqrt(0.5 * (mag - zr) );
|
||||
if(zi < 0)
|
||||
t = -t;
|
||||
r->i = t;
|
||||
t = zi / t;
|
||||
r->r = 0.5 * t;
|
||||
}
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+33
@@ -0,0 +1,33 @@
|
||||
#ifdef KR_headers
|
||||
extern double sqrt();
|
||||
double f__cabs(real, imag) double real, imag;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double f__cabs(double real, double imag)
|
||||
#endif
|
||||
{
|
||||
double temp;
|
||||
|
||||
if(real < 0)
|
||||
real = -real;
|
||||
if(imag < 0)
|
||||
imag = -imag;
|
||||
if(imag > real){
|
||||
temp = real;
|
||||
real = imag;
|
||||
imag = temp;
|
||||
}
|
||||
if((real+imag) == real)
|
||||
return(real);
|
||||
|
||||
temp = imag/real;
|
||||
temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/
|
||||
return(temp);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+3468
File diff suppressed because it is too large
Load Diff
+101
@@ -0,0 +1,101 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#ifdef KR_headers
|
||||
integer f_clos(a) cllist *a;
|
||||
#else
|
||||
#undef abs
|
||||
#undef min
|
||||
#undef max
|
||||
#include "stdlib.h"
|
||||
#ifdef NON_UNIX_STDIO
|
||||
#ifndef unlink
|
||||
#define unlink remove
|
||||
#endif
|
||||
#else
|
||||
#ifdef MSDOS
|
||||
#include "io.h"
|
||||
#else
|
||||
#ifdef __cplusplus
|
||||
extern "C" int unlink(const char*);
|
||||
#else
|
||||
extern int unlink(const char*);
|
||||
#endif
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
integer f_clos(cllist *a)
|
||||
#endif
|
||||
{ unit *b;
|
||||
|
||||
if(a->cunit >= MXUNIT) return(0);
|
||||
b= &f__units[a->cunit];
|
||||
if(b->ufd==NULL)
|
||||
goto done;
|
||||
if (b->uscrtch == 1)
|
||||
goto Delete;
|
||||
if (!a->csta)
|
||||
goto Keep;
|
||||
switch(*a->csta) {
|
||||
default:
|
||||
Keep:
|
||||
case 'k':
|
||||
case 'K':
|
||||
if(b->uwrt == 1)
|
||||
t_runc((alist *)a);
|
||||
if(b->ufnm) {
|
||||
fclose(b->ufd);
|
||||
free(b->ufnm);
|
||||
}
|
||||
break;
|
||||
case 'd':
|
||||
case 'D':
|
||||
Delete:
|
||||
fclose(b->ufd);
|
||||
if(b->ufnm) {
|
||||
unlink(b->ufnm); /*SYSDEP*/
|
||||
free(b->ufnm);
|
||||
}
|
||||
}
|
||||
b->ufd=NULL;
|
||||
done:
|
||||
b->uend=0;
|
||||
b->ufnm=NULL;
|
||||
return(0);
|
||||
}
|
||||
void
|
||||
#ifdef KR_headers
|
||||
f_exit()
|
||||
#else
|
||||
f_exit(void)
|
||||
#endif
|
||||
{ int i;
|
||||
static cllist xx;
|
||||
if (!xx.cerr) {
|
||||
xx.cerr=1;
|
||||
xx.csta=NULL;
|
||||
for(i=0;i<MXUNIT;i++)
|
||||
{
|
||||
xx.cunit=i;
|
||||
(void) f_clos(&xx);
|
||||
}
|
||||
}
|
||||
}
|
||||
int
|
||||
#ifdef KR_headers
|
||||
flush_()
|
||||
#else
|
||||
flush_(void)
|
||||
#endif
|
||||
{ int i;
|
||||
for(i=0;i<MXUNIT;i++)
|
||||
if(f__units[i].ufd != NULL && f__units[i].uwrt)
|
||||
fflush(f__units[i].ufd);
|
||||
return 0;
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+2
@@ -0,0 +1,2 @@
|
||||
#define My_ctype_DEF
|
||||
#include "ctype.h"
|
||||
+47
@@ -0,0 +1,47 @@
|
||||
/* Custom ctype.h to overcome trouble with recent versions of Linux libc.a */
|
||||
|
||||
#ifdef NO_My_ctype
|
||||
#include <ctype.h>
|
||||
#else /*{*/
|
||||
#ifndef My_ctype_DEF
|
||||
extern char My_ctype[];
|
||||
#else /*{*/
|
||||
char My_ctype[264] = {
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 2, 2, 2, 2, 2, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
2, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
1, 1, 1, 1, 1, 1, 1, 1,
|
||||
1, 1, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0,
|
||||
0, 0, 0, 0, 0, 0, 0, 0};
|
||||
#endif /*}*/
|
||||
|
||||
#define isdigit(x) (My_ctype[(x)+8] & 1)
|
||||
#define isspace(x) (My_ctype[(x)+8] & 2)
|
||||
#endif
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double d_abs(x) doublereal *x;
|
||||
#else
|
||||
double d_abs(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
if(*x >= 0)
|
||||
return(*x);
|
||||
return(- *x);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double acos();
|
||||
double d_acos(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_acos(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( acos(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double asin();
|
||||
double d_asin(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_asin(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( asin(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double atan();
|
||||
double d_atan(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_atan(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( atan(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double atan2();
|
||||
double d_atn2(x,y) doublereal *x, *y;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_atn2(doublereal *x, doublereal *y)
|
||||
#endif
|
||||
{
|
||||
return( atan2(*x,*y) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
VOID
|
||||
#ifdef KR_headers
|
||||
d_cnjg(r, z) doublecomplex *r, *z;
|
||||
#else
|
||||
d_cnjg(doublecomplex *r, doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
doublereal zi = z->i;
|
||||
r->r = z->r;
|
||||
r->i = -zi;
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double cos();
|
||||
double d_cos(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_cos(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( cos(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double cosh();
|
||||
double d_cosh(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_cosh(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( cosh(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+16
@@ -0,0 +1,16 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double d_dim(a,b) doublereal *a, *b;
|
||||
#else
|
||||
double d_dim(doublereal *a, doublereal *b)
|
||||
#endif
|
||||
{
|
||||
return( *a > *b ? *a - *b : 0);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double exp();
|
||||
double d_exp(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_exp(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( exp(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+16
@@ -0,0 +1,16 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double d_imag(z) doublecomplex *z;
|
||||
#else
|
||||
double d_imag(doublecomplex *z)
|
||||
#endif
|
||||
{
|
||||
return(z->i);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double floor();
|
||||
double d_int(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_int(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( (*x>0) ? floor(*x) : -floor(- *x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+21
@@ -0,0 +1,21 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#define log10e 0.43429448190325182765
|
||||
|
||||
#ifdef KR_headers
|
||||
double log();
|
||||
double d_lg10(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_lg10(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( log10e * log(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double log();
|
||||
double d_log(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_log(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( log(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+46
@@ -0,0 +1,46 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
#ifdef IEEE_drem
|
||||
double drem();
|
||||
#else
|
||||
double floor();
|
||||
#endif
|
||||
double d_mod(x,y) doublereal *x, *y;
|
||||
#else
|
||||
#ifdef IEEE_drem
|
||||
double drem(double, double);
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#endif
|
||||
double d_mod(doublereal *x, doublereal *y)
|
||||
#endif
|
||||
{
|
||||
#ifdef IEEE_drem
|
||||
double xa, ya, z;
|
||||
if ((ya = *y) < 0.)
|
||||
ya = -ya;
|
||||
z = drem(xa = *x, ya);
|
||||
if (xa > 0) {
|
||||
if (z < 0)
|
||||
z += ya;
|
||||
}
|
||||
else if (z > 0)
|
||||
z -= ya;
|
||||
return z;
|
||||
#else
|
||||
double quotient;
|
||||
if( (quotient = *x / *y) >= 0)
|
||||
quotient = floor(quotient);
|
||||
else
|
||||
quotient = -floor(-quotient);
|
||||
return(*x - (*y) * quotient );
|
||||
#endif
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+20
@@ -0,0 +1,20 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double floor();
|
||||
double d_nint(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_nint(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( (*x)>=0 ?
|
||||
floor(*x + .5) : -floor(.5 - *x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+16
@@ -0,0 +1,16 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double d_prod(x,y) real *x, *y;
|
||||
#else
|
||||
double d_prod(real *x, real *y)
|
||||
#endif
|
||||
{
|
||||
return( (*x) * (*y) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+18
@@ -0,0 +1,18 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double d_sign(a,b) doublereal *a, *b;
|
||||
#else
|
||||
double d_sign(doublereal *a, doublereal *b)
|
||||
#endif
|
||||
{
|
||||
double x;
|
||||
x = (*a >= 0 ? *a : - *a);
|
||||
return( *b >= 0 ? x : -x);
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double sin();
|
||||
double d_sin(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_sin(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( sin(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double sinh();
|
||||
double d_sinh(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_sinh(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( sinh(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double sqrt();
|
||||
double d_sqrt(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_sqrt(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( sqrt(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double tan();
|
||||
double d_tan(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_tan(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( tan(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
|
||||
#ifdef KR_headers
|
||||
double tanh();
|
||||
double d_tanh(x) doublereal *x;
|
||||
#else
|
||||
#undef abs
|
||||
#include "math.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
double d_tanh(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( tanh(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
#undef abs
|
||||
#include <math.h>
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double derf_(x) doublereal *x;
|
||||
#else
|
||||
double derf_(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( erf(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+19
@@ -0,0 +1,19 @@
|
||||
#include "f2c.h"
|
||||
#undef abs
|
||||
#include <math.h>
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef KR_headers
|
||||
double derfc_(x) doublereal *x;
|
||||
#else
|
||||
double derfc_(doublereal *x)
|
||||
#endif
|
||||
{
|
||||
return( erfc(*x) );
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+151
@@ -0,0 +1,151 @@
|
||||
#include "f2c.h"
|
||||
#include "fio.h"
|
||||
#include "fmt.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
int
|
||||
y_rsk(Void)
|
||||
{
|
||||
if(f__curunit->uend || f__curunit->url <= f__recpos
|
||||
|| f__curunit->url == 1) return 0;
|
||||
do {
|
||||
getc(f__cf);
|
||||
} while(++f__recpos < f__curunit->url);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
y_getc(Void)
|
||||
{
|
||||
int ch;
|
||||
if(f__curunit->uend) return(-1);
|
||||
if((ch=getc(f__cf))!=EOF)
|
||||
{
|
||||
f__recpos++;
|
||||
if(f__curunit->url>=f__recpos ||
|
||||
f__curunit->url==1)
|
||||
return(ch);
|
||||
else return(' ');
|
||||
}
|
||||
if(feof(f__cf))
|
||||
{
|
||||
f__curunit->uend=1;
|
||||
errno=0;
|
||||
return(-1);
|
||||
}
|
||||
err(f__elist->cierr,errno,"readingd");
|
||||
}
|
||||
|
||||
static int
|
||||
y_rev(Void)
|
||||
{
|
||||
if (f__recpos < f__hiwater)
|
||||
f__recpos = f__hiwater;
|
||||
if (f__curunit->url > 1)
|
||||
while(f__recpos < f__curunit->url)
|
||||
(*f__putn)(' ');
|
||||
if (f__recpos)
|
||||
f__putbuf(0);
|
||||
f__recpos = 0;
|
||||
return(0);
|
||||
}
|
||||
|
||||
static int
|
||||
y_err(Void)
|
||||
{
|
||||
err(f__elist->cierr, 110, "dfe");
|
||||
}
|
||||
|
||||
static int
|
||||
y_newrec(Void)
|
||||
{
|
||||
y_rev();
|
||||
f__hiwater = f__cursor = 0;
|
||||
return(1);
|
||||
}
|
||||
|
||||
int
|
||||
#ifdef KR_headers
|
||||
c_dfe(a) cilist *a;
|
||||
#else
|
||||
c_dfe(cilist *a)
|
||||
#endif
|
||||
{
|
||||
f__sequential=0;
|
||||
f__formatted=f__external=1;
|
||||
f__elist=a;
|
||||
f__cursor=f__scale=f__recpos=0;
|
||||
f__curunit = &f__units[a->ciunit];
|
||||
if(a->ciunit>MXUNIT || a->ciunit<0)
|
||||
err(a->cierr,101,"startchk");
|
||||
if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
|
||||
err(a->cierr,104,"dfe");
|
||||
f__cf=f__curunit->ufd;
|
||||
if(!f__curunit->ufmt) err(a->cierr,102,"dfe")
|
||||
if(!f__curunit->useek) err(a->cierr,104,"dfe")
|
||||
f__fmtbuf=a->cifmt;
|
||||
if(a->cirec <= 0)
|
||||
err(a->cierr,130,"dfe")
|
||||
FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET);
|
||||
f__curunit->uend = 0;
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_rdfe(a) cilist *a;
|
||||
#else
|
||||
integer s_rdfe(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
f__reading=1;
|
||||
if(n=c_dfe(a))return(n);
|
||||
if(f__curunit->uwrt && f__nowreading(f__curunit))
|
||||
err(a->cierr,errno,"read start");
|
||||
f__getn = y_getc;
|
||||
f__doed = rd_ed;
|
||||
f__doned = rd_ned;
|
||||
f__dorevert = f__donewrec = y_err;
|
||||
f__doend = y_rsk;
|
||||
if(pars_f(f__fmtbuf)<0)
|
||||
err(a->cierr,100,"read start");
|
||||
fmt_bg();
|
||||
return(0);
|
||||
}
|
||||
#ifdef KR_headers
|
||||
integer s_wdfe(a) cilist *a;
|
||||
#else
|
||||
integer s_wdfe(cilist *a)
|
||||
#endif
|
||||
{
|
||||
int n;
|
||||
if(!f__init) f_init();
|
||||
f__reading=0;
|
||||
if(n=c_dfe(a)) return(n);
|
||||
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
|
||||
err(a->cierr,errno,"startwrt");
|
||||
f__putn = x_putc;
|
||||
f__doed = w_ed;
|
||||
f__doned= w_ned;
|
||||
f__dorevert = y_err;
|
||||
f__donewrec = y_newrec;
|
||||
f__doend = y_rev;
|
||||
if(pars_f(f__fmtbuf)<0)
|
||||
err(a->cierr,100,"startwrt");
|
||||
fmt_bg();
|
||||
return(0);
|
||||
}
|
||||
integer e_rdfe(Void)
|
||||
{
|
||||
en_fio();
|
||||
return 0;
|
||||
}
|
||||
integer e_wdfe(Void)
|
||||
{
|
||||
return en_fio();
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
+26
@@ -0,0 +1,26 @@
|
||||
#include "f2c.h"
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#endif
|
||||
#ifdef KR_headers
|
||||
extern int (*f__lioproc)();
|
||||
|
||||
integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
|
||||
#else
|
||||
extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint);
|
||||
|
||||
integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len)
|
||||
#endif
|
||||
{
|
||||
return((*f__lioproc)(number,ptr,len,*type));
|
||||
}
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user