[GRASS-SVN] r39389 - in grass/trunk: . imagery/i.cca imagery/i.pca
imagery/i.smap include include/Make lib lib/external
lib/external/ccmath lib/gmath lib/gmath/test lib/gpde
lib/gpde/test lib/vector/Vlib raster/r.gwflow raster3d/r3.gwflow
svn_grass at osgeo.org
svn_grass at osgeo.org
Sat Oct 3 15:05:33 EDT 2009
Author: huhabla
Date: 2009-10-03 15:05:32 -0400 (Sat, 03 Oct 2009)
New Revision: 39389
Added:
grass/trunk/lib/external/ccmath/
grass/trunk/lib/external/ccmath/C01-matrix
grass/trunk/lib/external/ccmath/Makefile
grass/trunk/lib/external/ccmath/README
grass/trunk/lib/external/ccmath/atou1.c
grass/trunk/lib/external/ccmath/atovm.c
grass/trunk/lib/external/ccmath/ccmath.h
grass/trunk/lib/external/ccmath/chouse.c
grass/trunk/lib/external/ccmath/chousv.c
grass/trunk/lib/external/ccmath/cmattr.c
grass/trunk/lib/external/ccmath/cmcpy.c
grass/trunk/lib/external/ccmath/cminv.c
grass/trunk/lib/external/ccmath/cmmul.c
grass/trunk/lib/external/ccmath/cmmult.c
grass/trunk/lib/external/ccmath/cmprt.c
grass/trunk/lib/external/ccmath/csolv.c
grass/trunk/lib/external/ccmath/cvmul.c
grass/trunk/lib/external/ccmath/eigen.c
grass/trunk/lib/external/ccmath/eigval.c
grass/trunk/lib/external/ccmath/evmax.c
grass/trunk/lib/external/ccmath/hconj.c
grass/trunk/lib/external/ccmath/heigval.c
grass/trunk/lib/external/ccmath/heigvec.c
grass/trunk/lib/external/ccmath/hevmax.c
grass/trunk/lib/external/ccmath/hmgen.c
grass/trunk/lib/external/ccmath/house.c
grass/trunk/lib/external/ccmath/housev.c
grass/trunk/lib/external/ccmath/ldumat.c
grass/trunk/lib/external/ccmath/ldvmat.c
grass/trunk/lib/external/ccmath/lgpl.license
grass/trunk/lib/external/ccmath/matprt.c
grass/trunk/lib/external/ccmath/mattr.c
grass/trunk/lib/external/ccmath/mcopy.c
grass/trunk/lib/external/ccmath/minv.c
grass/trunk/lib/external/ccmath/mmul.c
grass/trunk/lib/external/ccmath/ortho.c
grass/trunk/lib/external/ccmath/otrma.c
grass/trunk/lib/external/ccmath/otrsm.c
grass/trunk/lib/external/ccmath/psinv.c
grass/trunk/lib/external/ccmath/qrbdi.c
grass/trunk/lib/external/ccmath/qrbdu1.c
grass/trunk/lib/external/ccmath/qrbdv.c
grass/trunk/lib/external/ccmath/qrecvc.c
grass/trunk/lib/external/ccmath/qreval.c
grass/trunk/lib/external/ccmath/qrevec.c
grass/trunk/lib/external/ccmath/rmmult.c
grass/trunk/lib/external/ccmath/ruinv.c
grass/trunk/lib/external/ccmath/smgen.c
grass/trunk/lib/external/ccmath/solv.c
grass/trunk/lib/external/ccmath/solv.s
grass/trunk/lib/external/ccmath/solvps.c
grass/trunk/lib/external/ccmath/solvru.c
grass/trunk/lib/external/ccmath/solvtd.c
grass/trunk/lib/external/ccmath/sv2u1v.c
grass/trunk/lib/external/ccmath/sv2uv.c
grass/trunk/lib/external/ccmath/sv2val.c
grass/trunk/lib/external/ccmath/svdu1v.c
grass/trunk/lib/external/ccmath/svduv.c
grass/trunk/lib/external/ccmath/svdval.c
grass/trunk/lib/external/ccmath/trncm.c
grass/trunk/lib/external/ccmath/trnm.c
grass/trunk/lib/external/ccmath/unfl.c
grass/trunk/lib/external/ccmath/unitary.c
grass/trunk/lib/external/ccmath/utrncm.c
grass/trunk/lib/external/ccmath/utrnhm.c
grass/trunk/lib/external/ccmath/vmul.c
grass/trunk/lib/gmath/ATLAS_wrapper_blas_level_1.c
grass/trunk/lib/gmath/blas_level_1.c
grass/trunk/lib/gmath/blas_level_2.c
grass/trunk/lib/gmath/blas_level_3.c
grass/trunk/lib/gmath/ccmath_grass_wrapper.c
grass/trunk/lib/gmath/solvers_classic_iter.c
grass/trunk/lib/gmath/solvers_direct.c
grass/trunk/lib/gmath/solvers_krylov.c
grass/trunk/lib/gmath/sparse_matrix.c
grass/trunk/lib/gmath/test/
grass/trunk/lib/gmath/test/Makefile
grass/trunk/lib/gmath/test/bench_blas2.c
grass/trunk/lib/gmath/test/bench_blas3.c
grass/trunk/lib/gmath/test/bench_solver_direct.c
grass/trunk/lib/gmath/test/bench_solver_krylov.c
grass/trunk/lib/gmath/test/test.gmath.lib.html
grass/trunk/lib/gmath/test/test_blas1.c
grass/trunk/lib/gmath/test/test_blas2.c
grass/trunk/lib/gmath/test/test_blas3.c
grass/trunk/lib/gmath/test/test_ccmath_wrapper.c
grass/trunk/lib/gmath/test/test_gmath_lib.h
grass/trunk/lib/gmath/test/test_main.c
grass/trunk/lib/gmath/test/test_solvers.c
grass/trunk/lib/gmath/test/test_tools.c
grass/trunk/lib/gmath/test/test_tools_les.c
Removed:
grass/trunk/lib/gmath/eigen.c
grass/trunk/lib/gmath/jacobi.c
grass/trunk/lib/gmath/svd.c
grass/trunk/lib/gpde/N_les_pivot.c
grass/trunk/lib/gpde/N_solvers.c
grass/trunk/lib/gpde/N_solvers_classic_iter.c
grass/trunk/lib/gpde/N_solvers_krylov.c
grass/trunk/lib/gpde/solvers_local_proto.h
grass/trunk/lib/gpde/test/test_solvers.c
Modified:
grass/trunk/
grass/trunk/imagery/i.cca/local_proto.h
grass/trunk/imagery/i.cca/main.c
grass/trunk/imagery/i.cca/matrix.c
grass/trunk/imagery/i.cca/stats.c
grass/trunk/imagery/i.cca/transform.c
grass/trunk/imagery/i.pca/main.c
grass/trunk/imagery/i.smap/model.c
grass/trunk/include/Make/
grass/trunk/include/Make/Grass.make
grass/trunk/include/gmath.h
grass/trunk/lib/Makefile
grass/trunk/lib/external/Makefile
grass/trunk/lib/gmath/TODO
grass/trunk/lib/gmath/del2g.c
grass/trunk/lib/gmath/eigen_tools.c
grass/trunk/lib/gmath/la.c
grass/trunk/lib/gmath/mult.c
grass/trunk/lib/gpde/N_arrays.c
grass/trunk/lib/gpde/N_gradient_calc.c
grass/trunk/lib/gpde/N_heatflow.h
grass/trunk/lib/gpde/N_les.c
grass/trunk/lib/gpde/N_les_assemble.c
grass/trunk/lib/gpde/N_parse_options.c
grass/trunk/lib/gpde/N_pde.h
grass/trunk/lib/gpde/test/Makefile
grass/trunk/lib/gpde/test/test_arrays.c
grass/trunk/lib/gpde/test/test_assemble.c
grass/trunk/lib/gpde/test/test_geom.c
grass/trunk/lib/gpde/test/test_gpde_lib.h
grass/trunk/lib/gpde/test/test_gradient.c
grass/trunk/lib/gpde/test/test_gwflow.c
grass/trunk/lib/gpde/test/test_les.c
grass/trunk/lib/gpde/test/test_main.c
grass/trunk/lib/gpde/test/test_solute_transport.c
grass/trunk/lib/gpde/test/test_tools.c
grass/trunk/lib/vector/Vlib/
grass/trunk/raster/r.gwflow/Makefile
grass/trunk/raster/r.gwflow/main.c
grass/trunk/raster/r.gwflow/valid_calc_7x7.sh
grass/trunk/raster/r.gwflow/valid_calc_excavation.sh
grass/trunk/raster3d/r3.gwflow/Makefile
grass/trunk/raster3d/r3.gwflow/main.c
Log:
Added a new library to grass called ccmath (LGPL license) to replace the
NR algorithms of the gmath library.
Moved the linear equation solver code from gpde lib to gmath lib.
Added blas level 1, 2 and 3 algorithm in gmath lib.
Modified the gmath solver to use the grass blas implementation.
Added wrapper for ATLAS blas level 1 algorithms.
Updated the gpde library tests.
Added gmath library tests for the numerical part and ccmath wrapper.
Modified the groundwater flow modules (raster, raster3d)to use the gmath
solver.
Patched i.cca, i.pca and i.smap to use gmath vecotr and matrix functions
and the ccmath wrapper for eigen value computation.
Removed NR svd and eigen value code.
Property changes on: grass/trunk
___________________________________________________________________
Modified: svn:ignore
- grass.pc
config.status*
dist.*
config.log
error.log
bin.*
autom4te.cache
+ autom4te.cache
dist.*
bin.*
config.log
Makefile-grass_trunk.mk
error.log
grass.pc
config.status*
Modified: grass/trunk/imagery/i.cca/local_proto.h
===================================================================
--- grass/trunk/imagery/i.cca/local_proto.h 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.cca/local_proto.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -3,22 +3,19 @@
#include <grass/raster.h>
-#define MX 9
-#define MC 50
-
/* matrix.c */
-int product(double[MX], double, double[MX][MX], int);
-int setdiag(double[MX], int, double[MX][MX]);
-int getsqrt(double[MX][MX], int, double[MX][MX], double[MX][MX]);
-int solveq(double[MX][MX], int, double[MX][MX], double[MX][MX]);
-int matmul(double[MX][MX], double[MX][MX], double[MX][MX], int);
+int product(double*, double, double**, int);
+int setdiag(double*, int, double**);
+int getsqrt(double**, int, double**, double**);
+int solveq(double**, int, double**, double**);
+int print_matrix(double **matrix, int bands);
/* stats.c */
-int within(int, int, double[MC], double[MC][MX][MX], double[MX][MX], int);
-int between(int, int, double[MC], double[MC][MX], double[MX][MX], int);
+int within(int, int, double*, double***, double**, int);
+int between(int, int, double*, double**, double**, int);
/* transform.c */
-int transform(int[MX], int[MX], int, int, double[MX][MX], int, CELL[MX],
- CELL[MX]);
+int transform(int*, int*, int, int, double**, int, CELL*,
+ CELL*);
#endif /* __LOCAL_PROTO_H__ */
Modified: grass/trunk/imagery/i.cca/main.c
===================================================================
--- grass/trunk/imagery/i.cca/main.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.cca/main.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -53,26 +53,26 @@
int bands; /* Number of image bands */
int nclass; /* Number of classes */
int samptot; /* Total number of sample points */
- double mu[MC][MX]; /* Mean vector for image classes */
- double w[MX][MX]; /* Within Class Covariance Matrix */
- double p[MX][MX]; /* Between class Covariance Matrix */
- double l[MX][MX]; /* Diagonal matrix of eigenvalues */
- double q[MX][MX]; /* Transformation matrix */
- double cov[MC][MX][MX]; /* Individual class Covariance Matrix */
- double nsamp[MC]; /* Number of samples in a given class */
- double eigval[MX]; /* Eigen value vector */
- double eigmat[MX][MX]; /* Eigen Matrix */
- char tempname[50];
+ double **mu; /* Mean vector for image classes */
+ double **w; /* Within Class Covariance Matrix */
+ double **p; /* Between class Covariance Matrix */
+ double **l; /* Diagonal matrix of eigenvalues */
+ double **q; /* Transformation matrix */
+ double ***cov; /* Individual class Covariance Matrix */
+ double *nsamp; /* Number of samples in a given class */
+ double *eigval; /* Eigen value vector */
+ double **eigmat; /* Eigen Matrix */
+ char tempname[1024];
/* used to make the color tables */
- CELL outbandmax[MX]; /* will hold the maximums found in the out maps */
- CELL outbandmin[MX]; /* will hold the minimums found in the out maps */
+ CELL *outbandmax; /* will hold the maximums found in the out maps */
+ CELL *outbandmin; /* will hold the minimums found in the out maps */
struct Colors color_tbl;
struct Signature sigs;
FILE *sigfp;
struct Ref refs;
- int datafds[MX];
- int outfds[MX];
+ int *datafds;
+ int *outfds;
struct GModule *module;
struct Option *grp_opt, *subgrp_opt, *sig_opt, *out_opt;
@@ -129,10 +129,29 @@
/* check the number of input bands */
bands = refs.nfiles;
- if (bands > MX - 1)
- G_fatal_error(_("Subgroup too large. Maximum number of bands is %d\n."),
- MX - 1);
+ /*memory allocation*/
+ mu = G_alloc_matrix(nclass, bands);
+ w = G_alloc_matrix(bands, bands);
+ p = G_alloc_matrix(bands, bands);
+ l = G_alloc_matrix(bands, bands);
+ q = G_alloc_matrix(bands, bands);
+ eigmat = G_alloc_matrix(bands, bands);
+ nsamp = G_alloc_vector(nclass);
+ eigval = G_alloc_vector(bands);
+
+ cov = (double***)G_calloc(nclass, sizeof(double**));
+ for(i = 0; i < nclass; i++)
+ {
+ cov[i] = G_alloc_matrix(bands,bands);
+ }
+
+ outbandmax = (CELL*)G_calloc(nclass, sizeof(CELL));
+ outbandmin = (CELL*)G_calloc(nclass, sizeof(CELL));
+ datafds = (int*)G_calloc(nclass, sizeof(int));
+ outfds = (int*)G_calloc(nclass, sizeof(int));
+
+
/*
Here is where the information regarding
a) Number of samples per class
@@ -154,15 +173,27 @@
within(samptot, nclass, nsamp, cov, w, bands);
between(samptot, nclass, nsamp, mu, p, bands);
- jacobi(w, (long)bands, eigval, eigmat);
- egvorder(eigval, eigmat, (long)bands);
+ G_math_d_copy(w[0], eigmat[0], bands*bands);
+ G_math_eigen(eigmat, eigval, bands);
+ G_math_egvorder(eigval, eigmat, bands);
setdiag(eigval, bands, l);
getsqrt(w, bands, l, eigmat);
solveq(q, bands, w, p);
- jacobi(q, (long)bands, eigval, eigmat);
- egvorder(eigval, eigmat, (long)bands);
- matmul(q, eigmat, w, bands);
+ G_math_d_copy(q[0], eigmat[0], bands*bands);
+ G_math_eigen(eigmat, eigval, bands);
+ G_math_egvorder(eigval, eigmat, bands);
+ G_math_d_AB(eigmat, w, q, bands, bands, bands);
+ for(i = 0; i < bands; i++)
+ {
+ G_verbose_message("%i. eigen value: %+6.5f", i, eigval[i]);
+ G_verbose_message("eigen vector:");
+ for(j = 0; j < bands; j++)
+ G_verbose_message("%+6.5f ", eigmat[i][j]);
+
+ }
+
+
/* open the cell maps */
for (i = 1; i <= bands; i++) {
outbandmax[i] = (CELL) 0;
@@ -205,6 +236,25 @@
I_free_signatures(&sigs);
I_free_group_ref(&refs);
+
+ /*free memory*/
+ G_free_matrix(mu);
+ G_free_matrix(w);
+ G_free_matrix(p);
+ G_free_matrix(l);
+ G_free_matrix(q);
+ G_free_matrix(eigmat);
+ for(i = 0; i < nclass; i++)
+ G_free_matrix(cov[i]);
+ G_free(cov);
+ G_free_vector(nsamp);
+ G_free_vector(eigval);
+
+ G_free(outbandmax);
+ G_free(outbandmin);
+ G_free(datafds);
+ G_free(outfds);
+
exit(EXIT_SUCCESS);
}
Modified: grass/trunk/imagery/i.cca/matrix.c
===================================================================
--- grass/trunk/imagery/i.cca/matrix.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.cca/matrix.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -4,25 +4,39 @@
#include "local_proto.h"
-int product(double vector[MX], double factor, double matrix1[MX][MX],
+int print_matrix(double **matrix, int bands)
+{
+ int i, j;
+
+ for (i = 0; i < bands; i++)
+ {
+ for (j = 0; j < bands; j++) {
+ printf("%g ", matrix[i][j]);
+ }
+ printf("\n");
+ }
+ return 0;
+}
+
+int product(double *vector, double factor, double **matrix1,
int bands)
{
int i, j;
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++) {
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++) {
matrix1[i][j] = (double)factor *(vector[i] * vector[j]);
}
return 0;
}
-int setdiag(double eigval[MX], int bands, double l[MX][MX])
+int setdiag(double *eigval, int bands, double **l)
{
int i, j;
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++)
if (i == j)
l[i][j] = eigval[i];
else
@@ -32,43 +46,37 @@
int
-getsqrt(double w[MX][MX], int bands, double l[MX][MX], double eigmat[MX][MX])
+getsqrt(double **w, int bands, double **l, double **eigmat)
{
int i;
- double tmp[MX][MX];
+ double **tmp;
- for (i = 1; i <= bands; i++)
+ tmp = G_alloc_matrix(bands, bands);
+
+ for (i = 0; i < bands; i++)
l[i][i] = 1.0 / sqrt(l[i][i]);
- matmul(tmp, eigmat, l, bands);
- transpose(eigmat, bands);
- matmul(w, tmp, eigmat, bands);
- return 0;
-}
+ G_math_d_AB(eigmat, l, tmp, bands, bands, bands);
+ G_math_d_A_T(eigmat, bands);
+ G_math_d_AB(tmp, eigmat, w, bands, bands, bands);
-int solveq(double q[MX][MX], int bands, double w[MX][MX], double p[MX][MX])
-{
- double tmp[MX][MX];
+ G_free_matrix(tmp);
- matmul(tmp, w, p, bands);
- matmul(q, tmp, w, bands);
return 0;
}
-int matmul(double res[MX][MX], double m1[MX][MX], double m2[MX][MX], int dim)
+int solveq(double **q, int bands, double **w, double **p)
{
- int i, j, k;
- double sum;
+ double **tmp;
- for (i = 1; i <= dim; i++) {
- for (j = 1; j <= dim; j++) {
- sum = 0.0;
- for (k = 1; k <= dim; k++)
- sum += m1[i][k] * m2[k][j];
- res[i][j] = sum;
- }
- }
+ tmp = G_alloc_matrix(bands, bands);
+ G_math_d_AB(w, p, tmp, bands, bands, bands);
+ G_math_d_AB(tmp, w, q, bands, bands, bands);
+
+ G_free_matrix(tmp);
+
return 0;
}
+
Modified: grass/trunk/imagery/i.cca/stats.c
===================================================================
--- grass/trunk/imagery/i.cca/stats.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.cca/stats.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,25 +1,26 @@
#include <grass/gis.h>
+#include <grass/gmath.h>
+
#include "local_proto.h"
-
int
-within(int samptot, int nclass, double nsamp[MC], double cov[MC][MX][MX],
- double w[MX][MX], int bands)
+within(int samptot, int nclass, double *nsamp, double ***cov,
+ double **w, int bands)
{
int i, j, k;
/* Initialize within class covariance matrix */
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++)
w[i][j] = 0.0;
- for (i = 1; i <= nclass; i++)
- for (j = 1; j <= bands; j++)
- for (k = 1; k <= bands; k++)
+ for (i = 0; i < nclass; i++)
+ for (j = 0; j < bands; j++)
+ for (k = 0; k < bands; k++)
w[j][k] += (nsamp[i] - 1) * cov[i][j][k];
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++)
w[i][j] = (1.0 / ((double)(samptot - nclass))) * w[i][j];
return 0;
@@ -27,50 +28,41 @@
int
-between(int samptot, int nclass, double nsamp[MC], double mu[MC][MX],
- double p[MX][MX], int bands)
+between(int samptot, int nclass, double *nsamp, double **mu,
+ double **p, int bands)
{
int i, j, k;
- double tmp0[MX][MX], tmp1[MX][MX], tmp2[MX][MX];
- double newvec[MX];
+ double **tmp0, **tmp1, **tmp2;
+ double *newvec;
- for (i = 0; i < MX; i++)
- newvec[i] = 0.0;
+ tmp0 = G_alloc_matrix(bands, bands);
+ tmp1 = G_alloc_matrix(bands, bands);
+ tmp2 = G_alloc_matrix(bands, bands);
+ newvec = G_alloc_vector(bands);
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
- tmp1[i][j] = tmp2[i][j] = 0.0;
-
- /* for (i = 1 ; i <= nclass ; i++)
- product(mu[i],nsamp[i],tmp0,tmp1,bands);
- for (i = 1 ; i <= nclass ; i++)
- for (j = 1 ; j <= bands ; j++)
- newvec[j] += nsamp[i] * mu[i][j];
- for (i = 1 ; i <= bands ; i++)
- for (j = 1 ; i <= bands ; j++)
- tmp2[i][j] = (newvec[i] * newvec[j]) / samptot;
- for (i = 1 ; i <= bands ; i++)
- for (j = 1 ; j <= bands ; j++)
- p[i][j] = (tmp1[i][j] - tmp2[i][j]) / (nclass - 1);
- */
-
- for (i = 1; i <= nclass; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < nclass; i++)
+ for (j = 0; j < bands; j++)
newvec[j] += nsamp[i] * mu[i][j];
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++)
tmp1[i][j] = (newvec[i] * newvec[j]) / samptot;
- for (k = 1; k <= nclass; k++) {
+ for (k = 0; k < nclass; k++) {
product(mu[k], nsamp[k], tmp0, bands);
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++)
tmp2[i][j] += tmp0[i][j] - tmp1[i][j];
}
- for (i = 1; i <= bands; i++)
- for (j = 1; j <= bands; j++)
+ for (i = 0; i < bands; i++)
+ for (j = 0; j < bands; j++)
p[i][j] = tmp2[i][j] / (nclass - 1);
+ G_free_matrix(tmp0);
+ G_free_matrix(tmp1);
+ G_free_matrix(tmp2);
+ G_free_vector(newvec);
+
return 0;
}
+
Modified: grass/trunk/imagery/i.cca/transform.c
===================================================================
--- grass/trunk/imagery/i.cca/transform.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.cca/transform.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,38 +1,43 @@
#include <stdlib.h>
+
#include <grass/gis.h>
-#include <grass/raster.h>
+#include <grass/gmath.h>
#include <grass/glocale.h>
+
#include "local_proto.h"
-
int
-transform(int datafds[MX], int outfds[MX], int rows, int cols,
- double eigmat[MX][MX], int bands, CELL mins[MX], CELL maxs[MX])
+transform(int *datafds, int *outfds, int rows, int cols,
+ double **eigmat, int bands, CELL *mins, CELL *maxs)
{
int i, j, k, l;
- double sum[MX];
- CELL *rowbufs[MX];
+ double *sum;
+ CELL **rowbufs;
+ sum = G_alloc_vector(bands);
+ rowbufs = (CELL**)G_calloc(bands, sizeof(CELL*));
+
+
/* allocate row buffers for each band */
- for (i = 1; i <= bands; i++)
+ for (i = 0; i < bands; i++)
if ((rowbufs[i] = Rast_allocate_c_buf()) == NULL)
G_fatal_error(_("Unable to allocate cell buffers."));
for (i = 0; i < rows; i++) {
/* get one row of data */
- for (j = 1; j <= bands; j++)
+ for (j = 0; j < bands; j++)
if (Rast_get_c_row(datafds[j], rowbufs[j], i) < 0)
G_fatal_error(_("Error reading cell map during transform."));
/* transform each cell in the row */
for (l = 0; l < cols; l++) {
- for (j = 1; j <= bands; j++) {
+ for (j = 0; j < bands; j++) {
sum[j] = 0.0;
- for (k = 1; k <= bands; k++) {
+ for (k = 0; k < bands; k++) {
sum[j] += eigmat[j][k] * (double)rowbufs[k][l];
}
}
- for (j = 1; j <= bands; j++) {
+ for (j = 0; j < bands; j++) {
rowbufs[j][l] = (CELL) (sum[j] + 0.5);
if (rowbufs[j][l] > maxs[j])
maxs[j] = rowbufs[j][l];
@@ -42,13 +47,16 @@
}
/* output the row of data */
- for (j = 1; j <= bands; j++)
+ for (j = 0; j < bands; j++)
if (Rast_put_row(outfds[j], rowbufs[j], CELL_TYPE) < 0)
G_fatal_error(_("Error writing cell map during transform."));
}
- for (i = 1; i <= bands; i++)
+ for (i = 0; i < bands; i++)
G_free(rowbufs[i]);
+ G_free(rowbufs);
+ G_free_vector(sum);
+
G_message(_("Transform completed.\n"));
return 0;
Modified: grass/trunk/imagery/i.pca/main.c
===================================================================
--- grass/trunk/imagery/i.pca/main.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.pca/main.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -104,22 +104,12 @@
set_output_scale(opt_scale, &scale, &scale_min, &scale_max);
/* allocate memory */
- covar = (double **)G_calloc(bands, sizeof(double *));
- mu = (double *)G_malloc(bands * sizeof(double));
- inp_fd = (int *)G_malloc(bands * sizeof(int));
- eigmat = (double **)G_calloc(bands, sizeof(double *));
- eigval = (double *)G_calloc(bands, sizeof(double));
+ covar = G_alloc_matrix(bands, bands);
+ mu = G_alloc_vector(bands);
+ inp_fd = G_alloc_ivector(bands);
+ eigmat = G_alloc_matrix(bands, bands);
+ eigval = G_alloc_vector(bands);
- /* allocate memory for matrices */
- for (i = 0; i < bands; i++) {
- covar[i] = (double *)G_malloc(bands * sizeof(double));
- eigmat[i] = (double *)G_calloc(bands, sizeof(double));
-
- /* initialize covariance matrix */
- for (j = 0; j < bands; j++)
- covar[i][j] = 0.;
- }
-
/* open and check input/output files */
for (i = 0; i < bands; i++) {
char tmpbuf[128];
@@ -146,8 +136,9 @@
}
}
+ G_math_d_copy(covar[0], eigmat[0], bands*bands);
G_debug(1, "Calculating eigenvalues and eigenvectors...");
- eigen(covar, eigmat, eigval, bands);
+ G_math_eigen(eigmat, eigval, bands);
#ifdef PCA_DEBUG
/* dump eigen matrix and eigen values */
@@ -155,10 +146,10 @@
#endif
G_debug(1, "Ordering eigenvalues in descending order...");
- egvorder2(eigval, eigmat, bands);
+ G_math_egvorder(eigval, eigmat, bands);
G_debug(1, "Transposing eigen matrix...");
- transpose2(eigmat, bands);
+ G_math_d_A_T(eigmat, bands);
/* write output images */
write_pca(eigmat, inp_fd, opt_out->answer, bands, scale, scale_min,
@@ -176,6 +167,13 @@
/* close output file */
Rast_unopen(inp_fd[i]);
}
+
+ /* free memory */
+ G_free_matrix(covar);
+ G_free_vector(mu);
+ G_free_ivector(inp_fd);
+ G_free_matrix(eigmat);
+ G_free_vector(eigval);
exit(EXIT_SUCCESS);
}
Modified: grass/trunk/imagery/i.smap/model.c
===================================================================
--- grass/trunk/imagery/i.smap/model.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/imagery/i.smap/model.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -16,13 +16,16 @@
int b1, b2;
int nbands;
double *lambda;
+ double **tmp_mat;
struct ClassSig *C;
struct SubSig *SubS;
nbands = S->nbands;
/* allocate scratch memory */
- lambda = (double *)G_malloc(nbands * sizeof(double));
+ lambda = G_alloc_vector(nbands);
+ tmp_mat = G_alloc_matrix(nbands, nbands);
+
/* invert matrix and compute constant for each subclass */
/* for each class */
@@ -41,10 +44,12 @@
m + 1, i + 1);
SubS->Rinv[b1][b2] = SubS->R[b1][b2];
+ tmp_mat[b1][b2] = SubS->R[b1][b2];
+
}
/* Test for positive definite matrix */
- eigen(SubS->Rinv, NULL, lambda, nbands);
+ G_math_eigen(tmp_mat, lambda, nbands);
for (b1 = 0; b1 < nbands; b1++) {
if (lambda[b1] <= 0.0)
G_warning(_("Nonpositive eigenvalues for class %d subclass %d"),
@@ -61,7 +66,8 @@
invert(SubS->Rinv, nbands);
}
}
- G_free((char *)lambda);
+ G_free_vector(lambda);
+ G_free_matrix(tmp_mat);
}
Property changes on: grass/trunk/include/Make
___________________________________________________________________
Modified: svn:ignore
- Platform.make
+ Platform.make
.Grass.make.swp
Modified: grass/trunk/include/Make/Grass.make
===================================================================
--- grass/trunk/include/Make/Grass.make 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/include/Make/Grass.make 2009-10-03 19:05:32 UTC (rev 39389)
@@ -115,6 +115,7 @@
BTREE:btree \
CAIRODRIVER:cairodriver \
CDHC:cdhc \
+ CCMATH:ccmath \
CLUSTER:cluster \
COORCNV:coorcnv \
DATETIME:datetime \
@@ -194,7 +195,7 @@
FORMDEPS = $(DBMILIB) $(GISLIB)
G3DDEPS = $(RASTERLIB) $(GISLIB) $(XDRLIB)
GISDEPS = $(DATETIMELIB) $(ZLIBLIBPATH) $(ZLIB) $(INTLLIB) $(PTHREADLIBPATH) $(PTHREADLIB) $(MATHLIB)
-GMATHDEPS = $(GISLIB) $(FFTWLIB) $(LAPACKLIB) $(BLASLIB)
+GMATHDEPS = $(GISLIB) $(FFTWLIB) $(LAPACKLIB) $(BLASLIB) $(CCMATHLIB)
GPDEDEPS = $(G3DLIB) $(RASTERLIB) $(GISLIB) $(MATHLIB)
GPROJDEPS = $(GISLIB) $(GDALLIBS) $(PROJLIB) $(MATHLIB)
HTMLDRIVERDEPS = $(DRIVERLIB) $(GISLIB) $(MATHLIB)
Modified: grass/trunk/include/gmath.h
===================================================================
--- grass/trunk/include/gmath.h 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/include/gmath.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,11 +1,10 @@
-
/******************************************************************************
* gmath.h
* Top level header file for gmath units
* @Copyright David D.Gray <ddgray at armadce.demon.co.uk>
* 27th. Sep. 2000
- * Last updated: 2007-08-26
+ * Last updated: $Id$
*
* This file is part of GRASS GIS. It is free software. You can
@@ -31,71 +30,194 @@
#endif
#include <stddef.h>
+/*solver names */
+#define G_MATH_SOLVER_DIRECT_GAUSS "gauss"
+#define G_MATH_SOLVER_DIRECT_LU "lu"
+#define G_MATH_SOLVER_DIRECT_CHOLESKY "cholesky"
+#define G_MATH_SOLVER_ITERATIVE_JACOBI "jacobi"
+#define G_MATH_SOLVER_ITERATIVE_SOR "sor"
+#define G_MATH_SOLVER_ITERATIVE_CG "cg"
+#define G_MATH_SOLVER_ITERATIVE_PCG "pcg"
+#define G_MATH_SOLVER_ITERATIVE_BICGSTAB "bicgstab"
+
+/*preconditioner */
+#define G_MATH_DIAGONAL_PRECONDITION 1
+#define G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION 2
+#define G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION 3
+#define G_MATH_ROWSCALE_MAXNORM_PRECONDITION 4
+
+/* dalloc.c */
+double *G_alloc_vector(size_t);
+double **G_alloc_matrix(int, int);
+float *G_alloc_fvector(size_t);
+float **G_alloc_fmatrix(int, int);
+void G_free_vector(double *);
+void G_free_matrix(double **);
+void G_free_fvector(float *);
+void G_free_fmatrix(float **);
+
+/* ialloc.c */
+int *G_alloc_ivector(size_t);
+int **G_alloc_imatrix(int, int);
+void G_free_ivector(int *);
+void G_free_imatrix(int **);
+
/* fft.c */
-int fft(int, double *[2], int, int, int);
-int fft2(int, double (*)[2], int, int, int);
+extern int fft(int, double *[2], int, int, int);
+extern int fft2(int, double (*)[2], int, int, int);
/* gauss.c */
-double G_math_rand_gauss(int, double);
+extern double G_math_rand_gauss(int, double);
/* max_pow2.c */
-long G_math_max_pow2(long);
-long G_math_min_pow2(long);
+extern long G_math_max_pow2 (long n);
+extern long G_math_min_pow2 (long n);
/* rand1.c */
-float G_math_rand(int);
+extern float G_math_rand(int);
/* del2g.c */
-int del2g(double *[2], int, double);
+extern int del2g(double *[2], int, double);
+/* getg.c */
+extern int getg(double, double *[2], int);
+
+/* eigen_tools.c */
+extern int G_math_egvorder(double *, double **, long);
+
+/* mult.c */
+extern int G_math_complex_mult (double *v1[2], int size1, double *v2[2], int size2, double *v3[2], int size3);
+
+/* lu.c*/
+extern int G_ludcmp(double **, int, int *, double *);
+extern void G_lubksb(double **a, int n, int *indx, double b[]);
+
/* findzc.c */
-int G_math_findzc(double[], int, double[], double, int);
+extern int G_math_findzc(double conv[], int size, double zc[], double thresh, int num_orients);
-/* getg.c */
-int getg(double, double *[2], int);
-/* eigen.c */
-int eigen(double **, double **, double *, int);
-int egvorder2(double *, double **, long);
-int transpose2(double **, long);
+/* *************************************************************** */
+/* ***** WRAPPER FOR CCMATH FUNCTIONS USED IN GRASS ************** */
+/* *************************************************************** */
+extern int G_math_solv(double **,double *,int);
+extern int G_math_solvps(double **,double *,int);
+extern void G_math_solvtd(double *,double *,double *,double *,int);
+extern int G_math_solvru(double **,double *,int);
+extern int G_math_minv(double **,int);
+extern int G_math_psinv(double **,int);
+extern int G_math_ruinv(double **,int);
+extern void G_math_eigval(double **,double *,int);
+extern void G_math_eigen(double **,double *,int);
+extern double G_math_evmax(double **,double *,int);
+extern int G_math_svdval(double *,double **,int,int);
+extern int G_math_sv2val(double *,double **,int,int);
+extern int G_math_svduv(double *,double **,double **, int,double **,int);
+extern int G_math_sv2uv(double *,double **,double **,int,double **,int);
+extern int G_math_svdu1v(double *,double **,int,double **,int);
-/* jacobi.c */
-#define MX 9
-int jacobi(double[MX][MX], long, double[MX], double[MX][MX]);
-int egvorder(double[MX], double[MX][MX], long);
-int transpose(double[MX][MX], long);
-/* mult.c */
-int mult(double *v1[2], int size1, double *v2[2], int size2, double *v3[2],
- int size3);
+/* *************************************************************** */
+/* *************** LINEARE EQUATION SYSTEM PART ****************** */
+/* *************************************************************** */
-/* dalloc.c */
-double *G_alloc_vector(size_t);
-double **G_alloc_matrix(int, int);
-float *G_alloc_fvector(size_t);
-float **G_alloc_fmatrix(int, int);
-void G_free_vector(double *);
-void G_free_matrix(double **);
-void G_free_fvector(float *);
-void G_free_fmatrix(float **);
+/*!
+ * \brief The row vector of the sparse matrix
+ * */
+typedef struct
+{
+ double *values; /*The non null values of the row */
+ unsigned int cols; /*Number of entries */
+ unsigned int *index; /*the index number */
+} G_math_spvector;
-/* eigen_tools.c */
-int G_tqli(double[], double[], int, double **);
-void G_tred2(double **, int, double[], double[]);
+/* Sparse matrix and sparse vector functions
+ * */
+extern G_math_spvector *G_math_alloc_spvector(int );
+extern G_math_spvector **G_math_alloc_spmatrix(int );
+extern void G_math_free_spmatrix(G_math_spvector ** , int );
+extern void G_math_free_spvector(G_math_spvector * );
+extern int G_math_add_spvector(G_math_spvector **, G_math_spvector * , int );
-/* ialloc.c */
-int *G_alloc_ivector(size_t);
-int **G_alloc_imatrix(int, int);
-void G_free_ivector(int *);
-void G_free_imatrix(int **);
+/*linear equation solver, most of them are multithreaded wih OpenMP*/
+extern int G_math_solver_gauss(double **, double *, double *, int );
+extern int G_math_solver_lu(double **, double *, double *, int );
+extern int G_math_solver_cholesky(double **, double *, double *, int , int );
+extern int G_math_solver_jacobi(double **, double *, double *, int , int , double , double );
+extern int G_math_solver_gs(double **, double *, double *, int , int , double , double );
+extern int G_math_solver_pcg(double **, double *, double *, int , int , double , int );
+extern int G_math_solver_cg(double **, double *, double *, int , int , double );
+extern int G_math_solver_bicgstab(double **, double *, double *, int , int , double );
+extern int G_math_solver_sparse_jacobi(G_math_spvector **, double *, double *, int , int , double , double );
+extern int G_math_solver_sparse_gs(G_math_spvector **, double *, double *, int , int , double , double );
+extern int G_math_solver_sparse_pcg(G_math_spvector **, double *, double *, int , int , double , int );
+extern int G_math_solver_sparse_cg(G_math_spvector **, double *, double *, int , int , double );
+extern int G_math_solver_sparse_bicgstab(G_math_spvector **, double *, double *, int , int , double );
+/* solver algoithms and helper functions*/
+extern void G_math_gauss_elimination(double **, double *, int );
+extern void G_math_lu_decomposition(double **, double *, int );
+extern int G_math_cholesky_decomposition(double **, int , int );
+extern void G_math_backward_solving(double **, double *, double *, int );
+extern void G_math_forward_solving(double **, double *, double *, int );
+extern int G_math_pivot_create(double **, double *, int , int );
-/* lu.c */
-int G_ludcmp(double **, int, int *, double *);
-void G_lubksb(double **, int, int *, double[]);
-/* svd.c */
-int G_svdcmp(double **, int, int, double *, double **);
-int G_svbksb(double **, double[], double **, int, int, double[], double[]);
-int G_svelim(double *, int);
+/*BLAS like level 1,2 and 3 functions*/
+/*level 1 vector - vector grass implementation with OpenMP thread support*/
+extern void G_math_d_x_dot_y(double *, double *, double *, int );
+extern void G_math_d_asum_norm(double *, double *, int );
+extern void G_math_d_euclid_norm(double *, double *, int );
+extern void G_math_d_max_norm(double *, double *, int );
+extern void G_math_d_ax_by(double *, double *, double *, double , double , int );
+extern void G_math_d_copy(double *, double *, int );
+
+extern void G_math_f_x_dot_y(float *, float *, float *, int );
+extern void G_math_f_asum_norm(float *, float *, int );
+extern void G_math_f_euclid_norm(float *, float *, int );
+extern void G_math_f_max_norm(float *, float *, int );
+extern void G_math_f_ax_by(float *, float *, float *, float , float , int );
+extern void G_math_f_copy(float *, float *, int );
+
+extern void G_math_i_x_dot_y(int *, int *, double *, int );
+extern void G_math_i_asum_norm(int *, double *, int );
+extern void G_math_i_euclid_norm(int *, double *,int );
+extern void G_math_i_max_norm(int *, int *, int );
+extern void G_math_i_ax_by(int *, int *, int *, int , int , int );
+extern void G_math_i_copy(int *, int *, int );
+
+/*ATLAS blas level 1 wrapper*/
+extern double G_math_ddot(double *, double *, int );
+extern float G_math_sdot(float *, float *, int );
+extern float G_math_sdsdot(float *, float *, float , int );
+extern double G_math_dnrm2(double *, int );
+extern double G_math_dasum(double *, int );
+extern double G_math_idamax(double *, int );
+extern float G_math_snrm2(float *, int );
+extern float G_math_sasum(float *, int );
+extern float G_math_isamax(float *, int );
+extern void G_math_dscal(double *, double , int );
+extern void G_math_sscal(float *, float , int );
+extern void G_math_dcopy(double *, double *, int );
+extern void G_math_scopy(float *, float *, int );
+extern void G_math_daxpy(double *, double *, double , int );
+extern void G_math_saxpy(float *, float *, float , int );
+
+/*level 2 matrix - vector grass implementation with OpenMP thread support*/
+extern void G_math_Ax_sparse(G_math_spvector **, double *, double *, int );
+extern void G_math_d_Ax(double **, double *, double *, int , int );
+extern void G_math_f_Ax(float **, float *, float *, int , int );
+extern void G_math_d_x_dyad_y(double *, double *, double **, int, int );
+extern void G_math_f_x_dyad_y(float *, float *, float **, int, int );
+extern void G_math_d_aAx_by(double **, double *, double *, double , double , double *, int , int );
+extern void G_math_f_aAx_by(float **, float *, float *, float , float , float *, int , int );
+extern int G_math_d_A_T(double **A, int rows);
+extern int G_math_f_A_T(float **A, int rows);
+
+/*level 3 matrix - matrix grass implementation with OpenMP thread support*/
+extern void G_math_d_aA_B(double **, double **, double , double **, int , int );
+extern void G_math_f_aA_B(float **, float **, float , float **, int , int );
+extern void G_math_d_AB(double **, double **, double **, int , int , int );
+extern void G_math_f_AB(float **, float **, float **, int , int , int );
+
#endif /* GMATH_H_ */
+
Modified: grass/trunk/lib/Makefile
===================================================================
--- grass/trunk/lib/Makefile 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -7,6 +7,7 @@
datetime \
gis \
raster \
+ external \
gmath \
linkm \
driver \
@@ -18,7 +19,6 @@
btree \
display \
db \
- external \
fonts \
gtcltk \
form \
Modified: grass/trunk/lib/external/Makefile
===================================================================
--- grass/trunk/lib/external/Makefile 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/external/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -3,6 +3,7 @@
SUBDIRS = \
bwidget \
+ ccmath \
shapelib
include $(MODULE_TOPDIR)/include/Make/Dir.make
Added: grass/trunk/lib/external/ccmath/C01-matrix
===================================================================
--- grass/trunk/lib/external/ccmath/C01-matrix (rev 0)
+++ grass/trunk/lib/external/ccmath/C01-matrix 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,1280 @@
+ Chapter 1
+
+ LINEAR ALGEBRA
+
+ Summary
+
+ The matrix algebra library contains functions that
+ perform the standard computations of linear algebra.
+ General areas covered are:
+
+ o Solution of Linear Systems
+ o Matrix Inversion
+ o Eigensystem Analysis
+ o Matrix Utility Operations
+ o Singular Value Decomposition
+
+ The operations covered here are fundamental to many
+ areas of mathematics and statistics. Thus, functions
+ in this library segment are called by other library
+ functions. Both real and complex valued matrices
+ are covered by functions in the first four of these
+ categories.
+
+
+ Notes on Contents
+
+ Functions in this library segment provide the basic operations of
+ numerical linear algebra and some useful utility functions for operations on
+ vectors and matrices. The following list describes the functions available for
+ operations with real-valued matrices.
+
+
+ o Solving and Inverting Linear Systems:
+
+ solv --------- solve a general system of real linear equations.
+ solvps ------- solve a real symmetric linear system.
+ solvru ------- solve a real right upper triangular linear system.
+ solvtd ------- solve a tridiagonal real linear system.
+
+ minv --------- invert a general real square matrix.
+ psinv -------- invert a real symmetric matrix.
+ ruinv -------- invert a right upper triangular matrix.
+
+
+ The solution of a general linear system and efficient algorithms for
+ solving special systems with symmetric and tridiagonal matrices are provided
+ by these functions. The general solution function employs a LU factorization
+ with partial pivoting and it is very robust. It will work efficiently on any
+ problem that is not ill-conditioned. The symmetric matrix solution is based
+ on a modified Cholesky factorization. It is best used on positive definite
+ matrices that do not require pivoting for numeric stability. Tridiagonal
+ solvers require order-N operations (N = dimension). Thus, they are highly
+ recommended for this important class of sparse systems. Two matrix inversion
+ routines are provided. The general inversion function is again LU based. It
+ is suitable for use on any stable (ie. well-conditioned) problem. The
+ Cholesky based symmetric matrix inversion is efficient and safe for use on
+ matrices known to be positive definite, such as the variance matrices
+ encountered in statistical computations. Both the solver and the inverse
+ functions are designed to enhance data locality. They are very effective
+ on modern microprocessors.
+
+
+ o Eigensystem Analysis:
+
+ eigen ------ extract all eigen values and vectors of a real
+ symmetric matrix.
+ eigval ----- extract the eigen values of a real symmetric matrix.
+ evmax ------ compute the eigen value of maximum absolute magnitude
+ and its corresponding vector for a symmetric matrix.
+
+
+ Eigensystem functions operate on real symmetric matrices. Two forms of
+ the general eigen routine are provided because the computation of eigen values
+ only is much faster when vectors are not required. The basic algorithms use
+ a Householder reduction to tridiagonal form followed by QR iterations with
+ shifts to enhance convergence. This has become the accepted standard for
+ symmetric eigensystem computation. The evmax function uses an efficient
+ iterative power method algorithm to extract the eigen value of maximum
+ absolute size and the corresponding eigenvector.
+
+
+ o Singular Value Decomposition:
+
+ svdval ----- compute the singular values of a m by n real matrix.
+ sv2val ----- compute the singular values of a real matrix
+ efficiently for m >> n.
+ svduv ------ compute the singular values and the transformation
+ matrices u and v for a real m by n matrix.
+ sv2uv ------ compute the singular values and transformation
+ matrices efficiently for m >> n.
+ svdu1v ----- compute the singular values and transformation
+ matrices u1 and v, where u1 overloads the input
+ with the first n column vectors of u.
+ sv2u1v ----- compute the singular values and the transformation
+ matrices u1 and v efficiently for m >> n.
+
+
+ Singular value decomposition is extremely useful when dealing with linear
+ systems that may be singular. Singular values with values near zero are flags
+ of a potential rank deficiency in the system matrix. They can be used to
+ identify the presence of an ill-conditioned problem and, in some cases, to
+ deal with the potential instability. They are applied to the linear least
+ squares problem in this library. Singular values also define some important
+ matrix norm parameters such as the 2-norm and the condition value. A complete
+ decomposition provides both singular values and an orthogonal decomposition of
+ vector spaces related to the matrix identifying the range and null-space.
+ Fortunately, a highly stable algorithm based on Householder reduction to
+ bidiagonal form and QR rotations can be used to implement the decomposition.
+ The library provides two forms with one more efficient when the dimensions
+ satisfy m > (3/2)n.
+
+
+ o Real Matrix Utilities:
+
+ rmmult ----- multiply two compatible real matrices.
+ mmul ------- multiply two real square matrices.
+ vmul ------- multiply a vector by a square matrix (transform).
+ mattr ------ compute the transpose of a general matrix.
+ trnm ------- transpose a real square matrix in place.
+ otrma ------ compute orthogonal conjugate of a square matrix.
+ otrsm ------ compute orthogonal conjugate of a symmetric matrix.
+ smgen ------ construct a symmetric matrix from its eigen values
+ and vectors.
+ ortho ------ generate a general orthogonal matrix (uses random
+ rotation generator).
+ mcopy ------ make a copy of an array.
+ matprt ----- print a matrix in row order with a specified
+ format for elements to stdout or a file (fmatprt).
+
+
+ The utility functions perform simple matrix operations such as matrix
+ multiplication, transposition, matrix conjugation, and linear transformation
+ of a vector. They are used to facilitate the rapid production of test and
+ application code requiring these operations. The function call overhead
+ associated with use of these utilities becomes negligible as the dimension of
+ the matrices increases. The implementation of these routines is designed to
+ enhance data locality and thus execution performance. A generator for
+ orthogonal matrices can be used to generate test matrices.
+
+
+ Linear Algebra with Complex Matrices
+
+ The complex section of the linear algebra library contains functions that
+ operate on general complex valued matrices and on Hermitian matrices.
+ Hermitian matrices are the complex analog of symmetric matrices. Complex
+ arithmetic is performed in-line in these functions to ensure efficient
+ execution.
+
+
+ o Solving and Inverting Complex Linear Systems:
+
+ csolv ------ solve a general complex system of linear equations.
+
+ cminv ------ invert a general complex matrix.
+
+
+ Both these functions are based on the robust LU factorization algorithm
+ with row pivots. They can be expected to solve or invert any system that is
+ well conditioned.
+
+
+ o Hermitian Eigensystem Analysis:
+
+ heigvec ---- extract the eigen values and vectors of a Hermitian
+ matrix.
+ heigval ---- compute the eigenvalues of a Hermitian matrix.
+ hevmax ----- compute the eigen value of largest absolute magnitude
+ and the corresponding vector of a Hermitian matrix.
+
+
+ The algorithms used for complex eigensystems are complex generalizations
+ of those employed in the real systems. The eigen values of Hermitian matrices
+ are real and their eigenvectors form a unitary matrix. As in the real case,
+ the function for eigen values only is provided as a time saver. These
+ routines have important application to many quantum mechanical problems.
+
+
+ o Complex Matrix Utilities:
+
+ cmmult ---- multiply two general, size compatible, complex matrices.
+ cmmul ----- multiply two square complex matrices.
+ cvmul ----- multiply a complex vector by a complex square matrix.
+ cmattr ---- transpose a general complex matrix.
+ trncm ----- transpose a complex square matrix in place.
+ hconj ----- transform a square complex matrix to its Hermitian
+ conjugate in place.
+ utrncm ---- compute the unitary transform of a complex matrix.
+ utrnhm ---- compute the unitary transform of a Hermitian matrix.
+ hmgen ----- generate a general Hermitian from its eigen values
+ and vectors.
+ unitary --- generate a general unitary matrix (uses a random
+ rotation generator).
+ cmcpy ----- copy a complex array.
+ cmprt ----- print a complex matrix in row order with a specified
+ format for matrix elements.
+
+
+ These utility operations replicate the utilities available for real
+ matrices. Matrix computations implemented in a manner that enhances data
+ locality. This ensures their efficiency on modern computers with a memory
+ hierarchy.
+
+-------------------------------------------------------------------------------
+
+ General Technical Comments
+
+ Efficient computation with matrices on modern processors must be
+ adapted to the storage scheme employed for matrix elements. The functions
+ of this library segment do not employ the multidimensional array intrinsic
+ of the C language. Access to elements employs the simple row-major scheme
+ described here.
+
+ Matrices are modeled by the library functions as arrays with elements
+ stored in row order. Thus, the element in the jth row and kth column of
+ the n by n matrix M, stored in the array mat[], is addressed by
+
+ M[j,k] = mat[n*j+k] , with 0 =< j,k <= n-1 .
+
+ (Remember that C employs zero as the starting index.) The storage order has
+ important implications for data locality.
+
+ The algorithms employed here all have excellent numerical stability, and
+ the default double precision arithmetic of C enhances this. Thus, any
+ problems encountered in using the matrix algebra functions will almost
+ certainly be due to an ill-conditioned matrix. (The Hilbert matrices,
+
+ H[i,j] = 1/(1+i+j) for i,j < n
+
+ form a good example of such ill-conditioned systems.) We remind the reader
+ that the appropriate response to such ill-conditioning is to seek an
+ alternative approach to the problem. The option of increasing precision has
+ already been exploited. Modification of the linear algebra algorithm code is
+ not normally effective in an ill-conditioned problem.
+
+------------------------------------------------------------------------------
+ FUNCTION SYNOPSES
+------------------------------------------------------------------------------
+
+ Linear System Solutions:
+-----------------------------------------------------------------------------
+
+solv
+
+ Solve a general linear system A*x = b.
+
+ int solv(double a[],double b[],int n)
+ a = array containing system matrix A in row order
+ (altered to L-U factored form by computation)
+ b = array containing system vector b at entry and
+ solution vector x at exit
+ n = dimension of system
+ return: 0 -> normal exit
+ -1 -> singular input
+
+ -----------------------------------------------------------
+
+solvps
+
+ Solve a symmetric positive definite linear system S*x = b.
+
+ int solvps(double a[],double b[],int n)
+ a = array containing system matrix S (altered to
+ Cholesky upper right factor by computation)
+ b = array containing system vector b as input and
+ solution vector x as output
+ n = dimension of system
+ return: 0 -> normal exit
+ 1 -> input matrix not positive definite
+
+ --------------------------------------------------------------
+
+solvtd
+
+ Solve a tridiagonal linear system M*x = y.
+
+ void solvtd(double a[],double b[],double c[],double x[],int m)
+ a = array containing m+1 diagonal elements of M
+ b = array of m elements below the main diagonal of M
+ c = array of m elements above the main diagonal
+ x = array containing the system vector y initially, and
+ the solution vector at exit (m+1 elements)
+ m = dimension parameter ( M is (m+1)x(m+1) )
+
+ --------------------------------------------------------------
+
+solvru
+
+ Solve an upper right triangular linear system T*x = b.
+
+ int solvru(double *a,double *b,int n)
+ a = pointer to array of upper right triangular matrix T
+ b = pointer to array of system vector
+ The computation overloads this with the
+ solution vector x.
+ n = dimension (dim(a)=n*n,dim(b)=n)
+ return value: f = status flag, with 0 -> normal exit
+ -1 -> system singular
+
+------------------------------------------------------------------------------
+
+ Matrix Inversion:
+------------------------------------------------------------------------------
+
+minv
+
+ Invert (in place) a general real matrix A -> Inv(A).
+
+ int minv(double a[],int n)
+ a = array containing the input matrix A
+ This is converted to the inverse matrix.
+ n = dimension of the system (i.e. A is n x n )
+ return: 0 -> normal exit
+ 1 -> singular input matrix
+
+ --------------------------------------------------------------
+
+psinv
+
+ Invert (in place) a symmetric real matrix, V -> Inv(V).
+
+ int psinv(double v[],int n)
+ v = array containing a symmetric input matrix
+ This is converted to the inverse matrix.
+ n = dimension of the system (dim(v)=n*n)
+ return: 0 -> normal exit
+ 1 -> input matrix not positive definite
+
+ The input matrix V is symmetric (V[i,j] = V[j,i]).
+
+ --------------------------------------------------------------
+
+ruinv
+
+ Invert an upper right triangular matrix T -> Inv(T).
+
+ int ruinv(double *a,int n)
+ a = pointer to array of upper right triangular matrix
+ This is replaced by the inverse matrix.
+ n = dimension (dim(a)=n*n)
+ return value: status flag, with 0 -> matrix inverted
+ -1 -> matrix singular
+
+
+-----------------------------------------------------------------------------
+
+ Symmetric Eigensystem Analysis:
+-----------------------------------------------------------------------------
+
+eigval
+
+ Compute the eigenvalues of a real symmetric matrix A.
+
+ void eigval(double *a,double *ev,int n)
+ a = pointer to array of symmetric n by n input
+ matrix A. The computation alters these values.
+ ev = pointer to array of the output eigenvalues
+ n = dimension parameter (dim(a)= n*n, dim(ev)= n)
+
+ --------------------------------------------------------------
+
+eigen
+
+ Compute the eigenvalues and eigenvectors of a real symmetric
+ matrix A.
+
+ void eigen(double *a,double *ev,int n)
+ double *a,*ev; int n;
+ a = pointer to store for symmetric n by n input
+ matrix A. The computation overloads this with an
+ orthogonal matrix of eigenvectors E.
+ ev = pointer to the array of the output eigenvalues
+ n = dimension parameter (dim(a)= n*n, dim(ev)= n)
+
+ The input and output matrices are related by
+
+ A = E*D*E~ where D is the diagonal matrix of eigenvalues
+ D[i,j] = ev[i] if i=j and 0 otherwise.
+
+ The columns of E are the eigenvectors.
+
+ ---------------------------------------------------------------
+
+evmax
+
+ Compute the maximum (absolute) eigenvalue and corresponding
+ eigenvector of a real symmetric matrix A.
+
+ double evmax(double a[],double u[],int n)
+ double a[],u[]; int n;
+ a = array containing symmetric input matrix A
+ u = array containing the n components of the eigenvector
+ at exit (vector normalized to 1)
+ n = dimension of system
+ return: ev = eigenvalue of A with maximum absolute value
+ HUGE -> convergence failure
+
+
+-----------------------------------------------------------------------------
+ Eigensystem Auxiliaries:
+-----------------------------------------------------------------------------
+
+ The following routines are used by the eigensystem functions.
+ They are not normally called by the user.
+
+house
+
+ Transform a real symmetric matrix to tridiagonal form.
+
+ void house(double *a,double *d,double *dp,int n)
+ a = pointer to array of the symmetric input matrix A
+ These values are altered by the computation.
+ d = pointer to array of output diagonal elements
+ dp = pointer to array of n-1 elements neighboring the
+ diagonal in the symmetric transformed matrix
+ n = dimension (dim(a)= n*n, dim(d)=dim(dp)=n)
+
+ The output arrays are related to the tridiagonal matrix T by
+
+ T[i,i+1] = T[i+1,i] = dp[i] for i=0 to n-2, and
+ T[i,i] = d[i] for i=0 to n-1.
+ --------------------------------------------------------------
+
+housev
+
+ Transform a real symmetric matrix to tridiagonal form and
+ compute the orthogonal matrix of this transformation.
+
+ void housev(double *a,double *d,double *dp,int n)
+ a = pointer to array of symmetric input matrix A
+ The computation overloads this array with the
+ orthogonal transformation matrix O.
+ d = pointer to array of diagonal output elements
+ dp = pointer to array of n-1 elements neighboring the
+ diagonal in the symmetric transformed matrix
+ n = dimension (dim(a)= n*n, dim(d)=dim(dp)=n)
+
+ The orthogonal transformation matrix O satisfies O~*T*O = A.
+ ----------------------------------------------------------------
+
+qreval
+
+ Perform a QR reduction of a real symmetric tridiagonal
+ matrix to diagonal form.
+
+ int qreval(double *ev,double *dp,int n)
+ ev = pointer to array of input diagonal elements
+ The computation overloads this array with
+ eigenvalues.
+ dp = pointer to array input elements neighboring the
+ diagonal. This array is altered by the computation.
+ n = dimension (dim(ev)=dim(dp)= n)
+
+ ---------------------------------------------------------------
+
+qrevec
+
+ Perform a QR reduction of a real symmetric tridiagonal matrix
+ to diagonal form and update an orthogonal transformation matrix.
+
+ int qrevec(double *ev,double *evec,double *dp,int n)
+ ev = pointer to array of input diagonal elements
+ that the computation overloads with eigenvalues
+ evec = pointer array of orthogonal input matrix
+ This is updated by the computation to a matrix
+ of eigenvectors.
+ dp = pointer to array input elements neighboring the
+ diagonal. This array is altered by the computation.
+ n = dimension (dim(ev)=dim(dp)= n)
+
+ This function operates on the output of 'housev'.
+
+------------------------------------------------------------------------------
+
+ Matrix Utilities:
+------------------------------------------------------------------------------
+
+mmul
+
+ Multiply two real square matrices C = A * B.
+
+ void mmul(double *c,double *a,double *b,int n)
+ double *a,*b,*c; int n;
+ a = pointer to store for left product matrix
+ b = pointer to store for right product matrix
+ c = pointer to store for output matrix
+ n = dimension (dim(a)=dim(b)=dim(c)=n*n)
+
+ -------------------------------------------------------
+
+rmmult
+
+ Multiply two matrices Mat = A*B.
+
+ void rmmult(double *mat,double *a,double *b,int m,int k,int n)
+ double mat[],a[],b[]; int m,k,n;
+ mat = array containing m by n product matrix at exit
+ a = input array containing m by k matrix
+ b = input array containing k by n matrix
+ (all matrices stored in row order)
+ m,k,n = dimension parameters of arrays
+
+ ----------------------------------------------------------
+
+vmul
+
+ Multiply a vector by a matrix Vp = Mat*V.
+
+ void vmul(double *vp,double *mat,double *v,int n)
+ vp = pointer to array containing output vector
+ mat = pointer to array containing input matrix in row order
+ v = pointer to array containing input vector
+ n = dimension of vectors (mat is n by n)
+
+ ----------------------------------------------------------------
+
+vnrm
+
+ Compute the inner product of two real vectors, p = u~*v.
+
+ double vnrm(double *u,double *v,int n)
+ u = pointer to array of input vector u
+ v = pointer to array of input vector v
+ n = dimension (dim(u)=dim(v)=n)
+ return value: p = u~*v (dot product of u and v)
+
+ -----------------------------------------------------
+
+trnm
+
+ Transpose a real square matrix in place A -> A~.
+
+ void trnm(double *a,int n)
+ a = pointer to array of n by n input matrix A
+ This is overloaded by the transpose of A.
+ n = dimension (dim(a)=n*n)
+
+ ---------------------------------------------------------
+
+mattr
+
+ Transpose an m by n matrix A = B~.
+
+ void mattr(double *a,double *b,int m,int n)
+ a = pointer to array containing output n by m matrix
+ b = pointer to array containing input m by n matrix
+ (matrices stored in row order)
+ m,n = dimension parameters (dim(a)=dim(b)=n*m)
+
+ ------------------------------------------------------------
+
+otrma
+
+ Perform an orthogonal similarity transform C = A*B*A~.
+
+ void otrma(double *c,double *a,double *b,int n)
+ c = pointer to array of output matrix C
+ a = pointer to array of transformation A
+ b = pointer to array of input matrix B
+ n = dimension (dim(a)=dim(b)=dim(c)=n*n)
+
+ -----------------------------------------------------------
+
+otrsm
+
+ Perform a similarity transform on a symmetric matrix S = A*B*A~.
+
+ void otrsm(double *sm,double *a,double *b,int n)
+ sm = pointer to array of output matrix S
+ a = pointer to array of transformation matrix A
+ b = pointer to array of symmetric input matrix B
+ n = dimension (dim(a)=dim(b)=dim(sm)=n*n)
+
+ ---------------------------------------------------------------
+
+smgen
+
+ Construct a symmetric matrix from specified eigenvalues and
+ eigenvectors.
+
+ void smgen(double *a,double *eval,double *evec,int n)
+ a = pointer to array containing output matrix
+ eval = pointer to array containing the n eigenvalues
+ evec = pointer to array containing eigenvectors
+ (n by n with kth column the vector corresponding
+ to the kth eigenvalue)
+ n = system dimension
+
+ If D is the diagonal matrix of eigenvalues
+ and E[i,j] = evec[j+n*i] , then A = E*D*E~.
+
+ ----------------------------------------------------------------
+
+ortho
+
+ Generate a general orthogonal transformation matrix, E~*E = I.
+
+ void ortho(double *e,int n)
+ e = pointer to array of orthogonal output matrix E
+ n = dimension of vector space (dim(e)=n*n)
+
+ This function calls on the uniform random generator 'unfl' to
+ produce random rotation angles. Therefore this random generator
+ should be initialized by a call of 'setunfl' before calling
+ ortho (see Chapter 7).
+
+ -----------------------------------------------------------------
+
+mcopy
+
+ Copy an array a = b.
+
+ void mcopy(double *a,double *b,int n)
+ a = array containing output values, identical to input
+ b at exit
+ b = input array
+ n = dimension of arrays
+
+ -----------------------------------------------------------
+
+matprt
+
+ Print an array in n rows of m columns to stdout.
+
+ void matprt(double *a,int n,int m,char *fmt)
+ a = pointer to input array stored in row order (size = n*m)
+ n = number of output rows
+ m = number of output columns
+ fmt= pointer to character array containing format string
+ (printf formats eg. " %f")
+
+ Long rows may overflow the print line.
+
+ ---------------------------------------------------------------
+
+fmatprt
+
+ Print formatted array output to a file.
+
+ void fmatprt(FILE *fp,double *a,int n,int m,char *fmt)
+ fp = pointer to file opened for writing
+ a = pointer to input array stored in row order (size = n*m)
+ n = number of output rows
+ m = number of output columns
+ fmt= pounter to character array containing format string
+ (printf formats eg. " %f")
+
+------------------------------------------------------------------------------
+
+ Singular Value Decomposition:
+------------------------------------------------------------------------------
+
+ A number of versions of the Singular Value Decomposition (SVD)
+ are implemented in the library. They support the efficient
+ computation of this important factorization for a real m by n
+ matrix A. The general form of the SVD is
+
+ A = U*S*V~ with S = | D |
+ | 0 |
+
+ where U is an m by m orthogonal matrix, V is an n by n orthogonal matrix,
+ D is the n by n diagonal matrix of singular value, and S is the singular
+ m by n matrix produced by the transformation.
+
+ The singular values computed by these functions provide important
+ information on the rank of the matrix A, and on several matrix
+ norms of A. The number of non-zero singular values d[i] in D
+ equal to the rank of A. The two norm of A is
+
+ ||A|| = max(d[i]) , and the condition number is
+
+ k(A) = max(d[i])/min(d[i]) .
+
+ The Frobenius norm of the matrix A is
+
+ Fn(A) = Sum(i=0 to n-1) d[i]^2 .
+
+ Singular values consistent with zero are easily recognized, since
+ the decomposition algorithms have excellent numerical stability.
+ The value of a 'zero' d[i] is no larger than a few times the
+ computational rounding error e.
+
+ The matrix U1 is formed from the first n orthonormal column vectors
+ of U. U1[i,j] = U[i,j] for i = 1 to m and j = 1 to n. A singular
+ value decomposition of A can also be expressed in terms of the m by\
+ n matrix U1, with
+
+ A = U1*D*V~ .
+
+ SVD functions with three forms of output are provided. The first
+ form computes only the singular values, while the second computes
+ the singular values and the U and V orthogonal transformation
+ matrices. The third form of output computes singular values, the
+ V matrix, and saves space by overloading the input array with
+ the U1 matrix.
+
+ Two forms of decomposition algorithm are available for each of the
+ three output types. One is computationally efficient when m ~ n.
+ The second, distinguished by the prefix 'sv2' in the function name,
+ employs a two stage Householder reduction to accelerate computation
+ when m substantially exceeds n. Use of functions of the second form
+ is recommended for m > 2n.
+
+ Singular value output from each of the six SVD functions satisfies
+
+ d[i] >= 0 for i = 0 to n-1.
+-------------------------------------------------------------------------------
+
+svdval
+
+ Compute the singular values of a real m by n matrix A.
+
+ int svdval(double *d,double *a,int m,int n)
+ d = pointer to double array of dimension n
+ (output = singular values of A)
+ a = pointer to store of the m by n input matrix A
+ (A is altered by the computation)
+ m = number of rows in A
+ n = number of columns in A (m>=n required)
+ return value: status flag with:
+ 0 -> success
+ -1 -> input error m < n
+
+ ------------------------------------------------------------
+
+sv2val
+
+ Compute singular values when m >> n.
+
+ int sv2val(double *d,double *a,int m,int n)
+ d = pointer to double array of dimension n
+ (output = singular values of A)
+ a = pointer to store of the m by n input matrix A
+ (A is altered by the computation)
+ m = number of rows in A
+ n = number of columns in A (m>=n required)
+ return value: status flag with:
+ 0 -> success
+ -1 -> input error m < n
+ --------------------------------------------------------------
+
+svduv
+
+ Compute the singular value transformation S = U~*A*V.
+
+ int svduv(double *d,double *a,double *u,int m,double *v,int n)
+ d = pointer to double array of dimension n
+ (output = singular values of A)
+ a = pointer to store of the m by n input matrix A
+ (A is altered by the computation)
+ u = pointer to store for m by m orthogonal matrix U
+ v = pointer to store for n by n orthogonal matrix V
+ m = number of rows in A
+ n = number of columns in A (m>=n required)
+ return value: status flag with:
+ 0 -> success
+ -1 -> input error m < n
+
+ --------------------------------------------------------------------
+
+sv2uv
+
+ Compute the singular value transformation when m >> n.
+
+ int sv2uv(double *d,double *a,double *u,int m,double *v,int n)
+ d = pointer to double array of dimension n
+ (output = singular values of A)
+ a = pointer to store of the m by n input matrix A
+ (A is altered by the computation)
+ u = pointer to store for m by m orthogonal matrix U
+ v = pointer to store for n by n orthogonal matrix V
+ m = number of rows in A
+ n = number of columns in A (m>=n required)
+ return value: status flag with:
+ 0 -> success
+ -1 -> input error m < n
+
+ ----------------------------------------------------------------
+
+svdu1v
+
+ Compute the singular value transformation with A overloaded by
+ the partial U-matrix.
+
+ int svdu1v(double *d,double *a,int m,double *v,int n)
+ d = pointer to double array of dimension n
+ (output = singular values of A)
+ a = pointer to store of the m by n input matrix A
+ (At output a is overloaded by the matrix U1
+ whose n columns are orthogonal vectors equal to
+ the first n columns of U.)
+ v = pointer to store for n by n orthogonal matrix V
+ m = number of rows in A
+ n = number of columns in A (m>=n required)
+ return value: status flag with:
+ 0 -> success
+ -1 -> input error m < n
+
+ ------------------------------------------------------------------
+
+sv2u1v
+
+ Compute the singular value transformation with partial U
+ matrix U1 efficiently for m >> n.
+
+ #include <math.h>
+ int sv2u1v(d,a,m,v,n)
+ double *d,*a,*v; int m,n;
+ d = pointer to double array of dimension n
+ (output = singular values of A)
+ a = pointer to store of the m by n input matrix A
+ (At output a is overloaded by the matrix U1
+ whose n columns are orthogonal vectors equal to
+ the first n columns of U.)
+ v = pointer to store for n by n orthogonal matrix V
+ m = number of rows in A
+ n = number of columns in A (m>=n required)
+ return value: status flag with:
+ 0 -> success
+ -1 -> input error m < n
+
+-------------------------------------------------------------------------------
+ Auxiliary Functions used in SVD Computation:
+-------------------------------------------------------------------------------
+
+ The following routines are used by the singular value decomposition
+ functions. They are not normally called by the user.
+
+qrbdi
+
+ Perform a QR reduction of a bidiagonal matrix.
+
+ int qrbdi(double *d,double *e,int m)
+ d = pointer to n-dimensional array of diagonal values
+ (overloaded by diagonal elements of reduced matrix)
+ e = pointer to store of superdiagonal values (loaded in
+ first m-1 elements of the array). Values are altered
+ by the computation.
+ m = dimension of the d and e arrays
+ return value: N = number of QR iterations required
+
+ -------------------------------------------------------------
+
+qrbdv
+
+ Perform a QR reduction of a bidiagonal matrix and update the
+ the orthogonal transformation matrices U and V.
+
+ int qrbdv(double *d,double *e,double *u,int m,double *v,int n)
+ d = pointer to n-dimensional array of diagonal values
+ (overloaded by diagonal elements of reduced matrix)
+ e = pointer to store of superdiagonal values (loaded in
+ first m-1 elements of the array). Values are altered
+ by the computation.
+ u = pointer to store of m by m orthogonal matrix U updated
+ by the computation
+ v = pointer to store of n by n orthogonal matrix V updated
+ by the computation
+ m = dimension parameter of the U matrix
+ n = size of the d and e arrays and the number of rows and
+ columns in the V matrix
+ return value: N = number of QR iterations required
+
+ ---------------------------------------------------------------
+
+qrbd1
+
+ Perform a QR reduction of a bidiagonal matrix and update the
+ transformation matrices U1 and V.
+
+ int qrbdu1(double *d,double *e,double *u1,int m,double *v,int n)
+ d = pointer to n-dimensional array of diagonal values
+ (overloaded by diagonal elements of reduced matrix)
+ e = pointer to store of superdiagonal values (loaded in
+ first m-1 elements of the array). Values are altered
+ by the computation.
+ u1 = pointer to store of m by n transformation matrix U1
+ updated by the computation
+ v = pointer to store of n by n orthogonal matrix V updated
+ by the computation
+ m = number of rows in the U1 matrix
+ n = size of the d and e arrays, number of columns in the U1
+ matrix, and the number of rows and columns in the V matrix.
+ return value: N = number of QR iterations required
+
+ ------------------------------------------------------------------
+
+ldumat
+
+ Compute a left Householder transform matrix U from the vectors
+ specifying the Householder reflections.
+
+ void ldumat(double *a,double *u,int m,int n)
+ a = pointer to store of m by n input matrix A. Elements
+ of A on and below the main diagonal specify the
+ vectors of n Householder reflections (see note below).
+ u = pointer to store for the m by m orthogonal output
+ matrix U.
+ m = number of rows in A and U, and number of columns in U.
+ n = number of columns in A
+
+ --------------------------------------------------------------
+
+ldvmat
+
+ Compute a right Householder transform matrix from the vectors
+ specifying the Householder reflections.
+
+ void ldvmat(double *a,double *v,int n)
+ a = pointer to store of n by n input matrix A. Elements
+ of A on and above the superdiagonal specify vectors
+ of a sequence of Householder reflections (see note below).
+ v = pointer to store for the n by n orthogonal output
+ matrix V
+ n = number of rows and columns in A and V
+
+ -----------------------------------------------------------------
+
+atou1
+
+ Overload a Householder left-factored matrix A with the first
+ n columns of the Householder orthogonal matrix.
+
+ void atou1(double *a,int m,int n)
+ a = pointer to store of m by n input matrix A. Elements
+ of A on and below the main diagonal specify the
+ vectors of n Householder reflections (see note below).
+ This array is overloaded by the first n columns of the
+ Householder transformation matrix.
+ m = number of rows in A
+ n = number of columns in A
+
+ ---------------------------------------------------------------
+
+atovm
+
+ Overload a Householder right-factored square matrix A with the
+ Householder transformation matrix V.
+
+ void atovm(double *v,int n)
+ v = pointer to store for the n by n orthogonal
+ output matrix V
+ n = number of rows and columns in V
+
+-------------------------------------------------------------------------------
+
+ Individual Householder reflections are specified by a vector h.
+ The corresponding orthogonal reflection matrix is given by
+
+ H = I - c* h~ .
+
+ Input matrices store the vector, normalized to have its leading
+ coefficient equal to one, and the normalization factor
+
+ c = 2/(h~*h) .
+
+ Storage for the vectors is by column starting at the diagonal for
+ a left transform, and by row starting at the superdiagonal for a
+ right transform. The first location holds c followed by
+ components 2 to k of the vector.
+
+
+-------------------------------------------------------------------------------
+ Complex Linear Algebra
+-------------------------------------------------------------------------------
+
+ Solution and Inverse:
+-------------------------------------------------------------------------------
+
+csolv
+
+ Solve a complex linear system A*x = b.
+
+ int csolv(Cpx *a,Cpx *b,int n)
+ a = pointer to array of n by n system matrix A
+ The computation alters this array to a LU factorization.
+ b = pointer to input array of system vector b
+ This is replaced by the solution vector b -> x.
+ n = dimension of system (dim(a)=n*n, dim(b)=n)
+ return value: status flag with: 0 -> valid solution
+ 1 -> system singular
+
+ ---------------------------------------------------------------
+
+cminv
+
+ Invert a general complex matrix in place A -> Inv(A).
+
+ int cminv(Cpx *a,int n)
+ a = pointer to input array of complex n by n matrix A
+ The computation replaces A by its inverse.
+ n = dimension of system (dim(a)=n*n)
+ return value: status flag with: 0 -> valid solution
+ 1 -> system singular
+
+------------------------------------------------------------------------------
+
+ Hermitian Eigensystems:
+------------------------------------------------------------------------------
+
+heigval
+
+ Compute the eigenvalues of a Hermitian matrix.
+
+ void heigval(Cpx *a,double *ev,int n)
+ a = pointer to array for the Hermitian matrix H
+ These values are altered by the computation.
+ ev = pointer to array that is loaded with the
+ eigenvalues of H by the computation
+ n = dimension (dim(a)=n*n, dim(ev)=n)
+
+ --------------------------------------------------------
+
+heigvec
+
+ Compute the eigenvalues and eigenvectors of a Hermitian
+ matrix.
+
+ void heigvec(Cpx *a,double *ev,int n)
+ a = pointer to array for the hermitian matrix H
+ This array is loaded with a unitary matrix of
+ eigenvectors E by the computation.
+ ev = pointer to array that is loaded with the
+ eigenvalues of H by the computation
+ n = dimension (dim(a)=n*n, dim(ev)=n)
+
+ The eigen vector matrix output E satisfies
+
+ E^*E = I and A = E*D*E^
+
+ where D[i,j] = ev[i] for i=j and 0 otherwise
+ and E^ is the Hermitian conjugate of E.
+ The columns of E are the eigenvectors of A.
+
+ ----------------------------------------------------------
+
+hevmax
+
+ Compute the eigenvalue of maximum absolute value and
+ the corresponding eigenvector of a Hermitian matrix.
+
+ double hevmax(Cpx *a,Cpx *u,int n)
+ Cpx *a,*u; int n;
+ a = pointer to array for the Hermitian matrix H
+ u = pointer to array for the eigenvector umax
+ n = dimension (dim(a)=n*n, dim(u)=n)
+ return value: emax = eigenvalue of H with largest
+ absolute value
+
+ The eigenvector u and eigenvalue emax are related by u^*A*u = emax.
+
+------------------------------------------------------------------------------
+ Hermitian Eigensystem Auxiliaries:
+------------------------------------------------------------------------------
+
+ The following routines are called by the Hermitian eigensystem
+ functions. They are not normally called by the user.
+
+chouse
+
+ Transform a Hermitian matrix H to real symmetric tridiagonal
+ form.
+
+ void chouse(Cpx *a,double *d,double *dp,int n)
+ a = pointer to input array of complex matrix elements of H
+ This array is altered by the computation
+ d = pointer to output array of real diagonal elements
+ dp = pointer to output array of real superdiagonal elements
+ n = system dimension, with:
+ dim(a) = n * n, dim(d) = dim(dn) = n;
+
+ -----------------------------------------------------------------
+
+chousv
+
+ Transform a Hermitian matrix H to real symmetric tridiagonal
+ form, and compute the unitary matrix of this transformation.
+
+ void chousv(Cpx *a,double *d,double *dp,int n)
+ a = pointer to input array of complex matrix elements of H
+ The computation replaces this with the unitary matrix
+ U of the transformation.
+ d = pointer to output array of real diagonal elements
+ dp = pointer to output array of real superdiagonal elements
+ n = system dimension, with:
+ dim(a) = n*n, dim(d) = dim(dn) = n;
+
+ The matrix U satisfies
+
+ A = U^*T*U where T is real and tridiagonal,
+ with T[i,i+1] = T[i+1,i] = dp[i] and T[i,i] = d[i].
+
+ ------------------------------------------------------------
+
+qrecvc
+
+ Use QR transformations to reduce a real symmetric tridiagonal
+ matrix to diagonal form, and update a unitary transformation
+ matrix.
+
+ void qrecvc(double *ev,Cpx *evec,double *dp,int n)
+ ev = pointer to input array of diagonal elements
+ The computation transforms these to eigenvalues
+ of the input matrix.
+ evec = pointer to input array of a unitary transformation
+ matrix U. The computation applies the QR rotations
+ to this matrix.
+ dp = pointer to input array of elements neighboring the
+ diagonal. These values are altered by the computation.
+ n = dimension parameter (dim(ev)=dim(dp)=n, dim(evec)=n*n)
+
+ This function operates on the output of 'chousv'.
+
+-------------------------------------------------------------------------------
+
+ Complex Matrix Utilities:
+-------------------------------------------------------------------------------
+
+cvmul
+
+ Transform a complex vector u = A*v.
+
+ void cvmul(Cpx *u,Cpx *a,Cpx *v,int n)
+ u = pointer to array of output vector u.
+ a = pointer to array of transform matrix A.
+ v = pointer to array of input vector v.
+ n = dimension (dim(u)=dim(v)=n, dim(a)=n*n)
+
+ -----------------------------------------------------------
+
+cvnrm
+
+ Compute a Hermitian inner product s = u^*v.
+
+ Cpx cvnrm(Cpx *u,Cpx *v,int n)
+ u = pointer to array of first vector u
+ v = pointer to array of second vector v
+ n = dimension (dim(u)=dim(v)=n)
+ return value: s = complex value of inner product
+
+ -----------------------------------------------------------
+
+cmmul
+
+ Multiply two square complex matrices C = A * B.
+
+ void cmmul(Cpx *c,Cpx *a,Cpx *b,int n)
+ a = pointer to input array of left matrix factor A
+ b = pointer to input array of right matrix factor B
+ c = pointer to array of output product matrix C
+ n = dimension parameter (dim(c)=dim(a)=dim(b)=n*n)
+
+ -------------------------------------------------------------
+
+cmmult
+
+ Multiply two complex matrices C = A * B.
+
+ void cmmult(Cpx *c,Cpx *a,Cpx *b,int n,int m,int l)
+ a = pointer to input array of right n by m factor matrix A
+ b = pointer to input array of left m by l factor matrix B
+ c = pointer to store for n by l output matrix C
+ n,m,l = system dimension parameters, with
+ (dim(c)=n*l, dim(a)=n*m, dim(b)=m*l)
+
+ ----------------------------------------------------------------
+
+hconj
+
+ Compute the Hermitian conjugate in place, A -> A^.
+
+ void hconj(Cpx *a,int n)
+ a = pointer to input array for the complex matrix A
+ This is converted to the Hermitian conjugate A^.
+ n = dimension (dim(a)=n*n)
+
+ ----------------------------------------------------------
+
+utrncm
+
+ Perform a unitary similarity transformation C = T*B*T^.
+
+ void utrncm(Cpx *cm,Cpx *a,Cpx *b,int n)
+ a = pointer to the array of the transform matrix T
+ b = pointer to the array of the input matrix B
+ cm = pointer to output array of the transformed matrix C
+ n = dimension (dim(cm)=dim(a)=dim(b)=n*n)
+
+ ---------------------------------------------------------------
+
+utrnhm
+
+ Perform a unitary similarity transformation on a Hermitian
+ matrix H' = T*H*T^.
+
+ void utrnhm(Cpx *hm,Cpx *a,Cpx *b,int n)
+ a = pointer to the array of the transform matrix T
+ b = pointer to the array of the Hermitian input matrix H
+ hm = pointer to array containing Hermitian output matrix H'
+ n = dimension (dim(cm)=dim(a)=dim(b)=n*n)
+
+ -----------------------------------------------------------------
+
+trncm
+
+ Transpose a complex square matrix in place A -> A~.
+
+ void trncm(Cpx *a,int n)
+ a = pointer to array of n by n complex matrix A
+ The computation replaces A by its transpose
+ n = dimension (dim(a)=n*n)
+
+ ---------------------------------------------------------
+
+cmattr
+
+ Compute the transpose A = B~ of a complex m by n matrix.
+
+ void cmattr(Cpx *a,Cpx *b,int m,int n)
+ a = pointer to output array of matrix A
+ b = pointer to input array of matrix B
+ m, n = matrix dimensions, with B m by n and A n by m
+ (dim(a)=dim(b)= m*n)
+
+ -----------------------------------------------------------------
+
+hmgen
+
+ Generate a Hermitian matrix with specified eigen values and
+ eigenvectors.
+
+ void hmgen(Cpx *h,double *ev,Cpx *u,int n)
+ h = pointer to complex array of output matrix H
+ ev = pointer to real array of input eigen values
+ u = pointer to complex array of unitary matrix U
+ n = dimension (dim(h)=dim(u)=n*n, dim(ev)=n)
+
+ If D is a diagonal matrix with D[i,j] = ev[i] for i=j and 0
+ otherwise. H = U*D*U^. The columns of U are eigenvectors.
+
+ -----------------------------------------------------------------
+
+unitary
+
+ Generate a random unitary transformation U.
+
+ void unitary(Cpx *u,int n)
+ u = pointer to complex output array for U
+ n = dimension (dim(u)=n*n)
+
+
+ This function calls on the uniform random generator 'unfl' to
+ produce random rotation angles. Therefore this random generator
+ should be initialized by a call of 'setunfl' before calling
+ 'unitary' (see Chapter 7).
+
+ ---------------------------------------------------------------------
+
+cmcpy
+
+ Copy a complex array A = B.
+
+ void cmcpy(Cpx *a,Cpx *b,int n)
+ a = pointer to store for output array
+ b = pointer to store for input array
+ n = dimension of complex arrays A and B
+
+ -----------------------------------------------------------
+
+cmprt
+
+ Print rows of a complex matrix in a specified format.
+
+ void cmprt(Cpx *a,int m,int n,char *f)
+ a = pointer to array of complex m by n matrix
+ m = number of columns
+ n = number of rows
+ f = character array holding format for complex number
+ output (ie., "%f, %f ")
+
+ Long rows may overflow the print line.
Added: grass/trunk/lib/external/ccmath/Makefile
===================================================================
--- grass/trunk/lib/external/ccmath/Makefile (rev 0)
+++ grass/trunk/lib/external/ccmath/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,14 @@
+MODULE_TOPDIR = ../../..
+
+LIB = CCMATH
+
+include $(MODULE_TOPDIR)/include/Make/Lib.make
+
+default: $(ARCH_INCDIR)/ccmath_grass.h
+ $(MAKE) lib
+
+$(ARCH_INCDIR)/ccmath_grass.h: ccmath.h
+ $(INSTALL_DATA) ccmath.h $(ARCH_INCDIR)/ccmath_grass.h
+
+#doxygen:
+DOXNAME=ccmath
Added: grass/trunk/lib/external/ccmath/README
===================================================================
--- grass/trunk/lib/external/ccmath/README (rev 0)
+++ grass/trunk/lib/external/ccmath/README 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,5 @@
+The code in this directory is a part of the
+ccmath library version 2.2.1.
+
+This code is licensed under the terms of the LGPL.
+See the lgpl.license file for details.
Added: grass/trunk/lib/external/ccmath/atou1.c
===================================================================
--- grass/trunk/lib/external/ccmath/atou1.c (rev 0)
+++ grass/trunk/lib/external/ccmath/atou1.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,51 @@
+/* atou1.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+void atou1(double *a, int m, int n)
+{
+ double *p0, *p, *q, *w;
+
+ int i, j, k, mm;
+
+ double s, h;
+
+ w = (double *)calloc(m, sizeof(double));
+ p0 = a + n * n - 1;
+ i = n - 1;
+ mm = m - n;
+ if (mm == 0) {
+ *p0 = 1.;
+ p0 -= n + 1;
+ --i;
+ ++mm;
+ }
+ for (; i >= 0; --i, ++mm, p0 -= n + 1) {
+ if (*p0 != 0.) {
+ for (j = 0, p = p0 + n; j < mm; p += n)
+ w[j++] = *p;
+ h = *p0;
+ *p0 = 1. - h;
+ for (j = 0, p = p0 + n; j < mm; p += n)
+ *p = -h * w[j++];
+ for (k = i + 1, q = p0 + 1; k < n; ++k) {
+ for (j = 0, p = q + n, s = 0.; j < mm; p += n)
+ s += w[j++] * *p;
+ s *= h;
+ for (j = 0, p = q + n; j < mm; p += n)
+ *p -= s * w[j++];
+ *q++ = -s;
+ }
+ }
+ else {
+ *p0 = 1.;
+ for (j = 0, p = p0 + n, q = p0 + 1; j < mm; ++j, p += n)
+ *p = *q++ = 0.;
+ }
+ }
+ free(w);
+}
Added: grass/trunk/lib/external/ccmath/atovm.c
===================================================================
--- grass/trunk/lib/external/ccmath/atovm.c (rev 0)
+++ grass/trunk/lib/external/ccmath/atovm.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,43 @@
+/* atovm.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void atovm(double *v, int n)
+{
+ double *p0, *q0, *p, *q, *qq;
+
+ double h, s;
+
+ int i, j, k, mm;
+
+ q0 = v + n * n - 1;
+ *q0 = 1.;
+ q0 -= n + 1;
+ p0 = v + n * n - n - n - 1;
+ for (i = n - 2, mm = 1; i >= 0; --i, p0 -= n + 1, q0 -= n + 1, ++mm) {
+ if (i && *(p0 - 1) != 0.) {
+ for (j = 0, p = p0, h = 1.; j < mm; ++j, ++p)
+ h += *p * *p;
+ h = *(p0 - 1);
+ *q0 = 1. - h;
+ for (j = 0, q = q0 + n, p = p0; j < mm; ++j, q += n)
+ *q = -h * *p++;
+ for (k = i + 1, q = q0 + 1; k < n; ++k) {
+ for (j = 0, qq = q + n, p = p0, s = 0.; j < mm; ++j, qq += n)
+ s += *qq * *p++;
+ s *= h;
+ for (j = 0, qq = q + n, p = p0; j < mm; ++j, qq += n)
+ *qq -= s * *p++;
+ *q++ = -s;
+ }
+ }
+ else {
+ *q0 = 1.;
+ for (j = 0, p = q0 + 1, q = q0 + n; j < mm; ++j, q += n)
+ *q = *p++ = 0.;
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/ccmath.h
===================================================================
--- grass/trunk/lib/external/ccmath/ccmath.h (rev 0)
+++ grass/trunk/lib/external/ccmath/ccmath.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,181 @@
+/* ccmath.h CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ *
+ * Modified by Soeren gebbert 2009/01/08
+ * Removed al unued functions in grass. Only the linear algebra
+ * functions are used.
+ * ------------------------------------------------------------------------
+ */
+/*
+ CCM
+
+ Numerical Analysis Toolkit Header File
+ ELF Shared Library Version
+*/
+ /* Required for Shared Library */
+#ifndef _CCMATH_H_
+#define _CCMATH_H_
+#define XMATH 1
+
+ /* Define File Pointers and Standard Library */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+
+ /* Definitions of Types */
+
+#ifndef NULL
+#define NULL ((void *)0
+#endif
+
+ /* Complex Types */
+
+#ifndef CPX
+struct complex {double re,im;};
+typedef struct complex Cpx;
+#define CPX 1
+#endif
+
+/* Linear Algebra */
+
+
+ /* Real Linear Systems */
+
+
+ int minv(double *a,int n) ;
+
+ int psinv(double *v,int n) ;
+
+ int ruinv(double *a,int n) ;
+
+ int solv(double *a,double *b,int n) ;
+
+ int solvps(double *s,double *x,int n) ;
+
+ int solvru(double *a,double *b,int n) ;
+
+ void solvtd(double *a,double *b,double *c,double *x,int m) ;
+
+ void eigen(double *a,double *eval,int n) ;
+
+ void eigval(double *a,double *eval,int n) ;
+
+ double evmax(double *a,double *u,int n) ;
+
+ int svdval(double *d,double *a,int m,int n) ;
+
+ int sv2val(double *d,double *a,int m,int n) ;
+
+ int svduv(double *d,double *a,double *u,int m,double *v,int n) ;
+
+ int sv2uv(double *d,double *a,double *u,int m,double *v,int n) ;
+
+ int svdu1v(double *d,double *a,int m,double *v,int n) ;
+
+ int sv2u1v(double *d,double *a,int m,double *v,int n) ;
+
+ void mmul(double *mat,double *a,double *b,int n) ;
+
+ void rmmult(double *mat,double *a,double *b,int m,int k,int n) ;
+
+ void vmul(double *vp,double *mat,double *v,int n) ;
+
+ double vnrm(double *u,double *v,int n) ;
+
+ void matprt(double *a,int n,int m,char *fmt) ;
+
+ void fmatprt(FILE *fp,double *a,int n,int m,char *fmt) ;
+
+ void trnm(double *a,int n) ;
+
+ void mattr(double *a,double *b,int m,int n) ;
+
+ void otrma(double *at,double *u,double *a,int n) ;
+
+ void otrsm(double *st,double *u,double *s0,int n) ;
+
+ void mcopy(double *a,double *b,int m) ;
+
+ void ortho(double *evc,int n) ;
+
+ void smgen(double *a,double *eval,double *evec,int n) ;
+
+ /* utility routines for real symmertic eigensystems */
+
+ void house(double *a,double *d,double *ud,int n) ;
+
+ void housev(double *a,double *d,double *ud,int n) ;
+
+ int qreval(double *eval,double *ud,int n) ;
+
+ int qrevec(double *eval,double *evec,double *dp,int n) ;
+
+ /* utility routines for singular value decomposition */
+
+ int qrbdi(double *d, double *e,int n) ;
+
+ int qrbdv(double *d, double *e,double *u,int m,double *v,int n) ;
+
+ int qrbdu1(double *d, double *e,double *u,int m,double *v,int n) ;
+
+ void ldumat(double *a,double *u,int m,int n) ;
+
+ void ldvmat(double *a,double *v,int n) ;
+
+ void atou1(double *a,int m,int n) ;
+
+ void atovm(double *v,int n) ;
+
+
+ /* Complex Matrix Algebra */
+
+
+ int cminv(Cpx *a,int n) ;
+
+ int csolv(Cpx *a,Cpx *b,int n) ;
+
+ void heigvec(Cpx *a,double *eval,int n) ;
+
+ void heigval(Cpx *a,double *eval,int n) ;
+
+ double hevmax(Cpx *a,Cpx *u,int n) ;
+
+ void cmmul(Cpx *c,Cpx *a,Cpx *b,int n) ;
+
+ void cmmult(Cpx *c,Cpx *a,Cpx *b,int m,int k,int n) ;
+
+ void cvmul(Cpx *vp,Cpx *mat,Cpx *v,int n) ;
+
+ Cpx cvnrm(Cpx *u,Cpx *v,int n) ;
+
+ void cmprt(Cpx *a,int n,int m,char *fmt) ;
+
+ void trncm(Cpx *a,int n) ;
+
+ void hconj(Cpx *u,int n) ;
+
+ void cmattr(Cpx *a,Cpx *b,int m,int n) ;
+
+ void utrncm(Cpx *at,Cpx *u,Cpx *a,int n) ;
+
+ void utrnhm(Cpx *ht,Cpx *u,Cpx *h0,int n) ;
+
+ void cmcpy(Cpx *a,Cpx *b,int n) ;
+
+ void unitary(Cpx *u,int n) ;
+
+ void hmgen(Cpx *h,double *eval,Cpx *u,int n) ;
+
+
+ /* utility routines for hermitian eigen problems */
+
+ void chouse(Cpx *a,double *d,double *ud,int n) ;
+
+ void chousv(Cpx *a,double *d,double *ud,int n) ;
+
+ void qrecvc(double *eval,Cpx *evec,double *ud,int n) ;
+#endif
Added: grass/trunk/lib/external/ccmath/chouse.c
===================================================================
--- grass/trunk/lib/external/ccmath/chouse.c (rev 0)
+++ grass/trunk/lib/external/ccmath/chouse.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,96 @@
+/* chouse.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void chouse(Cpx * a, double *d, double *dp, int n)
+{
+ double sc, x, y;
+
+ Cpx cc, u, *q0;
+
+ int i, j, k, m, e;
+
+ Cpx *qw, *pc, *p;
+
+ q0 = (Cpx *) calloc(2 * n, sizeof(Cpx));
+ for (i = 0, p = q0 + n, pc = a; i < n; ++i, pc += n + 1)
+ *p++ = *pc;
+ for (j = 0, pc = a; j < n - 2; ++j, pc += n + 1) {
+ m = n - j - 1;
+ for (i = 1, sc = 0.; i <= m; ++i)
+ sc += pc[i].re * pc[i].re + pc[i].im * pc[i].im;
+ if (sc > 0.) {
+ sc = sqrt(sc);
+ p = pc + 1;
+ y = sc + (x = sqrt(p->re * p->re + p->im * p->im));
+ if (x > 0.) {
+ cc.re = p->re / x;
+ cc.im = p->im / x;
+ }
+ else {
+ cc.re = 1.;
+ cc.im = 0.;
+ }
+ x = 1. / sqrt(2. * sc * y);
+ y *= x;
+ for (i = 0, qw = pc + 1; i < m; ++i) {
+ q0[i].re = q0[i].im = 0.;
+ if (i) {
+ qw[i].re *= x;
+ qw[i].im *= -x;
+ }
+ else {
+ qw[0].re = y * cc.re;
+ qw[0].im = -y * cc.im;
+ }
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1, y = 0.; i < m;
+ ++i, p += e++) {
+ q0[i].re += (u.re = qw[i].re) * p->re - (u.im =
+ qw[i].im) * p->im;
+ q0[i].im += u.re * p->im + u.im * p->re;
+ ++p;
+ for (k = i + 1; k < m; ++k, ++p) {
+ q0[i].re += qw[k].re * p->re - qw[k].im * p->im;
+ q0[i].im += qw[k].im * p->re + qw[k].re * p->im;
+ q0[k].re += u.re * p->re + u.im * p->im;
+ q0[k].im += u.im * p->re - u.re * p->im;
+ }
+ y += u.re * q0[i].re + u.im * q0[i].im;
+ }
+ for (i = 0; i < m; ++i) {
+ q0[i].re -= y * qw[i].re;
+ q0[i].re += q0[i].re;
+ q0[i].im -= y * qw[i].im;
+ q0[i].im += q0[i].im;
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1; i < m; ++i, p += e++) {
+ for (k = i; k < m; ++k, ++p) {
+ p->re -= qw[i].re * q0[k].re + qw[i].im * q0[k].im
+ + q0[i].re * qw[k].re + q0[i].im * qw[k].im;
+ p->im -= qw[i].im * q0[k].re - qw[i].re * q0[k].im
+ + q0[i].im * qw[k].re - q0[i].re * qw[k].im;
+ }
+ }
+ }
+ d[j] = pc->re;
+ dp[j] = sc;
+ }
+ d[j] = pc->re;
+ d[j + 1] = (pc + n + 1)->re;
+ u = *(pc + 1);
+ dp[j] = sqrt(u.re * u.re + u.im * u.im);
+ for (j = 0, pc = a, qw = q0 + n; j < n; ++j, pc += n + 1) {
+ *pc = qw[j];
+ for (i = 1, p = pc + n; i < n - j; ++i, p += n) {
+ pc[i].re = p->re;
+ pc[i].im = -p->im;
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/chousv.c
===================================================================
--- grass/trunk/lib/external/ccmath/chousv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/chousv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,123 @@
+/* chousv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void chousv(Cpx * a, double *d, double *dp, int n)
+{
+ double sc, x, y;
+
+ Cpx cc, u, *qs;
+
+ int i, j, k, m, e;
+
+ Cpx *qw, *pc, *p, *q;
+
+ qs = (Cpx *) calloc(2 * n, sizeof(Cpx));
+ q = qs + n;
+ for (j = 0, pc = a; j < n - 2; ++j, pc += n + 1, ++q) {
+ m = n - j - 1;
+ for (i = 1, sc = 0.; i <= m; ++i)
+ sc += pc[i].re * pc[i].re + pc[i].im * pc[i].im;
+ if (sc > 0.) {
+ sc = sqrt(sc);
+ p = pc + 1;
+ y = sc + (x = sqrt(p->re * p->re + p->im * p->im));
+ if (x > 0.) {
+ cc.re = p->re / x;
+ cc.im = p->im / x;
+ }
+ else {
+ cc.re = 1.;
+ cc.im = 0.;
+ }
+ q->re = -cc.re;
+ q->im = -cc.im;
+ x = 1. / sqrt(2. * sc * y);
+ y *= x;
+ for (i = 0, qw = pc + 1; i < m; ++i) {
+ qs[i].re = qs[i].im = 0.;
+ if (i) {
+ qw[i].re *= x;
+ qw[i].im *= -x;
+ }
+ else {
+ qw[0].re = y * cc.re;
+ qw[0].im = -y * cc.im;
+ }
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1, y = 0.; i < m;
+ ++i, p += e++) {
+ qs[i].re += (u.re = qw[i].re) * p->re - (u.im =
+ qw[i].im) * p->im;
+ qs[i].im += u.re * p->im + u.im * p->re;
+ ++p;
+ for (k = i + 1; k < m; ++k, ++p) {
+ qs[i].re += qw[k].re * p->re - qw[k].im * p->im;
+ qs[i].im += qw[k].im * p->re + qw[k].re * p->im;
+ qs[k].re += u.re * p->re + u.im * p->im;
+ qs[k].im += u.im * p->re - u.re * p->im;
+ }
+ y += u.re * qs[i].re + u.im * qs[i].im;
+ }
+ for (i = 0; i < m; ++i) {
+ qs[i].re -= y * qw[i].re;
+ qs[i].re += qs[i].re;
+ qs[i].im -= y * qw[i].im;
+ qs[i].im += qs[i].im;
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1; i < m; ++i, p += e++) {
+ for (k = i; k < m; ++k, ++p) {
+ p->re -= qw[i].re * qs[k].re + qw[i].im * qs[k].im
+ + qs[i].re * qw[k].re + qs[i].im * qw[k].im;
+ p->im -= qw[i].im * qs[k].re - qw[i].re * qs[k].im
+ + qs[i].im * qw[k].re - qs[i].re * qw[k].im;
+ }
+ }
+ }
+ d[j] = pc->re;
+ dp[j] = sc;
+ }
+ d[j] = pc->re;
+ cc = *(pc + 1);
+ d[j + 1] = (pc += n + 1)->re;
+ dp[j] = sc = sqrt(cc.re * cc.re + cc.im * cc.im);
+ q->re = cc.re /= sc;
+ q->im = cc.im /= sc;
+ for (i = 0, m = n + n, p = pc; i < m; ++i, --p)
+ p->re = p->im = 0.;
+ pc->re = 1.;
+ (pc -= n + 1)->re = 1.;
+ qw = pc - n;
+ for (m = 2; m < n; ++m, qw -= n + 1) {
+ for (j = 0, p = pc, pc->re = 1.; j < m; ++j, p += n) {
+ for (i = 0, q = p, u.re = u.im = 0.; i < m; ++i, ++q) {
+ u.re += qw[i].re * q->re - qw[i].im * q->im;
+ u.im += qw[i].re * q->im + qw[i].im * q->re;
+ }
+ for (i = 0, q = p, u.re += u.re, u.im += u.im; i < m; ++i, ++q) {
+ q->re -= u.re * qw[i].re + u.im * qw[i].im;
+ q->im -= u.im * qw[i].re - u.re * qw[i].im;
+ }
+ }
+ for (i = 0, p = qw + m - 1; i < n; ++i, --p)
+ p->re = p->im = 0.;
+ (pc -= n + 1)->re = 1.;
+ }
+ for (j = 1, p = a + n + 1, q = qs + n, u.re = 1., u.im = 0.; j < n;
+ ++j, ++p, ++q) {
+ sc = u.re * q->re - u.im * q->im;
+ u.im = u.im * q->re + u.re * q->im;
+ u.re = sc;
+ for (i = 1; i < n; ++i, ++p) {
+ sc = u.re * p->re - u.im * p->im;
+ p->im = u.re * p->im + u.im * p->re;
+ p->re = sc;
+ }
+ }
+ free(qs);
+}
Added: grass/trunk/lib/external/ccmath/cmattr.c
===================================================================
--- grass/trunk/lib/external/ccmath/cmattr.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cmattr.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,18 @@
+/* cmattr.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void cmattr(Cpx * a, Cpx * b, int m, int n)
+{
+ Cpx *p;
+
+ int i, j;
+
+ for (i = 0; i < n; ++i, ++b)
+ for (j = 0, p = b; j < m; ++j, p += n)
+ *a++ = *p;
+}
Added: grass/trunk/lib/external/ccmath/cmcpy.c
===================================================================
--- grass/trunk/lib/external/ccmath/cmcpy.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cmcpy.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,15 @@
+/* cmcpy.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void cmcpy(Cpx * a, Cpx * b, int n)
+{
+ int i;
+
+ for (i = 0; i < n; ++i)
+ *a++ = *b++;
+}
Added: grass/trunk/lib/external/ccmath/cminv.c
===================================================================
--- grass/trunk/lib/external/ccmath/cminv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cminv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,149 @@
+/* cminv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int cminv(Cpx * a, int n)
+{
+ int i, j, k, m, lc, *le;
+
+ Cpx *ps, *p, *q, *pa, *pd;
+
+ Cpx z, h, *q0;
+
+ double s, t, tq = 0., zr = 1.e-15;
+
+ le = (int *)calloc(n, sizeof(int));
+ q0 = (Cpx *) calloc(n, sizeof(Cpx));
+ pa = pd = a;
+ for (j = 0; j < n; ++j, ++pa, pd += n + 1) {
+ if (j > 0) {
+ for (i = 0, p = pa, q = q0; i < n; ++i, p += n)
+ *q++ = *p;
+ for (i = 1; i < n; ++i) {
+ lc = i < j ? i : j;
+ z.re = z.im = 0.;
+ for (k = 0, p = pa + i * n - j, q = q0; k < lc; ++k, ++q, ++p) {
+ z.re += p->re * q->re - p->im * q->im;
+ z.im += p->im * q->re + p->re * q->im;
+ }
+ q0[i].re -= z.re;
+ q0[i].im -= z.im;
+ }
+ for (i = 0, p = pa, q = q0; i < n; ++i, p += n)
+ *p = *q++;
+ }
+ s = fabs(pd->re) + fabs(pd->im);
+ lc = j;
+ for (k = j + 1, ps = pd; k < n; ++k) {
+ ps += n;
+ if ((t = fabs(ps->re) + fabs(ps->im)) > s) {
+ s = t;
+ lc = k;
+ }
+ }
+ tq = tq > s ? tq : s;
+ if (s < zr * tq) {
+ free(le - j);
+ free(q0);
+ return -1;
+ }
+ *le++ = lc;
+ if (lc != j) {
+ p = a + n * j;
+ q = a + n * lc;
+ for (k = 0; k < n; ++k, ++p, ++q) {
+ h = *p;
+ *p = *q;
+ *q = h;
+ }
+ }
+ t = pd->re * pd->re + pd->im * pd->im;
+ h.re = pd->re / t;
+ h.im = -(pd->im) / t;
+ for (k = j + 1, ps = pd + n; k < n; ++k, ps += n) {
+ z.re = ps->re * h.re - ps->im * h.im;
+ z.im = ps->im * h.re + ps->re * h.im;
+ *ps = z;
+ }
+ *pd = h;
+ }
+ for (j = 1, pd = ps = a; j < n; ++j) {
+ for (k = 0, pd += n + 1, q = ++ps; k < j; ++k, q += n) {
+ z.re = q->re * pd->re - q->im * pd->im;
+ z.im = q->im * pd->re + q->re * pd->im;
+ *q = z;
+ }
+ }
+ for (j = 1, pa = a; j < n; ++j) {
+ ++pa;
+ for (i = 0, q = q0, p = pa; i < j; ++i, p += n)
+ *q++ = *p;
+ for (k = 0; k < j; ++k) {
+ h.re = h.im = 0.;
+ for (i = k, p = pa + k * n + k - j, q = q0 + k; i < j; ++i) {
+ h.re -= p->re * q->re - p->im * q->im;
+ h.im -= p->im * q->re + p->re * q->im;
+ ++p;
+ ++q;
+ }
+ q0[k] = h;
+ }
+ for (i = 0, q = q0, p = pa; i < j; ++i, p += n)
+ *p = *q++;
+ }
+ for (j = n - 2, pd = pa = a + n * n - 1; j >= 0; --j) {
+ --pa;
+ pd -= n + 1;
+ for (i = 0, m = n - j - 1, q = q0, p = pd + n; i < m; ++i, p += n)
+ *q++ = *p;
+ for (k = n - 1, ps = pa; k > j; --k, ps -= n) {
+ z.re = -ps->re;
+ z.im = -ps->im;
+ for (i = j + 1, p = ps + 1, q = q0; i < k; ++i, ++p, ++q) {
+ z.re -= p->re * q->re - p->im * q->im;
+ z.im -= p->im * q->re + p->re * q->im;
+ }
+ q0[--m] = z;
+ }
+ for (i = 0, m = n - j - 1, q = q0, p = pd + n; i < m; ++i, p += n)
+ *p = *q++;
+ }
+ for (k = 0, pa = a; k < n - 1; ++k, ++pa) {
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *q++ = *p;
+ for (j = 0, ps = a; j < n; ++j, ps += n) {
+ if (j > k) {
+ h.re = h.im = 0.;
+ p = ps + j;
+ i = j;
+ }
+ else {
+ h = q0[j];
+ p = ps + k + 1;
+ i = k + 1;
+ }
+ for (; i < n; ++i, ++p) {
+ h.re += p->re * q0[i].re - p->im * q0[i].im;
+ h.im += p->im * q0[i].re + p->re * q0[i].im;
+ }
+ q0[j] = h;
+ }
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *p = *q++;
+ }
+ for (j = n - 2, le--; j >= 0; --j) {
+ for (k = 0, p = a + j, q = a + *(--le); k < n; ++k, p += n, q += n) {
+ h = *p;
+ *p = *q;
+ *q = h;
+ }
+ }
+ free(le);
+ free(q0);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/cmmul.c
===================================================================
--- grass/trunk/lib/external/ccmath/cmmul.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cmmul.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,28 @@
+/* cmmul.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void cmmul(Cpx * c, Cpx * a, Cpx * b, int n)
+{
+ Cpx s, *p, *q;
+
+ int i, j, k;
+
+ trncm(b, n);
+ for (i = 0; i < n; ++i, a += n) {
+ for (j = 0, q = b; j < n; ++j) {
+ for (k = 0, p = a, s.re = s.im = 0.; k < n; ++k) {
+ s.re += p->re * q->re - p->im * q->im;
+ s.im += p->im * q->re + p->re * q->im;
+ ++p;
+ ++q;
+ }
+ *c++ = s;
+ }
+ }
+ trncm(b, n);
+}
Added: grass/trunk/lib/external/ccmath/cmmult.c
===================================================================
--- grass/trunk/lib/external/ccmath/cmmult.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cmmult.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,29 @@
+/* cmmult.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void cmmult(Cpx * cm, Cpx * a, Cpx * b, int n, int m, int l)
+{
+ Cpx z, *q0, *p, *q;
+
+ int i, j, k;
+
+ q0 = (Cpx *) calloc(m, sizeof(Cpx));
+ for (i = 0; i < l; ++i, ++cm) {
+ for (k = 0, p = b + i; k < m; p += l)
+ q0[k++] = *p;
+ for (j = 0, p = a, q = cm; j < n; ++j, q += l) {
+ for (k = 0, z.re = z.im = 0.; k < m; ++k, ++p) {
+ z.re += p->re * q0[k].re - p->im * q0[k].im;
+ z.im += p->im * q0[k].re + p->re * q0[k].im;
+ }
+ *q = z;
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/cmprt.c
===================================================================
--- grass/trunk/lib/external/ccmath/cmprt.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cmprt.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,20 @@
+/* cmprt.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void cmprt(Cpx * a, int m, int n, char *f)
+{
+ int i, j;
+
+ Cpx *p;
+
+ for (i = 0, p = a; i < m; ++i) {
+ for (j = 0; j < n; ++j, ++p)
+ printf(f, p->re, p->im);
+ printf("\n");
+ }
+}
Added: grass/trunk/lib/external/ccmath/csolv.c
===================================================================
--- grass/trunk/lib/external/ccmath/csolv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/csolv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,102 @@
+/* csolv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int csolv(Cpx * a, Cpx * b, int n)
+{
+ int i, j, k, lc;
+
+ Cpx *ps, *p, *q, *pa, *pd;
+
+ Cpx z, h, *q0;
+
+ double s, t, tq = 0., zr = 1.e-15;
+
+ q0 = (Cpx *) calloc(n, sizeof(Cpx));
+ pa = a;
+ pd = a;
+ for (j = 0; j < n; ++j, ++pa, pd += n + 1) {
+ if (j > 0) {
+ for (i = 0, p = pa, q = q0; i < n; ++i, p += n)
+ *q++ = *p;
+ for (i = 1; i < n; ++i) {
+ lc = i < j ? i : j;
+ z.re = z.im = 0.;
+ for (k = 0, p = pa + i * n - j, q = q0; k < lc; ++k, ++q, ++p) {
+ z.re += p->re * q->re - p->im * q->im;
+ z.im += p->im * q->re + p->re * q->im;
+ }
+ q0[i].re -= z.re;
+ q0[i].im -= z.im;
+ }
+ for (i = 0, p = pa, q = q0; i < n; ++i, p += n)
+ *p = *q++;
+ }
+ s = fabs(pd->re) + fabs(pd->im);
+ lc = j;
+ for (k = j + 1, ps = pd; k < n; ++k) {
+ ps += n;
+ if ((t = fabs(ps->re) + fabs(ps->im)) > s) {
+ s = t;
+ lc = k;
+ }
+ }
+ tq = tq > s ? tq : s;
+ if (s < zr * tq) {
+ free(q0);
+ return -1;
+ }
+ if (lc != j) {
+ h = b[j];
+ b[j] = b[lc];
+ b[lc] = h;
+ p = a + n * j;
+ q = a + n * lc;
+ for (k = 0; k < n; ++k) {
+ h = *p;
+ *p++ = *q;
+ *q++ = h;
+ }
+ }
+ t = pd->re * pd->re + pd->im * pd->im;
+ h.re = pd->re / t;
+ h.im = -(pd->im) / t;
+ for (k = j + 1, ps = pd + n; k < n; ++k, ps += n) {
+ z.re = ps->re * h.re - ps->im * h.im;
+ z.im = ps->im * h.re + ps->re * h.im;
+ *ps = z;
+ }
+ }
+ for (j = 1, ps = b + 1; j < n; ++j, ++ps) {
+ for (k = 0, p = a + n * j, q = b, z.re = z.im = 0.; k < j; ++k) {
+ z.re += p->re * q->re - p->im * q->im;
+ z.im += p->im * q->re + p->re * q->im;
+ ++p;
+ ++q;
+ }
+ ps->re -= z.re;
+ ps->im -= z.im;
+ }
+ for (j = n - 1, --ps, pd = a + n * n - 1; j >= 0; --j, pd -= n + 1) {
+ for (k = j + 1, p = pd + 1, q = b + j + 1, z.re = z.im = 0.; k < n;
+ ++k) {
+ z.re += p->re * q->re - p->im * q->im;
+ z.im += p->im * q->re + p->re * q->im;
+ ++p;
+ ++q;
+ }
+ h.re = ps->re - z.re;
+ h.im = ps->im - z.im;
+ t = pd->re * pd->re + pd->im * pd->im;
+ ps->re = (h.re * pd->re + h.im * pd->im) / t;
+ ps->im = (h.im * pd->re - h.re * pd->im) / t;
+ --ps;
+ }
+ free(q0);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/cvmul.c
===================================================================
--- grass/trunk/lib/external/ccmath/cvmul.c (rev 0)
+++ grass/trunk/lib/external/ccmath/cvmul.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,36 @@
+/* cvmul.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void cvmul(Cpx * u, Cpx * a, Cpx * v, int n)
+{
+ Cpx *q;
+
+ int i, j;
+
+ for (i = 0; i < n; ++i, ++u) {
+ u->re = u->im = 0.;
+ for (j = 0, q = v; j < n; ++j, ++a, ++q) {
+ u->re += a->re * q->re - a->im * q->im;
+ u->im += a->im * q->re + a->re * q->im;
+ }
+ }
+}
+
+Cpx cvnrm(Cpx * u, Cpx * v, int n)
+{
+ int k;
+
+ Cpx z;
+
+ z.re = z.im = 0.;
+ for (k = 0; k < n; ++k, ++u, ++v) {
+ z.re += u->re * v->re + u->im * v->im;
+ z.im += u->re * v->im - u->im * v->re;
+ }
+ return z;
+}
Added: grass/trunk/lib/external/ccmath/eigen.c
===================================================================
--- grass/trunk/lib/external/ccmath/eigen.c (rev 0)
+++ grass/trunk/lib/external/ccmath/eigen.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,19 @@
+/* eigen.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void eigen(double *a, double *ev, int n)
+{
+ double *dp;
+
+ dp = (double *)calloc(n, sizeof(double));
+ housev(a, ev, dp, n);
+ qrevec(ev, a, dp, n);
+ trnm(a, n);
+ free(dp);
+}
Added: grass/trunk/lib/external/ccmath/eigval.c
===================================================================
--- grass/trunk/lib/external/ccmath/eigval.c (rev 0)
+++ grass/trunk/lib/external/ccmath/eigval.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,18 @@
+/* eigval.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void eigval(double *a, double *ev, int n)
+{
+ double *dp;
+
+ dp = (double *)calloc(n, sizeof(double));
+ house(a, ev, dp, n);
+ qreval(ev, dp, n);
+ free(dp);
+}
Added: grass/trunk/lib/external/ccmath/evmax.c
===================================================================
--- grass/trunk/lib/external/ccmath/evmax.c (rev 0)
+++ grass/trunk/lib/external/ccmath/evmax.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,47 @@
+/* evmax.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+double evmax(double *a, double *u, int n)
+{
+ double *p, *q, *qm, *r, *s, *t;
+
+ double ev, evm, c, h;
+
+ int kc;
+
+ q = (double *)calloc(n, sizeof(double));
+ qm = q + n;
+ *(qm - 1) = 1.;
+ ev = 0.;
+ for (kc = 0; kc < 200; ++kc) {
+ h = c = 0.;
+ evm = ev;
+ for (p = u, r = a, s = q; s < qm;) {
+ *p = 0.;
+ for (t = q; t < qm;)
+ *p += *r++ * *t++;
+ c += *p * *p;
+ h += *p++ * *s++;
+ }
+ ev = c / h;
+ c = sqrt(c);
+ for (p = u, s = q; s < qm;) {
+ *p /= c;
+ *s++ = *p++;
+ }
+ if (((c = ev - evm) < 0. ? -c : c) < 1.e-16 * (ev < 0. ? -ev : ev)) {
+ free(q);
+ return ev;
+ }
+ }
+ free(q);
+ for (kc = 0; kc < n;)
+ u[kc++] = 0.;
+ return 0.;
+}
Added: grass/trunk/lib/external/ccmath/hconj.c
===================================================================
--- grass/trunk/lib/external/ccmath/hconj.c (rev 0)
+++ grass/trunk/lib/external/ccmath/hconj.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,26 @@
+/* hconj.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void hconj(Cpx * a, int n)
+{
+ Cpx s, *p, *q;
+
+ int i, j, e;
+
+ for (i = 0, e = n - 1; i < n; ++i, --e, a += n + 1) {
+ for (j = 0, p = a + 1, q = a + n; j < e; ++j) {
+ s = *p;
+ s.im = -s.im;
+ p->re = q->re;
+ (p++)->im = -q->im;
+ *q = s;
+ q += n;
+ }
+ a->im = -a->im;
+ }
+}
Added: grass/trunk/lib/external/ccmath/heigval.c
===================================================================
--- grass/trunk/lib/external/ccmath/heigval.c (rev 0)
+++ grass/trunk/lib/external/ccmath/heigval.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,18 @@
+/* heigval.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void heigval(Cpx * a, double *ev, int n)
+{
+ double *dp;
+
+ dp = (double *)calloc(n, sizeof(double));
+ chouse(a, ev, dp, n);
+ qreval(ev, dp, n);
+ free(dp);
+}
Added: grass/trunk/lib/external/ccmath/heigvec.c
===================================================================
--- grass/trunk/lib/external/ccmath/heigvec.c (rev 0)
+++ grass/trunk/lib/external/ccmath/heigvec.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,19 @@
+/* heigvec.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void heigvec(Cpx * a, double *ev, int n)
+{
+ double *dp;
+
+ dp = (double *)calloc(n, sizeof(double));
+ chousv(a, ev, dp, n);
+ qrecvc(ev, a, dp, n);
+ hconj(a, n);
+ free(dp);
+}
Added: grass/trunk/lib/external/ccmath/hevmax.c
===================================================================
--- grass/trunk/lib/external/ccmath/hevmax.c (rev 0)
+++ grass/trunk/lib/external/ccmath/hevmax.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,42 @@
+/* hevmax.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+double hevmax(Cpx * a, Cpx * u, int n)
+{
+ Cpx *x, *p, h;
+
+ double e, ep, s, t, te = 1.e-12;
+
+ int k, j;
+
+ x = (Cpx *) calloc(n, sizeof(Cpx));
+ x[0].re = 1.;
+ e = 0.;
+ do {
+ for (k = 0, p = a, s = t = 0.; k < n; ++k) {
+ for (j = 0, h.re = h.im = 0.; j < n; ++j, ++p) {
+ h.re += p->re * x[j].re - p->im * x[j].im;
+ h.im += p->im * x[j].re + p->re * x[j].im;
+ }
+ s += h.re * h.re + h.im * h.im;
+ t += h.re * x[k].re + h.im * x[k].im;
+ u[k] = h;
+ }
+ ep = e;
+ e = s / t;
+ s = 1. / sqrt(s);
+ for (k = 0; k < n; ++k) {
+ u[k].re *= s;
+ u[k].im *= s;
+ x[k] = u[k];
+ }
+ } while (fabs(e - ep) > fabs(te * e));
+ free(x);
+ return e;
+}
Added: grass/trunk/lib/external/ccmath/hmgen.c
===================================================================
--- grass/trunk/lib/external/ccmath/hmgen.c (rev 0)
+++ grass/trunk/lib/external/ccmath/hmgen.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,29 @@
+/* hmgen.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void hmgen(Cpx * h, double *ev, Cpx * u, int n)
+{
+ Cpx *v, *p;
+
+ int i, j;
+
+ double e;
+
+ v = (Cpx *) calloc(n * n, sizeof(Cpx));
+ cmcpy(v, u, n * n);
+ hconj(v, n);
+ for (i = 0, p = v; i < n; ++i) {
+ for (j = 0, e = ev[i]; j < n; ++j, ++p) {
+ p->re *= e;
+ p->im *= e;
+ }
+ }
+ cmmul(h, u, v, n);
+ free(v);
+}
Added: grass/trunk/lib/external/ccmath/house.c
===================================================================
--- grass/trunk/lib/external/ccmath/house.c (rev 0)
+++ grass/trunk/lib/external/ccmath/house.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,73 @@
+/* house.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void house(double *a, double *d, double *dp, int n)
+{
+ double sc, x, y, h;
+
+ int i, j, k, m, e;
+
+ double *qw, *qs, *pc, *p;
+
+ qs = (double *)calloc(2 * n, sizeof(double));
+ for (j = 0, qw = qs + n, pc = a; j < n; pc += n + 1)
+ qw[j++] = *pc;
+ for (j = 0, pc = a; j < n - 2; ++j, pc += n + 1) {
+ m = n - j - 1;
+ for (i = 1, sc = 0.; i <= m; ++i)
+ sc += pc[i] * pc[i];
+ if (sc > 0.) {
+ sc = sqrt(sc);
+ if ((x = *(pc + 1)) < 0.) {
+ y = x - sc;
+ h = 1. / sqrt(-2. * sc * y);
+ }
+ else {
+ y = x + sc;
+ h = 1. / sqrt(2. * sc * y);
+ sc = -sc;
+ }
+ for (i = 0, qw = pc + 1; i < m; ++i) {
+ qs[i] = 0.;
+ if (i)
+ qw[i] *= h;
+ else
+ qw[i] = y * h;
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1, h = 0.; i < m;
+ ++i, p += e++) {
+ qs[i] += (y = qw[i]) * *p++;
+ for (k = i + 1; k < m; ++k) {
+ qs[i] += qw[k] * *p;
+ qs[k] += y * *p++;
+ }
+ h += y * qs[i];
+ }
+ for (i = 0; i < m; ++i) {
+ qs[i] -= h * qw[i];
+ qs[i] += qs[i];
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1; i < m; ++i, p += e++) {
+ for (k = i; k < m; ++k)
+ *p++ -= qw[i] * qs[k] + qs[i] * qw[k];
+ }
+ }
+ d[j] = *pc;
+ dp[j] = sc;
+ }
+ d[j] = *pc;
+ dp[j] = *(pc + 1);
+ d[j + 1] = *(pc + n + 1);
+ for (j = 0, pc = a, qw = qs + n; j < n; ++j, pc += n + 1) {
+ *pc = qw[j];
+ for (i = 1, p = pc + n; i < n - j; p += n)
+ pc[i++] = *p;
+ }
+ free(qs);
+}
Added: grass/trunk/lib/external/ccmath/housev.c
===================================================================
--- grass/trunk/lib/external/ccmath/housev.c (rev 0)
+++ grass/trunk/lib/external/ccmath/housev.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,82 @@
+/* housev.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void housev(double *a, double *d, double *dp, int n)
+{
+ double sc, x, y, h;
+
+ int i, j, k, m, e;
+
+ double *qw, *qs, *pc, *p;
+
+ qs = (double *)calloc(n, sizeof(double));
+ for (j = 0, pc = a; j < n - 2; ++j, pc += n + 1) {
+ m = n - j - 1;
+ for (i = 1, sc = 0.; i <= m; ++i)
+ sc += pc[i] * pc[i];
+ if (sc > 0.) {
+ sc = sqrt(sc);
+ if ((x = *(pc + 1)) < 0.) {
+ y = x - sc;
+ h = 1. / sqrt(-2. * sc * y);
+ }
+ else {
+ y = x + sc;
+ h = 1. / sqrt(2. * sc * y);
+ sc = -sc;
+ }
+ for (i = 0, qw = pc + 1; i < m; ++i) {
+ qs[i] = 0.;
+ if (i)
+ qw[i] *= h;
+ else
+ qw[i] = y * h;
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1, h = 0.; i < m;
+ ++i, p += e++) {
+ qs[i] += (y = qw[i]) * *p++;
+ for (k = i + 1; k < m; ++k) {
+ qs[i] += qw[k] * *p;
+ qs[k] += y * *p++;
+ }
+ h += y * qs[i];
+ }
+ for (i = 0; i < m; ++i) {
+ qs[i] -= h * qw[i];
+ qs[i] += qs[i];
+ }
+ for (i = 0, e = j + 2, p = pc + n + 1; i < m; ++i, p += e++) {
+ for (k = i; k < m; ++k)
+ *p++ -= qw[i] * qs[k] + qs[i] * qw[k];
+ }
+ }
+ d[j] = *pc;
+ dp[j] = sc;
+ }
+ d[j] = *pc;
+ dp[j] = *(pc + 1);
+ d[j + 1] = *(pc += n + 1);
+ free(qs);
+ for (i = 0, m = n + n, p = pc; i < m; ++i)
+ *p-- = 0.;
+ *pc = 1.;
+ *(pc -= n + 1) = 1.;
+ qw = pc - n;
+ for (m = 2; m < n; ++m, qw -= n + 1) {
+ for (j = 0, p = pc, *pc = 1.; j < m; ++j, p += n) {
+ for (i = 0, qs = p, h = 0.; i < m;)
+ h += qw[i++] * *qs++;
+ for (i = 0, qs = p, h += h; i < m;)
+ *qs++ -= h * qw[i++];
+ }
+ for (i = 0, p = qw + m; i < n; ++i)
+ *(--p) = 0.;
+ *(pc -= n + 1) = 1.;
+ }
+}
Added: grass/trunk/lib/external/ccmath/ldumat.c
===================================================================
--- grass/trunk/lib/external/ccmath/ldumat.c (rev 0)
+++ grass/trunk/lib/external/ccmath/ldumat.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,57 @@
+/* ldumat.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+void ldumat(double *a, double *u, int m, int n)
+{
+ double *p0, *q0, *p, *q, *w;
+
+ int i, j, k, mm;
+
+ double s, h;
+
+ w = (double *)calloc(m, sizeof(double));
+ for (i = 0, mm = m * m, q = u; i < mm; ++i)
+ *q++ = 0.;
+ p0 = a + n * n - 1;
+ q0 = u + m * m - 1;
+ mm = m - n;
+ i = n - 1;
+ for (j = 0; j < mm; ++j, q0 -= m + 1)
+ *q0 = 1.;
+ if (mm == 0) {
+ p0 -= n + 1;
+ *q0 = 1.;
+ q0 -= m + 1;
+ --i;
+ ++mm;
+ }
+ for (; i >= 0; --i, ++mm, p0 -= n + 1, q0 -= m + 1) {
+ if (*p0 != 0.) {
+ for (j = 0, p = p0 + n, h = 1.; j < mm; p += n)
+ w[j++] = *p;
+ h = *p0;
+ *q0 = 1. - h;
+ for (j = 0, q = q0 + m; j < mm; q += m)
+ *q = -h * w[j++];
+ for (k = i + 1, q = q0 + 1; k < m; ++k) {
+ for (j = 0, p = q + m, s = 0.; j < mm; p += m)
+ s += w[j++] * *p;
+ s *= h;
+ for (j = 0, p = q + m; j < mm; p += m)
+ *p -= s * w[j++];
+ *q++ = -s;
+ }
+ }
+ else {
+ *q0 = 1.;
+ for (j = 0, p = q0 + 1, q = q0 + m; j < mm; ++j, q += m)
+ *q = *p++ = 0.;
+ }
+ }
+ free(w);
+}
Added: grass/trunk/lib/external/ccmath/ldvmat.c
===================================================================
--- grass/trunk/lib/external/ccmath/ldvmat.c (rev 0)
+++ grass/trunk/lib/external/ccmath/ldvmat.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,46 @@
+/* ldvmat.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void ldvmat(double *a, double *v, int n)
+{
+ double *p0, *q0, *p, *q, *qq;
+
+ double h, s;
+
+ int i, j, k, mm;
+
+ for (i = 0, mm = n * n, q = v; i < mm; ++i)
+ *q++ = 0.;
+ *v = 1.;
+ q0 = v + n * n - 1;
+ *q0 = 1.;
+ q0 -= n + 1;
+ p0 = a + n * n - n - n - 1;
+ for (i = n - 2, mm = 1; i > 0; --i, p0 -= n + 1, q0 -= n + 1, ++mm) {
+ if (*(p0 - 1) != 0.) {
+ for (j = 0, p = p0, h = 1.; j < mm; ++j, ++p)
+ h += *p * *p;
+ h = *(p0 - 1);
+ *q0 = 1. - h;
+ for (j = 0, q = q0 + n, p = p0; j < mm; ++j, q += n)
+ *q = -h * *p++;
+ for (k = i + 1, q = q0 + 1; k < n; ++k) {
+ for (j = 0, qq = q + n, p = p0, s = 0.; j < mm; ++j, qq += n)
+ s += *qq * *p++;
+ s *= h;
+ for (j = 0, qq = q + n, p = p0; j < mm; ++j, qq += n)
+ *qq -= s * *p++;
+ *q++ = -s;
+ }
+ }
+ else {
+ *q0 = 1.;
+ for (j = 0, p = q0 + 1, q = q0 + n; j < mm; ++j, q += n)
+ *q = *p++ = 0.;
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/lgpl.license
===================================================================
--- grass/trunk/lib/external/ccmath/lgpl.license (rev 0)
+++ grass/trunk/lib/external/ccmath/lgpl.license 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,513 @@
+
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL. It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+ This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it. You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations
+below.
+
+ When we speak of free software, we are referring to freedom of use,
+not price. Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+ To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights. These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+ For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you. You must make sure that they, too, receive or can get the source
+code. If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it. And you must show them these terms so they know their rights.
+
+ We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+ To protect each distributor, we want to make it very clear that
+there is no warranty for the free library. Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+^L
+ Finally, software patents pose a constant threat to the existence of
+any free program. We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder. Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+ Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License. This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License. We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+ When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library. The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom. The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+ We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License. It also provides other free software developers Less
+of an advantage over competing non-free programs. These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries. However, the Lesser license provides advantages in certain
+special circumstances.
+
+ For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it
+becomes a de-facto standard. To achieve this, non-free programs must be
+allowed to use the library. A more frequent case is that a free
+library does the same job as widely used non-free libraries. In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+ In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software. For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+ Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+ The precise terms and conditions for copying, distribution and
+modification follow. Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library". The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+^L
+ GNU LESSER GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+ A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+ The "Library", below, refers to any such software library or work
+which has been distributed under these terms. A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language. (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+ "Source code" for a work means the preferred form of the work for
+making modifications to it. For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control
+compilation and installation of the library.
+
+ Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it). Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+ 1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+ You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+ 2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+
+ b) You must cause the files modified to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ c) You must cause the whole of the work to be licensed at no
+ charge to all third parties under the terms of this License.
+
+ d) If a facility in the modified Library refers to a function or a
+ table of data to be supplied by an application program that uses
+ the facility, other than as an argument passed when the facility
+ is invoked, then you must make a good faith effort to ensure that,
+ in the event an application does not supply such function or
+ table, the facility still operates, and performs whatever part of
+ its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has
+ a purpose that is entirely well-defined independent of the
+ application. Therefore, Subsection 2d requires that any
+ application-supplied function or table used by this function must
+ be optional: if the application does not supply it, the square
+ root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library. To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License. (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.) Do not make any other change in
+these notices.
+^L
+ Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+ This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+ 4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+ If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library". Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+ However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library". The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+ When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library. The
+threshold for this to be true is not precisely defined by law.
+
+ If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work. (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+ Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+^L
+ 6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+ You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License. You must supply a copy of this License. If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License. Also, you must do one
+of these things:
+
+ a) Accompany the work with the complete corresponding
+ machine-readable source code for the Library including whatever
+ changes were used in the work (which must be distributed under
+ Sections 1 and 2 above); and, if the work is an executable linked
+ with the Library, with the complete machine-readable "work that
+ uses the Library", as object code and/or source code, so that the
+ user can modify the Library and then relink to produce a modified
+ executable containing the modified Library. (It is understood
+ that the user who changes the contents of definitions files in the
+ Library will not necessarily be able to recompile the application
+ to use the modified definitions.)
+
+ b) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (1) uses at run time a
+ copy of the library already present on the user's computer system,
+ rather than copying library functions into the executable, and (2)
+ will operate properly with a modified version of the library, if
+ the user installs one, as long as the modified version is
+ interface-compatible with the version that the work was made with.
+
+ c) Accompany the work with a written offer, valid for at
+ least three years, to give the same user the materials
+ specified in Subsection 6a, above, for a charge no more
+ than the cost of performing this distribution.
+
+ d) If distribution of the work is made by offering access to copy
+ from a designated place, offer equivalent access to copy the above
+ specified materials from the same place.
+
+ e) Verify that the user has already received a copy of these
+ materials or that you have already sent this user a copy.
+
+ For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it. However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+ It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system. Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+^L
+ 7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities. This must be distributed under the terms of the
+ Sections above.
+
+ b) Give prominent notice with the combined library of the fact
+ that part of it is a work based on the Library, and explaining
+ where to find the accompanying uncombined form of the same work.
+
+ 8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License. Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License. However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+ 9. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Library or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+ 10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+^L
+ 11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all. For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply, and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License
+may add an explicit geographical distribution limitation excluding those
+countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation. If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+^L
+ 14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission. For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this. Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+ NO WARRANTY
+
+ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+^L
+ How to Apply These Terms to Your New Libraries
+
+ If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change. You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms
+of the ordinary General Public License).
+
+ To apply these terms, attach the following notices to the library.
+It is safest to attach them to the start of each source file to most
+effectively convey the exclusion of warranty; and each file should
+have at least the "copyright" line and a pointer to where the full
+notice is found.
+
+
+ <one line to give the library's name and a brief idea of what it
+does.>
+ Copyright (C) <year> <name of author>
+
+ This library 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 of the License, or (at your option) any later version.
+
+ This library 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 library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+You should also get your employer (if you work as a programmer) or
+your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ library `Frob' (a library for tweaking knobs) written by James
+Random Hacker.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
Added: grass/trunk/lib/external/ccmath/matprt.c
===================================================================
--- grass/trunk/lib/external/ccmath/matprt.c (rev 0)
+++ grass/trunk/lib/external/ccmath/matprt.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,33 @@
+/* matprt.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdio.h>
+void matprt(double *a, int n, int m, char *fmt)
+{
+ int i, j;
+
+ double *p;
+
+ for (i = 0, p = a; i < n; ++i) {
+ for (j = 0; j < m; ++j)
+ printf(fmt, *p++);
+ printf("\n");
+ }
+}
+
+void fmatprt(FILE * fp, double *a, int n, int m, char *fmt)
+{
+ int i, j;
+
+ double *p;
+
+ for (i = 0, p = a; i < n; ++i) {
+ for (j = 0; j < m; ++j)
+ fprintf(fp, fmt, *p++);
+ fprintf(fp, "\n");
+ }
+}
Added: grass/trunk/lib/external/ccmath/mattr.c
===================================================================
--- grass/trunk/lib/external/ccmath/mattr.c (rev 0)
+++ grass/trunk/lib/external/ccmath/mattr.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,17 @@
+/* mattr.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void mattr(double *a, double *b, int m, int n)
+{
+ double *p;
+
+ int i, j;
+
+ for (i = 0; i < n; ++i, ++b)
+ for (j = 0, p = b; j < m; ++j, p += n)
+ *a++ = *p;
+}
Added: grass/trunk/lib/external/ccmath/mcopy.c
===================================================================
--- grass/trunk/lib/external/ccmath/mcopy.c (rev 0)
+++ grass/trunk/lib/external/ccmath/mcopy.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,16 @@
+/* mcopy.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void mcopy(double *a, double *b, int m)
+{
+ double *p, *q;
+
+ int k;
+
+ for (p = a, q = b, k = 0; k < m; ++k)
+ *p++ = *q++;
+}
Added: grass/trunk/lib/external/ccmath/minv.c
===================================================================
--- grass/trunk/lib/external/ccmath/minv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/minv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,123 @@
+/* minv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int minv(double *a, int n)
+{
+ int lc, *le;
+
+ double s, t, tq = 0., zr = 1.e-15;
+
+ double *pa, *pd, *ps, *p, *q, *q0;
+
+ int i, j, k, m;
+
+ le = (int *)malloc(n * sizeof(int));
+ q0 = (double *)malloc(n * sizeof(double));
+ for (j = 0, pa = pd = a; j < n; ++j, ++pa, pd += n + 1) {
+ if (j > 0) {
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *q++ = *p;
+ for (i = 1; i < n; ++i) {
+ lc = i < j ? i : j;
+ for (k = 0, p = pa + i * n - j, q = q0, t = 0.; k < lc; ++k)
+ t += *p++ * *q++;
+ q0[i] -= t;
+ }
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *p = *q++;
+ }
+ s = fabs(*pd);
+ lc = j;
+ for (k = j + 1, ps = pd; k < n; ++k) {
+ if ((t = fabs(*(ps += n))) > s) {
+ s = t;
+ lc = k;
+ }
+ }
+ tq = tq > s ? tq : s;
+ if (s < zr * tq) {
+ free(le - j);
+ free(q0);
+ return -1;
+ }
+ *le++ = lc;
+ if (lc != j) {
+ for (k = 0, p = a + n * j, q = a + n * lc; k < n; ++k) {
+ t = *p;
+ *p++ = *q;
+ *q++ = t;
+ }
+ }
+ for (k = j + 1, ps = pd, t = 1. / *pd; k < n; ++k)
+ *(ps += n) *= t;
+ *pd = t;
+ }
+ for (j = 1, pd = ps = a; j < n; ++j) {
+ for (k = 0, pd += n + 1, q = ++ps; k < j; ++k, q += n)
+ *q *= *pd;
+ }
+ for (j = 1, pa = a; j < n; ++j) {
+ ++pa;
+ for (i = 0, q = q0, p = pa; i < j; ++i, p += n)
+ *q++ = *p;
+ for (k = 0; k < j; ++k) {
+ t = 0.;
+ for (i = k, p = pa + k * n + k - j, q = q0 + k; i < j; ++i)
+ t -= *p++ * *q++;
+ q0[k] = t;
+ }
+ for (i = 0, q = q0, p = pa; i < j; ++i, p += n)
+ *p = *q++;
+ }
+ for (j = n - 2, pd = pa = a + n * n - 1; j >= 0; --j) {
+ --pa;
+ pd -= n + 1;
+ for (i = 0, m = n - j - 1, q = q0, p = pd + n; i < m; ++i, p += n)
+ *q++ = *p;
+ for (k = n - 1, ps = pa; k > j; --k, ps -= n) {
+ t = -(*ps);
+ for (i = j + 1, p = ps, q = q0; i < k; ++i)
+ t -= *++p * *q++;
+ q0[--m] = t;
+ }
+ for (i = 0, m = n - j - 1, q = q0, p = pd + n; i < m; ++i, p += n)
+ *p = *q++;
+ }
+ for (k = 0, pa = a; k < n - 1; ++k, ++pa) {
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *q++ = *p;
+ for (j = 0, ps = a; j < n; ++j, ps += n) {
+ if (j > k) {
+ t = 0.;
+ p = ps + j;
+ i = j;
+ }
+ else {
+ t = q0[j];
+ p = ps + k + 1;
+ i = k + 1;
+ }
+ for (; i < n;)
+ t += *p++ * q0[i++];
+ q0[j] = t;
+ }
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *p = *q++;
+ }
+ for (j = n - 2, le--; j >= 0; --j) {
+ for (k = 0, p = a + j, q = a + *(--le); k < n; ++k, p += n, q += n) {
+ t = *p;
+ *p = *q;
+ *q = t;
+ }
+ }
+ free(le);
+ free(q0);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/mmul.c
===================================================================
--- grass/trunk/lib/external/ccmath/mmul.c (rev 0)
+++ grass/trunk/lib/external/ccmath/mmul.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,24 @@
+/* mmul.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void mmul(double *c, double *a, double *b, int n)
+{
+ double *p, *q, s;
+
+ int i, j, k;
+
+ trnm(b, n);
+ for (i = 0; i < n; ++i, a += n) {
+ for (j = 0, q = b; j < n; ++j) {
+ for (k = 0, p = a, s = 0.; k < n; ++k)
+ s += *p++ * *q++;
+ *c++ = s;
+ }
+ }
+ trnm(b, n);
+}
Added: grass/trunk/lib/external/ccmath/ortho.c
===================================================================
--- grass/trunk/lib/external/ccmath/ortho.c (rev 0)
+++ grass/trunk/lib/external/ccmath/ortho.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,40 @@
+/* ortho.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+static double tpi = 6.28318530717958647;
+
+void ortho(double *e, int n)
+{
+ int i, j, k, m;
+
+ double *p, *q, c, s, a, unfl();
+
+ for (i = 0, p = e; i < n; ++i) {
+ for (j = 0; j < n; ++j) {
+ if (i == j)
+ *p++ = 1.;
+ else
+ *p++ = 0.;
+ }
+ }
+ for (i = 0, m = n - 1; i < m; ++i) {
+ for (j = i + 1; j < n; ++j) {
+ a = tpi * unfl();
+ c = cos(a);
+ s = sin(a);
+ p = e + n * i;
+ q = e + n * j;
+ for (k = 0; k < n; ++k) {
+ a = *p * c + *q * s;
+ *q = *q * c - *p * s;
+ *p++ = a;
+ ++q;
+ }
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/otrma.c
===================================================================
--- grass/trunk/lib/external/ccmath/otrma.c (rev 0)
+++ grass/trunk/lib/external/ccmath/otrma.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,29 @@
+/* otrma.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+void otrma(double *c, double *a, double *b, int n)
+{
+ double z, *q0, *p, *s, *t;
+
+ int i, j, k;
+
+ q0 = (double *)calloc(n, sizeof(double));
+ for (i = 0; i < n; ++i, ++c) {
+ for (j = 0, t = b; j < n; ++j) {
+ for (k = 0, s = a + i * n, z = 0.; k < n; ++k)
+ z += *t++ * *s++;
+ q0[j] = z;
+ }
+ for (j = 0, p = c, t = a; j < n; ++j, p += n) {
+ for (k = 0, s = q0, z = 0.; k < n; ++k)
+ z += *t++ * *s++;
+ *p = z;
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/otrsm.c
===================================================================
--- grass/trunk/lib/external/ccmath/otrsm.c (rev 0)
+++ grass/trunk/lib/external/ccmath/otrsm.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,31 @@
+/* otrsm.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+void otrsm(double *sm, double *a, double *b, int n)
+{
+ double z, *q0, *p, *s, *t;
+
+ int i, j, k;
+
+ q0 = (double *)calloc(n, sizeof(double));
+ for (i = 0; i < n; ++i) {
+ for (j = 0, t = b; j < n; ++j) {
+ for (k = 0, s = a + i * n, z = 0.; k < n; ++k)
+ z += *t++ * *s++;
+ q0[j] = z;
+ }
+ for (j = 0, p = sm + i, t = a; j <= i; ++j, p += n) {
+ for (k = 0, s = q0, z = 0.; k < n; ++k)
+ z += *t++ * *s++;
+ *p = z;
+ if (j < i)
+ sm[i * n + j] = z;
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/psinv.c
===================================================================
--- grass/trunk/lib/external/ccmath/psinv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/psinv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,45 @@
+/* psinv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+int psinv(double *v, int n)
+{
+ double z, *p, *q, *r, *s, *t;
+
+ int j, k;
+
+ for (j = 0, p = v; j < n; ++j, p += n + 1) {
+ for (q = v + j * n; q < p; ++q)
+ *p -= *q * *q;
+ if (*p <= 0.)
+ return -1;
+ *p = sqrt(*p);
+ for (k = j + 1, q = p + n; k < n; ++k, q += n) {
+ for (r = v + j * n, s = v + k * n, z = 0.; r < p;)
+ z += *r++ * *s++;
+ *q -= z;
+ *q /= *p;
+ }
+ }
+ trnm(v, n);
+ for (j = 0, p = v; j < n; ++j, p += n + 1) {
+ *p = 1. / *p;
+ for (q = v + j, t = v; q < p; t += n + 1, q += n) {
+ for (s = q, r = t, z = 0.; s < p; s += n)
+ z -= *s * *r++;
+ *q = z * *p;
+ }
+ }
+ for (j = 0, p = v; j < n; ++j, p += n + 1) {
+ for (q = v + j, t = p - j; q <= p; q += n) {
+ for (k = j, r = p, s = q, z = 0.; k < n; ++k)
+ z += *r++ * *s++;
+ *t++ = (*q = z);
+ }
+ }
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/qrbdi.c
===================================================================
--- grass/trunk/lib/external/ccmath/qrbdi.c (rev 0)
+++ grass/trunk/lib/external/ccmath/qrbdi.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,77 @@
+/* qrbdi.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+int qrbdi(double *dm, double *em, int m)
+{
+ int i, j, k, n;
+
+ double u, x, y, a, b, c, s, t;
+
+ for (j = 1, t = fabs(dm[0]); j < m; ++j)
+ if ((s = fabs(dm[j]) + fabs(em[j - 1])) > t)
+ t = s;
+ t *= 1.e-15;
+ n = 100 * m;
+ for (j = 0; m > 1 && j < n; ++j) {
+ for (k = m - 1; k > 0; --k) {
+ if (fabs(em[k - 1]) < t)
+ break;
+ if (fabs(dm[k - 1]) < t) {
+ for (i = k, s = 1., c = 0.; i < m; ++i) {
+ a = s * em[i - 1];
+ b = dm[i];
+ em[i - 1] *= c;
+ dm[i] = u = sqrt(a * a + b * b);
+ s = -a / u;
+ c = b / u;
+ }
+ break;
+ }
+ }
+ y = dm[k];
+ x = dm[m - 1];
+ u = em[m - 2];
+ a = (y + x) * (y - x) - u * u;
+ s = y * em[k];
+ b = s + s;
+ u = sqrt(a * a + b * b);
+ if (u > 0.) {
+ c = sqrt((u + a) / (u + u));
+ if (c != 0.)
+ s /= (c * u);
+ else
+ s = 1.;
+ for (i = k; i < m - 1; ++i) {
+ b = em[i];
+ if (i > k) {
+ a = s * em[i];
+ b *= c;
+ em[i - 1] = u = sqrt(x * x + a * a);
+ c = x / u;
+ s = a / u;
+ }
+ a = c * y + s * b;
+ b = c * b - s * y;
+ s *= dm[i + 1];
+ dm[i] = u = sqrt(a * a + s * s);
+ y = c * dm[i + 1];
+ c = a / u;
+ s /= u;
+ x = c * b + s * y;
+ y = c * y - s * b;
+ }
+ }
+ em[m - 2] = x;
+ dm[m - 1] = y;
+ if (fabs(x) < t)
+ --m;
+ if (m == k + 1)
+ --m;
+ }
+ return j;
+}
Added: grass/trunk/lib/external/ccmath/qrbdu1.c
===================================================================
--- grass/trunk/lib/external/ccmath/qrbdu1.c (rev 0)
+++ grass/trunk/lib/external/ccmath/qrbdu1.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,94 @@
+/* qrbdu1.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+int qrbdu1(double *dm, double *em, double *um, int mm, double *vm, int m)
+{
+ int i, j, k, n, jj, nm;
+
+ double u, x, y, a, b, c, s, t, w, *p, *q;
+
+ for (j = 1, t = fabs(dm[0]); j < m; ++j)
+ if ((s = fabs(dm[j]) + fabs(em[j - 1])) > t)
+ t = s;
+ t *= 1.e-15;
+ n = 100 * m;
+ nm = m;
+ for (j = 0; m > 1 && j < n; ++j) {
+ for (k = m - 1; k > 0; --k) {
+ if (fabs(em[k - 1]) < t)
+ break;
+ if (fabs(dm[k - 1]) < t) {
+ for (i = k, s = 1., c = 0.; i < m; ++i) {
+ a = s * em[i - 1];
+ b = dm[i];
+ em[i - 1] *= c;
+ dm[i] = u = sqrt(a * a + b * b);
+ s = -a / u;
+ c = b / u;
+ for (jj = 0, p = um + k - 1; jj < mm; ++jj, p += nm) {
+ q = p + i - k + 1;
+ w = c * *p + s * *q;
+ *q = c * *q - s * *p;
+ *p = w;
+ }
+ }
+ break;
+ }
+ }
+ y = dm[k];
+ x = dm[m - 1];
+ u = em[m - 2];
+ a = (y + x) * (y - x) - u * u;
+ s = y * em[k];
+ b = s + s;
+ u = sqrt(a * a + b * b);
+ if (u > 0.) {
+ c = sqrt((u + a) / (u + u));
+ if (c != 0.)
+ s /= (c * u);
+ else
+ s = 1.;
+ for (i = k; i < m - 1; ++i) {
+ b = em[i];
+ if (i > k) {
+ a = s * em[i];
+ b *= c;
+ em[i - 1] = u = sqrt(x * x + a * a);
+ c = x / u;
+ s = a / u;
+ }
+ a = c * y + s * b;
+ b = c * b - s * y;
+ for (jj = 0, p = vm + i; jj < nm; ++jj, p += nm) {
+ w = c * *p + s * *(p + 1);
+ *(p + 1) = c * *(p + 1) - s * *p;
+ *p = w;
+ }
+ s *= dm[i + 1];
+ dm[i] = u = sqrt(a * a + s * s);
+ y = c * dm[i + 1];
+ c = a / u;
+ s /= u;
+ x = c * b + s * y;
+ y = c * y - s * b;
+ for (jj = 0, p = um + i; jj < mm; ++jj, p += nm) {
+ w = c * *p + s * *(p + 1);
+ *(p + 1) = c * *(p + 1) - s * *p;
+ *p = w;
+ }
+ }
+ }
+ em[m - 2] = x;
+ dm[m - 1] = y;
+ if (fabs(x) < t)
+ --m;
+ if (m == k + 1)
+ --m;
+ }
+ return j;
+}
Added: grass/trunk/lib/external/ccmath/qrbdv.c
===================================================================
--- grass/trunk/lib/external/ccmath/qrbdv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/qrbdv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,94 @@
+/* qrbdv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+int qrbdv(double *dm, double *em, double *um, int mm, double *vm, int m)
+{
+ int i, j, k, n, jj, nm;
+
+ double u, x, y, a, b, c, s, t, w, *p, *q;
+
+ for (j = 1, t = fabs(dm[0]); j < m; ++j)
+ if ((s = fabs(dm[j]) + fabs(em[j - 1])) > t)
+ t = s;
+ t *= 1.e-15;
+ n = 100 * m;
+ nm = m;
+ for (j = 0; m > 1 && j < n; ++j) {
+ for (k = m - 1; k > 0; --k) {
+ if (fabs(em[k - 1]) < t)
+ break;
+ if (fabs(dm[k - 1]) < t) {
+ for (i = k, s = 1., c = 0.; i < m; ++i) {
+ a = s * em[i - 1];
+ b = dm[i];
+ em[i - 1] *= c;
+ dm[i] = u = sqrt(a * a + b * b);
+ s = -a / u;
+ c = b / u;
+ for (jj = 0, p = um + k - 1; jj < mm; ++jj, p += mm) {
+ q = p + i - k + 1;
+ w = c * *p + s * *q;
+ *q = c * *q - s * *p;
+ *p = w;
+ }
+ }
+ break;
+ }
+ }
+ y = dm[k];
+ x = dm[m - 1];
+ u = em[m - 2];
+ a = (y + x) * (y - x) - u * u;
+ s = y * em[k];
+ b = s + s;
+ u = sqrt(a * a + b * b);
+ if (u != 0.) {
+ c = sqrt((u + a) / (u + u));
+ if (c != 0.)
+ s /= (c * u);
+ else
+ s = 1.;
+ for (i = k; i < m - 1; ++i) {
+ b = em[i];
+ if (i > k) {
+ a = s * em[i];
+ b *= c;
+ em[i - 1] = u = sqrt(x * x + a * a);
+ c = x / u;
+ s = a / u;
+ }
+ a = c * y + s * b;
+ b = c * b - s * y;
+ for (jj = 0, p = vm + i; jj < nm; ++jj, p += nm) {
+ w = c * *p + s * *(p + 1);
+ *(p + 1) = c * *(p + 1) - s * *p;
+ *p = w;
+ }
+ s *= dm[i + 1];
+ dm[i] = u = sqrt(a * a + s * s);
+ y = c * dm[i + 1];
+ c = a / u;
+ s /= u;
+ x = c * b + s * y;
+ y = c * y - s * b;
+ for (jj = 0, p = um + i; jj < mm; ++jj, p += mm) {
+ w = c * *p + s * *(p + 1);
+ *(p + 1) = c * *(p + 1) - s * *p;
+ *p = w;
+ }
+ }
+ }
+ em[m - 2] = x;
+ dm[m - 1] = y;
+ if (fabs(x) < t)
+ --m;
+ if (m == k + 1)
+ --m;
+ }
+ return j;
+}
Added: grass/trunk/lib/external/ccmath/qrecvc.c
===================================================================
--- grass/trunk/lib/external/ccmath/qrecvc.c (rev 0)
+++ grass/trunk/lib/external/ccmath/qrecvc.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,78 @@
+/* qrecvc.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void qrecvc(double *ev, Cpx * evec, double *dp, int n)
+{
+ double cc, sc = 0.0, d, x = 0.0, y, h = 0.0, tzr = 1.e-15;
+
+ int i, j, k, m, nqr = 50 * n;
+
+ Cpx *p;
+
+ for (j = 0, m = n - 1; j < nqr; ++j) {
+ while (1) {
+ if (m < 1)
+ break;
+ k = m - 1;
+ if (fabs(dp[k]) <= fabs(ev[m]) * tzr)
+ --m;
+ else {
+ x = (ev[k] - ev[m]) / 2.;
+ h = sqrt(x * x + dp[k] * dp[k]);
+ if (m > 1 && fabs(dp[m - 2]) > fabs(ev[k]) * tzr)
+ break;
+ if ((cc = sqrt((1. + x / h) / 2.)) != 0.)
+ sc = dp[k] / (2. * cc * h);
+ else
+ sc = 1.;
+ x += ev[m];
+ ev[m--] = x - h;
+ ev[m--] = x + h;
+ for (i = 0, p = evec + n * (m + 1); i < n; ++i, ++p) {
+ h = p[0].re;
+ p[0].re = cc * h + sc * p[n].re;
+ p[n].re = cc * p[n].re - sc * h;
+ h = p[0].im;
+ p[0].im = cc * h + sc * p[n].im;
+ p[n].im = cc * p[n].im - sc * h;
+ }
+ }
+ }
+ if (x > 0.)
+ d = ev[m] + x - h;
+ else
+ d = ev[m] + x + h;
+ cc = 1.;
+ y = 0.;
+ ev[0] -= d;
+ for (k = 0; k < m; ++k) {
+ x = ev[k] * cc - y;
+ y = dp[k] * cc;
+ h = sqrt(x * x + dp[k] * dp[k]);
+ if (k > 0)
+ dp[k - 1] = sc * h;
+ ev[k] = cc * h;
+ cc = x / h;
+ sc = dp[k] / h;
+ ev[k + 1] -= d;
+ y *= sc;
+ ev[k] = cc * (ev[k] + y) + ev[k + 1] * sc * sc + d;
+ for (i = 0, p = evec + n * k; i < n; ++i, ++p) {
+ h = p[0].re;
+ p[0].re = cc * h + sc * p[n].re;
+ p[n].re = cc * p[n].re - sc * h;
+ h = p[0].im;
+ p[0].im = cc * h + sc * p[n].im;
+ p[n].im = cc * p[n].im - sc * h;
+ }
+ }
+ ev[k] = ev[k] * cc - y;
+ dp[k - 1] = ev[k] * sc;
+ ev[k] = ev[k] * cc + d;
+ }
+}
Added: grass/trunk/lib/external/ccmath/qreval.c
===================================================================
--- grass/trunk/lib/external/ccmath/qreval.c (rev 0)
+++ grass/trunk/lib/external/ccmath/qreval.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,59 @@
+/* qreval.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+int qreval(double *ev, double *dp, int n)
+{
+ double cc, sc = 0.0, d, x, y, h, tzr = 1.e-15;
+
+ int j, k, m, mqr = 8 * n;
+
+ for (j = 0, m = n - 1;; ++j) {
+ while (1) {
+ if (m < 1)
+ return 0;
+ k = m - 1;
+ if (fabs(dp[k]) <= fabs(ev[m]) * tzr)
+ --m;
+ else {
+ x = (ev[k] - ev[m]) / 2.;
+ h = sqrt(x * x + dp[k] * dp[k]);
+ if (m > 1 && fabs(dp[m - 2]) > fabs(ev[k]) * tzr)
+ break;
+ x += ev[m];
+ ev[m--] = x - h;
+ ev[m--] = x + h;
+ }
+ }
+ if (j > mqr)
+ return -1;
+ if (x > 0.)
+ d = ev[m] + x - h;
+ else
+ d = ev[m] + x + h;
+ cc = 1.;
+ y = 0.;
+ ev[0] -= d;
+ for (k = 0; k < m; ++k) {
+ x = ev[k] * cc - y;
+ y = dp[k] * cc;
+ h = sqrt(x * x + dp[k] * dp[k]);
+ if (k > 0)
+ dp[k - 1] = sc * h;
+ ev[k] = cc * h;
+ cc = x / h;
+ sc = dp[k] / h;
+ ev[k + 1] -= d;
+ y *= sc;
+ ev[k] = cc * (ev[k] + y) + ev[k + 1] * sc * sc + d;
+ }
+ ev[k] = ev[k] * cc - y;
+ dp[k - 1] = ev[k] * sc;
+ ev[k] = ev[k] * cc + d;
+ }
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/qrevec.c
===================================================================
--- grass/trunk/lib/external/ccmath/qrevec.c (rev 0)
+++ grass/trunk/lib/external/ccmath/qrevec.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,75 @@
+/* qrevec.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <math.h>
+int qrevec(double *ev, double *evec, double *dp, int n)
+{
+ double cc, sc = 0.0, d, x, y, h, tzr = 1.e-15;
+
+ int i, j, k, m, mqr = 8 * n;
+
+ double *p;
+
+ for (j = 0, m = n - 1;; ++j) {
+ while (1) {
+ if (m < 1)
+ return 0;
+ k = m - 1;
+ if (fabs(dp[k]) <= fabs(ev[m]) * tzr)
+ --m;
+ else {
+ x = (ev[k] - ev[m]) / 2.;
+ h = sqrt(x * x + dp[k] * dp[k]);
+ if (m > 1 && fabs(dp[m - 2]) > fabs(ev[k]) * tzr)
+ break;
+ if ((cc = sqrt((1. + x / h) / 2.)) != 0.)
+ sc = dp[k] / (2. * cc * h);
+ else
+ sc = 1.;
+ x += ev[m];
+ ev[m--] = x - h;
+ ev[m--] = x + h;
+ for (i = 0, p = evec + n * (m + 1); i < n; ++i, ++p) {
+ h = p[0];
+ p[0] = cc * h + sc * p[n];
+ p[n] = cc * p[n] - sc * h;
+ }
+ }
+ }
+ if (j > mqr)
+ return -1;
+ if (x > 0.)
+ d = ev[m] + x - h;
+ else
+ d = ev[m] + x + h;
+ cc = 1.;
+ y = 0.;
+ ev[0] -= d;
+ for (k = 0; k < m; ++k) {
+ x = ev[k] * cc - y;
+ y = dp[k] * cc;
+ h = sqrt(x * x + dp[k] * dp[k]);
+ if (k > 0)
+ dp[k - 1] = sc * h;
+ ev[k] = cc * h;
+ cc = x / h;
+ sc = dp[k] / h;
+ ev[k + 1] -= d;
+ y *= sc;
+ ev[k] = cc * (ev[k] + y) + ev[k + 1] * sc * sc + d;
+ for (i = 0, p = evec + n * k; i < n; ++i, ++p) {
+ h = p[0];
+ p[0] = cc * h + sc * p[n];
+ p[n] = cc * p[n] - sc * h;
+ }
+ }
+ ev[k] = ev[k] * cc - y;
+ dp[k - 1] = ev[k] * sc;
+ ev[k] = ev[k] * cc + d;
+ }
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/rmmult.c
===================================================================
--- grass/trunk/lib/external/ccmath/rmmult.c (rev 0)
+++ grass/trunk/lib/external/ccmath/rmmult.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,26 @@
+/* rmmult.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+void rmmult(double *rm, double *a, double *b, int n, int m, int l)
+{
+ double z, *q0, *p, *q;
+
+ int i, j, k;
+
+ q0 = (double *)calloc(m, sizeof(double));
+ for (i = 0; i < l; ++i, ++rm) {
+ for (k = 0, p = b + i; k < m; p += l)
+ q0[k++] = *p;
+ for (j = 0, p = a, q = rm; j < n; ++j, q += l) {
+ for (k = 0, z = 0.; k < m;)
+ z += *p++ * q0[k++];
+ *q = z;
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/ruinv.c
===================================================================
--- grass/trunk/lib/external/ccmath/ruinv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/ruinv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,31 @@
+/* ruinv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+int ruinv(double *a, int n)
+{
+ int j;
+
+ double fabs();
+
+ double tt, z, *p, *q, *r, *s, *t;
+
+ for (j = 0, tt = 0., p = a; j < n; ++j, p += n + 1)
+ if ((z = fabs(*p)) > tt)
+ tt = z;
+ tt *= 1.e-16;
+ for (j = 0, p = a; j < n; ++j, p += n + 1) {
+ if (fabs(*p) < tt)
+ return -1;
+ *p = 1. / *p;
+ for (q = a + j, t = a; q < p; t += n + 1, q += n) {
+ for (s = q, r = t, z = 0.; s < p; s += n)
+ z -= *s * *r++;
+ *q = z * *p;
+ }
+ }
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/smgen.c
===================================================================
--- grass/trunk/lib/external/ccmath/smgen.c (rev 0)
+++ grass/trunk/lib/external/ccmath/smgen.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,19 @@
+/* smgen.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void smgen(double *a, double *eval, double *evec, int n)
+{
+ double *p, *q, *ps, *r, *s, *t, *v = evec + n * n;
+
+ for (ps = a, p = evec; p < v; p += n) {
+ for (q = evec; q < v; q += n, ++ps) {
+ *ps = 0.;
+ for (r = eval, s = p, t = q; r < eval + n;)
+ *ps += *r++ * *s++ * *t++;
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/solv.c
===================================================================
--- grass/trunk/lib/external/ccmath/solv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/solv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,71 @@
+/* solv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU general
+ * public license. ( See the gpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int solv(double *a, double *b, int n)
+{
+ int i, j, k, lc;
+
+ double *ps, *p, *q, *pa, *pd;
+
+ double *q0, s, t, tq = 0., zr = 1.e-15;
+
+ q0 = (double *)calloc(n, sizeof(double));
+ for (j = 0, pa = a, pd = a; j < n; ++j, ++pa, pd += n + 1) {
+ if (j) {
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *q++ = *p;
+ for (i = 1; i < n; ++i) {
+ lc = i < j ? i : j;
+ for (k = 0, p = pa + i * n - j, q = q0, t = 0.; k < lc; ++k)
+ t += *p++ * *q++;
+ q0[i] -= t;
+ }
+ for (i = 0, q = q0, p = pa; i < n; ++i, p += n)
+ *p = *q++;
+ }
+ s = fabs(*pd);
+ lc = j;
+ for (k = j + 1, ps = pd; k < n; ++k) {
+ if ((t = fabs(*(ps += n))) > s) {
+ s = t;
+ lc = k;
+ }
+ }
+ tq = tq > s ? tq : s;
+ if (s < zr * tq) {
+ free(q0);
+ return -1;
+ }
+ if (lc != j) {
+ t = b[j];
+ b[j] = b[lc];
+ b[lc] = t;
+ for (k = 0, p = a + n * j, q = a + n * lc; k < n; ++k) {
+ t = *p;
+ *p++ = *q;
+ *q++ = t;
+ }
+ }
+ for (k = j + 1, ps = pd, t = 1. / *pd; k < n; ++k)
+ *(ps += n) *= t;
+ }
+ for (j = 1, ps = b + 1; j < n; ++j) {
+ for (k = 0, p = a + n * j, q = b, t = 0.; k < j; ++k)
+ t += *p++ * *q++;
+ *ps++ -= t;
+ }
+ for (j = n - 1, --ps, pd = a + n * n - 1; j >= 0; --j, pd -= n + 1) {
+ for (k = j + 1, p = pd, q = b + j, t = 0.; k < n; ++k)
+ t += *++p * *++q;
+ *ps -= t;
+ *ps-- /= *pd;
+ }
+ free(q0);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/solv.s
===================================================================
--- grass/trunk/lib/external/ccmath/solv.s (rev 0)
+++ grass/trunk/lib/external/ccmath/solv.s 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,387 @@
+ .file "solv2.c"
+ .version "01.01"
+gcc2_compiled.:
+.section .rodata
+ .align 4
+.LC0:
+ .long 0x9ee75616,0x3cd203af
+.text
+ .align 4
+.globl solv
+ .type solv, at function
+solv:
+ pushl %ebp
+ movl %esp,%ebp
+ subl $72,%esp
+ pushl %edi
+ pushl %esi
+ pushl %ebx
+ fldz
+ pushl $8
+ movl 16(%ebp),%edx
+ pushl %edx
+ fstpt -60(%ebp)
+ call calloc
+ movl %eax,-20(%ebp)
+ movl $0,-4(%ebp)
+ movl 8(%ebp),%ecx
+ movl %ecx,-12(%ebp)
+ movl %ecx,-16(%ebp)
+ addl $8,%esp
+ fldt -60(%ebp)
+ movl 16(%ebp),%edi
+ cmpl %edi,-4(%ebp)
+ jge .L72
+ leal 0(,%edi,8),%edx
+ movl %edx,-24(%ebp)
+ addl $8,%edx
+ movl %edx,-32(%ebp)
+ movl $0,-40(%ebp)
+ movl 12(%ebp),%ecx
+ movl %ecx,-44(%ebp)
+ movl $0,-48(%ebp)
+ .align 4
+.L7:
+ cmpl $0,-4(%ebp)
+ je .L8
+ movl $0,-64(%ebp)
+ movl -20(%ebp),%edi
+ movl %edi,-72(%ebp)
+ movl -12(%ebp),%ebx
+ movl 16(%ebp),%edx
+ cmpl %edx,-64(%ebp)
+ jge .L10
+ .align 4
+.L12:
+ movl -72(%ebp),%ecx
+ movl (%ebx),%eax
+ movl %eax,(%ecx)
+ movl 4(%ebx),%eax
+ movl %eax,4(%ecx)
+ addl $8,%ecx
+ movl %ecx,-72(%ebp)
+ incl -64(%ebp)
+ addl -24(%ebp),%ebx
+ movl 16(%ebp),%edi
+ cmpl %edi,-64(%ebp)
+ jl .L12
+.L10:
+ movl $1,-64(%ebp)
+ movl 16(%ebp),%edx
+ cmpl %edx,-64(%ebp)
+ jge .L15
+ movl -48(%ebp),%ecx
+ movl %ecx,-28(%ebp)
+ movl -20(%ebp),%edi
+ addl $8,%edi
+ movl %edi,-68(%ebp)
+ movl %edx,-36(%ebp)
+ .align 4
+.L17:
+ movl -64(%ebp),%edx
+ movl %edx,-8(%ebp)
+ movl -4(%ebp),%ecx
+ cmpl %ecx,%edx
+ jle .L18
+ movl %ecx,-8(%ebp)
+.L18:
+ xorl %esi,%esi
+ movl -36(%ebp),%edi
+ movl -12(%ebp),%edx
+ leal (%edx,%edi,8),%eax
+ movl %eax,%ebx
+ subl -28(%ebp),%ebx
+ movl -20(%ebp),%ecx
+ movl %ecx,%edi
+ movl %ecx,-72(%ebp)
+ movl -8(%ebp),%ecx
+ fldz
+ cmpl %esi,%ecx
+ jle .L20
+ .align 4
+.L22:
+ fldl (%ebx)
+ fmull (%edi)
+ faddp %st,%st(1)
+ addl $8,%edi
+ addl $8,%ebx
+ incl %esi
+ cmpl %esi,%ecx
+ jg .L22
+.L20:
+ movl -72(%ebp),%ecx
+ movl -68(%ebp),%edx
+ fldl (%edx)
+ fsubp %st,%st(1)
+ fstpl (%edx)
+ addl $8,%edx
+ movl %edx,-68(%ebp)
+ movl 16(%ebp),%ecx
+ addl %ecx,-36(%ebp)
+ incl -64(%ebp)
+ cmpl %ecx,-64(%ebp)
+ jl .L17
+.L15:
+ movl $0,-64(%ebp)
+ movl -20(%ebp),%edi
+ movl %edi,-72(%ebp)
+ movl -12(%ebp),%ebx
+ movl 16(%ebp),%edx
+ cmpl %edx,-64(%ebp)
+ jge .L8
+ .align 4
+.L28:
+ movl -72(%ebp),%ecx
+ movl (%ecx),%eax
+ movl %eax,(%ebx)
+ movl 4(%ecx),%eax
+ movl %eax,4(%ebx)
+ addl $8,%ecx
+ movl %ecx,-72(%ebp)
+ incl -64(%ebp)
+ addl -24(%ebp),%ebx
+ movl 16(%ebp),%edi
+ cmpl %edi,-64(%ebp)
+ jl .L28
+.L8:
+ movl -16(%ebp),%edx
+ fldl (%edx)
+ fabs
+ movl -4(%ebp),%ecx
+ movl %ecx,-8(%ebp)
+ movl %ecx,%esi
+ incl %esi
+ movl %edx,-68(%ebp)
+ cmpl %esi,16(%ebp)
+ jle .L31
+ .align 4
+.L33:
+ movl -24(%ebp),%edi
+ addl %edi,-68(%ebp)
+ movl -68(%ebp),%edx
+ fldl (%edx)
+ fabs
+ fcom %st(1)
+ fnstsw %ax
+ andb $69,%ah
+ jne .L73
+ fstp %st(1)
+ movl %esi,-8(%ebp)
+ jmp .L32
+ .align 4
+.L73:
+ fstp %st(0)
+.L32:
+ incl %esi
+ cmpl %esi,16(%ebp)
+ jg .L33
+.L31:
+ fld %st(0)
+ fxch %st(2)
+ fcom %st(1)
+ fnstsw %ax
+ andb $69,%ah
+ jne .L74
+ fstp %st(2)
+ jmp .L36
+ .align 4
+.L74:
+ fstp %st(0)
+.L36:
+ fldl .LC0
+ fmul %st(2),%st
+ fcompp
+ fnstsw %ax
+ andb $69,%ah
+ jne .L38
+ fstp %st(0)
+ movl -20(%ebp),%ecx
+ pushl %ecx
+ call free
+ movl $-1,%eax
+ jmp .L71
+ .align 4
+.L38:
+ movl -4(%ebp),%edi
+ cmpl %edi,-8(%ebp)
+ je .L39
+ movl -44(%ebp),%edx
+ fldl (%edx)
+ movl -8(%ebp),%ecx
+ movl 12(%ebp),%edi
+ movl (%edi,%ecx,8),%eax
+ movl %eax,(%edx)
+ movl 4(%edi,%ecx,8),%eax
+ movl %eax,4(%edx)
+ fstpl (%edi,%ecx,8)
+ xorl %esi,%esi
+ movl -40(%ebp),%edx
+ movl 8(%ebp),%ecx
+ leal (%ecx,%edx,8),%ebx
+ movl 16(%ebp),%eax
+ imull -8(%ebp),%eax
+ leal (%ecx,%eax,8),%eax
+ movl %eax,-72(%ebp)
+ cmpl %esi,16(%ebp)
+ jle .L39
+ .align 4
+.L43:
+ fldl (%ebx)
+ movl -72(%ebp),%edi
+ movl (%edi),%eax
+ movl %eax,(%ebx)
+ movl 4(%edi),%eax
+ movl %eax,4(%ebx)
+ addl $8,%ebx
+ fstpl (%edi)
+ addl $8,%edi
+ movl %edi,-72(%ebp)
+ incl %esi
+ cmpl %esi,16(%ebp)
+ jg .L43
+.L39:
+ movl -4(%ebp),%esi
+ incl %esi
+ movl -16(%ebp),%edx
+ movl %edx,-68(%ebp)
+ fld1
+ fdivl (%edx)
+ cmpl %esi,16(%ebp)
+ jle .L75
+ .align 4
+.L48:
+ movl -24(%ebp),%ecx
+ addl %ecx,-68(%ebp)
+ movl -68(%ebp),%edi
+ fldl (%edi)
+ fmul %st(1),%st
+ fstpl (%edi)
+ incl %esi
+ cmpl %esi,16(%ebp)
+ jg .L48
+.L75:
+ fstp %st(0)
+ movl 16(%ebp),%edx
+ addl %edx,-40(%ebp)
+ addl $8,-44(%ebp)
+ addl $8,-48(%ebp)
+ incl -4(%ebp)
+ addl $8,-12(%ebp)
+ movl -32(%ebp),%ecx
+ addl %ecx,-16(%ebp)
+ cmpl %edx,-4(%ebp)
+ jl .L7
+.L72:
+ fstp %st(0)
+ movl $1,-4(%ebp)
+ movl 12(%ebp),%edi
+ addl $8,%edi
+ movl %edi,-68(%ebp)
+ movl 16(%ebp),%edx
+ cmpl %edx,-4(%ebp)
+ jge .L52
+ movl 16(%ebp),%eax
+ .align 4
+.L54:
+ xorl %esi,%esi
+ movl 8(%ebp),%ecx
+ leal (%ecx,%eax,8),%ebx
+ movl 12(%ebp),%edi
+ movl %edi,-72(%ebp)
+ fldz
+ cmpl %esi,-4(%ebp)
+ jle .L56
+ .align 4
+.L58:
+ fldl (%ebx)
+ movl -72(%ebp),%edx
+ fmull (%edx)
+ faddp %st,%st(1)
+ addl $8,%edx
+ movl %edx,-72(%ebp)
+ addl $8,%ebx
+ incl %esi
+ cmpl %esi,-4(%ebp)
+ jg .L58
+.L56:
+ movl -68(%ebp),%ecx
+ fldl (%ecx)
+ fsubp %st,%st(1)
+ fstpl (%ecx)
+ addl $8,%ecx
+ movl %ecx,-68(%ebp)
+ addl 16(%ebp),%eax
+ incl -4(%ebp)
+ movl 16(%ebp),%edi
+ cmpl %edi,-4(%ebp)
+ jl .L54
+.L52:
+ movl 16(%ebp),%edx
+ decl %edx
+ movl %edx,-4(%ebp)
+ addl $-8,-68(%ebp)
+ movl 16(%ebp),%eax
+ imull %eax,%eax
+ movl 8(%ebp),%ecx
+ leal -8(%ecx,%eax,8),%eax
+ movl %eax,-16(%ebp)
+ testl %edx,%edx
+ jl .L62
+ movl 16(%ebp),%edi
+ leal 8(,%edi,8),%edi
+ movl %edi,-64(%ebp)
+ leal 0(,%edx,8),%eax
+ .align 4
+.L64:
+ movl -4(%ebp),%esi
+ incl %esi
+ movl -16(%ebp),%ebx
+ movl 12(%ebp),%edx
+ addl %eax,%edx
+ movl %edx,-72(%ebp)
+ fldz
+ cmpl %esi,16(%ebp)
+ jle .L66
+ .align 4
+.L68:
+ addl $8,%ebx
+ addl $8,-72(%ebp)
+ fldl (%ebx)
+ movl -72(%ebp),%ecx
+ fmull (%ecx)
+ faddp %st,%st(1)
+ incl %esi
+ cmpl %esi,16(%ebp)
+ jg .L68
+.L66:
+ movl -68(%ebp),%edi
+ fldl (%edi)
+ fsubp %st,%st(1)
+ fstl (%edi)
+ movl -16(%ebp),%edx
+ fdivl (%edx)
+ fstpl (%edi)
+ addl $-8,%edi
+ movl %edi,-68(%ebp)
+ addl $-8,%eax
+ movl -64(%ebp),%ecx
+ subl %ecx,%edx
+ movl %edx,-16(%ebp)
+ decl -4(%ebp)
+ jns .L64
+.L62:
+ movl -20(%ebp),%edi
+ pushl %edi
+ call free
+ xorl %eax,%eax
+.L71:
+ leal -84(%ebp),%esp
+ popl %ebx
+ popl %esi
+ popl %edi
+ movl %ebp,%esp
+ popl %ebp
+ ret
+.Lfe1:
+ .size solv,.Lfe1-solv
+ .ident "GCC: (GNU) 2.7.2"
Added: grass/trunk/lib/external/ccmath/solvps.c
===================================================================
--- grass/trunk/lib/external/ccmath/solvps.c (rev 0)
+++ grass/trunk/lib/external/ccmath/solvps.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,39 @@
+/* solvps.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+int solvps(double *a, double *b, int n)
+{
+ double *p, *q, *r, *s, t;
+
+ int j, k;
+
+ for (j = 0, p = a; j < n; ++j, p += n + 1) {
+ for (q = a + j * n; q < p; ++q)
+ *p -= *q * *q;
+ if (*p <= 0.)
+ return -1;
+ *p = sqrt(*p);
+ for (k = j + 1, q = p + n; k < n; ++k, q += n) {
+ for (r = a + j * n, s = a + k * n, t = 0.; r < p;)
+ t += *r++ * *s++;
+ *q -= t;
+ *q /= *p;
+ }
+ }
+ for (j = 0, p = a; j < n; ++j, p += n + 1) {
+ for (k = 0, q = a + j * n; k < j;)
+ b[j] -= b[k++] * *q++;
+ b[j] /= *p;
+ }
+ for (j = n - 1, p = a + n * n - 1; j >= 0; --j, p -= n + 1) {
+ for (k = j + 1, q = p + n; k < n; q += n)
+ b[j] -= b[k++] * *q;
+ b[j] /= *p;
+ }
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/solvru.c
===================================================================
--- grass/trunk/lib/external/ccmath/solvru.c (rev 0)
+++ grass/trunk/lib/external/ccmath/solvru.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,28 @@
+/* solvru.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+int solvru(double *a, double *b, int n)
+{
+ int j, k;
+
+ double fabs();
+
+ double s, t, *p, *q;
+
+ for (j = 0, s = 0., p = a; j < n; ++j, p += n + 1)
+ if ((t = fabs(*p)) > s)
+ s = t;
+ s *= 1.e-16;
+ for (j = n - 1, p = a + n * n - 1; j >= 0; --j, p -= n + 1) {
+ for (k = j + 1, q = p + 1; k < n;)
+ b[j] -= b[k++] * *q++;
+ if (fabs(*p) < s)
+ return -1;
+ b[j] /= *p;
+ }
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/solvtd.c
===================================================================
--- grass/trunk/lib/external/ccmath/solvtd.c (rev 0)
+++ grass/trunk/lib/external/ccmath/solvtd.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,23 @@
+/* solvtd.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void solvtd(double *a, double *b, double *c, double *x, int m)
+{
+ double s;
+
+ int j;
+
+ for (j = 0; j < m; ++j) {
+ s = b[j] / a[j];
+ a[j + 1] -= s * c[j];
+ x[j + 1] -= s * x[j];
+ }
+ for (j = m, s = 0.; j >= 0; --j) {
+ x[j] -= s * c[j];
+ s = (x[j] /= a[j]);
+ }
+}
Added: grass/trunk/lib/external/ccmath/sv2u1v.c
===================================================================
--- grass/trunk/lib/external/ccmath/sv2u1v.c (rev 0)
+++ grass/trunk/lib/external/ccmath/sv2u1v.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,136 @@
+/* sv2u1v.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int sv2u1v(double *d, double *a, int m, double *v, int n)
+{
+ double *p, *p1, *q, *pp, *w, *e;
+
+ double s, t, h, r, sv;
+
+ int i, j, k, mm, nm, ms;
+
+ if (m < n)
+ return -1;
+ w = (double *)calloc(m + n, sizeof(double));
+ e = w + m;
+ for (i = 0, mm = m, p = a; i < n; ++i, --mm, p += n + 1) {
+ if (mm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ t = 1. / (w[0] += h);
+ sv = 1. + fabs(*p / h);
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, r = 0.; j < mm; q += n)
+ r += w[j++] * *q;
+ r = r * s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= r * w[j++];
+ }
+ for (j = 1, q = p; j < mm;)
+ *(q += n) = w[j++] * t;
+ }
+ *p = sv;
+ d[i] = -h;
+ }
+ if (mm == 1)
+ d[i] = *p;
+ }
+ for (i = 0, q = v, p = a; i < n; ++i) {
+ for (j = 0; j < n; ++j, ++q, ++p) {
+ if (j < i)
+ *q = 0.;
+ else if (j == i)
+ *q = d[i];
+ else
+ *q = *p;
+ }
+ }
+ atou1(a, m, n);
+ for (i = 0, mm = n, nm = n - 1, p = v; i < n; ++i, --mm, --nm, p += n + 1) {
+ if (i && mm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ t = 1. / (w[0] += h);
+ sv = 1. + fabs(*p / h);
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, r = 0.; j < mm; q += n)
+ r += w[j++] * *q;
+ for (j = 0, q = p + k, r *= s; j < mm; q += n)
+ *q -= r * w[j++];
+ }
+ for (k = 0, p1 = a + i; k < m; ++k, p1 += n) {
+ for (j = 0, q = p1, r = 0.; j < mm;)
+ r += w[j++] * *q++;
+ for (j = 0, q = p1, r *= s; j < mm;)
+ *q++ -= r * w[j++];
+ }
+ }
+ *p = sv;
+ d[i] = -h;
+ }
+ if (mm == 1)
+ d[i] = *p;
+ p1 = p + 1;
+ if (nm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p1, s = 0.; j < nm; ++j, ++q)
+ s += *q * *q;
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p1 < 0.)
+ h = -h;
+ sv = 1. + fabs(*p1 / h);
+ s += *p1 * h;
+ s = 1. / s;
+ t = 1. / (*p1 += h);
+ for (k = n, ms = n * (n - i); k < ms; k += n) {
+ for (j = 0, q = p1, pp = p1 + k, r = 0.; j < nm; ++j)
+ r += *q++ * *pp++;
+ for (j = 0, q = p1, pp = p1 + k, r *= s; j < nm; ++j)
+ *pp++ -= r * *q++;
+ }
+ for (j = 1, q = p1 + 1; j < nm; ++j)
+ *q++ *= t;
+ }
+ *p1 = sv;
+ e[i] = -h;
+ }
+ if (nm == 1)
+ e[i] = *p1;
+ }
+ atovm(v, n);
+ qrbdu1(d, e, a, m, v, n);
+ for (i = 0; i < n; ++i) {
+ if (d[i] < 0.) {
+ d[i] = -d[i];
+ for (j = 0, p = v + i; j < n; ++j, p += n)
+ *p = -*p;
+ }
+ }
+ free(w);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/sv2uv.c
===================================================================
--- grass/trunk/lib/external/ccmath/sv2uv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/sv2uv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,134 @@
+/* sv2uv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int sv2uv(double *d, double *a, double *u, int m, double *v, int n)
+{
+ double *p, *p1, *q, *pp, *w, *e;
+
+ double s, t, h, r, sv;
+
+ int i, j, k, mm, nm, ms;
+
+ if (m < n)
+ return -1;
+ w = (double *)calloc(m + n, sizeof(double));
+ e = w + m;
+ for (i = 0, mm = m, p = a; i < n; ++i, --mm, p += n + 1) {
+ if (mm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ t = 1. / (w[0] += h);
+ sv = 1. + fabs(*p / h);
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, r = 0.; j < mm; q += n)
+ r += w[j++] * *q;
+ r = r * s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= r * w[j++];
+ }
+ for (j = 1, q = p; j < mm;)
+ *(q += n) = w[j++] * t;
+ }
+ *p = sv;
+ d[i] = -h;
+ }
+ if (mm == 1)
+ d[i] = *p;
+ }
+ ldumat(a, u, m, n);
+ for (i = 0, q = a; i < n; ++i) {
+ for (j = 0; j < n; ++j, ++q) {
+ if (j < i)
+ *q = 0.;
+ else if (j == i)
+ *q = d[i];
+ }
+ }
+ for (i = 0, mm = n, nm = n - 1, p = a; i < n; ++i, --mm, --nm, p += n + 1) {
+ if (i && mm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ t = 1. / (w[0] += h);
+ sv = 1. + fabs(*p / h);
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, r = 0.; j < mm; q += n)
+ r += w[j++] * *q;
+ for (j = 0, q = p + k, r *= s; j < mm; q += n)
+ *q -= r * w[j++];
+ }
+ for (k = 0, p1 = u + i; k < m; ++k, p1 += m) {
+ for (j = 0, q = p1, r = 0.; j < mm;)
+ r += w[j++] * *q++;
+ for (j = 0, q = p1, r *= s; j < mm;)
+ *q++ -= r * w[j++];
+ }
+ }
+ *p = sv;
+ d[i] = -h;
+ }
+ if (mm == 1)
+ d[i] = *p;
+ p1 = p + 1;
+ if (nm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p1, s = 0.; j < nm; ++j, ++q)
+ s += *q * *q;
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p1 < 0.)
+ h = -h;
+ sv = 1. + fabs(*p1 / h);
+ s += *p1 * h;
+ s = 1. / s;
+ t = 1. / (*p1 += h);
+ for (k = n, ms = n * (n - i); k < ms; k += n) {
+ for (j = 0, q = p1, pp = p1 + k, r = 0.; j < nm; ++j)
+ r += *q++ * *pp++;
+ for (j = 0, q = p1, pp = p1 + k, r *= s; j < nm; ++j)
+ *pp++ -= r * *q++;
+ }
+ for (j = 1, q = p1 + 1; j < nm; ++j)
+ *q++ *= t;
+ }
+ *p1 = sv;
+ e[i] = -h;
+ }
+ if (nm == 1)
+ e[i] = *p1;
+ }
+ ldvmat(a, v, n);
+ qrbdv(d, e, u, m, v, n);
+ for (i = 0; i < n; ++i) {
+ if (d[i] < 0.) {
+ d[i] = -d[i];
+ for (j = 0, p = v + i; j < n; ++j, p += n)
+ *p = -*p;
+ }
+ }
+ free(w);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/sv2val.c
===================================================================
--- grass/trunk/lib/external/ccmath/sv2val.c (rev 0)
+++ grass/trunk/lib/external/ccmath/sv2val.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,105 @@
+/* sv2val.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int sv2val(double *d, double *a, int m, int n)
+{
+ double *p, *p1, *q, *w, *v;
+
+ double s, h, u;
+
+ int i, j, k, mm, nm, ms;
+
+ if (m < n)
+ return -1;
+ w = (double *)calloc(m, sizeof(double));
+ for (i = 0, mm = m, p = a; i < n && mm > 1; ++i, --mm, p += n + 1) {
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ w[0] += h;
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, u = 0.; j < mm; q += n)
+ u += w[j++] * *q;
+ u = u * s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= u * w[j++];
+ }
+ *p = -h;
+ }
+ }
+ for (i = 0, p = a; i < n; ++i, p += n) {
+ for (j = 0, q = p; j < i; ++j)
+ *q++ = 0.;
+ }
+ for (i = 0, mm = n, nm = n - 1, p = a; i < n; ++i, --mm, --nm, p += n + 1) {
+ if (i && mm > 1) {
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ w[0] += h;
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, u = 0.; j < mm; q += n)
+ u += w[j++] * *q;
+ u *= s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= u * w[j++];
+ }
+ *p = -h;
+ }
+ }
+ p1 = p + 1;
+ if (nm > 1) {
+ for (j = 0, q = p1, s = 0.; j < nm; ++j, ++q)
+ s += *q * *q;
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p1 < 0.)
+ h = -h;
+ s += *p1 * h;
+ s = 1. / s;
+ *p1 += h;
+ for (k = n, ms = n * (m - i); k < ms; k += n) {
+ for (j = 0, q = p1, v = p1 + k, u = 0.; j < nm; ++j)
+ u += *q++ * *v++;
+ u *= s;
+ for (j = 0, q = p1, v = p1 + k; j < nm; ++j)
+ *v++ -= u * *q++;
+ }
+ *p1 = -h;
+ }
+ }
+ }
+ for (j = 0, p = a; j < n; ++j, p += n + 1) {
+ d[j] = *p;
+ if (j < n - 1)
+ w[j] = *(p + 1);
+ else
+ w[j] = 0.;
+ }
+ qrbdi(d, w, n);
+ for (i = 0; i < n; ++i)
+ if (d[i] < 0.)
+ d[i] = -d[i];
+ free(w);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/svdu1v.c
===================================================================
--- grass/trunk/lib/external/ccmath/svdu1v.c (rev 0)
+++ grass/trunk/lib/external/ccmath/svdu1v.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,93 @@
+/* svdu1v.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int svdu1v(double *d, double *a, int m, double *v, int n)
+{
+ double *p, *p1, *q, *pp, *w, *e;
+
+ double s, h, r, t, sv;
+
+ int i, j, k, mm, nm, ms;
+
+ if (m < n)
+ return -1;
+ w = (double *)calloc(m + n, sizeof(double));
+ e = w + m;
+ for (i = 0, mm = m, nm = n - 1, p = a; i < n; ++i, --mm, --nm, p += n + 1) {
+ if (mm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ t = 1. / (w[0] += h);
+ sv = 1. + fabs(*p / h);
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, r = 0.; j < mm; q += n)
+ r += w[j++] * *q;
+ r *= s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= r * w[j++];
+ }
+ for (j = 1, q = p; j < mm;)
+ *(q += n) = t * w[j++];
+ }
+ *p = sv;
+ d[i] = -h;
+ }
+ if (mm == 1)
+ d[i] = *p;
+ p1 = p + 1;
+ sv = h = 0.;
+ if (nm > 1) {
+ for (j = 0, q = p1, s = 0.; j < nm; ++j, ++q)
+ s += *q * *q;
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p1 < 0.)
+ h = -h;
+ sv = 1. + fabs(*p1 / h);
+ s += *p1 * h;
+ s = 1. / s;
+ t = 1. / (*p1 += h);
+ for (k = n, ms = n * (m - i); k < ms; k += n) {
+ for (j = 0, q = p1, pp = p1 + k, r = 0.; j < nm; ++j)
+ r += *q++ * *pp++;
+ r *= s;
+ for (j = 0, q = p1, pp = p1 + k; j < nm; ++j)
+ *pp++ -= r * *q++;
+ }
+ for (j = 1, q = p1 + 1; j < nm; ++j)
+ *q++ *= t;
+ }
+ *p1 = sv;
+ e[i] = -h;
+ }
+ if (nm == 1)
+ e[i] = *p1;
+ }
+ ldvmat(a, v, n);
+ atou1(a, m, n);
+ qrbdu1(d, e, a, m, v, n);
+ for (i = 0; i < n; ++i) {
+ if (d[i] < 0.) {
+ d[i] = -d[i];
+ for (j = 0, p = v + i; j < n; ++j, p += n)
+ *p = -*p;
+ }
+ }
+ free(w);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/svduv.c
===================================================================
--- grass/trunk/lib/external/ccmath/svduv.c (rev 0)
+++ grass/trunk/lib/external/ccmath/svduv.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,93 @@
+/* svduv.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int svduv(double *d, double *a, double *u, int m, double *v, int n)
+{
+ double *p, *p1, *q, *pp, *w, *e;
+
+ double s, h, r, t, sv;
+
+ int i, j, k, mm, nm, ms;
+
+ if (m < n)
+ return -1;
+ w = (double *)calloc(m + n, sizeof(double));
+ e = w + m;
+ for (i = 0, mm = m, nm = n - 1, p = a; i < n; ++i, --mm, --nm, p += n + 1) {
+ if (mm > 1) {
+ sv = h = 0.;
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ t = 1. / (w[0] += h);
+ sv = 1. + fabs(*p / h);
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, r = 0.; j < mm; q += n)
+ r += w[j++] * *q;
+ r *= s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= r * w[j++];
+ }
+ for (j = 1, q = p; j < mm;)
+ *(q += n) = t * w[j++];
+ }
+ *p = sv;
+ d[i] = -h;
+ }
+ if (mm == 1)
+ d[i] = *p;
+ p1 = p + 1;
+ sv = h = 0.;
+ if (nm > 1) {
+ for (j = 0, q = p1, s = 0.; j < nm; ++j, ++q)
+ s += *q * *q;
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p1 < 0.)
+ h = -h;
+ sv = 1. + fabs(*p1 / h);
+ s += *p1 * h;
+ s = 1. / s;
+ t = 1. / (*p1 += h);
+ for (k = n, ms = n * (m - i); k < ms; k += n) {
+ for (j = 0, q = p1, pp = p1 + k, r = 0.; j < nm; ++j)
+ r += *q++ * *pp++;
+ r *= s;
+ for (j = 0, q = p1, pp = p1 + k; j < nm; ++j)
+ *pp++ -= r * *q++;
+ }
+ for (j = 1, q = p1 + 1; j < nm; ++j)
+ *q++ *= t;
+ }
+ *p1 = sv;
+ e[i] = -h;
+ }
+ if (nm == 1)
+ e[i] = *p1;
+ }
+ ldvmat(a, v, n);
+ ldumat(a, u, m, n);
+ qrbdv(d, e, u, m, v, n);
+ for (i = 0; i < n; ++i) {
+ if (d[i] < 0.) {
+ d[i] = -d[i];
+ for (j = 0, p = v + i; j < n; ++j, p += n)
+ *p = -*p;
+ }
+ }
+ free(w);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/svdval.c
===================================================================
--- grass/trunk/lib/external/ccmath/svdval.c (rev 0)
+++ grass/trunk/lib/external/ccmath/svdval.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,80 @@
+/* svdval.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+int svdval(double *d, double *a, int m, int n)
+{
+ double *p, *p1, *q, *w, *v;
+
+ double s, h, u;
+
+ int i, j, k, mm, nm, ms;
+
+ if (m < n)
+ return -1;
+ w = (double *)calloc(m, sizeof(double));
+ for (i = 0, mm = m, nm = n - 1, p = a; i < n; ++i, --mm, --nm, p += n + 1) {
+ if (mm > 1) {
+ for (j = 0, q = p, s = 0.; j < mm; ++j, q += n) {
+ w[j] = *q;
+ s += *q * *q;
+ }
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p < 0.)
+ h = -h;
+ s += *p * h;
+ s = 1. / s;
+ w[0] += h;
+ for (k = 1, ms = n - i; k < ms; ++k) {
+ for (j = 0, q = p + k, u = 0.; j < mm; q += n)
+ u += w[j++] * *q;
+ u *= s;
+ for (j = 0, q = p + k; j < mm; q += n)
+ *q -= u * w[j++];
+ }
+ *p = -h;
+ }
+ }
+ p1 = p + 1;
+ if (nm > 1) {
+ for (j = 0, q = p1, s = 0.; j < nm; ++j, ++q)
+ s += *q * *q;
+ if (s > 0.) {
+ h = sqrt(s);
+ if (*p1 < 0.)
+ h = -h;
+ s += *p1 * h;
+ s = 1. / s;
+ *p1 += h;
+ for (k = n, ms = n * (m - i); k < ms; k += n) {
+ for (j = 0, q = p1, v = p1 + k, u = 0.; j < nm; ++j)
+ u += *q++ * *v++;
+ u *= s;
+ for (j = 0, q = p1, v = p1 + k; j < nm; ++j)
+ *v++ -= u * *q++;
+ }
+ *p1 = -h;
+ }
+ }
+ }
+
+ for (j = 0, p = a; j < n; ++j, p += n + 1) {
+ d[j] = *p;
+ if (j != n - 1)
+ w[j] = *(p + 1);
+ else
+ w[j] = 0.;
+ }
+ qrbdi(d, w, n);
+ for (i = 0; i < n; ++i)
+ if (d[i] < 0.)
+ d[i] = -d[i];
+ free(w);
+ return 0;
+}
Added: grass/trunk/lib/external/ccmath/trncm.c
===================================================================
--- grass/trunk/lib/external/ccmath/trncm.c (rev 0)
+++ grass/trunk/lib/external/ccmath/trncm.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,23 @@
+/* trncm.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include "ccmath.h"
+void trncm(Cpx * a, int n)
+{
+ Cpx s, *p, *q;
+
+ int i, j, e;
+
+ for (i = 0, e = n - 1; i < n - 1; ++i, --e, a += n + 1) {
+ for (j = 0, p = a + 1, q = a + n; j < e; ++j) {
+ s = *p;
+ *p++ = *q;
+ *q = s;
+ q += n;
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/trnm.c
===================================================================
--- grass/trunk/lib/external/ccmath/trnm.c (rev 0)
+++ grass/trunk/lib/external/ccmath/trnm.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,22 @@
+/* trnm.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void trnm(double *a, int n)
+{
+ double s, *p, *q;
+
+ int i, j, e;
+
+ for (i = 0, e = n - 1; i < n - 1; ++i, --e, a += n + 1) {
+ for (p = a + 1, q = a + n, j = 0; j < e; ++j) {
+ s = *p;
+ *p++ = *q;
+ *q = s;
+ q += n;
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/unfl.c
===================================================================
--- grass/trunk/lib/external/ccmath/unfl.c (rev 0)
+++ grass/trunk/lib/external/ccmath/unfl.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,22 @@
+/* unfl.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+static unsigned int a=69069U,c=244045795U;
+static unsigned int s,h,sbuf[256];
+double unfl()
+{ int i;
+ i=(int)(s>>24); s=sbuf[i];
+ h=a*h+c; sbuf[i]=h;
+ return s*2.328306436538696e-10;
+}
+void setunfl(unsigned int k)
+{ int j;
+ for(h=k,j=0; j<=256 ;++j){
+ h=a*h+c;
+ if(j<256) sbuf[j]=h; else s=h;
+ }
+}
Added: grass/trunk/lib/external/ccmath/unitary.c
===================================================================
--- grass/trunk/lib/external/ccmath/unitary.c (rev 0)
+++ grass/trunk/lib/external/ccmath/unitary.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,99 @@
+/* unitary.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+static double tpi = 6.283185307179586;
+
+static void uortho(double *g, int n);
+
+double unfl();
+
+void unitary(Cpx * u, int n)
+{
+ int i, j, k, m;
+
+ Cpx h, *v, *e, *p, *r;
+
+ double *g, *q, a;
+
+ m = n * n;
+ g = (double *)calloc(n * n, sizeof(double));
+ v = (Cpx *) calloc(m + n, sizeof(Cpx));
+ e = v + m;
+ h.re = 1.;
+ h.im = 0.;
+ for (i = 0; i < n; ++i) {
+ a = tpi * unfl();
+ e[i].re = cos(a);
+ e[i].im = sin(a);
+ a = h.re * e[i].re - h.im * e[i].im;
+ h.im = h.im * e[i].re + h.re * e[i].im;
+ h.re = a;
+ }
+ h.im = -h.im;
+ for (i = 0; i < n; ++i) {
+ a = e[i].re * h.re - e[i].im * h.im;
+ e[i].im = e[i].re * h.im + e[i].im * h.re;
+ e[i].re = a;
+ }
+ uortho(g, n);
+ for (i = 0, p = v, q = g; i < n; ++i) {
+ for (j = 0; j < n; ++j)
+ (p++)->re = *q++;
+ }
+ for (i = 0, p = v; i < n; ++i) {
+ for (j = 0, h = e[i]; j < n; ++j, ++p) {
+ a = h.re * p->re - h.im * p->im;
+ p->im = h.im * p->re + h.re * p->im;
+ p->re = a;
+ }
+ }
+ uortho(g, n);
+ for (i = m = 0, p = u; i < n; ++i, m += n) {
+ for (j = 0; j < n; ++j, ++p) {
+ p->re = p->im = 0.;
+ for (k = 0, q = g + m, r = v + j; k < n; ++k, r += n) {
+ p->re += *q * r->re;
+ p->im += *q++ * r->im;
+ }
+ }
+ }
+ free(g);
+ free(v);
+}
+
+static void uortho(double *g, int n)
+{
+ int i, j, k, m;
+
+ double *p, *q, c, s, a;
+
+ for (i = 0, p = g; i < n; ++i) {
+ for (j = 0; j < n; ++j) {
+ if (i == j)
+ *p++ = 1.;
+ else
+ *p++ = 0.;
+ }
+ }
+ for (i = 0, m = n - 1; i < m; ++i) {
+ for (j = i + 1; j < n; ++j) {
+ a = tpi * unfl();
+ c = cos(a);
+ s = sin(a);
+ p = g + n * i;
+ q = g + n * j;
+ for (k = 0; k < n; ++k) {
+ a = *p * c + *q * s;
+ *q = *q * c - *p * s;
+ *p++ = a;
+ ++q;
+ }
+ }
+ }
+}
Added: grass/trunk/lib/external/ccmath/utrncm.c
===================================================================
--- grass/trunk/lib/external/ccmath/utrncm.c (rev 0)
+++ grass/trunk/lib/external/ccmath/utrncm.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,36 @@
+/* utrncm.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void utrncm(Cpx * cm, Cpx * a, Cpx * b, int n)
+{
+ Cpx z, *q0, *p, *s, *t;
+
+ int i, j, k;
+
+ q0 = (Cpx *) calloc(n, sizeof(Cpx));
+ for (i = 0; i < n; ++i, ++cm) {
+ for (j = 0, t = b; j < n; ++j) {
+ z.re = z.im = 0.;
+ for (k = 0, s = a + i * n; k < n; ++k, ++s, ++t) {
+ z.re += t->re * s->re + t->im * s->im;
+ z.im += t->im * s->re - t->re * s->im;
+ }
+ q0[j] = z;
+ }
+ for (j = 0, p = cm, t = a; j < n; ++j, p += n) {
+ z.re = z.im = 0.;
+ for (k = 0, s = q0; k < n; ++k, ++t, ++s) {
+ z.re += t->re * s->re - t->im * s->im;
+ z.im += t->im * s->re + t->re * s->im;
+ }
+ *p = z;
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/utrnhm.c
===================================================================
--- grass/trunk/lib/external/ccmath/utrnhm.c (rev 0)
+++ grass/trunk/lib/external/ccmath/utrnhm.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,40 @@
+/* utrnhm.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+#include <stdlib.h>
+#include "ccmath.h"
+void utrnhm(Cpx * hm, Cpx * a, Cpx * b, int n)
+{
+ Cpx z, *q0, *p, *s, *t;
+
+ int i, j, k;
+
+ q0 = (Cpx *) calloc(n, sizeof(Cpx));
+ for (i = 0; i < n; ++i) {
+ for (j = 0, t = b; j < n; ++j) {
+ z.re = z.im = 0.;
+ for (k = 0, s = a + i * n; k < n; ++k, ++s, ++t) {
+ z.re += t->re * s->re + t->im * s->im;
+ z.im += t->im * s->re - t->re * s->im;
+ }
+ q0[j] = z;
+ }
+ for (j = 0, p = hm + i, t = a; j <= i; ++j, p += n) {
+ z.re = z.im = 0.;
+ for (k = 0, s = q0; k < n; ++k, ++t, ++s) {
+ z.re += t->re * s->re - t->im * s->im;
+ z.im += t->im * s->re + t->re * s->im;
+ }
+ *p = z;
+ if (j < i) {
+ z.im = -z.im;
+ hm[i * n + j] = z;
+ }
+ }
+ }
+ free(q0);
+}
Added: grass/trunk/lib/external/ccmath/vmul.c
===================================================================
--- grass/trunk/lib/external/ccmath/vmul.c (rev 0)
+++ grass/trunk/lib/external/ccmath/vmul.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,30 @@
+/* vmul.c CCMATH mathematics library source code.
+ *
+ * Copyright (C) 2000 Daniel A. Atkinson All rights reserved.
+ * This code may be redistributed under the terms of the GNU library
+ * public license (LGPL). ( See the lgpl.license file for details.)
+ * ------------------------------------------------------------------------
+ */
+void vmul(double *vp, double *mat, double *v, int n)
+{
+ double s, *q;
+
+ int k, i;
+
+ for (k = 0; k < n; ++k) {
+ for (i = 0, q = v, s = 0.; i < n; ++i)
+ s += *mat++ * *q++;
+ *vp++ = s;
+ }
+}
+
+double vnrm(double *u, double *v, int n)
+{
+ double s;
+
+ int i;
+
+ for (i = 0, s = 0.; i < n; ++i)
+ s += *u++ * *v++;
+ return s;
+}
Added: grass/trunk/lib/gmath/ATLAS_wrapper_blas_level_1.c
===================================================================
--- grass/trunk/lib/gmath/ATLAS_wrapper_blas_level_1.c (rev 0)
+++ grass/trunk/lib/gmath/ATLAS_wrapper_blas_level_1.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,417 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: blas level 1 like functions
+* part of the gpde library
+*
+* COPYRIGHT: (C) 2000 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <grass/gmath.h>
+
+#if defined(HAVE_ATLAS)
+#include <cblas.h>
+#endif
+
+
+/*!
+ * \brief Compute the dot product of vector x and y
+ * using the ATLAS routine cblas_ddot
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_x_dot_y, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param rows (int)
+ * \return (double)
+ *
+ * */
+double G_math_ddot(double *x, double *y, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_ddot(rows, x, 1, y, 1);
+#else
+ double val;
+
+ G_math_d_x_dot_y(x, y, &val, rows);
+ return val;
+#endif
+}
+
+
+/*!
+ * \brief Compute the dot product of vector x and y
+ * using the ATLAS routine cblas_sdsdot
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_x_dot_y, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param a (float)
+ * \param rows (int)
+ * \return (float)
+ *
+ * */
+float G_math_sdsdot(float *x, float *y, float a, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_sdsdot(rows, a, x, 1, y, 1);
+#else
+ float val;
+
+ G_math_f_x_dot_y(x, y, &val, rows);
+ return a + val;
+#endif
+}
+
+/*!
+ * \brief Compute the euclidean norm of vector x
+ * using the ATLAS routine cblas_dnrm2
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_d_euclid_norm, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (double *)
+ * \param rows (int)
+ * \return (double)
+ *
+ * */
+double G_math_dnrm2(double *x, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_dnrm2(rows, x, 1);
+#else
+ double val;
+
+ G_math_d_euclid_norm(x, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Compute the absolute sum norm of vector x
+ * using the ATLAS routine cblas_dasum
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_d_asum_norm, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (double *)
+ * \param rows (int)
+ * \return (double)
+ *
+ * */
+double G_math_dasum(double *x, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_dasum(rows, x, 1);
+#else
+ double val;
+
+ G_math_d_asum_norm(x, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Compute the maximum norm of vector x
+ * using the ATLAS routine cblas_idamax
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_d_max_norm, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (double *)
+ * \param rows (int)
+ * \return (double)
+ *
+ * */
+double G_math_idamax(double *x, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_idamax(rows, x, 1);
+#else
+ double val;
+
+ G_math_d_max_norm(x, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Scale vector x with scalar a
+ * using the ATLAS routine cblas_dscal
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_d_ax_by, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (double *)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_dscal(double *x, double a, int rows)
+{
+#if defined(HAVE_ATLAS)
+ cblas_dscal(rows, a, x, 1);
+#else
+ G_math_d_ax_by(x, x, x, a, 0.0, rows);
+#endif
+
+ return;
+}
+
+/*!
+ * \brief Copy vector x to vector y
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_d_copy
+ *
+ * \param x (double *)
+ * \param y (double *)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_dcopy(double *x, double *y, int rows)
+{
+#if defined(HAVE_ATLAS)
+ cblas_dcopy(rows, x, 1, y, 1);
+#else
+ G_math_d_copy(x, y, rows);
+#endif
+
+ return;
+}
+
+
+/*!
+ * \brief Scale vector x with scalar a and add it to y
+ *
+ * \f[ {\bf z} = a{\bf x} + {\bf y} \f]
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_d_ax_by, the
+ * grass implementatiom
+
+ *
+ * \param x (double *)
+ * \param y (double *)
+ * \param a (double)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_daxpy(double *x, double *y, double a, int rows)
+{
+#if defined(HAVE_ATLAS)
+ cblas_daxpy(rows, a, x, 1, y, 1);
+#else
+ G_math_d_ax_by(x, y, y, a, 1.0, rows);
+#endif
+
+ return;
+}
+
+/****************************************************************** */
+
+/********* F L O A T / S I N G L E P E P R E C I S I O N ******** */
+
+/****************************************************************** */
+
+/*!
+ * \brief Compute the dot product of vector x and y
+ * using the ATLAS routine cblas_sdot
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_x_dot_y, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param rows (int)
+ * \return (float)
+ *
+ * */
+float G_math_sdot(float *x, float *y, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_sdot(rows, x, 1, y, 1);
+#else
+ float val;
+
+ G_math_f_x_dot_y(x, y, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Compute the euclidean norm of vector x
+ * using the ATLAS routine cblas_dnrm2
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_euclid_norm, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param rows (int)
+ * \return (float)
+ *
+ * */
+float G_math_snrm2(float *x, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_snrm2(rows, x, 1);
+#else
+ float val;
+
+ G_math_f_euclid_norm(x, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Compute the absolute sum norm of vector x
+ * using the ATLAS routine cblas_dasum
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_asum_norm, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param rows (int)
+ * \return (float)
+ *
+ * */
+float G_math_sasum(float *x, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_sasum(rows, x, 1);
+#else
+ float val;
+
+ G_math_f_asum_norm(x, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Compute the maximum norm of vector x
+ * using the ATLAS routine cblas_idamax
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_max_norm, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param rows (int)
+ * \return (float)
+ *
+ * */
+float G_math_isamax(float *x, int rows)
+{
+#if defined(HAVE_ATLAS)
+ return cblas_isamax(rows, x, 1);
+#else
+ float val;
+
+ G_math_f_max_norm(x, &val, rows);
+ return val;
+#endif
+}
+
+/*!
+ * \brief Scale vector x with scalar a
+ * using the ATLAS routine cblas_dscal
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_ax_by, the OpenMP multi threaded
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param rows (int)
+ * \return (float)
+ *
+ * */
+void G_math_sscal(float *x, float a, int rows)
+{
+#if defined(HAVE_ATLAS)
+ cblas_sscal(rows, a, x, 1);
+#else
+ G_math_f_ax_by(x, x, x, a, 0.0, rows);
+#endif
+
+ return;
+}
+
+/*!
+ * \brief Copy vector x to vector y
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_copy, the
+ * grass implementatiom
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_scopy(float *x, float *y, int rows)
+{
+#if defined(HAVE_ATLAS)
+ cblas_scopy(rows, x, 1, y, 1);
+#else
+ G_math_f_copy(x, y, rows);
+#endif
+
+ return;
+}
+
+
+/*!
+ * \brief Scale vector x with scalar a and add it to y
+ *
+ * \f[ {\bf z} = a{\bf x} + {\bf y} \f]
+ *
+ * If grass was not compiled with ATLAS support
+ * it will call #G_math_f_ax_by, the
+ * grass implementatiom
+
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param a (float)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_saxpy(float *x, float *y, float a, int rows)
+{
+#if defined(HAVE_ATLAS)
+ cblas_saxpy(rows, a, x, 1, y, 1);
+#else
+ G_math_f_ax_by(x, y, y, a, 1.0, rows);
+#endif
+
+ return;
+}
Modified: grass/trunk/lib/gmath/TODO
===================================================================
--- grass/trunk/lib/gmath/TODO 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/TODO 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,4 +1,13 @@
TODO
+Date_ 2009-10-03
+* Add ATLAS wrapper for blas level 2 and level 3 functions.
+* Inlcude the HAVE_ATLAS definition in the configure system
+* Replace the lu-solver in lu.c with the one from the ccmath library
+ and patch alll modules using lu.c
+* Implement a robust parallelizable LU solver with pivoting
+
+
+TODO
Date: 2006-11-20
http://www.netlib.org/lapack/
@@ -32,11 +41,3 @@
row2: 28.26 34.82 38.27 40.1 38.27 23.7
row3: 10.54 16.35 23.7 38.98 40.1 38.98
------------------------------------------------------------------------
-eigen.c/jacobi.c:
- there are two conflicting
- egvorder(), egvorder2()
- transpose(), transpose2()
- both used in i.pca and i.cca. Header different, functionality identical.
- To be merged.
- -> some cleanup done by Glynn
Added: grass/trunk/lib/gmath/blas_level_1.c
===================================================================
--- grass/trunk/lib/gmath/blas_level_1.c (rev 0)
+++ grass/trunk/lib/gmath/blas_level_1.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,674 @@
+
+/*****************************************************************************
+ *
+ * MODULE: Grass Gmath Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2007
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: blas level 1 like functions
+ * part of the gmath library
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <grass/gmath.h>
+#include <grass/gis.h>
+
+/* **************************************************************** */
+/* *************** D O U B L E ************************************ */
+/* **************************************************************** */
+
+/*!
+ * \brief Compute the dot product of vector x and y
+ *
+ * \f[ a = {\bf x}^T {\bf y} \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (double *)
+ * \param y (double *)
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_x_dot_y(double *x, double *y, double *value, int rows)
+{
+ int i;
+
+ double s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += x[i] * y[i];
+ }
+#pragma omp single
+ {
+ *value = s;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the euclid norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_2 \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (double *) -- the vector
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_euclid_norm(double *x, double *value, int rows)
+{
+ int i;
+
+ double s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += x[i] * x[i];
+ }
+#pragma omp single
+ {
+ *value = sqrt(s);
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the asum norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_1 \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (double *)-- the vector
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_asum_norm(double *x, double *value, int rows)
+{
+ int i = 0;
+
+ double s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += fabs(x[i]);
+ }
+#pragma omp single
+ {
+ *value = s;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the maximum norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_\infty \f]
+ *
+ * This function is not multi-threaded
+ *
+ * \param x (double *)-- the vector
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_max_norm(double *x, double *value, int rows)
+{
+ int i;
+
+ double max = 0.0;
+
+ max = fabs(x[rows - 1]);
+ for (i = rows - 2; i >= 0; i--) {
+ if (max < fabs(x[i]))
+ max = fabs(x[i]);
+ }
+
+ *value = max;
+}
+
+/*!
+ * \brief Scales vectors x and y with the scalars a and b and adds them
+ *
+ * \f[ {\bf z} = a{\bf x} + b{\bf y} \f]
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param x (double *)
+ * \param y (double *)
+ * \param z (double *)
+ * \param a (double)
+ * \param b (double)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_ax_by(double *x, double *y, double *z, double a, double b,
+ int rows)
+{
+ int i;
+
+ /*find specific cases */
+ if (b == 0.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i];
+ }
+ }
+ else if ((a == 1.0) && (b == 1.0)) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = x[i] + y[i];
+ }
+ }
+ else if ((a == 1.0) && (b == -1.0)) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = x[i] - y[i];
+ }
+ }
+ else if (a == b) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * (x[i] + y[i]);
+ }
+ }
+ else if (b == -1.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] - y[i];
+ }
+ }
+ else if (b == 1.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] + y[i];
+ }
+ }
+ else {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] + b * y[i];
+ }
+ }
+
+ return;
+}
+
+/*!
+ * \brief Copy the vector x to y
+ *
+ * \f[ {\bf y} = {\bf x} \f]
+ *
+ * This function is not multi-threaded
+ *
+ * \param x (double *)
+ * \param y (double *)
+ * \param rows (int)
+ *
+ * */
+void G_math_d_copy(double *x, double *y, int rows)
+{
+ y = memcpy(y, x, rows * sizeof(double));
+
+ return;
+}
+
+/* **************************************************************** */
+/* *************** F L O A T ************************************** */
+/* **************************************************************** */
+
+/*!
+ * \brief Compute the dot product of vector x and y
+ *
+ * \f[ a = {\bf x}^T {\bf y} \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param value (float *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_x_dot_y(float *x, float *y, float *value, int rows)
+{
+ int i;
+
+ float s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += x[i] * y[i];
+ }
+#pragma omp single
+ {
+ *value = s;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the euclid norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_2 \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (double *) -- the vector
+ * \param value (float *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_euclid_norm(float *x, float *value, int rows)
+{
+ int i;
+
+ float s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += x[i] * x[i];
+ }
+#pragma omp single
+ {
+ *value = sqrt(s);
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the asum norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_1 \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (float *)-- the vector
+ * \param value (float *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_asum_norm(float *x, float *value, int rows)
+{
+ int i;
+
+ int count = 0;
+
+ float s = 0.0;
+
+#pragma omp parallel for schedule (static) private(i) reduction(+:s, count)
+ for (i = 0; i < rows; i++) {
+ s += fabs(x[i]);
+ count++;
+ }
+#pragma omp single
+ {
+ *value = s;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the maximum norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_\infty \f]
+ *
+ * This function is not multi-threaded
+ *
+ * \param x (float *)-- the vector
+ * \param value (float *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_max_norm(float *x, float *value, int rows)
+{
+ int i;
+
+ float max = 0.0;
+
+ max = fabs(x[rows - 1]);
+ for (i = rows - 2; i >= 0; i--) {
+ if (max < fabs(x[i]))
+ max = fabs(x[i]);
+ }
+ *value = max;
+ return;
+}
+
+/*!
+ * \brief Scales vectors x and y with the scalars a and b and adds them
+ *
+ * \f[ {\bf z} = a{\bf x} + b{\bf y} \f]
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param z (float *)
+ * \param a (float)
+ * \param b (float)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_ax_by(float *x, float *y, float *z, float a, float b, int rows)
+{
+ int i;
+
+ /*find specific cases */
+ if (b == 0.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i];
+ }
+ }
+ else if ((a == 1.0) && (b == 1.0)) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = x[i] + y[i];
+ }
+ }
+ else if ((a == 1.0) && (b == -1.0)) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = x[i] - y[i];
+ }
+ }
+ else if (a == b) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * (x[i] + y[i]);
+ }
+ }
+ else if (b == -1.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] - y[i];
+ }
+ }
+ else if (b == 1.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] + y[i];
+ }
+ }
+ else {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] + b * y[i];
+ }
+ }
+
+ return;
+}
+
+/*!
+ * \brief Copy the vector x to y
+ *
+ * \f[ {\bf y} = {\bf x} \f]
+ *
+ * This function is not multi-threaded
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param rows (int)
+ *
+ * */
+void G_math_f_copy(float *x, float *y, int rows)
+{
+ y = memcpy(y, x, rows * sizeof(float));
+
+ return;
+}
+
+/* **************************************************************** */
+/* *************** I N T E G E R ********************************** */
+/* **************************************************************** */
+
+/*!
+ * \brief Compute the dot product of vector x and y
+ *
+ * \f[ a = {\bf x}^T {\bf y} \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (int *)
+ * \param y (int *)
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_i_x_dot_y(int *x, int *y, double *value, int rows)
+{
+ int i;
+
+ double s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += x[i] * y[i];
+ }
+#pragma omp single
+ {
+ *value = s;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the euclid norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_2 \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (int *) -- the vector
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_i_euclid_norm(int *x, double *value, int rows)
+{
+ int i;
+
+ double s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += x[i] * x[i];
+ }
+#pragma omp single
+ {
+ *value = sqrt(s);
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the asum norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_1 \f]
+ *
+ * The functions creates its own parallel OpenMP region.
+ * It can be called within a parallel OpenMP region if nested parallelism is supported
+ * by the compiler.
+ *
+ * \param x (int *)-- the vector
+ * \param value (double *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_i_asum_norm(int *x, double *value, int rows)
+{
+ int i;
+
+ double s = 0.0;
+
+#pragma omp parallel for schedule (static) reduction(+:s)
+ for (i = rows - 1; i >= 0; i--) {
+ s += fabs(x[i]);
+ }
+#pragma omp single
+ {
+ *value = s;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the maximum norm of vector x
+ *
+ * \f[ a = ||{\bf x}||_\infty \f]
+ *
+ * This function is not multi-threaded
+ *
+ * \param x (int *)-- the vector
+ * \param value (int *) -- the return value
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_i_max_norm(int *x, int *value, int rows)
+{
+ int i;
+
+ int max = 0.0;
+
+ max = fabs(x[rows - 1]);
+ for (i = rows - 2; i >= 0; i--) {
+ if (max < fabs(x[i]))
+ max = fabs(x[i]);
+ }
+
+ *value = max;
+}
+
+/*!
+ * \brief Scales vectors x and y with the scalars a and b and adds them
+ *
+ * \f[ {\bf z} = a{\bf x} + b{\bf y} \f]
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param x (int *)
+ * \param y (int *)
+ * \param z (int *)
+ * \param a (int)
+ * \param b (int)
+ * \param rows (int)
+ * \return (void)
+ *
+ * */
+void G_math_i_ax_by(int *x, int *y, int *z, int a, int b, int rows)
+{
+ int i;
+
+ /*find specific cases */
+ if (b == 0.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i];
+ }
+ }
+ else if ((a == 1.0) && (b == 1.0)) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = x[i] + y[i];
+ }
+ }
+ else if ((a == 1.0) && (b == -1.0)) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = x[i] - y[i];
+ }
+ }
+ else if (a == b) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * (x[i] + y[i]);
+ }
+ }
+ else if (b == -1.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] - y[i];
+ }
+ }
+ else if (b == 1.0) {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] + y[i];
+ }
+ }
+ else {
+#pragma omp for schedule (static)
+ for (i = rows - 1; i >= 0; i--) {
+ z[i] = a * x[i] + b * y[i];
+ }
+ }
+
+ return;
+}
+
+/*!
+ * \brief Copy the vector x to y
+ *
+ * \f[ {\bf y} = {\bf x} \f]
+ *
+ * This function is not multi-threaded
+ *
+ * \param x (int *)
+ * \param y (int *)
+ * \param rows (int)
+ *
+ * */
+void G_math_i_copy(int *x, int *y, int rows)
+{
+ y = memcpy(y, x, rows * sizeof(int));
+
+ return;
+}
Added: grass/trunk/lib/gmath/blas_level_2.c
===================================================================
--- grass/trunk/lib/gmath/blas_level_2.c (rev 0)
+++ grass/trunk/lib/gmath/blas_level_2.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,420 @@
+
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2007
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: linear equation system solvers
+ * part of the gpde library
+ *
+ * COPYRIGHT: (C) 2007 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <grass/gmath.h>
+#include <grass/gis.h>
+#include <grass/gisdefs.h>
+
+#define EPSILON 0.00000000000000001
+
+/*!
+ * \brief Compute the matrix - vector product
+ * of sparse matrix **Asp and vector x.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * y = A * x
+ *
+ *
+ * \param Asp (G_math_spvector **)
+ * \param x (double) *)
+ * \param y (double * )
+ * \return (void)
+ *
+ * */
+void G_math_Ax_sparse(G_math_spvector ** Asp, double *x, double *y, int rows)
+{
+ int i, j;
+
+ double tmp;
+
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = 0; j < Asp[i]->cols; j++) {
+ tmp += Asp[i]->values[j] * x[Asp[i]->index[j]];
+ }
+ y[i] = tmp;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the matrix - vector product
+ * of matrix A and vector x.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * y = A * x
+ *
+ *
+ * \param A (double ** )
+ * \param x (double *)
+ * \param y (double *)
+ * \param rows (int)
+ * \param cols (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_Ax(double **A, double *x, double *y, int rows, int cols)
+{
+ int i, j;
+
+ double tmp;
+
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += A[i][j] * x[j];
+ }
+ y[i] = tmp;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the matrix - vector product
+ * of matrix A and vector x.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * y = A * x
+ *
+ *
+ * \param A (float ** )
+ * \param x (float *)
+ * \param y (float *)
+ * \param rows (int)
+ * \param cols (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_Ax(float **A, float *x, float *y, int rows, int cols)
+{
+ int i, j;
+
+ float tmp;
+
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += A[i][j] * x[j];
+ }
+ y[i] = tmp;
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the dyadic product of two vectors.
+ * The result is stored in the matrix A.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * A = x * y^T
+ *
+ *
+ * \param x (double *)
+ * \param y (double *)
+ * \param A (float **) -- matrix of size rows*cols
+ * \param rows (int) -- length of vector x
+ * \param cols (int) -- lengt of vector y
+ * \return (void)
+ *
+ * */
+void G_math_d_x_dyad_y(double *x, double *y, double **A, int rows, int cols)
+{
+ int i, j;
+
+#pragma omp for schedule (static) private(i, j)
+ for (i = 0; i < rows; i++) {
+ for (j = cols - 1; j >= 0; j--) {
+ A[i][j] = x[i] * y[j];
+ }
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the dyadic product of twMo vectors.
+ * The result is stored in the matrix A.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * A = x * y^T
+ *
+ *
+ * \param x (float *)
+ * \param y (float *)
+ * \param A (float **= -- matrix of size rows*cols
+ * \param rows (int) -- length of vector x
+ * \param cols (int) -- lengt of vector y
+ * \return (void)
+ *
+ * */
+void G_math_f_x_dyad_y(float *x, float *y, float **A, int rows, int cols)
+{
+ int i, j;
+
+#pragma omp for schedule (static) private(i, j)
+ for (i = 0; i < rows; i++) {
+ for (j = cols - 1; j >= 0; j--) {
+ A[i][j] = x[i] * y[j];
+ }
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the scaled matrix - vector product
+ * of matrix double **A and vector x and y.
+ *
+ * z = a * A * x + b * y
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ *
+ * \param A (double **)
+ * \param x (double *)
+ * \param y (double *)
+ * \param a (double)
+ * \param b (double)
+ * \param z (double *)
+ * \param rows (int)
+ * \param cols (int)
+ * \return (void)
+ *
+ * */
+
+void G_math_d_aAx_by(double **A, double *x, double *y, double a, double b,
+ double *z, int rows, int cols)
+{
+ int i, j;
+
+ double tmp;
+
+ /*catch specific cases */
+ if (a == b) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += A[i][j] * x[j] + y[j];
+ }
+ z[i] = a * tmp;
+ }
+ }
+ else if (b == -1.0) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += a * A[i][j] * x[j] - y[j];
+ }
+ z[i] = tmp;
+ }
+ }
+ else if (b == 0.0) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += A[i][j] * x[j];
+ }
+ z[i] = a * tmp;
+ }
+ }
+ else if (a == -1.0) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += b * y[j] - A[i][j] * x[j];
+ }
+ z[i] = tmp;
+ }
+ }
+ else {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += a * A[i][j] * x[j] + b * y[j];
+ }
+ z[i] = tmp;
+ }
+ }
+ return;
+}
+
+/*!
+ * \brief Compute the scaled matrix - vector product
+ * of matrix A and vectors x and y.
+ *
+ * z = a * A * x + b * y
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ *
+ * \param A (float **)
+ * \param x (float *)
+ * \param y (float *)
+ * \param a (float)
+ * \param b (float)
+ * \param z (float *)
+ * \param rows (int)
+ * \param cols (int)
+ * \return (void)
+ *
+ * */
+
+void G_math_f_aAx_by(float **A, float *x, float *y, float a, float b,
+ float *z, int rows, int cols)
+{
+ int i, j;
+
+ float tmp;
+
+ /*catch specific cases */
+ if (a == b) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += A[i][j] * x[j] + y[j];
+ }
+ z[i] = a * tmp;
+ }
+ }
+ else if (b == -1.0) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += a * A[i][j] * x[j] - y[j];
+ }
+ z[i] = tmp;
+ }
+ }
+ else if (b == 0.0) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += A[i][j] * x[j];
+ }
+ z[i] = a * tmp;
+ }
+ }
+ else if (a == -1.0) {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += b * y[j] - A[i][j] * x[j];
+ }
+ z[i] = tmp;
+ }
+ }
+ else {
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++) {
+ tmp = 0;
+ for (j = cols - 1; j >= 0; j--) {
+ tmp += a * A[i][j] * x[j] + b * y[j];
+ }
+ z[i] = tmp;
+ }
+ }
+ return;
+}
+
+
+
+/*!
+ * \fn int G_math_d_A_T(double **A, int rows)
+ *
+ * \brief Compute the transposition of matrix A.
+ * Matrix A will be overwritten.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * Returns 0.
+ *
+ * \param A (double **)
+ * \param rows (int)
+ * \return int
+ */
+
+int G_math_d_A_T(double **A, int rows)
+{
+ int i, j;
+
+ double tmp;
+
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++)
+ for (j = 0; j < i; j++) {
+ tmp = A[i][j];
+
+ A[i][j] = A[j][i];
+ A[j][i] = tmp;
+ }
+
+ return 0;
+}
+
+/*!
+ * \fn int G_math_d_A_T(float **A, int rows)
+ *
+ * \brief Compute the transposition of matrix A.
+ * Matrix A will be overwritten.
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * Returns 0.
+ *
+ * \param A (float **)
+ * \param rows (int)
+ * \return int
+ */
+
+int G_math_f_A_T(float **A, int rows)
+{
+ int i, j;
+
+ float tmp;
+
+#pragma omp for schedule (static) private(i, j, tmp)
+ for (i = 0; i < rows; i++)
+ for (j = 0; j < i; j++) {
+ tmp = A[i][j];
+
+ A[i][j] = A[j][i];
+ A[j][i] = tmp;
+ }
+
+ return 0;
+}
Added: grass/trunk/lib/gmath/blas_level_3.c
===================================================================
--- grass/trunk/lib/gmath/blas_level_3.c (rev 0)
+++ grass/trunk/lib/gmath/blas_level_3.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,231 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2007
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: linear equation system solvers
+* part of the gpde library
+*
+* COPYRIGHT: (C) 2007 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include "grass/gmath.h"
+#include <grass/gis.h>
+
+
+/*!
+ * \brief Add two matrices and scale matrix A with the scalar a
+ *
+ * \f[ {\bf C} = a {\bf A} + {\bf B} \f]
+ *
+ * In case B == NULL, matrix A will be scaled by scalar a. \n
+ * In case a == 1.0, a simple matrix addition is performed. \n
+ * In case a == -1.0 matrix A is substracted from matrix B. \n
+ * The result is written into matrix C.
+ *
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param A (double **)
+ * \param B (double **) if NULL, matrix A is scaled by scalar a only
+ * \param a (double)
+ * \param C (double **)
+ * \param rows (int)
+ * \param cols (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_aA_B(double **A, double **B, double a, double **C, int rows,
+ int cols)
+{
+ int i, j;
+
+
+ /*If B is null, scale the matrix A with th scalar a */
+ if (B == NULL) {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = a * A[i][j];
+
+ return;
+ }
+
+ /*select special cases */
+ if (a == 1.0) {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = A[i][j] + B[i][j];
+ }
+ else if (a == -1.0) {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = B[i][j] - A[i][j];
+ }
+ else {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = a * A[i][j] + B[i][j];
+ }
+
+ return;
+}
+
+/*!
+ * \brief Add two matrices and scale matrix A with the scalar a
+ *
+ * \f[ {\bf C} = a {\bf A} + {\bf B} \f]
+ *
+ * In case B == NULL, matrix A will be scaled by scalar a. \n
+ * In case a == 1.0, a simple matrix addition is performed. \n
+ * In case a == -1.0 matrix A is substracted from matrix B. \n
+ * The result is written into matrix C.
+ *
+ *
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param A (float **)
+ * \param B (float **) if NULL, matrix A is scaled by scalar a only
+ * \param a (float)
+ * \param C (float **)
+ * \param rows (int)
+ * \param cols (int)
+
+ * \return (void)
+ *
+ * */
+void G_math_f_aA_B(float **A, float **B, float a, float **C, int rows,
+ int cols)
+{
+ int i, j;
+
+ /*If B is null, scale the matrix A with th scalar a */
+ if (B == NULL) {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = a * A[i][j];
+ return;
+ }
+
+ /*select special cases */
+ if (a == 1.0) {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = A[i][j] + B[i][j];
+ }
+ else if (a == -1.0) {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = B[i][j] - A[i][j];
+ }
+ else {
+#pragma omp for schedule (static) private(i, j)
+ for (i = rows - 1; i >= 0; i--)
+ for (j = cols - 1; j >= 0; j--)
+ C[i][j] = a * A[i][j] + B[i][j];
+ }
+
+ return;
+}
+
+
+/*!
+ * \brief Matrix multiplication
+ *
+ * \f[ {\bf C} = {\bf A}{\bf B} \f]
+ *
+ * The result is written into matrix C.
+ *
+ * A must be of size rows_A * cols_A
+ * B must be of size rows_B * cols_B with rows_B == cols_A
+ * C must be of size rows_A * rows_B
+ *
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param A (double **)
+ * \param B (double **)
+ * \param C (double **)
+ * \param rows_A (int)
+ * \param cols_A (int)
+ * \param rows_B (int)
+ * \return (void)
+ *
+ * */
+void G_math_d_AB(double **A, double **B, double **C, int rows_A,
+ int cols_A, int rows_B)
+{
+ int i, j, k;
+
+#pragma omp for schedule (static) private(i, j, k)
+ for (i = 0; i < rows_A; i++) {
+ for (j = 0; j < rows_B; j++) {
+ C[i][j] = 0.0;
+ for (k = cols_A - 1; k >= 0; k--) {
+ C[i][j] += A[i][k] * B[k][j];
+ }
+ }
+ }
+
+ return;
+}
+
+/*!
+ * \brief Matrix multiplication
+ *
+ * \f[ {\bf C} = {\bf A}{\bf B} \f]
+ *
+ * The result is written into matrix C.
+ *
+ * A must be of size rows_A * cols_A
+ * B must be of size rows_B * cols_B with rows_B == cols_A
+ * C must be of size rows_A * rows_B
+ *
+ *
+ * This function is multi-threaded with OpenMP and can be called within a parallel OpenMP region.
+ *
+ * \param A (float **)
+ * \param B (float **)
+ * \param D (float **)
+ * \param rows_A (int)
+ * \param cols_A (int)
+ * \param rows_B (int)
+ * \return (void)
+ *
+ * */
+void G_math_f_AB(float **A, float **B, float **C, int rows_A,
+ int cols_A, int rows_B)
+{
+ int i, j, k;
+
+#pragma omp for schedule (static) private(i, j, k)
+ for (i = 0; i < rows_A; i++) {
+ for (j = 0; j < rows_B; j++) {
+ C[i][j] = 0.0;
+ for (k = cols_A - 1; k >= 0; k--) {
+ C[i][j] += A[i][k] * B[k][j];
+ }
+ }
+ }
+
+ return;
+}
Added: grass/trunk/lib/gmath/ccmath_grass_wrapper.c
===================================================================
--- grass/trunk/lib/gmath/ccmath_grass_wrapper.c (rev 0)
+++ grass/trunk/lib/gmath/ccmath_grass_wrapper.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,458 @@
+#if defined(HAVE_CCMATH)
+#include <ccmath.h>
+#else
+#include <grass/ccmath_grass.h>
+#endif
+/**
+ Chapter 1
+
+ LINEAR ALGEBRA
+
+ Summary
+
+ The matrix algebra library contains functions that
+ perform the standard computations of linear algebra.
+ General areas covered are:
+
+ o Solution of Linear Systems
+ o Matrix Inversion
+ o Eigensystem Analysis
+ o Matrix Utility Operations
+ o Singular Value Decomposition
+
+ The operations covered here are fundamental to many
+ areas of mathematics and statistics. Thus, functions
+ in this library segment are called by other library
+ functions. Both real and complex valued matrices
+ are covered by functions in the first four of these
+ categories.
+
+
+ Notes on Contents
+
+ Functions in this library segment provide the basic operations of
+ numerical linear algebra and some useful utility functions for operations on
+ vectors and matrices. The following list describes the functions available for
+ operations with real-valued matrices.
+
+
+ o Solving and Inverting Linear Systems:
+
+ solv --------- solve a general system of real linear equations.
+ solvps ------- solve a real symmetric linear system.
+ solvru ------- solve a real right upper triangular linear system.
+ solvtd ------- solve a tridiagonal real linear system.
+
+ minv --------- invert a general real square matrix.
+ psinv -------- invert a real symmetric matrix.
+ ruinv -------- invert a right upper triangular matrix.
+
+
+ The solution of a general linear system and efficient algorithms for
+ solving special systems with symmetric and tridiagonal matrices are provided
+ by these functions. The general solution function employs a LU factorization
+ with partial pivoting and it is very robust. It will work efficiently on any
+ problem that is not ill-conditioned. The symmetric matrix solution is based
+ on a modified Cholesky factorization. It is best used on positive definite
+ matrices that do not require pivoting for numeric stability. Tridiagonal
+ solvers require order-N operations (N = dimension). Thus, they are highly
+ recommended for this important class of sparse systems. Two matrix inversion
+ routines are provided. The general inversion function is again LU based. It
+ is suitable for use on any stable (ie. well-conditioned) problem. The
+ Cholesky based symmetric matrix inversion is efficient and safe for use on
+ matrices known to be positive definite, such as the variance matrices
+ encountered in statistical computations. Both the solver and the inverse
+ functions are designed to enhance data locality. They are very effective
+ on modern microprocessors.
+
+
+ o Eigensystem Analysis:
+
+ eigen ------ extract all eigen values and vectors of a real
+ symmetric matrix.
+ eigval ----- extract the eigen values of a real symmetric matrix.
+ evmax ------ compute the eigen value of maximum absolute magnitude
+ and its corresponding vector for a symmetric matrix.
+
+
+ Eigensystem functions operate on real symmetric matrices. Two forms of
+ the general eigen routine are provided because the computation of eigen values
+ only is much faster when vectors are not required. The basic algorithms use
+ a Householder reduction to tridiagonal form followed by QR iterations with
+ shifts to enhance convergence. This has become the accepted standard for
+ symmetric eigensystem computation. The evmax function uses an efficient
+ iterative power method algorithm to extract the eigen value of maximum
+ absolute size and the corresponding eigenvector.
+
+
+ o Singular Value Decomposition:
+
+ svdval ----- compute the singular values of a m by n real matrix.
+ sv2val ----- compute the singular values of a real matrix
+ efficiently for m >> n.
+ svduv ------ compute the singular values and the transformation
+ matrices u and v for a real m by n matrix.
+ sv2uv ------ compute the singular values and transformation
+ matrices efficiently for m >> n.
+ svdu1v ----- compute the singular values and transformation
+ matrices u1 and v, where u1 overloads the input
+ with the first n column vectors of u.
+ sv2u1v ----- compute the singular values and the transformation
+ matrices u1 and v efficiently for m >> n.
+
+
+ Singular value decomposition is extremely useful when dealing with linear
+ systems that may be singular. Singular values with values near zero are flags
+ of a potential rank deficiency in the system matrix. They can be used to
+ identify the presence of an ill-conditioned problem and, in some cases, to
+ deal with the potential instability. They are applied to the linear least
+ squares problem in this library. Singular values also define some important
+ matrix norm parameters such as the 2-norm and the condition value. A complete
+ decomposition provides both singular values and an orthogonal decomposition of
+ vector spaces related to the matrix identifying the range and null-space.
+ Fortunately, a highly stable algorithm based on Householder reduction to
+ bidiagonal form and QR rotations can be used to implement the decomposition.
+ The library provides two forms with one more efficient when the dimensions
+ satisfy m > (3/2)n.
+
+ General Technical Comments
+
+ Efficient computation with matrices on modern processors must be
+ adapted to the storage scheme employed for matrix elements. The functions
+ of this library segment do not employ the multidimensional array intrinsic
+ of the C language. Access to elements employs the simple row-major scheme
+ described here.
+
+ Matrices are modeled by the library functions as arrays with elements
+ stored in row order. Thus, the element in the jth row and kth column of
+ the n by n matrix M, stored in the array mat[], is addressed by
+
+ M[j,k] = mat[n*j+k] , with 0 =< j,k <= n-1 .
+
+ (Remember that C employs zero as the starting index.) The storage order has
+ important implications for data locality.
+
+ The algorithms employed here all have excellent numerical stability, and
+ the default double precision arithmetic of C enhances this. Thus, any
+ problems encountered in using the matrix algebra functions will almost
+ certainly be due to an ill-conditioned matrix. (The Hilbert matrices,
+
+ H[i,j] = 1/(1+i+j) for i,j < n
+
+ form a good example of such ill-conditioned systems.) We remind the reader
+ that the appropriate response to such ill-conditioning is to seek an
+ alternative approach to the problem. The option of increasing precision has
+ already been exploited. Modification of the linear algebra algorithm code is
+ not normally effective in an ill-conditioned problem.
+
+------------------------------------------------------------------------------
+ FUNCTION SYNOPSES
+------------------------------------------------------------------------------
+
+ Linear System Solutions:
+-----------------------------------------------------------------------------
+*/
+/**
+ \brief Solve a general linear system A*x = b.
+
+ \param a = array containing system matrix A in row order (altered to L-U factored form by computation)
+ \param b = array containing system vector b at entry and solution vector x at exit
+ \param n = dimension of system
+ \return 0 -> normal exit; -1 -> singular input
+ */
+int G_math_solv(double **a,double *b,int n)
+{
+ return solv(a[0],b, n);
+}
+
+
+/**
+ \brief Solve a symmetric positive definite linear system S*x = b.
+
+ \param a = array containing system matrix S (altered to Cholesky upper right factor by computation)
+ \param b = array containing system vector b as input and solution vector x as output
+ \param n = dimension of system
+ \return: 0 -> normal exit; -1 -> input matrix not positive definite
+ */
+ int G_math_solvps(double **a,double *b,int n)
+{
+ return solvps(a[0], b,n);
+}
+
+
+/**
+ \brief Solve a tridiagonal linear system M*x = y.
+
+ \param a = array containing m+1 diagonal elements of M
+ \param b = array of m elements below the main diagonal of M
+ \param c = array of m elements above the main diagonal
+ \param x = array containing the system vector y initially, and the solution vector at exit (m+1 elements)
+ \param m = dimension parameter ( M is (m+1)x(m+1) )
+
+*/
+void G_math_solvtd(double *a,double *b,double *c,double *x,int m)
+{
+ solvtd(a, b, c, x, m);
+ return;
+}
+
+
+/*
+ \brief Solve an upper right triangular linear system T*x = b.
+
+ \param a = pointer to array of upper right triangular matrix T
+ \param b = pointer to array of system vector The computation overloads this with the solution vector x.
+ \param n = dimension (dim(a)=n*n,dim(b)=n)
+ \return value: f = status flag, with 0 -> normal exit, -1 -> system singular
+*/
+int G_math_solvru(double **a,double *b,int n)
+{
+ return solvru(a[0], b, n);
+}
+
+
+/**
+ \brief Invert (in place) a general real matrix A -> Inv(A).
+
+ \param a = array containing the input matrix A. This is converted to the inverse matrix.
+ \param n = dimension of the system (i.e. A is n x n )
+ \return: 0 -> normal exit, 1 -> singular input matrix
+*/
+int G_math_minv(double **a,int n)
+{
+ return minv(a[0], n);
+}
+
+
+/**
+ \brief Invert (in place) a symmetric real matrix, V -> Inv(V).
+
+ The input matrix V is symmetric (V[i,j] = V[j,i]).
+ \param v = array containing a symmetric input matrix. This is converted to the inverse matrix.
+ \param n = dimension of the system (dim(v)=n*n)
+ \return: 0 -> normal exit 1 -> input matrix not positive definite
+*/
+int G_math_psinv(double **a,int n)
+{
+ return psinv( a[0], n);
+}
+
+
+/**
+ \brief Invert an upper right triangular matrix T -> Inv(T).
+
+ \param a = pointer to array of upper right triangular matrix, This is replaced by the inverse matrix.
+ \param n = dimension (dim(a)=n*n)
+ \return value: status flag, with 0 -> matrix inverted -1 -> matrix singular
+*/
+int G_math_ruinv(double **a,int n)
+{
+ return ruinv(a[0], n);
+}
+
+
+/*
+-----------------------------------------------------------------------------
+
+ Symmetric Eigensystem Analysis:
+-----------------------------------------------------------------------------
+*/
+/**
+
+ \brief Compute the eigenvalues of a real symmetric matrix A.
+
+ \param a = pointer to array of symmetric n by n input matrix A. The computation alters these values.
+ \param ev = pointer to array of the output eigenvalues
+ \param n = dimension parameter (dim(a)= n*n, dim(ev)= n)
+*/
+void G_math_eigval(double **a,double *ev,int n)
+{
+ eigval(a[0], ev, n);
+ return;
+}
+
+
+/**
+ \brief Compute the eigenvalues and eigenvectors of a real symmetric matrix A.
+
+ The input and output matrices are related by
+
+ A = E*D*E~ where D is the diagonal matrix of eigenvalues
+ D[i,j] = ev[i] if i=j and 0 otherwise.
+
+ The columns of E are the eigenvectors.
+
+ \param a = pointer to store for symmetric n by n input matrix A. The computation overloads this with an orthogonal matrix of eigenvectors E.
+ \param ev = pointer to the array of the output eigenvalues
+ \param n = dimension parameter (dim(a)= n*n, dim(ev)= n)
+*/
+void G_math_eigen(double **a,double *ev,int n)
+{
+ eigen(a[0], ev, n);
+ return;
+}
+
+
+/*
+ \brief Compute the maximum (absolute) eigenvalue and corresponding eigenvector of a real symmetric matrix A.
+
+
+ \param a = array containing symmetric input matrix A
+ \param u = array containing the n components of the eigenvector at exit (vector normalized to 1)
+ \param n = dimension of system
+ \return: ev = eigenvalue of A with maximum absolute value HUGE -> convergence failure
+*/
+double G_math_evmax(double **a,double *u,int n)
+{
+ return evmax(a[0], u, n);
+}
+
+
+/*
+------------------------------------------------------------------------------
+
+ Singular Value Decomposition:
+------------------------------------------------------------------------------
+
+ A number of versions of the Singular Value Decomposition (SVD)
+ are implemented in the library. They support the efficient
+ computation of this important factorization for a real m by n
+ matrix A. The general form of the SVD is
+
+ A = U*S*V~ with S = | D |
+ | 0 |
+
+ where U is an m by m orthogonal matrix, V is an n by n orthogonal matrix,
+ D is the n by n diagonal matrix of singular value, and S is the singular
+ m by n matrix produced by the transformation.
+
+ The singular values computed by these functions provide important
+ information on the rank of the matrix A, and on several matrix
+ norms of A. The number of non-zero singular values d[i] in D
+ equal to the rank of A. The two norm of A is
+
+ ||A|| = max(d[i]) , and the condition number is
+
+ k(A) = max(d[i])/min(d[i]) .
+
+ The Frobenius norm of the matrix A is
+
+ Fn(A) = Sum(i=0 to n-1) d[i]^2 .
+
+ Singular values consistent with zero are easily recognized, since
+ the decomposition algorithms have excellent numerical stability.
+ The value of a 'zero' d[i] is no larger than a few times the
+ computational rounding error e.
+
+ The matrix U1 is formed from the first n orthonormal column vectors
+ of U. U1[i,j] = U[i,j] for i = 1 to m and j = 1 to n. A singular
+ value decomposition of A can also be expressed in terms of the m by\
+ n matrix U1, with
+
+ A = U1*D*V~ .
+
+ SVD functions with three forms of output are provided. The first
+ form computes only the singular values, while the second computes
+ the singular values and the U and V orthogonal transformation
+ matrices. The third form of output computes singular values, the
+ V matrix, and saves space by overloading the input array with
+ the U1 matrix.
+
+ Two forms of decomposition algorithm are available for each of the
+ three output types. One is computationally efficient when m ~ n.
+ The second, distinguished by the prefix 'sv2' in the function name,
+ employs a two stage Householder reduction to accelerate computation
+ when m substantially exceeds n. Use of functions of the second form
+ is recommended for m > 2n.
+
+ Singular value output from each of the six SVD functions satisfies
+
+ d[i] >= 0 for i = 0 to n-1.
+-------------------------------------------------------------------------------
+*/
+
+
+/**
+ \brief Compute the singular values of a real m by n matrix A.
+
+
+ \param d = pointer to double array of dimension n (output = singular values of A)
+ \param a = pointer to store of the m by n input matrix A (A is altered by the computation)
+ \param m = number of rows in A
+ \param n = number of columns in A (m>=n required)
+ \return value: status flag with: 0 -> success -1 -> input error m < n
+
+*/
+int G_math_svdval(double *d,double **a,int m,int n)
+{
+ return svdval(d, a[0], m, n);
+}
+
+
+/**
+
+ \brief Compute singular values when m >> n.
+
+ \param d = pointer to double array of dimension n (output = singular values of A)
+ \param a = pointer to store of the m by n input matrix A (A is altered by the computation)
+ \param m = number of rows in A
+ \param n = number of columns in A (m>=n required)
+ \return value: status flag with: 0 -> success -1 -> input error m < n
+*/
+int G_math_sv2val(double *d,double **a,int m,int n)
+{
+ return sv2val(d, a[0], m, n);
+}
+
+
+/*
+ \brief Compute the singular value transformation S = U~*A*V.
+
+ \param d = pointer to double array of dimension n (output = singular values of A)
+ \param a = pointer to store of the m by n input matrix A (A is altered by the computation)
+ \param u = pointer to store for m by m orthogonal matrix U
+ \param v = pointer to store for n by n orthogonal matrix V
+ \param m = number of rows in A
+ \param n = number of columns in A (m>=n required)
+ \return value: status flag with: 0 -> success -1 -> input error m < n
+*/
+int G_math_svduv(double *d,double **a,double **u,int m,double **v,int n)
+{
+ return svduv(d, a[0], u[0], m, v[0], n);
+}
+
+
+/**
+ \brief Compute the singular value transformation when m >> n.
+
+ \param d = pointer to double array of dimension n (output = singular values of A)
+ \param a = pointer to store of the m by n input matrix A (A is altered by the computation)
+ \param u = pointer to store for m by m orthogonal matrix U
+ \param v = pointer to store for n by n orthogonal matrix V
+ \param m = number of rows in A
+ \param n = number of columns in A (m>=n required)
+ \return value: status flag with: 0 -> success -1 -> input error m < n
+*/
+int G_math_sv2uv(double *d,double **a,double **u,int m,double **v,int n)
+{
+ return sv2uv(d, a[0], u[0], m, v[0], n);
+}
+
+
+/**
+
+ \brief Compute the singular value transformation with A overloaded by the partial U-matrix.
+
+ \param d = pointer to double array of dimension n
+ (output = singular values of A)
+ \param a = pointer to store of the m by n input matrix A (At output a is overloaded by the matrix U1 whose n columns are orthogonal vectors equal to the first n columns of U.)
+ \param v = pointer to store for n by n orthogonal matrix V
+ \param m = number of rows in A
+ \param n = number of columns in A (m>=n required)
+ \return value: status flag with: 0 -> success -1 -> input error m < n
+
+*/
+int G_math_svdu1v(double *d,double **a,int m,double **v,int n)
+{
+ return svdu1v(d, a[0], m, v[0], n);
+}
Modified: grass/trunk/lib/gmath/del2g.c
===================================================================
--- grass/trunk/lib/gmath/del2g.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/del2g.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -61,7 +61,7 @@
/* multiply the complex vectors img and g, each of length size*size */
G_message(_(" multiplying transforms..."));
- mult(img, size * size, g, size * size, img, size * size);
+ G_math_complex_mult(img, size * size, g, size * size, img, size * size);
G_message(_(" taking inverse FFT..."));
fft(INVERSE, img, size * size, size, size);
Deleted: grass/trunk/lib/gmath/eigen.c
===================================================================
--- grass/trunk/lib/gmath/eigen.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/eigen.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,147 +0,0 @@
-/* taken from i.pca */
-
-#include <stdlib.h>
-#include <grass/gmath.h>
-#include <grass/gis.h>
-
-
-static int egcmp(const void *pa, const void *pb);
-
-
-/*!
- * \fn int eigen (double **M, double **Vectors, double *lambda, int n)
- *
- * \brief Computes eigenvalues (and eigen vectors if desired) for
- * symmetric matices.
- *
- * Computes eigenvalues (and eigen vectors if desired) for symmetric matices.
- *
- * \param M Input matrix
- * \param Vectors eigen output vector matrix
- * \param lambda Output eigenvalues
- * \param n Input matrix dimension
- * \return int
- */
-
-int eigen(double **M, /* Input matrix */
- double **Vectors, /* eigen vector matrix -output */
- double *lambda, /* Output eigenvalues */
- int n /* Input matrix dimension */
- )
-{
- int i, j;
- double **a, *e;
-
- a = G_alloc_matrix(n, n);
- e = G_alloc_vector(n);
-
- for (i = 0; i < n; i++)
- for (j = 0; j < n; j++)
- a[i][j] = M[i][j];
-
- G_tred2(a, n, lambda, e);
- G_tqli(lambda, e, n, a);
-
- /* Returns eigenvectors */
- if (Vectors)
- for (i = 0; i < n; i++)
- for (j = 0; j < n; j++)
- Vectors[i][j] = a[i][j];
-
- G_free_matrix(a);
- G_free_vector(e);
-
- return 0;
-}
-
-
-/*!
- * \fn int egvorder2 (double *d, double **z, long bands)
- *
- * \brief
- *
- * Returns 0.
- *
- * \param d
- * \param z
- * \param bands
- * \return int
- */
-
-int egvorder2(double *d, double **z, long bands)
-{
- double *buff;
- double **tmp;
- int i, j;
-
- /* allocate temporary matrix */
- buff = (double *)G_malloc(bands * (bands + 1) * sizeof(double));
- tmp = (double **)G_malloc(bands * sizeof(double *));
- for (i = 0; i < bands; i++)
- tmp[i] = &buff[i * (bands + 1)];
-
- /* concatenate (vertically) z and d into tmp */
- for (i = 0; i < bands; i++) {
- for (j = 0; j < bands; j++)
- tmp[i][j + 1] = z[j][i];
- tmp[i][0] = d[i];
- }
-
- /* sort the combined matrix */
- qsort(tmp, bands, sizeof(double *), egcmp);
-
- /* split tmp into z and d */
- for (i = 0; i < bands; i++) {
- for (j = 0; j < bands; j++)
- z[j][i] = tmp[i][j + 1];
- d[i] = tmp[i][0];
- }
-
- /* free temporary matrix */
- G_free(tmp);
- G_free(buff);
-
- return 0;
-}
-
-
-/*!
- * \fn int transpose2 (double **eigmat, long bands)
- *
- * \brief
- *
- * Returns 0.
- *
- * \param eigmat
- * \param bands
- * \return int
- */
-
-int transpose2(double **eigmat, long bands)
-{
- int i, j;
-
- for (i = 0; i < bands; i++)
- for (j = 0; j < i; j++) {
- double tmp = eigmat[i][j];
-
- eigmat[i][j] = eigmat[j][i];
- eigmat[j][i] = tmp;
- }
-
- return 0;
-}
-
-
-static int egcmp(const void *pa, const void *pb)
-{
- const double *a = *(const double *const *)pa;
- const double *b = *(const double *const *)pb;
-
- if (*a > *b)
- return -1;
- if (*a < *b)
- return 1;
-
- return 0;
-}
Modified: grass/trunk/lib/gmath/eigen_tools.c
===================================================================
--- grass/trunk/lib/gmath/eigen_tools.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/eigen_tools.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,156 +1,59 @@
-#include <grass/gis.h>
+#include <stdlib.h>
#include <math.h>
+#include <grass/gis.h>
+#include <grass/gmath.h>
+static int egcmp(const void *pa, const void *pb);
-#define MAX_ITERS 30
-#define SIGN(a,b) ((b)<0 ? -fabs(a) : fabs(a))
-
-int G_tqli(double d[], double e[], int n, double **z)
+int G_math_egvorder(double *d, double **z, long bands)
{
- int m, l, iter, i, k;
- double s, r, p, g, f, dd, c, b;
+ double *buff;
+ double **tmp;
+ int i, j;
- for (i = 1; i < n; i++)
- e[i - 1] = e[i];
- e[n - 1] = 0.0;
- for (l = 0; l < n; l++) {
- iter = 0;
+ /* allocate temporary matrix */
+ buff = (double *)G_malloc(bands * (bands + 1) * sizeof(double));
+ tmp = (double **)G_malloc(bands * sizeof(double *));
+ for (i = 0; i < bands; i++)
+ tmp[i] = &buff[i * (bands + 1)];
- do {
- for (m = l; m < n - 1; m++) {
- dd = fabs(d[m]) + fabs(d[m + 1]);
- if (fabs(e[m]) + dd == dd)
- break;
- }
+ /* concatenate (vertically) z and d into tmp */
+ for (i = 0; i < bands; i++) {
+ for (j = 0; j < bands; j++)
+ tmp[i][j + 1] = z[j][i];
+ tmp[i][0] = d[i];
+ }
- if (m != l) {
- if (iter++ == MAX_ITERS)
- return 0; /* Too many iterations in TQLI */
- g = (d[l + 1] - d[l]) / (2.0 * e[l]);
- r = sqrt((g * g) + 1.0);
- g = d[m] - d[l] + e[l] / (g + SIGN(r, g));
- s = c = 1.0;
- p = 0.0;
+ /* sort the combined matrix */
+ qsort(tmp, bands, sizeof(double *), egcmp);
- for (i = m - 1; i >= l; i--) {
- f = s * e[i];
- b = c * e[i];
-
- if (fabs(f) >= fabs(g)) {
- c = g / f;
- r = sqrt((c * c) + 1.0);
- e[i + 1] = f * r;
- c *= (s = 1.0 / r);
- }
- else {
- s = f / g;
- r = sqrt((s * s) + 1.0);
- e[i + 1] = g * r;
- s *= (c = 1.0 / r);
- }
-
- g = d[i + 1] - p;
- r = (d[i] - g) * s + 2.0 * c * b;
- p = s * r;
- d[i + 1] = g + p;
- g = c * r - b;
-
- /* Next loop can be omitted if eigenvectors not wanted */
- for (k = 0; k < n; k++) {
- f = z[k][i + 1];
- z[k][i + 1] = s * z[k][i] + c * f;
- z[k][i] = c * z[k][i] - s * f;
- }
- }
- d[l] = d[l] - p;
- e[l] = g;
- e[m] = 0.0;
- }
- } while (m != l);
+ /* split tmp into z and d */
+ for (i = 0; i < bands; i++) {
+ for (j = 0; j < bands; j++)
+ z[j][i] = tmp[i][j + 1];
+ d[i] = tmp[i][0];
}
- return 1;
+ /* free temporary matrix */
+ G_free(tmp);
+ G_free(buff);
+
+ return 0;
}
+/***************************************************************************/
-void G_tred2(double **a, int n, double d[], double e[])
+static int egcmp(const void *pa, const void *pb)
{
- int l, k, j, i;
- double scale, hh, h, g, f;
+ const double *a = *(const double *const *)pa;
+ const double *b = *(const double *const *)pb;
- for (i = n - 1; i >= 1; i--) {
- l = i - 1;
- h = scale = 0.0;
+ if (*a > *b)
+ return -1;
+ if (*a < *b)
+ return 1;
- if (l > 0) {
- for (k = 0; k <= l; k++)
- scale += fabs(a[i][k]);
-
- if (scale == 0.0)
- e[i] = a[i][l];
- else {
- for (k = 0; k <= l; k++) {
- a[i][k] /= scale;
- h += a[i][k] * a[i][k];
- }
-
- f = a[i][l];
- g = f > 0 ? -sqrt(h) : sqrt(h);
- e[i] = scale * g;
- h -= f * g;
- a[i][l] = f - g;
- f = 0.0;
-
- for (j = 0; j <= l; j++) {
- /* Next statement can be omitted if eigenvectors not wanted */
- a[j][i] = a[i][j] / h;
- g = 0.0;
- for (k = 0; k <= j; k++)
- g += a[j][k] * a[i][k];
- for (k = j + 1; k <= l; k++)
- g += a[k][j] * a[i][k];
- e[j] = g / h;
- f += e[j] * a[i][j];
- }
-
- hh = f / (h + h);
- for (j = 0; j <= l; j++) {
- f = a[i][j];
- e[j] = g = e[j] - hh * f;
-
- for (k = 0; k <= j; k++)
- a[j][k] -= (f * e[k] + g * a[i][k]);
- }
- }
- }
- else
- e[i] = a[i][l];
- d[i] = h;
- }
-
- /* Next statement can be omitted if eigenvectors not wanted */
- d[0] = 0.0;
- e[0] = 0.0;
-
- /* Contents of this loop can be omitted if eigenvectors not
- wanted except for statement d[i]=a[i][i]; */
- for (i = 0; i < n; i++) {
- l = i - 1;
-
- if (d[i]) {
- for (j = 0; j <= l; j++) {
- g = 0.0;
- for (k = 0; k <= l; k++)
- g += a[i][k] * a[k][j];
- for (k = 0; k <= l; k++)
- a[k][j] -= g * a[k][i];
- }
- }
-
- d[i] = a[i][i];
- a[i][i] = 1.0;
- for (j = 0; j <= l; j++)
- a[j][i] = a[i][j] = 0.0;
- }
+ return 0;
}
+/***************************************************************************/
Deleted: grass/trunk/lib/gmath/jacobi.c
===================================================================
--- grass/trunk/lib/gmath/jacobi.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/jacobi.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,99 +0,0 @@
-#include <stdlib.h>
-#include <math.h>
-#include <grass/gis.h>
-#include <grass/gmath.h>
-
-
-/***************************************************************************/
-
-/* this does not use the Jacobi method, but it should give the same result */
-
-int jacobi(double a[MX][MX], long n, double d[MX], double v[MX][MX])
-{
- double *aa[MX], *vv[MX], *dd;
- int i;
-
- for (i = 0; i < n; i++) {
- aa[i] = &a[i + 1][1];
- vv[i] = &v[i + 1][1];
- }
- dd = &d[1];
- eigen(aa, vv, dd, n);
-
- return 0;
-}
-
-/***************************************************************************/
-
-static int egcmp(const void *pa, const void *pb)
-{
- const double *a = *(const double *const *)pa;
- const double *b = *(const double *const *)pb;
-
- if (*a > *b)
- return -1;
- if (*a < *b)
- return 1;
-
- return 0;
-}
-
-int egvorder(double d[MX], double z[MX][MX], long bands)
-{
- double *buff;
- double **tmp;
- int i, j;
-
- /* allocate temporary matrix */
-
- buff = (double *)G_malloc(bands * (bands + 1) * sizeof(double));
- tmp = (double **)G_malloc(bands * sizeof(double *));
- for (i = 0; i < bands; i++)
- tmp[i] = &buff[i * (bands + 1)];
-
- /* concatenate (vertically) z and d into tmp */
-
- for (i = 0; i < bands; i++) {
- for (j = 0; j < bands; j++)
- tmp[i][j + 1] = z[j + 1][i + 1];
- tmp[i][0] = d[i + 1];
- }
-
- /* sort the combined matrix */
-
- qsort(tmp, bands, sizeof(double *), egcmp);
-
- /* split tmp into z and d */
-
- for (i = 0; i < bands; i++) {
- for (j = 0; j < bands; j++)
- z[j + 1][i + 1] = tmp[i][j + 1];
- d[i + 1] = tmp[i][0];
- }
-
- /* free temporary matrix */
-
- G_free(tmp);
- G_free(buff);
-
- return 0;
-}
-
-/***************************************************************************/
-
-int transpose(double eigmat[MX][MX], long bands)
-{
- int i, j;
-
- for (i = 1; i <= bands; i++)
- for (j = 1; j < i; j++) {
- double tmp = eigmat[i][j];
-
- eigmat[i][j] = eigmat[j][i];
- eigmat[j][i] = tmp;
- }
-
- return 0;
-}
-
-/***************************************************************************/
Modified: grass/trunk/lib/gmath/la.c
===================================================================
--- grass/trunk/lib/gmath/la.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/la.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -6,7 +6,8 @@
* @Copyright David D.Gray <ddgray at armadce.demon.co.uk>
* 26th. Sep. 2000
- * Last updated: 2006-11-23
+ * Last updated:
+ * 2006-11-23
* This file is part of GRASS GIS. It is free software. You can
* redistribute it and/or modify it under the terms of
Modified: grass/trunk/lib/gmath/mult.c
===================================================================
--- grass/trunk/lib/gmath/mult.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/mult.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,7 +1,7 @@
/* Author: Bill Hoff,2-114C,8645,3563478 (hoff) at uicsl */
/*!
- * \fn int mult (double *v1[2], int size1, double *v2[2], int size2, double *v3[2], int size3)
+ * \fn int G_math_complex_mult (double *v1[2], int size1, double *v2[2], int size2, double *v3[2], int size3)
*
* \brief Multiply two complex vectors, point by point
*
@@ -20,7 +20,7 @@
*/
int
-mult(double *v1[2], int size1, double *v2[2], int size2, double *v3[2],
+G_math_complex_mult(double *v1[2], int size1, double *v2[2], int size2, double *v3[2],
int size3)
{
int i, n;
Added: grass/trunk/lib/gmath/solvers_classic_iter.c
===================================================================
--- grass/trunk/lib/gmath/solvers_classic_iter.c (rev 0)
+++ grass/trunk/lib/gmath/solvers_classic_iter.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,281 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: linear equation system solvers
+* part of the gpde library
+*
+* COPYRIGHT: (C) 2007 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+
+
+/*!
+ * \brief The iterative jacobi solver for sparse matrices
+ *
+ * The Jacobi solver solves the linear equation system Ax = b
+ * The result is written to the vector x.
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp G_math_spvector ** -- the sparse matrix
+ * \param x double * -- the vector of unknowns
+ * \param b double * -- the right side vector
+ * \param rows int -- number of rows
+ * \param maxit int -- the maximum number of iterations
+ * \param sor double -- defines the successive overrelaxion parameter [0:1]
+ * \param error double -- defines the error break criteria
+ * \return int -- 1=success, -1=could not solve the les
+ *
+ * */
+int G_math_solver_sparse_jacobi(G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double sor, double error)
+{
+ int i, j, k, center, finished = 0;
+
+ double *Enew;
+
+ double E, err = 0;
+
+ Enew = G_alloc_vector(rows);
+
+ for (k = 0; k < maxit; k++) {
+ err = 0;
+ {
+ if (k == 0) {
+ for (j = 0; j < rows; j++) {
+ Enew[j] = x[j];
+ }
+ }
+ for (i = 0; i < rows; i++) {
+ E = 0;
+ center = 0;
+ for (j = 0; j < Asp[i]->cols; j++) {
+ E += Asp[i]->values[j] * x[Asp[i]->index[j]];
+ if (Asp[i]->index[j] == i)
+ center = j;
+ }
+ Enew[i] = x[i] - sor * (E - b[i]) / Asp[i]->values[center];
+ }
+ for (j = 0; j < rows; j++) {
+ err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
+
+ x[j] = Enew[j];
+ }
+ }
+
+ G_message(_("sparse Jacobi -- iteration %5i error %g\n"), k, err);
+
+ if (err < error) {
+ finished = 1;
+ break;
+ }
+ }
+
+ G_free(Enew);
+
+ return finished;
+}
+
+
+/*!
+ * \brief The iterative gauss seidel solver for sparse matrices
+ *
+ * The Jacobi solver solves the linear equation system Ax = b
+ * The result is written to the vector x.
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp G_math_spvector ** -- the sparse matrix
+ * \param x double * -- the vector of unknowns
+ * \param b double * -- the right side vector
+ * \param rows int -- number of rows
+ * \param maxit int -- the maximum number of iterations
+ * \param sor double -- defines the successive overrelaxion parameter [0:2]
+ * \param error double -- defines the error break criteria
+ * \return int -- 1=success, -1=could not solve the les
+ *
+ * */
+int G_math_solver_sparse_gs(G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double sor, double error)
+{
+ int i, j, k, finished = 0;
+
+ double *Enew;
+
+ double E, err = 0;
+
+ int center;
+
+ Enew = G_alloc_vector(rows);
+
+ for (k = 0; k < maxit; k++) {
+ err = 0;
+ {
+ if (k == 0) {
+ for (j = 0; j < rows; j++) {
+ Enew[j] = x[j];
+ }
+ }
+ for (i = 0; i < rows; i++) {
+ E = 0;
+ center = 0;
+ for (j = 0; j < Asp[i]->cols; j++) {
+ E += Asp[i]->values[j] * Enew[Asp[i]->index[j]];
+ if (Asp[i]->index[j] == i)
+ center = j;
+ }
+ Enew[i] = x[i] - sor * (E - b[i]) / Asp[i]->values[center];
+ }
+ for (j = 0; j < rows; j++) {
+ err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
+
+ x[j] = Enew[j];
+ }
+ }
+
+ G_message(_("sparse SOR -- iteration %5i error %g\n"), k, err);
+
+ if (err < error) {
+ finished = 1;
+ break;
+ }
+ }
+
+ G_free(Enew);
+
+ return finished;
+}
+
+
+/*!
+ * \brief The iterative jacobi solver for quadratic matrices
+ *
+ * The Jacobi solver solves the linear equation system Ax = b
+ * The result is written to the vector x.
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp G_math_spvector ** -- the sparse matrix
+ * \param x double * -- the vector of unknowns
+ * \param b double * -- the right side vector
+ * \param rows int -- number of rows
+ * \param maxit int -- the maximum number of iterations
+ * \param sor double -- defines the successive overrelaxion parameter [0:1]
+ * \param error double -- defines the error break criteria
+ * \return int -- 1=success, -1=could not solve the les
+ *
+ * */
+int G_math_solver_jacobi(double **A, double *x, double *b, int rows,
+ int maxit, double sor, double error)
+{
+ int i, j, k;
+
+ double *Enew;
+
+ double E, err = 0;
+
+ Enew = G_alloc_vector(rows);
+
+ for (j = 0; j < rows; j++) {
+ Enew[j] = x[j];
+ }
+
+ for (k = 0; k < maxit; k++) {
+ for (i = 0; i < rows; i++) {
+ E = 0;
+ for (j = 0; j < rows; j++) {
+ E += A[i][j] * x[j];
+ }
+ Enew[i] = x[i] - sor * (E - b[i]) / A[i][i];
+ }
+ err = 0;
+ for (j = 0; j < rows; j++) {
+ err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
+ x[j] = Enew[j];
+ }
+ G_message(_("Jacobi -- iteration %5i error %g\n"), k, err);
+ if (err < error)
+ break;
+ }
+
+ return 1;
+}
+
+
+/*!
+ * \brief The iterative gauss seidel solver for quadratic matrices
+ *
+ * The Jacobi solver solves the linear equation system Ax = b
+ * The result is written to the vector x.
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp G_math_spvector ** -- the sparse matrix
+ * \param x double * -- the vector of unknowns
+ * \param b double * -- the right side vector
+ * \param rows int -- number of rows
+ * \param maxit int -- the maximum number of iterations
+ * \param sor double -- defines the successive overrelaxion parameter [0:2]
+ * \param error double -- defines the error break criteria
+ * \return int -- 1=success, -1=could not solve the les
+ *
+ * */
+int G_math_solver_gs(double **A, double *x, double *b, int rows, int maxit,
+ double sor, double error)
+{
+ int i, j, k;
+
+ double *Enew;
+
+ double E, err = 0;
+
+ Enew = G_alloc_vector(rows);
+
+ for (j = 0; j < rows; j++) {
+ Enew[j] = x[j];
+ }
+
+ for (k = 0; k < maxit; k++) {
+ for (i = 0; i < rows; i++) {
+ E = 0;
+ for (j = 0; j < rows; j++) {
+ E += A[i][j] * Enew[j];
+ }
+ Enew[i] = x[i] - sor * (E - b[i]) / A[i][i];
+ }
+ err = 0;
+ for (j = 0; j < rows; j++) {
+ err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
+ x[j] = Enew[j];
+ }
+ G_message(_("SOR -- iteration %5i error %g\n"), k, err);
+ if (err < error)
+ break;
+ }
+
+ return 1;
+}
Added: grass/trunk/lib/gmath/solvers_direct.c
===================================================================
--- grass/trunk/lib/gmath/solvers_direct.c (rev 0)
+++ grass/trunk/lib/gmath/solvers_direct.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,416 @@
+
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: direkt linear equation system solvers
+ * part of the gpde library
+ *
+ * COPYRIGHT: (C) 2007 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include "grass/gis.h"
+#include "grass/glocale.h"
+#include "grass/gmath.h"
+
+#define TINY 1.0e-20
+#define COMP_PIVOT 100
+
+/*!
+ * \brief The gauss elimination solver for quardatic matrices
+ *
+ * This solver does not support sparse matrices
+ * The matrix A will be overwritten.
+ * The result is written to the vector x
+ *
+ * \param A double **
+ * \param x double *
+ * \param b double *
+ * \int rows int
+ * \return int -- 1 success
+ * */
+int G_math_solver_gauss(double **A, double *x, double *b, int rows)
+{
+ G_message(_("Starting direct gauss elimination solver"));
+
+ G_math_gauss_elimination(A, b, rows);
+ G_math_backward_solving(A, x, b, rows);
+
+ return 1;
+}
+
+/*!
+ * \brief The LU solver for quardatic matrices
+ *
+ * This solver does not support sparse matrices
+ * The matrix A will be overwritten.
+ * The result is written to the vector x in the G_math_les structure
+ *
+ *
+ * \param A double **
+ * \param x double *
+ * \param b double *
+ * \int rows int
+ * \return int -- 1 success
+ * */
+int G_math_solver_lu(double **A, double *x, double *b, int rows)
+{
+ int i;
+
+ double *c, *tmpv;
+
+ G_message(_("Starting direct lu decomposition solver"));
+
+ tmpv = G_alloc_vector(rows);
+ c = G_alloc_vector(rows);
+
+ G_math_lu_decomposition(A, b, rows);
+
+#pragma omp parallel
+ {
+
+#pragma omp for schedule (static) private(i)
+ for (i = 0; i < rows; i++) {
+ tmpv[i] = A[i][i];
+ A[i][i] = 1;
+ }
+
+#pragma omp single
+ {
+ G_math_forward_solving(A, b, b, rows);
+ }
+
+#pragma omp for schedule (static) private(i)
+ for (i = 0; i < rows; i++) {
+ A[i][i] = tmpv[i];
+ }
+
+#pragma omp single
+ {
+ G_math_backward_solving(A, x, b, rows);
+ }
+ }
+
+ G_free(c);
+ G_free(tmpv);
+
+
+ return 1;
+}
+
+/*!
+ * \brief The choleksy decomposition solver for quardatic, symmetric
+ * positiv definite matrices
+ *
+ * This solver does not support sparse matrices
+ * The matrix A will be overwritten.
+ * The result is written to the vector x
+ *
+ * \param A double **
+ * \param x double *
+ * \param b double *
+ * \int rows int
+ * \return int -- 1 success
+ * */
+int G_math_solver_cholesky(double **A, double *x, double *b, int bandwith,
+ int rows)
+{
+
+ G_message(_("Starting cholesky decomposition solver"));
+
+ if (G_math_cholesky_decomposition(A, rows, bandwith) != 1) {
+ G_warning(_("Unable to solve the linear equation system"));
+ return -2;
+ }
+
+ G_math_forward_solving(A, b, b, rows);
+ G_math_backward_solving(A, x, b, rows);
+
+ return 1;
+}
+
+/*!
+ * \brief Gauss elimination
+ *
+ * To run this solver efficiently,
+ * no pivoting is supported.
+ * The matrix will be overwritten with the decomposite form
+ * \param A double **
+ * \param b double *
+ * \param rows int
+ * \return void
+ *
+ * */
+void G_math_gauss_elimination(double **A, double *b, int rows)
+{
+ int i, j, k;
+
+ double tmpval = 0.0;
+
+ /*compute the pivot -- commented out, because its meaningless
+ to compute it only nth times. */
+ /*G_math_pivot_create(A, b, rows, 0); */
+
+ for (k = 0; k < rows - 1; k++) {
+#pragma omp parallel for schedule (static) private(i, j, tmpval) shared(k, A, b, rows)
+ for (i = k + 1; i < rows; i++) {
+ tmpval = A[i][k] / A[k][k];
+ b[i] = b[i] - tmpval * b[k];
+ for (j = k + 1; j < rows; j++) {
+ A[i][j] = A[i][j] - tmpval * A[k][j];
+ }
+ }
+ }
+
+ return;
+}
+
+/*!
+ * \brief lu decomposition
+ *
+ * To run this solver efficiently,
+ * no pivoting is supported.
+ * The matrix will be overwritten with the decomposite form
+ *
+ * \param A double **
+ * \param b double * -- this vector is needed if its part of the linear equation system, otherwise set it to NULL
+ * \param rows int
+ * \return void
+ *
+ * */
+void G_math_lu_decomposition(double **A, double *b, int rows)
+{
+
+ int i, j, k;
+
+ /*compute the pivot -- commented out, because its meaningless
+ to compute it only nth times. */
+ /*G_math_pivot_create(A, b, rows, 0); */
+
+ for (k = 0; k < rows - 1; k++) {
+#pragma omp parallel for schedule (static) private(i, j) shared(k, A, rows)
+ for (i = k + 1; i < rows; i++) {
+ A[i][k] = A[i][k] / A[k][k];
+ for (j = k + 1; j < rows; j++) {
+ A[i][j] = A[i][j] - A[i][k] * A[k][j];
+ }
+ }
+ }
+
+ return;
+}
+
+/*!
+ * \brief cholesky decomposition for symmetric, positiv definite matrices
+ * with bandwith optimization
+ *
+ * The provided matrix will be overwritten with the lower and
+ * upper triangle matrix A = LL^T
+ *
+ * \param A double **
+ * \param rows int
+ * \param bandwith int -- the bandwith of the matrix (0 > bandwith <= cols)
+ * \return void
+ *
+ * */
+int G_math_cholesky_decomposition(double **A, int rows, int bandwith)
+{
+
+ int i = 0, j = 0, k = 0;
+
+ double sum_1 = 0.0;
+
+ double sum_2 = 0.0;
+
+ int colsize;
+
+ if (bandwith <= 0)
+ bandwith = rows;
+
+ colsize = bandwith;
+
+ for (k = 0; k < rows; k++) {
+#pragma omp parallel for schedule (static) private(i, j, sum_2) shared(A, k) reduction(+:sum_1)
+ for (j = 0; j < k; j++) {
+ sum_1 += A[k][j] * A[k][j];
+ }
+
+ if (0 > (A[k][k] - sum_1)) {
+ G_warning("Matrix is not positive definite. break.");
+ return -1;
+ }
+ A[k][k] = sqrt(A[k][k] - sum_1);
+ sum_1 = 0.0;
+
+ if ((k + bandwith) > rows) {
+ colsize = rows;
+ }
+ else {
+ colsize = k + bandwith;
+ }
+
+#pragma omp parallel for schedule (static) private(i, j, sum_2) shared(A, k, sum_1, colsize)
+
+ for (i = k + 1; i < colsize; i++) {
+ sum_2 = 0.0;
+ for (j = 0; j < k; j++) {
+ sum_2 += A[i][j] * A[k][j];
+ }
+ A[i][k] = (A[i][k] - sum_2) / A[k][k];
+ }
+
+ }
+ /*we need to copy the lower triangle matrix to the upper trianle */
+#pragma omp parallel for schedule (static) private(i, k) shared(A, rows)
+ for (k = 0; k < rows; k++) {
+ for (i = k + 1; i < rows; i++) {
+ A[k][i] = A[i][k];
+ }
+ }
+
+
+ return 1;
+}
+
+/*!
+ * \brief backward solving
+ *
+ * \param A double **
+ * \param x double *
+ * \param b double *
+ * \param rows int
+ * \return void
+ *
+ * */
+void G_math_backward_solving(double **A, double *x, double *b, int rows)
+{
+ int i, j;
+
+ for (i = rows - 1; i >= 0; i--) {
+ for (j = i + 1; j < rows; j++) {
+ b[i] = b[i] - A[i][j] * x[j];
+ }
+ x[i] = (b[i]) / A[i][i];
+ }
+
+ return;
+}
+
+/*!
+ * \brief forward solving
+ *
+ * \param A double **
+ * \param x double *
+ * \param b double *
+ * \param rows int
+ * \return void
+ *
+ * */
+void G_math_forward_solving(double **A, double *x, double *b, int rows)
+{
+ int i, j;
+
+ double tmpval = 0.0;
+
+ for (i = 0; i < rows; i++) {
+ tmpval = 0;
+ for (j = 0; j < i; j++) {
+ tmpval += A[i][j] * x[j];
+ }
+ x[i] = (b[i] - tmpval) / A[i][i];
+ }
+
+ return;
+}
+
+
+/*!
+ * \brief Optimize the structure of the linear equation system with a common pivoting strategy
+ *
+ * Create a optimized linear equation system for
+ * direct solvers: gauss and lu decomposition.
+ *
+ * The rows are permuted based on the pivot elements.
+ *
+ * This algorithm will modify the provided linear equation system
+ * and should only be used with the gauss elimination and lu decomposition solver.
+ *
+ * \param A double ** - a quadratic matrix
+ * \param b double * - the right hand vector, if not available set it to NULL
+ * \param rows int
+ * \param start int -- the row
+ * \return int - the number of swapped rows
+ *
+ *
+ * */
+int G_math_pivot_create(double **A, double *b, int rows, int start)
+{
+ int num = 0; /*number of changed rows */
+
+ int i, j, k;
+
+ double max;
+
+ int number = 0;
+
+ double tmpval = 0.0, s = 0.0;
+
+ double *link = NULL;
+
+ link = G_alloc_vector(rows);
+
+ G_debug(2, "G_math_pivot_create: swap rows if needed");
+ for (i = start; i < rows; i++) {
+ s = 0.0;
+ for (k = i + 1; k < rows; k++) {
+ s += fabs(A[i][k]);
+ }
+ max = fabs(A[i][i]) / s;
+ number = i;
+ for (j = i + 1; j < rows; j++) {
+ s = 0.0;
+ for (k = j; k < rows; k++) {
+ s += fabs(A[j][k]);
+ }
+ /*search for the pivot element */
+ if (max < fabs(A[j][i]) / s) {
+ max = fabs(A[j][i] / s);
+ number = j;
+ }
+ }
+ if (max == 0) {
+ max = TINY;
+ G_warning("Matrix is singular");
+ }
+ /*if an pivot element was found, swap the les entries */
+ if (number != i) {
+
+ G_debug(4, "swap row %i with row %i", i, number);
+
+ if (b != NULL) {
+ tmpval = b[number];
+ b[number] = b[i];
+ b[i] = tmpval;
+ }
+ G_math_d_copy(A[number], link, rows);
+ G_math_d_copy(A[i], A[number], rows);
+ G_math_d_copy(link, A[i], rows);
+ num++;
+ }
+ }
+
+ G_free_vector(link);
+
+ return num;
+}
Added: grass/trunk/lib/gmath/solvers_krylov.c
===================================================================
--- grass/trunk/lib/gmath/solvers_krylov.c (rev 0)
+++ grass/trunk/lib/gmath/solvers_krylov.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,733 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: linear equation system solvers
+* part of the gpde library
+*
+* COPYRIGHT: (C) 2000 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <math.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include <grass/gis.h>
+#include <grass/gmath.h>
+#include <grass/glocale.h>
+
+static G_math_spvector **create_diag_precond_matrix(double **A,
+ G_math_spvector ** Asp,
+ int rows, int prec);
+static int solver_pcg(double **A, G_math_spvector ** Asp, double *x,
+ double *b, int rows, int maxit, double err, int prec);
+static int solver_cg(double **A, G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double err);
+static int solver_bicgstab(double **A, G_math_spvector ** Asp, double *x,
+ double *b, int rows, int maxit, double err);
+
+
+/*!
+ * \brief The iterative preconditioned conjugate gradients solver for symmetric positive definite matrices
+ *
+ * This iterative solver works with symmetric positive definite regular quadratic matrices.
+ *
+ * This solver solves the linear equation system:
+ * A x = b
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param A (double **) -- the matrix
+ * \param x (double *) -- the value vector
+ * \param b (double *) -- the right hand side
+ * \param rows (int)
+ * \param maxit (int) -- the maximum number of iterations
+ * \param err (double) -- defines the error break criteria
+ * \param prec (int) -- the preconditioner which shoudl be used 1,2 or 3
+ * \return (int) -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
+ *
+ * */
+int G_math_solver_pcg(double **A, double *x, double *b, int rows, int maxit,
+ double err, int prec)
+{
+
+ return solver_pcg(A, NULL, x, b, rows, maxit, err, prec);
+}
+
+/*!
+ * \brief The iterative preconditioned conjugate gradients solver for sparse symmetric positive definite matrices
+ *
+ * This iterative solver works with symmetric positive definite sparse matrices.
+ *
+ * This solver solves the linear equation system:
+ * A x = b
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp (G_math_spvector **) -- the sparse matrix
+ * \param x (double *) -- the value vector
+ * \param b (double *) -- the right hand side
+ * \param rows (int)
+ * \param maxit (int) -- the maximum number of iterations
+ * \param err (double) -- defines the error break criteria
+ * \param prec (int) -- the preconditioner which shoudl be used 1,2 or 3
+ * \return (int) -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
+ *
+ * */
+int G_math_solver_sparse_pcg(G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double err, int prec)
+{
+
+ return solver_pcg(NULL, Asp, x, b, rows, maxit, err, prec);
+}
+
+int solver_pcg(double **A, G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double err, int prec)
+{
+ double *r, *z;
+
+ double *p;
+
+ double *v;
+
+ double s = 0.0;
+
+ double a0 = 0, a1 = 0, mygamma, tmp = 0;
+
+ int m, i;
+
+ int finished = 2;
+
+ int error_break;
+
+ G_math_spvector **M;
+
+ r = G_alloc_vector(rows);
+ p = G_alloc_vector(rows);
+ v = G_alloc_vector(rows);
+ z = G_alloc_vector(rows);
+
+ error_break = 0;
+
+ /*compute the preconditioning matrix, this is a sparse matrix */
+ M = create_diag_precond_matrix(A, Asp, rows, prec);
+
+ /*
+ * residual calculation
+ */
+#pragma omp parallel
+ {
+ if (Asp)
+ G_math_Ax_sparse(Asp, x, v, rows);
+ else
+ G_math_d_Ax(A, x, v, rows, rows);
+
+ G_math_d_ax_by(b, v, r, 1.0, -1.0, rows);
+ /*performe the preconditioning */
+ G_math_Ax_sparse(M, r, p, rows);
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s)
+ for (i = 0; i < rows; i++) {
+ s += p[i] * r[i];
+ }
+ }
+
+ a0 = s;
+ s = 0.0;
+
+ /* ******************* */
+ /* start the iteration */
+ /* ******************* */
+ for (m = 0; m < maxit; m++) {
+#pragma omp parallel default(shared)
+ {
+ if (Asp)
+ G_math_Ax_sparse(Asp, p, v, rows);
+ else
+ G_math_d_Ax(A, p, v, rows, rows);
+
+
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s)
+ for (i = 0; i < rows; i++) {
+ s += v[i] * p[i];
+ }
+
+ /* barrier */
+#pragma omp single
+ {
+ tmp = s;
+ mygamma = a0 / tmp;
+ s = 0.0;
+ }
+
+ G_math_d_ax_by(p, x, x, mygamma, 1.0, rows);
+
+ if (m % 50 == 1) {
+ if (Asp)
+ G_math_Ax_sparse(Asp, x, v, rows);
+ else
+ G_math_d_Ax(A, x, v, rows, rows);
+
+ G_math_d_ax_by(b, v, r, 1.0, -1.0, rows);
+ }
+ else {
+ G_math_d_ax_by(r, v, r, 1.0, -1.0 * mygamma, rows);
+ }
+
+ /*performe the preconditioning */
+ G_math_Ax_sparse(M, r, z, rows);
+
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s)
+ for (i = 0; i < rows; i++) {
+ s += z[i] * r[i];
+ }
+
+ /* barrier */
+#pragma omp single
+ {
+ a1 = s;
+ tmp = a1 / a0;
+ a0 = a1;
+ s = 0.0;
+
+ if (a1 < 0 || a1 == 0 || a1 > 0) {
+ ;
+ }
+ else {
+ G_warning(_
+ ("Unable to solve the linear equation system"));
+ error_break = 1;
+ }
+ }
+ G_math_d_ax_by(p, z, p, tmp, 1.0, rows);
+ }
+
+ if (Asp != NULL)
+ G_message(_("Sparse PCG -- iteration %i error %g\n"), m, a0);
+ else
+ G_message(_("PCG -- iteration %i error %g\n"), m, a0);
+
+ if (error_break == 1) {
+ finished = -1;
+ break;
+ }
+
+
+ if (a0 < err) {
+ finished = 1;
+ break;
+ }
+ }
+
+ G_free(r);
+ G_free(p);
+ G_free(v);
+ G_free(z);
+ G_math_free_spmatrix(M, rows);
+
+ return finished;
+}
+
+
+/*!
+ * \brief The iterative conjugate gradients solver for symmetric positive definite matrices
+ *
+ * This iterative solver works with symmetric positive definite regular quadratic matrices.
+ *
+ * This solver solves the linear equation system:
+ * A x = b
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param A (double **) -- the matrix
+ * \param x (double *) -- the value vector
+ * \param b (double *) -- the right hand side
+ * \param rows (int)
+ * \param maxit (int) -- the maximum number of iterations
+ * \param err (double) -- defines the error break criteria
+ * \return (int) -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
+ *
+ * */
+int G_math_solver_cg(double **A, double *x, double *b, int rows, int maxit,
+ double err)
+{
+ return solver_cg(A, NULL, x, b, rows, maxit, err);
+}
+
+/*!
+ * \brief The iterative conjugate gradients solver for sparse symmetric positive definite matrices
+ *
+ * This iterative solver works with symmetric positive definite sparse matrices.
+ *
+ * This solver solves the linear equation system:
+ * A x = b
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp (G_math_spvector **) -- the sparse matrix
+ * \param x (double *) -- the value vector
+ * \param b (double *) -- the right hand side
+ * \param rows (int)
+ * \param maxit (int) -- the maximum number of iterations
+ * \param err (double) -- defines the error break criterias
+ * \return (int) -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
+ *
+ * */
+int G_math_solver_sparse_cg(G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double err)
+{
+ return solver_cg(NULL, Asp, x, b, rows, maxit, err);
+}
+
+
+int solver_cg(double **A, G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double err)
+{
+ double *r;
+
+ double *p;
+
+ double *v;
+
+ double s = 0.0;
+
+ double a0 = 0, a1 = 0, mygamma, tmp = 0;
+
+ int m, i;
+
+ int finished = 2;
+
+ int error_break;
+
+ r = G_alloc_vector(rows);
+ p = G_alloc_vector(rows);
+ v = G_alloc_vector(rows);
+
+ error_break = 0;
+ /*
+ * residual calculation
+ */
+#pragma omp parallel
+ {
+ if (Asp)
+ G_math_Ax_sparse(Asp, x, v, rows);
+ else
+ G_math_d_Ax(A, x, v, rows, rows);
+
+ G_math_d_ax_by(b, v, r, 1.0, -1.0, rows);
+ G_math_d_copy(r, p, rows);
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s)
+ for (i = 0; i < rows; i++) {
+ s += r[i] * r[i];
+ }
+ }
+
+ a0 = s;
+ s = 0.0;
+
+ /* ******************* */
+ /* start the iteration */
+ /* ******************* */
+ for (m = 0; m < maxit; m++) {
+#pragma omp parallel default(shared)
+ {
+ if (Asp)
+ G_math_Ax_sparse(Asp, p, v, rows);
+ else
+ G_math_d_Ax(A, p, v, rows, rows);
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s)
+ for (i = 0; i < rows; i++) {
+ s += v[i] * p[i];
+ }
+
+ /* barrier */
+#pragma omp single
+ {
+ tmp = s;
+ mygamma = a0 / tmp;
+ s = 0.0;
+ }
+
+ G_math_d_ax_by(p, x, x, mygamma, 1.0, rows);
+
+ if (m % 50 == 1) {
+ if (Asp)
+ G_math_Ax_sparse(Asp, x, v, rows);
+ else
+ G_math_d_Ax(A, x, v, rows, rows);
+
+ G_math_d_ax_by(b, v, r, 1.0, -1.0, rows);
+ }
+ else {
+ G_math_d_ax_by(r, v, r, 1.0, -1.0 * mygamma, rows);
+ }
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s)
+ for (i = 0; i < rows; i++) {
+ s += r[i] * r[i];
+ }
+
+ /* barrier */
+#pragma omp single
+ {
+ a1 = s;
+ tmp = a1 / a0;
+ a0 = a1;
+ s = 0.0;
+
+ if (a1 < 0 || a1 == 0 || a1 > 0) {
+ ;
+ }
+ else {
+ G_warning(_
+ ("Unable to solve the linear equation system"));
+ error_break = 1;
+ }
+ }
+ G_math_d_ax_by(p, r, p, tmp, 1.0, rows);
+ }
+
+ if (Asp != NULL)
+ G_message(_("Sparse CG -- iteration %i error %g\n"), m, a0);
+ else
+ G_message(_("CG -- iteration %i error %g\n"), m, a0);
+
+ if (error_break == 1) {
+ finished = -1;
+ break;
+ }
+
+ if (a0 < err) {
+ finished = 1;
+ break;
+ }
+ }
+
+ G_free(r);
+ G_free(p);
+ G_free(v);
+
+ return finished;
+}
+
+
+
+/*!
+ * \brief The iterative biconjugate gradients solver with stabilization for unsymmetric non-definite matrices
+ *
+ * This iterative solver works with regular quadratic matrices.
+ *
+ * This solver solves the linear equation system:
+ * A x = b
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param A (double **) -- the matrix
+ * \param x (double *) -- the value vector
+ * \param b (double *) -- the right hand side
+ * \param rows (int)
+ * \param maxit (int) -- the maximum number of iterations
+ * \param err (double) -- defines the error break criterias
+ * \return (int) -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
+ *
+ * */
+int G_math_solver_bicgstab(double **A, double *x, double *b, int rows,
+ int maxit, double err)
+{
+ return solver_bicgstab(A, NULL, x, b, rows, maxit, err);
+}
+
+/*!
+ * \brief The iterative biconjugate gradients solver with stabilization for unsymmetric non-definite matrices
+ *
+ * This iterative solver works with sparse matrices.
+ *
+ * This solver solves the linear equation system:
+ * A x = b
+ *
+ * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
+ * solver will abort the calculation and writes the current result into the vector x.
+ * The parameter <i>err</i> defines the error break criteria for the solver.
+ *
+ * \param Asp (G_math_spvector **) -- the sparse matrix
+ * \param x (double *) -- the value vector
+ * \param b (double *) -- the right hand side
+ * \param rows (int)
+ * \param maxit (int) -- the maximum number of iterations
+ * \param err (double) -- defines the error break criterias
+ * \return (int) -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
+ *
+ * */
+int G_math_solver_sparse_bicgstab(G_math_spvector ** Asp, double *x,
+ double *b, int rows, int maxit, double err)
+{
+ return solver_bicgstab(NULL, Asp, x, b, rows, maxit, err);
+}
+
+
+int solver_bicgstab(double **A, G_math_spvector ** Asp, double *x, double *b,
+ int rows, int maxit, double err)
+{
+ double *r;
+
+ double *r0;
+
+ double *p;
+
+ double *v;
+
+ double *s;
+
+ double *t;
+
+ double s1 = 0.0, s2 = 0.0, s3 = 0.0;
+
+ double alpha = 0, beta = 0, omega, rr0 = 0, error;
+
+ int m, i;
+
+ int finished = 2;
+
+ int error_break;
+
+ r = G_alloc_vector(rows);
+ r0 = G_alloc_vector(rows);
+ p = G_alloc_vector(rows);
+ v = G_alloc_vector(rows);
+ s = G_alloc_vector(rows);
+ t = G_alloc_vector(rows);
+
+ error_break = 0;
+
+#pragma omp parallel
+ {
+ if (Asp)
+ G_math_Ax_sparse(Asp, x, v, rows);
+ else
+ G_math_d_Ax(A, x, v, rows, rows);
+
+ G_math_d_ax_by(b, v, r, 1.0, -1.0, rows);
+ G_math_d_copy(r, r0, rows);
+ G_math_d_copy(r, p, rows);
+ }
+
+ s1 = s2 = s3 = 0.0;
+
+ /* ******************* */
+ /* start the iteration */
+ /* ******************* */
+ for (m = 0; m < maxit; m++) {
+
+#pragma omp parallel default(shared)
+ {
+ if (Asp)
+ G_math_Ax_sparse(Asp, p, v, rows);
+ else
+ G_math_d_Ax(A, p, v, rows, rows);
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s1, s2, s3)
+ for (i = 0; i < rows; i++) {
+ s1 += r[i] * r[i];
+ s2 += r[i] * r0[i];
+ s3 += v[i] * r0[i];
+ }
+
+#pragma omp single
+ {
+ error = s1;
+
+ if (error < 0 || error == 0 || error > 0) {
+ ;
+ }
+ else {
+ G_warning(_
+ ("Unable to solve the linear equation system"));
+ error_break = 1;
+ }
+
+ rr0 = s2;
+ alpha = rr0 / s3;
+ s1 = s2 = s3 = 0.0;
+ }
+
+ G_math_d_ax_by(r, v, s, 1.0, -1.0 * alpha, rows);
+ if (Asp)
+ G_math_Ax_sparse(Asp, s, t, rows);
+ else
+ G_math_d_Ax(A, s, t, rows, rows);
+
+ /* scalar product */
+#pragma omp for schedule (static) private(i) reduction(+:s1, s2)
+ for (i = 0; i < rows; i++) {
+ s1 += t[i] * s[i];
+ s2 += t[i] * t[i];
+ }
+
+#pragma omp single
+ {
+ omega = s1 / s2;
+ s1 = s2 = 0.0;
+ }
+
+ G_math_d_ax_by(p, s, r, alpha, omega, rows);
+ G_math_d_ax_by(x, r, x, 1.0, 1.0, rows);
+ G_math_d_ax_by(s, t, r, 1.0, -1.0 * omega, rows);
+
+#pragma omp for schedule (static) private(i) reduction(+:s1)
+ for (i = 0; i < rows; i++) {
+ s1 += r[i] * r0[i];
+ }
+
+#pragma omp single
+ {
+ beta = alpha / omega * s1 / rr0;
+ s1 = s2 = s3 = 0.0;
+ }
+
+ G_math_d_ax_by(p, v, p, 1.0, -1.0 * omega, rows);
+ G_math_d_ax_by(p, r, p, beta, 1.0, rows);
+ }
+
+
+ if (Asp != NULL)
+ G_message(_("Sparse BiCGStab -- iteration %i error %g\n"), m,
+ error);
+ else
+ G_message(_("BiCGStab -- iteration %i error %g\n"), m, error);
+
+ if (error_break == 1) {
+ finished = -1;
+ break;
+ }
+
+ if (error < err) {
+ finished = 1;
+ break;
+ }
+ }
+
+ G_free(r);
+ G_free(r0);
+ G_free(p);
+ G_free(v);
+ G_free(s);
+ G_free(t);
+
+ return finished;
+}
+
+
+/*!
+ * \brief Compute a diagonal preconditioning matrix for krylov space solver
+ *
+ * \param A (double **) -- the matrix for which the precondition should be computed (if the sparse matrix is used, set it to NULL)
+ * \param Asp (G_math_spvector **) -- the matrix for which the precondition should be computed
+ * \param rows (int)
+ * \param prec (int) -- which preconditioner should be used 1, 2 or 3
+ *
+ * */
+G_math_spvector **create_diag_precond_matrix(double **A,
+ G_math_spvector ** Asp, int rows,
+ int prec)
+{
+ G_math_spvector **Msp;
+
+ int i, j, cols = rows;
+
+ double sum;
+
+ Msp = G_math_alloc_spmatrix(rows);
+
+ if (A != NULL) {
+#pragma omp parallel for schedule (static) private(i, j, sum) shared(A, Msp, rows, cols, prec)
+ for (i = 0; i < rows; i++) {
+ G_math_spvector *spvect = G_math_alloc_spvector(1);
+
+ switch (prec) {
+ case G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION:
+ sum = 0;
+ for (j = 0; j < cols; j++)
+ sum += A[i][j] * A[i][j];
+ spvect->values[0] = 1.0 / sqrt(sum);
+ break;
+ case G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION:
+ sum = 0;
+ for (j = 0; j < cols; j++)
+ sum += fabs(A[i][j]);
+ spvect->values[0] = 1.0 / (sum);
+ break;
+ case G_MATH_DIAGONAL_PRECONDITION:
+ default:
+ spvect->values[0] = 1.0 / A[i][i];
+ break;
+ }
+
+
+ spvect->index[0] = i;
+ spvect->cols = 1;;
+ G_math_add_spvector(Msp, spvect, i);
+
+ }
+ }
+ else {
+#pragma omp parallel for schedule (static) private(i, j, sum) shared(Asp, Msp, rows, cols, prec)
+ for (i = 0; i < rows; i++) {
+ G_math_spvector *spvect = G_math_alloc_spvector(1);
+
+ switch (prec) {
+ case G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION:
+ sum = 0;
+ for (j = 0; j < Asp[i]->cols; j++)
+ sum += Asp[i]->values[j] * Asp[i]->values[j];
+ spvect->values[0] = 1.0 / sqrt(sum);
+ break;
+ case G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION:
+ sum = 0;
+ for (j = 0; j < Asp[i]->cols; j++)
+ sum += fabs(Asp[i]->values[j]);
+ spvect->values[0] = 1.0 / (sum);
+ break;
+ case G_MATH_DIAGONAL_PRECONDITION:
+ default:
+ for (j = 0; j < Asp[i]->cols; j++)
+ if (i == Asp[i]->index[j])
+ spvect->values[0] = 1.0 / Asp[i]->values[j];
+ break;
+ }
+
+ spvect->index[0] = i;
+ spvect->cols = 1;;
+ G_math_add_spvector(Msp, spvect, i);
+ }
+ }
+ return Msp;
+}
Added: grass/trunk/lib/gmath/sparse_matrix.c
===================================================================
--- grass/trunk/lib/gmath/sparse_matrix.c (rev 0)
+++ grass/trunk/lib/gmath/sparse_matrix.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,240 @@
+
+/*****************************************************************************
+ *
+ * MODULE: Grass Gmath Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: functions to manage linear equation systems
+ * part of the gmath library
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdlib.h>
+#include <math.h>
+#include <grass/gmath.h>
+#include <grass/gis.h>
+
+/*!
+ * \brief Adds a sparse vector to a sparse matrix at position row
+ *
+ * Return 1 for success and -1 for failure
+ *
+ * \param spmatrix G_math_spvector **
+ * \param spvector G_math_spvector *
+ * \param row int
+ * \return int 1 success, -1 failure
+ *
+ * */
+int G_math_add_spvector(G_math_spvector ** Asp, G_math_spvector * spvector,
+ int row)
+{
+ if (Asp != NULL) {
+ G_debug(5,
+ "Add sparse vector %p to the sparse linear equation system at row %i\n",
+ spvector, row);
+ Asp[row] = spvector;
+ }
+ else {
+ return -1;
+ }
+
+ return 1;
+}
+
+/*!
+ * \brief Allocate memory for a sparse matrix
+ *
+ * \param rows int
+ * \return G_math_spvector **
+ *
+ * */
+G_math_spvector **G_math_alloc_spmatrix(int rows)
+{
+ G_math_spvector **spmatrix;
+
+ G_debug(4, "Allocate memory for a sparse matrix with %i rows\n", rows);
+
+ spmatrix = (G_math_spvector **) G_calloc(rows, sizeof(G_math_spvector *));
+
+ return spmatrix;
+}
+
+/*!
+ * \brief Allocate memory for a sparse vector
+ *
+ * \param cols int
+ * \return G_math_spvector *
+ *
+ * */
+G_math_spvector *G_math_alloc_spvector(int cols)
+{
+ G_math_spvector *spvector;
+
+ G_debug(4, "Allocate memory for a sparse vector with %i cols\n", cols);
+
+ spvector = (G_math_spvector *) G_calloc(1, sizeof(G_math_spvector));
+
+ spvector->cols = cols;
+ spvector->index = (unsigned int *)G_calloc(cols, sizeof(unsigned int));
+ spvector->values = (double *)G_calloc(cols, sizeof(double));
+
+ return spvector;
+}
+
+/*!
+ * \brief Release the memory of the sparse vector
+ *
+ * \param spvector G_math_spvector *
+ * \return void
+ *
+ * */
+void G_math_free_spvector(G_math_spvector * spvector)
+{
+ if (spvector) {
+ if (spvector->values)
+ G_free(spvector->values);
+ if (spvector->index)
+ G_free(spvector->index);
+ G_free(spvector);
+
+ spvector = NULL;
+ }
+
+ return;
+}
+
+/*!
+ * \brief Release the memory of the sparse matrix
+ *
+ * \param spvector G_math_spvector **
+ * \param rows int
+ * \return void
+ *
+ * */
+void G_math_free_spmatrix(G_math_spvector ** spmatrix, int rows)
+{
+ int i;
+
+ if (spmatrix) {
+ for (i = 0; i < rows; i++)
+ G_math_free_spvector(spmatrix[i]);
+
+ G_free(spmatrix);
+ spmatrix = NULL;
+ }
+
+ return;
+}
+
+/*!
+ *
+ * \brief print the sparse matrix Asp to stdout
+ *
+ *
+ * \param Asp (G_math_spvector **)
+ * \param rows (int)
+ * \return void
+ *
+ * */
+void G_math_print_spmatrix(G_math_spvector ** Asp, int rows)
+{
+ int i, j, k, out;
+
+ for (i = 0; i < rows; i++) {
+ for (j = 0; j < rows; j++) {
+ out = 0;
+ for (k = 0; k < Asp[i]->cols; k++) {
+ if (Asp[i]->index[k] == j) {
+ fprintf(stdout, "%4.5f ", Asp[i]->values[k]);
+ out = 1;
+ }
+ }
+ if (!out)
+ fprintf(stdout, "%4.5f ", 0.0);
+ }
+ fprintf(stdout, "\n");
+ }
+
+ return;
+}
+
+
+/*!
+ * \brief Convert a sparse matrix into a quadratic matrix
+ *
+ * This function is multi-threaded with OpenMP. It creates its own parallel OpenMP region.
+ *
+ * \param Asp (G_math_spvector **)
+ * \param rows (int)
+ * \return (double **)
+ *
+ * */
+double **G_math_Asp_to_A(G_math_spvector ** Asp, int rows)
+{
+ int i, j;
+
+ double **A = NULL;
+
+ A = G_alloc_matrix(rows, rows);
+
+#pragma omp parallel for schedule (static) private(i, j)
+ for (i = 0; i < rows; i++) {
+ for (j = 0; j < Asp[i]->cols; j++) {
+ A[i][Asp[i]->index[j]] = Asp[i]->values[j];
+ }
+ }
+ return A;
+}
+
+/*!
+ * \brief Convert a quadratic matrix into a sparse matrix
+ *
+ * This function is multi-threaded with OpenMP. It creates its own parallel OpenMP region.
+ *
+ * \param A (double **)
+ * \param rows (int)
+ * \param epsilon (double) -- non-zero values are greater then epsilon
+ * \return (G_math_spvector **)
+ *
+ * */
+G_math_spvector **G_math_A_to_Asp(double **A, int rows, double epsilon)
+{
+ int i, j;
+
+ int nonull, count = 0;
+
+ G_math_spvector **Asp = NULL;
+
+ Asp = G_math_alloc_spmatrix(rows);
+
+#pragma omp parallel for schedule (static) private(i, j, nonull, count)
+ for (i = 0; i < rows; i++) {
+ nonull = 0;
+ /*Count the number of non zero entries */
+ for (j = 0; j < rows; j++) {
+ if (A[i][j] > epsilon)
+ nonull++;
+ }
+ /*Allocate the sparse vector and insert values */
+ G_math_spvector *v = G_math_alloc_spvector(nonull);
+
+ count = 0;
+ for (j = 0; j < rows; j++) {
+ if (A[i][j] > epsilon) {
+ v->index[count] = j;
+ v->values[count] = A[i][j];
+ count++;
+ }
+ }
+ /*Add vector to sparse matrix */
+ G_math_add_spvector(Asp, v, i);
+ }
+ return Asp;
+}
Deleted: grass/trunk/lib/gmath/svd.c
===================================================================
--- grass/trunk/lib/gmath/svd.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gmath/svd.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,283 +0,0 @@
-#include <math.h>
-#include <grass/gis.h>
-#include <grass/gmath.h>
-
-static double at, bt, ct;
-
-#define PYTHAG(a,b) ((at=fabs(a)) > (bt=fabs(b)) ? \
- (ct=bt/at,at*sqrt(1.0+ct*ct)) : (bt ? (ct=at/bt,bt*sqrt(1.0+ct*ct)): 0.0))
-
-static double maxarg1, maxarg2;
-
-#define MAX(a,b) (maxarg1=(a),maxarg2=(b),(maxarg1) > (maxarg2) ?\
- (maxarg1) : (maxarg2))
-#define SIGN(a,b) ((b) >= 0.0 ? fabs(a) : -fabs(a))
-
-int G_svdcmp(double **a, int m, int n, double *w, double **v)
-{
- int flag, i, its, j, jj, k, ii = 0, nm = 0;
- double c, f, h, s, x, y, z;
- double anorm = 0.0, g = 0.0, scale = 0.0;
- double *rv1, *G_alloc_vector();
-
-
- if (m < n)
- return -1; /* must augment A with extra zero rows */
- rv1 = G_alloc_vector(n);
-
- n--;
- m--;
-
- for (i = 0; i <= n; i++) {
- ii = i + 1;
- rv1[i] = scale * g;
- g = s = scale = 0.0;
- if (i <= m) {
- for (k = i; k <= m; k++)
- scale += fabs(a[k][i]);
- if (scale) {
- for (k = i; k <= m; k++) {
- a[k][i] /= scale;
- s += a[k][i] * a[k][i];
- }
- f = a[i][i];
- g = -SIGN(sqrt(s), f);
- h = f * g - s;
- a[i][i] = f - g;
- if (i != n) {
- for (j = ii; j <= n; j++) {
- for (s = 0.0, k = i; k <= m; k++)
- s += a[k][i] * a[k][j];
- f = s / h;
- for (k = i; k <= m; k++)
- a[k][j] += f * a[k][i];
- }
- }
- for (k = i; k <= m; k++)
- a[k][i] *= scale;
- }
- }
- w[i] = scale * g;
- g = s = scale = 0.0;
- if (i <= m && i != n) {
- for (k = ii; k <= n; k++)
- scale += fabs(a[i][k]);
- if (scale) {
- for (k = ii; k <= n; k++) {
- a[i][k] /= scale;
- s += a[i][k] * a[i][k];
- }
- f = a[i][ii];
- g = -SIGN(sqrt(s), f);
- h = f * g - s;
- a[i][ii] = f - g;
- for (k = ii; k <= n; k++)
- rv1[k] = a[i][k] / h;
- if (i != m) {
- for (j = ii; j <= m; j++) {
- for (s = 0.0, k = ii; k <= n; k++)
- s += a[j][k] * a[i][k];
- for (k = ii; k <= n; k++)
- a[j][k] += s * rv1[k];
- }
- }
- for (k = ii; k <= n; k++)
- a[i][k] *= scale;
- }
- }
- anorm = MAX(anorm, (fabs(w[i]) + fabs(rv1[i])));
- }
- for (i = n; i >= 0; i--) {
- if (i < n) {
- if (g) {
- for (j = ii; j <= n; j++)
- v[j][i] = (a[i][j] / a[i][ii]) / g;
- for (j = ii; j <= n; j++) {
- for (s = 0.0, k = ii; k <= n; k++)
- s += a[i][k] * v[k][j];
- for (k = ii; k <= n; k++)
- v[k][j] += s * v[k][i];
- }
- }
- for (j = ii; j <= n; j++)
- v[i][j] = v[j][i] = 0.0;
- }
- v[i][i] = 1.0;
- g = rv1[i];
- ii = i;
- }
- for (i = n; i >= 0; i--) {
- ii = i + 1;
- g = w[i];
- if (i < n)
- for (j = ii; j <= n; j++)
- a[i][j] = 0.0;
- if (g) {
- g = 1.0 / g;
- if (i != n) {
- for (j = ii; j <= n; j++) {
- for (s = 0.0, k = ii; k <= m; k++)
- s += a[k][i] * a[k][j];
- f = (s / a[i][i]) * g;
- for (k = i; k <= m; k++)
- a[k][j] += f * a[k][i];
- }
- }
- for (j = i; j <= m; j++)
- a[j][i] *= g;
- }
- else {
- for (j = i; j <= m; j++)
- a[j][i] = 0.0;
- }
- ++a[i][i];
- }
- for (k = n; k >= 0; k--) {
- for (its = 1; its <= 30; its++) {
- flag = 1;
- for (ii = k; ii >= 0; ii--) {
- nm = ii - 1;
- if (fabs(rv1[ii]) + anorm == anorm) {
- flag = 0;
- break;
- }
- if (fabs(w[nm]) + anorm == anorm)
- break;
- }
- if (flag) {
- c = 0.0;
- s = 1.0;
- for (i = ii; i <= k; i++) {
- f = s * rv1[i];
- if (fabs(f) + anorm != anorm) {
- g = w[i];
- h = PYTHAG(f, g);
- w[i] = h;
- h = 1.0 / h;
- c = g * h;
- s = (-f * h);
- for (j = 0; j <= m; j++) {
- y = a[j][nm];
- z = a[j][i];
- a[j][nm] = y * c + z * s;
- a[j][i] = z * c - y * s;
- }
- }
- }
- }
- z = w[k];
- if (ii == k) {
- if (z < 0.0) {
- w[k] = -z;
- for (j = 0; j <= n; j++)
- v[j][k] = (-v[j][k]);
- }
- break;
- }
- if (its == 30)
- return -2; /*No convergence in 30 SVDCMP iterations */
- x = w[ii];
- nm = k - 1;
- y = w[nm];
- g = rv1[nm];
- h = rv1[k];
- f = ((y - z) * (y + z) + (g - h) * (g + h)) / (2.0 * h * y);
- g = PYTHAG(f, 1.0);
- f = ((x - z) * (x + z) + h * ((y / (f + SIGN(g, f))) - h)) / x;
- c = s = 1.0;
- for (j = ii; j <= nm; j++) {
- i = j + 1;
- g = rv1[i];
- y = w[i];
- h = s * g;
- g = c * g;
- z = PYTHAG(f, h);
- rv1[j] = z;
- c = f / z;
- s = h / z;
- f = x * c + g * s;
- g = g * c - x * s;
- h = y * s;
- y = y * c;
- for (jj = 0; jj <= n; jj++) {
- x = v[jj][j];
- z = v[jj][i];
- v[jj][j] = x * c + z * s;
- v[jj][i] = z * c - x * s;
- }
- z = PYTHAG(f, h);
- w[j] = z;
- if (z) {
- z = 1.0 / z;
- c = f * z;
- s = h * z;
- }
- f = (c * g) + (s * y);
- x = (c * y) - (s * g);
- for (jj = 0; jj <= m; jj++) {
- y = a[jj][j];
- z = a[jj][i];
- a[jj][j] = y * c + z * s;
- a[jj][i] = z * c - y * s;
- }
- }
- rv1[ii] = 0.0;
- rv1[k] = f;
- w[k] = x;
- }
- }
- G_free_vector(rv1);
- return 0;
-}
-
-#undef SIGN
-#undef MAX
-#undef PYTHAG
-
-int G_svbksb(double **u, double w[], double **v,
- int m, int n, double b[], double x[])
-{
- int j, i;
- double s, *tmp, *G_alloc_vector();
-
- tmp = G_alloc_vector(n);
- for (j = 0; j < n; j++) {
- s = 0.0;
- if (w[j]) {
- for (i = 0; i < m; i++)
- s += u[i][j] * b[i];
- s /= w[j];
- }
- tmp[j] = s;
- }
- for (j = 0; j < n; j++) {
- s = 0.0;
- for (i = 0; i < n; i++)
- s += v[j][i] * tmp[i];
- x[j] = s;
- }
- G_free_vector(tmp);
-
- return 0;
-}
-
-#define TOL 1e-8
-
-int G_svelim(double *w, int n)
-{
- int i;
- double thresh;
-
- thresh = 0.0; /* remove singularity */
- for (i = 0; i < n; i++)
- if (w[i] > thresh)
- thresh = w[i];
- thresh *= TOL;
- for (i = 0; i < n; i++)
- if (w[i] < thresh)
- w[i] = 0.0;
-
- return 0;
-}
-
-#undef TOL
Added: grass/trunk/lib/gmath/test/Makefile
===================================================================
--- grass/trunk/lib/gmath/test/Makefile (rev 0)
+++ grass/trunk/lib/gmath/test/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,9 @@
+MODULE_TOPDIR = ../../..
+
+PGM=test.gmath.lib
+
+LIBES = $(GISLIB) $(GMATHLIB)
+DEPENDENCIES = $(GISDEP) $(GMATHDEP)
+include $(MODULE_TOPDIR)/include/Make/Module.make
+
+default: cmd
Added: grass/trunk/lib/gmath/test/bench_blas2.c
===================================================================
--- grass/trunk/lib/gmath/test/bench_blas2.c (rev 0)
+++ grass/trunk/lib/gmath/test/bench_blas2.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,111 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: Unit benchs for les creation
+*
+* COPYRIGHT: (C) 2000 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include <math.h>
+#include "test_gmath_lib.h"
+#include <sys/time.h>
+#define EPSILON 0.0000001
+
+/* prototypes */
+static void bench_blas_level_2_double(int rows);
+
+
+/* *************************************************************** */
+/* Perfrome the blas level 2 unit benchs ************************** */
+/* *************************************************************** */
+int bench_blas_level_2(int rows)
+{
+ G_message(_("\n++ Running blas level 2 benchmark ++"));
+
+ bench_blas_level_2_double(rows);
+
+ return 1;
+}
+
+/* *************************************************************** */
+/* ************** D O U B L E ************************************ */
+/* *************************************************************** */
+void bench_blas_level_2_double(int rows)
+{
+
+ double **A, *x, *y, *z;
+ struct timeval tstart;
+ struct timeval tend;
+
+ G_math_les *les;
+ les = create_normal_unsymmetric_les(rows);
+ G_math_les *sples;
+ sples = create_sparse_unsymmetric_les(rows);
+
+ x = G_alloc_vector(rows);
+ y = G_alloc_vector(rows);
+ z = G_alloc_vector(rows);
+
+ A = G_alloc_matrix(rows, rows);
+
+ fill_d_vector_range_1(x, 1, rows);
+
+ gettimeofday(&tstart, NULL);
+#pragma omp parallel default(shared)
+{
+ G_math_Ax_sparse(sples->Asp, x, z, rows);
+}
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time G_math_Ax_sparse: %g\n", compute_time_difference(tstart, tend));
+ gettimeofday(&tstart, NULL);
+#pragma omp parallel default(shared)
+{
+ G_math_d_Ax(les->A, x, z, rows, rows);
+}
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time G_math_d_Ax: %g\n", compute_time_difference(tstart, tend));
+ gettimeofday(&tstart, NULL);
+#pragma omp parallel default(shared)
+{
+ G_math_d_aAx_by(les->A, x, y, 3.0, 4.0, z, rows, rows);
+}
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time G_math_d_Ax_by: %g\n", compute_time_difference(tstart, tend));
+ gettimeofday(&tstart, NULL);
+#pragma omp parallel default(shared)
+{
+ G_math_d_x_dyad_y(x, x, A, rows, rows);
+}
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time G_math_d_x_dyad: %g\n", compute_time_difference(tstart, tend));
+ gettimeofday(&tstart, NULL);
+
+
+ if(x)
+ G_free_vector(x);
+ if(y)
+ G_free_vector(y);
+ if(z)
+ G_free_vector(z);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ if(A)
+ G_free_matrix(A);
+
+ return;
+}
+
Added: grass/trunk/lib/gmath/test/bench_blas3.c
===================================================================
--- grass/trunk/lib/gmath/test/bench_blas3.c (rev 0)
+++ grass/trunk/lib/gmath/test/bench_blas3.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,93 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2007
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: Unit benchs for les creation
+*
+* COPYRIGHT: (C) 2007 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include <math.h>
+#include "test_gmath_lib.h"
+#include <sys/time.h>
+
+/* prototypes */
+static void bench_blas_level_3_double(int rows);
+
+
+/* *************************************************************** */
+/* Perfrome the blas level 3 benchs ****************************** */
+/* *************************************************************** */
+int bench_blas_level_3(int rows)
+{
+ G_message(_("\n++ Running blas level 3 benchmark ++"));
+
+ bench_blas_level_3_double(rows);
+
+ return 1;
+}
+
+/* *************************************************************** */
+/* ************** D O U B L E ************************************ */
+/* *************************************************************** */
+void bench_blas_level_3_double(int rows)
+{
+ struct timeval tstart;
+ struct timeval tend;
+ double **A, **B, **C, *x, *y;
+
+ x = G_alloc_vector(rows);
+ y = G_alloc_vector(rows);
+
+ A = G_alloc_matrix(rows, rows);
+ B = G_alloc_matrix(rows, rows);
+ C = G_alloc_matrix(rows, rows);
+
+ fill_d_vector_range_1(x, 1, rows);
+ fill_d_vector_range_1(y, 1, rows);
+
+ fill_d_vector_range_1(A[0], 1, rows*rows);
+ fill_d_vector_range_1(B[0], 1, rows*rows);
+
+
+ gettimeofday(&tstart, NULL);
+#pragma omp parallel default(shared)
+{
+ G_math_d_aA_B(A, B, 4.0 , C, rows , rows);
+}
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time G_math_d_aA_B: %g\n", compute_time_difference(tstart, tend));
+ gettimeofday(&tstart, NULL);
+#pragma omp parallel default(shared)
+{
+ G_math_d_AB(A, B, C, rows , rows , rows);
+}
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time G_math_d_AB: %g\n", compute_time_difference(tstart, tend));
+
+
+ if(x)
+ G_free_vector(x);
+ if(y)
+ G_free_vector(y);
+
+ if(A)
+ G_free_matrix(A);
+ if(B)
+ G_free_matrix(B);
+ if(C)
+ G_free_matrix(C);
+
+ return;
+}
Added: grass/trunk/lib/gmath/test/bench_solver_direct.c
===================================================================
--- grass/trunk/lib/gmath/test/bench_solver_direct.c (rev 0)
+++ grass/trunk/lib/gmath/test/bench_solver_direct.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,99 @@
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: benchmarking the direct solvers
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include "test_gmath_lib.h"
+#include <sys/time.h>
+
+/* prototypes */
+static int bench_solvers(int rows);
+
+
+/* ************************************************************************* */
+/* Performe the solver unit tests ****************************************** */
+
+/* ************************************************************************* */
+int bench_solvers_direct(int rows) {
+ G_message(_("\n++ Running direct solver benchmark ++"));
+
+ bench_solvers(rows);
+
+ return 1;
+}
+
+
+/* *************************************************************** */
+/* Test all implemented solvers for sparse and normal matrix *** */
+
+/* *************************************************************** */
+int bench_solvers(int rows) {
+ G_math_les *les;
+ struct timeval tstart;
+ struct timeval tend;
+
+ G_message("\t * benchmarking gmath lu decomposition solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(rows);
+ gettimeofday(&tstart, NULL);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time gmath lu decomposition: %g\n", compute_time_difference(tstart, tend));
+ G_math_free_les(les);
+
+ G_message("\t * benchmarking lu ccmath decomposition solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(rows);
+ gettimeofday(&tstart, NULL);
+ G_math_solv(les->A, les->b, les->rows);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time ccmath lu decomposition: %g\n", compute_time_difference(tstart, tend));
+ G_math_free_les(les);
+
+
+ G_message("\t * benchmarking gauss elimination solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(rows);
+ gettimeofday(&tstart, NULL);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time gauss elimination: %g\n", compute_time_difference(tstart, tend));
+ G_math_free_les(les);
+
+ G_message("\t * benchmarking gmath cholesky decomposition solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(rows);
+ gettimeofday(&tstart, NULL);
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows, les->rows);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time gmath cholesky decomposition: %g\n", compute_time_difference(tstart, tend));
+ G_math_free_les(les);
+
+ G_message("\t * benchmarking ccmath cholesky decomposition solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(rows);
+ gettimeofday(&tstart, NULL);
+ G_math_solvps(les->A, les->b, les->rows);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time ccmath cholesky decomposition: %g\n", compute_time_difference(tstart, tend));
+ G_math_free_les(les);
+
+ return 1;
+}
+
Added: grass/trunk/lib/gmath/test/bench_solver_krylov.c
===================================================================
--- grass/trunk/lib/gmath/test/bench_solver_krylov.c (rev 0)
+++ grass/trunk/lib/gmath/test/bench_solver_krylov.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,111 @@
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: benchmarking the krylov subspace solvers
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include "test_gmath_lib.h"
+#include <sys/time.h>
+
+/* prototypes */
+static int bench_solvers(int rows);
+
+
+/* ************************************************************************* */
+/* Performe the solver unit tests ****************************************** */
+
+/* ************************************************************************* */
+int bench_solvers_krylov(int rows) {
+ G_message(_("\n++ Running krylov solver benchmark ++"));
+
+ bench_solvers(rows);
+
+ return 1;
+}
+
+
+/* *************************************************************** */
+/* Test all implemented solvers for sparse and normal matrix *** */
+
+/* *************************************************************** */
+int bench_solvers(int rows) {
+ G_math_les *les;
+ G_math_les *sples;
+ struct timeval tstart;
+ struct timeval tend;
+
+ G_message("\t * benchmarking pcg solver with symmetric matrix and preconditioner 1\n");
+
+ les = create_normal_symmetric_les(rows);
+ sples = create_sparse_symmetric_les(rows);
+
+ gettimeofday(&tstart, NULL);
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 250, 0.1e-9, 1);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time pcg normal matrix: %g\n", compute_time_difference(tstart, tend));
+
+ gettimeofday(&tstart, NULL);
+ G_math_solver_sparse_pcg(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 0.1e-9, 1);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time pcg sparse matrix: %g\n", compute_time_difference(tstart, tend));
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * benchmark cg solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(rows);
+ sples = create_sparse_symmetric_les(rows);
+
+ gettimeofday(&tstart, NULL);
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 250, 0.1e-9);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time cg normal matrix: %g\n", compute_time_difference(tstart, tend));
+
+ gettimeofday(&tstart, NULL);
+ G_math_solver_sparse_cg(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 0.1e-9);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time cg sparse matrix: %g\n", compute_time_difference(tstart, tend));
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * benchmark bicgstab solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(rows);
+ sples = create_sparse_unsymmetric_les(rows);
+
+ gettimeofday(&tstart, NULL);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 250, 0.1e-9);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time bicgstab normal matrix: %g\n", compute_time_difference(tstart, tend));
+
+ gettimeofday(&tstart, NULL);
+ G_math_solver_sparse_bicgstab(sples->Asp, sples->x, sples->b, les->rows,
+ 250, 0.1e-9);
+ gettimeofday(&tend, NULL);
+ G_important_message("Computation time bicgstab sparse matrix: %g\n", compute_time_difference(tstart, tend));
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ return 1;
+}
+
Added: grass/trunk/lib/gmath/test/test.gmath.lib.html
===================================================================
--- grass/trunk/lib/gmath/test/test.gmath.lib.html (rev 0)
+++ grass/trunk/lib/gmath/test/test.gmath.lib.html 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,3 @@
+
+
+Take a look at the module command line help for more information.
Added: grass/trunk/lib/gmath/test/test_blas1.c
===================================================================
--- grass/trunk/lib/gmath/test/test_blas1.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_blas1.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,517 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: Unit tests for les creation
+*
+* COPYRIGHT: (C) 2000 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include <math.h>
+#include "test_gmath_lib.h"
+
+#define EPSILON 0.000001
+
+
+/* prototypes */
+static int test_blas_level_1_double(void);
+static int test_blas_level_1_float(void);
+static int test_blas_level_1_int(void);
+
+
+/* *************************************************************** */
+/* Perfrome the blas level 1 unit tests ************************** */
+/* *************************************************************** */
+int unit_test_blas_level_1(void)
+{
+ int sum = 0;
+
+ G_message(_("\n++ Running blas level 1 unit tests ++"));
+
+ sum += test_blas_level_1_double();
+ sum += test_blas_level_1_float();
+ sum += test_blas_level_1_int();
+
+ if (sum > 0)
+ G_warning(_("\n-- blas level 1 unit tests failure --"));
+ else
+ G_message(_("\n-- blas level 1 unit tests finished successfully --"));
+
+ return sum;
+}
+
+
+/* *************************************************************** */
+/* ************** D O U B L E ************************************ */
+/* *************************************************************** */
+int test_blas_level_1_double(void)
+{
+
+ int sum = 0;
+ int rows = 10000;
+ double *x, *y, *z, a = 0.0, b = 0.0, c = 0.0, d = 0.0, e = 0.0;
+
+ x = G_alloc_vector(rows);
+ y = G_alloc_vector(rows);
+ z = G_alloc_vector(rows);
+
+ fill_d_vector_scalar(x, 1, rows);
+ fill_d_vector_scalar(y, 2, rows);
+
+/*test the grass implementation*/
+ G_math_d_x_dot_y(x, y, &a, rows);
+ G_math_d_asum_norm(x, &b, rows);
+ G_math_d_euclid_norm(x, &c, rows);
+
+
+ if(a != 2.0*rows) {
+ G_message("Error in G_math_d_x_dot_y %f != %f", 2.0*rows, a);
+ sum++;
+ }
+
+ if(b != rows) {
+ G_message("Error in G_math_d_asum_norm");
+ sum++;
+ }
+
+ if(c != sqrt(rows)) {
+ G_message("Error in G_math_d_euclid_norm");
+ sum++;
+ }
+
+ /*test the ATALS implemenation*/
+ a = G_math_dnrm2(x, rows);
+ b = G_math_dasum(x, rows);
+ c = G_math_ddot(x, y, rows);
+
+ if(a != sqrt(rows)) {
+ G_message("Error in G_math_dnrm2 %f != %f", sqrt(rows), a);
+ sum++;
+ }
+
+ if(b != rows) {
+ G_message("Error in G_math_dasum %f != %f", 2.0*rows, b);
+ sum++;
+ }
+
+ if(c != 2.0*rows) {
+ G_message("Error in G_math_ddot %f != %f", 2.0*rows, c);
+ sum++;
+ }
+
+ fill_d_vector_range_1(x, 1.0, rows);
+ fill_d_vector_range_2(y, 1.0, rows);
+
+ /*grass function*/
+ G_math_d_max_norm(x, &a, rows);
+ /*atlas function*/
+ b = G_math_idamax(x, rows);
+
+ if(a != 1.0*(rows - 1)) {
+ G_message("Error in G_math_d_max_norm: %f != %f", (double)1.0*(rows - 1), a);
+ sum++;
+ }
+
+ if(b != 1.0*(rows - 1)) {
+ G_message("Error in G_math_idamax: %f != %f", (double)1.0*(rows - 1), b);
+ sum++;
+ }
+
+#pragma omp parallel default(shared)
+{
+ G_math_d_ax_by(x, y, z, 1.0, 1.0, rows);
+}
+ G_math_d_asum_norm(z, &a, rows);
+
+#pragma omp parallel default(shared)
+{
+ G_math_d_ax_by(x, y, z, 1.0, -1.0, rows);
+}
+ G_math_d_asum_norm(z, &b, rows);
+
+#pragma omp parallel default(shared)
+{
+ G_math_d_ax_by(x, y, z, 2.0, 1.0, rows);
+}
+ G_math_d_asum_norm(z, &c, rows);
+
+
+ if(a != 1.0*(rows - 1)* rows) {
+ G_message("Error in G_math_d_ax_by: %f != %f", (double)1.0*(rows - 1)* rows, a);
+ sum++;
+ }
+
+ if(b != 5.0*(rows)*(rows/10)) {
+ G_message("Error in G_math_d_ax_by: %f != %f", (double)5.0*(rows)*(rows/10), b);
+ sum++;
+ }
+
+ if(c != 149985000) {
+ G_message("Error in G_math_d_ax_by: 149985000 != %f", c);
+ sum++;
+ }
+
+
+#pragma omp parallel default(shared)
+{
+ /*scale x with 1*/
+ G_math_d_ax_by(x, z, z, 1.0, 0.0, rows);
+}
+ G_math_d_asum_norm(x, &a, rows);
+ G_math_d_asum_norm(z, &b, rows);
+ /*scale x with -1*/
+#pragma omp parallel default(shared)
+{
+ G_math_d_ax_by(x, z, z, -1.0, 0.0, rows);
+}
+ G_math_d_asum_norm(z, &c, rows);
+
+ /*ATLAS implementation*/
+ G_math_dscal(x, 1.0, rows);
+ G_math_d_asum_norm(x, &d, rows);
+
+ /*ATLAS implementation*/
+ fill_d_vector_range_1(x, 1.0, rows);
+ fill_d_vector_scalar(z, 0.0, rows);
+ G_math_daxpy(x, z, 1.0, rows);
+ G_math_d_asum_norm(z, &e, rows);
+
+
+ if(a != 49995000 || a != b || b != c) {
+ G_message("Error in G_math_d_ax: 49995000 != %f", a);
+ sum++;
+ }
+
+ if(49995000 != d) {
+ G_message("Error in G_math_dscal: 49995000 != %f", d);
+ sum++;
+ }
+
+ if(49995000 != e) {
+ G_message("Error in G_math_daxpy: 49995000 != %f", e);
+ sum++;
+ }
+
+ fill_d_vector_scalar(z, 0, rows);
+
+ G_math_d_copy(x, z, rows);
+ G_math_d_asum_norm(x, &a, rows);
+ G_math_dcopy(x, z, rows);
+ G_math_d_asum_norm(x, &b, rows);
+
+ if(a != 49995000) {
+ G_message("Error in G_math_d_copy: 49995000 != %f", a);
+ sum++;
+ }
+
+ if(b != 49995000) {
+ G_message("Error in G_math_dcopy: 49995000 != %f", a);
+ sum++;
+ }
+
+ G_free_vector(x);
+ G_free_vector(y);
+ G_free_vector(z);
+
+ return sum;
+}
+
+
+/* *************************************************************** */
+/* ************** F L O A T ************************************** */
+/* *************************************************************** */
+int test_blas_level_1_float(void)
+{
+
+ int sum = 0;
+ int rows = 1000;
+ float *x, *y, *z, a = 0.0, b = 0.0, c = 0.0, d = 0.0, e = 0.0;
+
+ x = G_alloc_fvector(rows);
+ y = G_alloc_fvector(rows);
+ z = G_alloc_fvector(rows);
+
+ fill_f_vector_scalar(x, 1, rows);
+ fill_f_vector_scalar(y, 2, rows);
+
+/*test the grass implementation*/
+ G_math_f_x_dot_y(x, y, &a, rows);
+ G_math_f_asum_norm(x, &b, rows);
+ G_math_f_euclid_norm(x, &c, rows);
+
+
+ if(a != 2.0*rows) {
+ G_message("Error in G_math_f_x_dot_y %f != %f", 2.0*rows, a);
+ sum++;
+ }
+
+ if(b != rows) {
+ G_message("Error in G_math_f_asum_norm");
+ sum++;
+ }
+
+ if(fabs(c - (float)sqrt(rows)) > EPSILON) {
+ G_message("Error in G_math_f_euclid_norm");
+ sum++;
+ }
+
+ /*test the ATALS implemenation*/
+ a = G_math_snrm2(x, rows);
+ b = G_math_sasum(x, rows);
+ c = G_math_sdot(x, y, rows);
+
+ if(fabs(a - sqrt(rows)) > EPSILON) {
+ G_message("Error in G_math_snrm2 %f != %f", sqrt(rows), a);
+ sum++;
+ }
+
+ if(b != rows) {
+ G_message("Error in G_math_sasum %f != %f", 2.0*rows, b);
+ sum++;
+ }
+
+ if(c != 2.0*rows) {
+ G_message("Error in G_math_sdot %f != %f", 2.0*rows, c);
+ sum++;
+ }
+
+ fill_f_vector_range_1(x, 1.0, rows);
+ fill_f_vector_range_2(y, 1.0, rows);
+
+ /*grass function*/
+ G_math_f_max_norm(x, &a, rows);
+ /*atlas function*/
+ b = G_math_isamax(x, rows);
+
+ if(a != 1.0*(rows - 1)) {
+ G_message("Error in G_math_f_max_norm: %f != %f", (float)1.0*(rows - 1), a);
+ sum++;
+ }
+
+ if(b != 1.0*(rows - 1)) {
+ G_message("Error in G_math_isamax: %f != %f", (float)1.0*(rows - 1), b);
+ sum++;
+ }
+
+#pragma omp parallel default(shared)
+{
+ G_math_f_ax_by(x, y, z, 1.0, 1.0, rows);
+}
+ G_math_f_asum_norm(z, &a, rows);
+#pragma omp parallel default(shared)
+{
+ G_math_f_ax_by(x, y, z, 1.0, -1.0, rows);
+}
+G_math_f_asum_norm(z, &b, rows);
+#pragma omp parallel default(shared)
+{
+ G_math_f_ax_by(x, y, z, 2.0, 1.0, rows);
+}
+ G_math_f_asum_norm(z, &c, rows);
+
+
+ if(fabs(a - 1.0*(rows - 1)* rows) > EPSILON) {
+ G_message("Error in G_math_f_ax_by 1: %f != %f", (float)1.0*(rows - 1)* rows, a);
+ sum++;
+ }
+
+ if(fabs(b - 5.0*(rows)*(rows/10)) > EPSILON) {
+ G_message("Error in G_math_f_ax_by 2: %f != %f", (float)5.0*(rows)*(rows/10), b);
+ sum++;
+ }
+
+ if(fabs(c - 1498500) > EPSILON) {
+ G_message("Error in G_math_f_ax_by 3: 14998500 != %f", c);
+ sum++;
+ }
+
+
+#pragma omp parallel default(shared)
+{
+ /*scale x with 1*/
+ G_math_f_ax_by(x, z, z, 1.0, 0.0, rows);
+}
+ G_math_f_asum_norm(x, &a, rows);
+ G_math_f_asum_norm(z, &b, rows);
+ /*scale x with -1*/
+#pragma omp parallel default(shared)
+{
+ G_math_f_ax_by(x, z, z, -1.0, 0.0, rows);
+}
+ G_math_f_asum_norm(z, &c, rows);
+
+ /*ATLAS implementation*/
+ G_math_sscal(x, 1.0, rows);
+ G_math_f_asum_norm(x, &d, rows);
+
+ /*ATLAS implementation*/
+ fill_f_vector_range_1(x, 1.0, rows);
+ fill_f_vector_scalar(z, 0.0, rows);
+ G_math_saxpy(x, z, 1.0, rows);
+ G_math_f_asum_norm(z, &e, rows);
+
+
+ if(fabs(a - 499500) > EPSILON) {
+ G_message("Error in G_math_f_ax_by 4: 4999500 != %f", a);
+ sum++;
+ }
+ if(fabs(b - 499500) > EPSILON) {
+ G_message("Error in G_math_f_ax_by 4: 4999500 != %f", b);
+ sum++;
+ }
+ if(fabs(c - 499500) > EPSILON) {
+ G_message("Error in G_math_f_ax_by 4: 4999500 != %f", c);
+ sum++;
+ }
+ if(fabs(d - 499500) > EPSILON) {
+ G_message("Error in G_math_sscal: 4999500 != %f", d);
+ sum++;
+ }
+
+ if(fabs(e - 499500) > EPSILON) {
+ G_message("Error in G_math_saxpy: 4999500 != %f", e);
+ sum++;
+ }
+
+ fill_f_vector_range_1(x, 1.0, rows);
+ fill_f_vector_scalar(z, 0, rows);
+
+ G_math_f_copy(x, z, rows);
+ G_math_f_asum_norm(x, &a, rows);
+ G_math_scopy(x, z, rows);
+ G_math_f_asum_norm(x, &b, rows);
+
+ if(fabs(a - 499500) > EPSILON) {
+ G_message("Error in G_math_f_copy: 4999500 != %f", a);
+ sum++;
+ }
+
+ if(fabs(b - 499500) > EPSILON) {
+ G_message("Error in G_math_scopy: 4999500 != %f", b);
+ sum++;
+ }
+
+ G_free_fvector(x);
+ G_free_fvector(y);
+ G_free_fvector(z);
+
+ return sum;
+}
+
+
+/* *************************************************************** */
+/* ************** I N T E G E R ********************************** */
+/* *************************************************************** */
+int test_blas_level_1_int(void)
+{
+
+ int sum = 0;
+ int rows = 10000;
+ int *x, *y, *z, max;
+ double a, b, c;
+
+ x = G_alloc_ivector(rows);
+ y = G_alloc_ivector(rows);
+ z = G_alloc_ivector(rows);
+
+ fill_i_vector_scalar(x, 1, rows);
+ fill_i_vector_scalar(y, 2, rows);
+
+
+ G_math_i_x_dot_y(x, y, &a, rows);
+ G_math_i_asum_norm(x, &b, rows);
+ G_math_i_euclid_norm(x, &c, rows);
+
+
+ if(a != 2*rows) {
+ G_message("Error in G_math_i_x_dot_y");
+ sum++;
+ }
+
+ if(b != rows) {
+ G_message("Error in G_math_i_asum_norm");
+ sum++;
+ }
+
+ if(c != sqrt((double)rows)) {
+ G_message("Error in G_math_i_euclid_norm");
+ sum++;
+ }
+
+ fill_i_vector_range_1(x, 1, rows);
+ fill_i_vector_range_2(y, 1, rows);
+
+ G_math_i_max_norm(x, &max, rows);
+
+ if(max != (rows - 1)) {
+ G_message("Error in G_math_i_max_norm: %i != %i", (rows - 1), max);
+ sum++;
+ }
+
+#pragma omp parallel default(shared)
+{
+ G_math_i_ax_by(x, y, z, 1, 1, rows);
+}
+ G_math_i_asum_norm(z, &a, rows);
+#pragma omp parallel default(shared)
+{
+ G_math_i_ax_by(x, y, z, 1, -1, rows);
+}
+ G_math_i_asum_norm(z, &b, rows);
+#pragma omp parallel default(shared)
+{
+ G_math_i_ax_by(x, y, z, 2, 1, rows);
+}
+ G_math_i_asum_norm(z, &c, rows);
+
+
+ if(a != 1.0*(rows - 1)* rows) {
+ G_message("Error in G_math_i_ax_by: %f != %f", 1.0*(rows - 1)* rows, a);
+ sum++;
+ }
+
+ if(b != 5.0*(rows)*(rows/10)) {
+ G_message("Error in G_math_i_ax_by: %f != %f", 5.0*(rows)*(rows/10), b);
+ sum++;
+ }
+
+ if(c != 149985000) {
+ G_message("Error in G_math_i_ax_by: 149985000 != %f", c);
+ sum++;
+ }
+
+
+#pragma omp parallel default(shared)
+{
+ /*scale x with 1*/
+ G_math_i_ax_by(x, z, z, 1, 0, rows);
+}
+ G_math_i_asum_norm(x, &a, rows);
+ G_math_i_asum_norm(z, &b, rows);
+
+ /*scale a with -1*/
+#pragma omp parallel default(shared)
+{
+ G_math_i_ax_by(x, z, z, -1, 0, rows);
+}
+ G_math_i_asum_norm(z, &c, rows);
+
+
+ if(a != 49995000 || a != b || b != c) {
+ G_message("Error in G_math_i_ax_by: 49995000 != %f", a);
+ sum++;
+ }
+
+ return sum;
+}
Added: grass/trunk/lib/gmath/test/test_blas2.c
===================================================================
--- grass/trunk/lib/gmath/test/test_blas2.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_blas2.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,285 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: Unit tests for les creation
+*
+* COPYRIGHT: (C) 2000 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include <math.h>
+#include "test_gmath_lib.h"
+
+#define EPSILON 0.0000001
+
+/* prototypes */
+static int test_blas_level_2_double(void);
+static int test_blas_level_2_float(void);
+
+
+/* *************************************************************** */
+/* Perfrome the blas level 2 unit tests ************************** */
+/* *************************************************************** */
+int unit_test_blas_level_2(void)
+{
+ int sum = 0;
+
+ G_message(_("\n++ Running blas level 2 unit tests ++"));
+
+ sum += test_blas_level_2_double();
+ sum += test_blas_level_2_float();
+
+ if (sum > 0)
+ G_warning(_("\n-- blas level 2 unit tests failure --"));
+ else
+ G_message(_("\n-- blas level 2 unit tests finished successfully --"));
+
+ return sum;
+}
+/*
+extern double *G_math_Ax_sparse(G_math_spvector **, double *, double *, int );
+extern double *G_math_d_Ax(double **, double *, double *, int , int );
+extern float *G_math_f_Ax(float **, float *, float *, int , int );
+extern double **G_math_d_x_dyad_y(double *, double *, double **, int, int );
+extern float **G_math_f_x_dyad_y(float *, float *, float **, int, int );
+extern double *G_math_d_aAx_by(double **, double *, double *, double , double , double *, int , int );
+extern float *G_math_f_aAx_by(float **, float *, float *, float , float , float *, int , int );
+*/
+
+/* *************************************************************** */
+/* ************** D O U B L E ************************************ */
+/* *************************************************************** */
+int test_blas_level_2_double(void)
+{
+
+ int sum = 0;
+ int rows = TEST_NUM_ROWS;
+ double **A, **B, **C, *x, *y, *z, a = 0.0, b = 0.0, c = 0.0, d = 0.0, e = 0.0, f = 0.0, g = 0.0, h = 0.0, i = 0.0;
+
+ G_math_les *les;
+ les = create_normal_unsymmetric_les(rows);
+ G_math_les *sples;
+ sples = create_sparse_unsymmetric_les(rows);
+
+ x = G_alloc_vector(rows);
+ y = G_alloc_vector(rows);
+ z = G_alloc_vector(rows);
+
+ A = G_alloc_matrix(rows, rows);
+ B = G_alloc_matrix(rows, rows);
+ C = G_alloc_matrix(rows, rows);
+
+ fill_d_vector_scalar(x, 1, rows);
+ fill_d_vector_scalar(y, 0, rows);
+
+
+#pragma omp parallel default(shared)
+{
+ G_math_Ax_sparse(sples->Asp, x, z, rows);
+ G_math_d_asum_norm(z, &a, rows);
+
+ G_math_d_Ax(les->A, x, z, rows, rows);
+ G_math_d_asum_norm(z, &b, rows);
+
+ G_math_d_aAx_by(les->A, x, y, 1.0, 1.0, z, rows, rows);
+ G_math_d_asum_norm(z, &c, rows);
+
+ G_math_d_aAx_by(les->A, x, y, -1.0, 1.0, z, rows, rows);
+ G_math_d_asum_norm(z, &d, rows);
+
+ G_math_d_aAx_by(les->A, x, y, 1.0, 0.0, z, rows, rows);
+ G_math_d_asum_norm(z, &e, rows);
+
+ G_math_d_aAx_by(les->A, x, y, -1.0, -1.0, z, rows, rows);
+ G_math_d_asum_norm(z, &f, rows);
+
+ G_math_d_x_dyad_y(x, x, A, rows, rows);
+ G_math_d_Ax(A, x, z, rows, rows);
+ G_math_d_asum_norm(z, &g, rows);
+
+ G_math_d_x_dyad_y(x, x, C, rows, rows);
+ G_math_d_Ax(A, x, z, rows, rows);
+ G_math_d_asum_norm(z, &h, rows);
+}
+
+ G_math_d_asum_norm(les->b, &i, rows);
+
+ if(a - i > EPSILON) {
+ G_message("Error in G_math_Ax_sparse: %f != %f", i, a);
+ sum++;
+ }
+
+ if(b - i > EPSILON) {
+ G_message("Error in G_math_d_Ax: %f != %f", i, b);
+ sum++;
+ }
+
+ if(c - i > EPSILON) {
+ G_message("Error in G_math_aAx_by: %f != %f", i, c);
+ sum++;
+ }
+
+ if(d - i > EPSILON) {
+ G_message("Error in G_math_aAx_by: %f != %f", i, d);
+ sum++;
+ }
+
+ if(e - i > EPSILON) {
+ G_message("Error in G_math_aAx_by: %f != %f", i, e);
+ sum++;
+ }
+
+ if(f - i > EPSILON) {
+ G_message("Error in G_math_aAx_by: %f != %f", i, f);
+ sum++;
+ }
+
+ if(g - (double)rows*rows > EPSILON) {
+ G_message("Error in G_math_d_x_dyad_y: %f != %f", (double)rows*rows, g);
+ sum++;
+ }
+
+ if(h - (double)rows*rows > EPSILON) {
+ G_message("Error in G_math_d_x_dyad_y: %f != %f", (double)rows*rows, h);
+ sum++;
+ }
+
+ if(x)
+ G_free_vector(x);
+ if(y)
+ G_free_vector(y);
+ if(z)
+ G_free_vector(z);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ if(A)
+ G_free_matrix(A);
+ if(B)
+ G_free_matrix(B);
+ if(C)
+ G_free_matrix(C);
+
+ return sum;
+}
+
+
+/* *************************************************************** */
+/* ************** F L O A T ************************************** */
+/* *************************************************************** */
+int test_blas_level_2_float(void)
+{
+
+ int sum = 0;
+ int rows =TEST_NUM_ROWS;
+ float **A, **B, **C, *x, *y, *z, b = 0.0, c = 0.0, d = 0.0, e = 0.0, f = 0.0, g = 0.0, h = 0.0, i = 0.0;
+
+ G_math_f_les *les;
+ les = create_normal_unsymmetric_f_les(rows);
+
+ x = G_alloc_fvector(rows);
+ y = G_alloc_fvector(rows);
+ z = G_alloc_fvector(rows);
+
+ A = G_alloc_fmatrix(rows, rows);
+ B = G_alloc_fmatrix(rows, rows);
+ C = G_alloc_fmatrix(rows, rows);
+
+ fill_f_vector_scalar(x, 1, rows);
+ fill_f_vector_scalar(y, 0, rows);
+
+
+#pragma omp parallel default(shared)
+{
+ G_math_f_Ax(les->A, x, z, rows, rows);
+ G_math_f_asum_norm(z, &b, rows);
+
+ G_math_f_aAx_by(les->A, x, y, 1.0, 1.0, z, rows, rows);
+ G_math_f_asum_norm(z, &c, rows);
+
+ G_math_f_aAx_by(les->A, x, y, -1.0, 1.0, z, rows, rows);
+ G_math_f_asum_norm(z, &d, rows);
+
+ G_math_f_aAx_by(les->A, x, y, 1.0, 0.0, z, rows, rows);
+ G_math_f_asum_norm(z, &e, rows);
+
+ G_math_f_aAx_by(les->A, x, y, -1.0, -1.0, z, rows, rows);
+ G_math_f_asum_norm(z, &f, rows);
+
+ G_math_f_x_dyad_y(x, x, A, rows, rows);
+ G_math_f_Ax(A, x, z, rows, rows);
+ G_math_f_asum_norm(z, &g, rows);
+
+ G_math_f_x_dyad_y(x, x, C, rows, rows);
+ G_math_f_Ax(A, x, z, rows, rows);
+ G_math_f_asum_norm(z, &h, rows);
+}
+
+
+ G_math_f_asum_norm(les->b, &i, rows);
+
+ if(b - i > EPSILON) {
+ G_message("Error in G_math_f_Ax: %f != %f", i, b);
+ sum++;
+ }
+
+ if(c - i > EPSILON) {
+ G_message("Error in G_math_f_aAx_by: %f != %f", i, c);
+ sum++;
+ }
+
+ if(d - i > EPSILON) {
+ G_message("Error in G_math_f_aAx_by: %f != %f", i, d);
+ sum++;
+ }
+
+ if(e - i > EPSILON) {
+ G_message("Error in G_math_f_aAx_by: %f != %f", i, e);
+ sum++;
+ }
+
+ if(f - i > EPSILON) {
+ G_message("Error in G_math_f_aAx_by: %f != %f", i, f);
+ sum++;
+ }
+
+ if(g - (float)rows*rows > EPSILON) {
+ G_message("Error in G_math_f_x_dyad_y: %f != %f", (float)rows*rows, g);
+ sum++;
+ }
+
+ if(h - (float)rows*rows > EPSILON) {
+ G_message("Error in G_math_f_x_dyad_y: %f != %f", (float)rows*rows, h);
+ sum++;
+ }
+
+ if(x)
+ G_free_fvector(x);
+ if(y)
+ G_free_fvector(y);
+ if(z)
+ G_free_fvector(z);
+
+ G_math_free_f_les(les);
+
+ if(A)
+ G_free_fmatrix(A);
+ if(B)
+ G_free_fmatrix(B);
+ if(C)
+ G_free_fmatrix(C);
+
+ return sum;
+}
Added: grass/trunk/lib/gmath/test/test_blas3.c
===================================================================
--- grass/trunk/lib/gmath/test/test_blas3.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_blas3.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,259 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass PDE Numerical Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2007
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: Unit tests for les creation
+*
+* COPYRIGHT: (C) 2007 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include <math.h>
+#include "test_gmath_lib.h"
+
+#define EPSILON 0.0000001
+
+/* prototypes */
+static int test_blas_level_3_double(void);
+static int test_blas_level_3_float(void);
+
+
+/* *************************************************************** */
+/* Perfrome the blas level 3 unit tests ************************** */
+/* *************************************************************** */
+int unit_test_blas_level_3(void)
+{
+ int sum = 0;
+
+ G_message(_("\n++ Running blas level 3 unit tests ++"));
+
+ sum += test_blas_level_3_double();
+ sum += test_blas_level_3_float();
+
+ if (sum > 0)
+ G_warning(_("\n-- blas level 3 unit tests failure --"));
+ else
+ G_message(_("\n-- blas level 3 unit tests finished successfully --"));
+
+ return sum;
+}
+
+/* *************************************************************** */
+/* ************** D O U B L E ************************************ */
+/* *************************************************************** */
+int test_blas_level_3_double(void)
+{
+
+ int sum = 0;
+ int rows = TEST_NUM_ROWS;
+ int cols = TEST_NUM_COLS;
+ double **A, **B, **C, *x, *y, a = 0.0, b = 0.0, c = 0.0, d = 0.0;
+
+ x = G_alloc_vector(cols);
+ y = G_alloc_vector(rows);
+
+ A = G_alloc_matrix(rows, cols);
+ B = G_alloc_matrix(rows, cols);
+ C = G_alloc_matrix(rows, cols);
+
+ fill_d_vector_scalar(x, 1, cols);
+ fill_d_vector_scalar(y, 0, rows);
+
+ fill_d_vector_scalar(A[0], 1, rows*cols);
+ fill_d_vector_scalar(B[0], 2, rows*cols);
+
+#pragma omp parallel default(shared)
+{
+ G_math_d_aA_B(A, B, 1.0 , C, rows , cols );
+ G_math_d_Ax(C, x, y, rows, cols);
+}
+ G_math_d_asum_norm(y, &a, rows);
+
+
+ if(a != 3*rows*cols) {
+ G_message("Error in G_math_d_aA_B: %f != %f", a, (double)3*rows*cols);
+ sum++;
+ }
+#pragma omp parallel default(shared)
+{
+ G_math_d_aA_B(A, B, -1.0 , C, rows , cols );
+ G_math_d_Ax(C, x, y, rows, cols);
+}
+ G_math_d_asum_norm(y, &b, rows);
+
+
+ if(b != rows*cols) {
+ G_message("Error in G_math_d_aA_B: %f != %f", b, (double)rows*cols);
+ sum++;
+ }
+#pragma omp parallel default(shared)
+{
+ G_math_d_aA_B(A, B, 2.0 , C, rows , cols );
+ G_math_d_Ax(C, x, y, rows, cols);
+}
+ G_math_d_asum_norm(y, &c, rows);
+
+
+ if(c != 4*rows*cols) {
+ G_message("Error in G_math_d_aA_B: %f != %f", c, (double)4*rows*cols);
+ sum++;
+ }
+
+ G_free_matrix(A);
+ G_free_matrix(B);
+ G_free_matrix(C);
+ A = G_alloc_matrix(rows, cols);
+ B = G_alloc_matrix(cols, rows);
+ C = G_alloc_matrix(rows, rows);
+
+ G_free_vector(x);
+ G_free_vector(y);
+ x = G_alloc_vector(rows);
+ y = G_alloc_vector(rows);
+
+ fill_d_vector_scalar(x, 1, rows);
+ fill_d_vector_scalar(y, 0, rows);
+ fill_d_vector_scalar(A[0], 1, rows*cols);
+ fill_d_vector_scalar(B[0], 2, rows*cols);
+
+#pragma omp parallel default(shared)
+{
+ G_math_d_AB(A, B, C, rows , cols , cols );
+ G_math_d_Ax(C, x, y, rows, cols);
+}
+ G_math_d_asum_norm(y, &d, rows);
+
+
+ if(d != 2*rows*cols*cols) {
+ G_message("Error in G_math_d_AB: %f != %f", d, (double)2*rows*cols*cols);
+ sum++;
+ }
+
+ if(x)
+ G_free_vector(x);
+ if(y)
+ G_free_vector(y);
+
+ if(A)
+ G_free_matrix(A);
+ if(B)
+ G_free_matrix(B);
+ if(C)
+ G_free_matrix(C);
+
+ return sum;
+}
+
+
+/* *************************************************************** */
+/* ************** F L O A T ************************************** */
+/* *************************************************************** */
+int test_blas_level_3_float(void)
+{
+
+ int sum = 0;
+ int rows = TEST_NUM_ROWS;
+ int cols = TEST_NUM_COLS;
+ float **A, **B, **C, *x, *y, a = 0.0, b = 0.0, c = 0.0, d = 0.0;
+
+ x = G_alloc_fvector(cols);
+ y = G_alloc_fvector(rows);
+
+ A = G_alloc_fmatrix(rows, cols);
+ B = G_alloc_fmatrix(rows, cols);
+ C = G_alloc_fmatrix(rows, cols);
+
+ fill_f_vector_scalar(x, 1, cols);
+ fill_f_vector_scalar(y, 0, rows);
+
+ fill_f_vector_scalar(A[0], 1, rows*cols);
+ fill_f_vector_scalar(B[0], 2, rows*cols);
+
+#pragma omp parallel default(shared)
+{
+ G_math_f_aA_B(A, B, 1.0 , C, rows , cols );
+ G_math_f_Ax(C, x, y, rows, cols);
+}
+ G_math_f_asum_norm(y, &a, rows);
+
+ if(a != 3*rows*cols) {
+ G_message("Error in G_math_f_aA_B: %f != %f", a, (double)3*rows*cols);
+ sum++;
+ }
+#pragma omp parallel default(shared)
+{
+ G_math_f_aA_B(A, B, -1.0 , C, rows , cols );
+ G_math_f_Ax(C, x, y, rows, cols);
+}
+ G_math_f_asum_norm(y, &b, rows);
+
+ if(b != rows*cols) {
+ G_message("Error in G_math_f_aA_B: %f != %f", b, (double)rows*cols);
+ sum++;
+ }
+#pragma omp parallel default(shared)
+{
+ G_math_f_aA_B(A, B, 2.0 , C, rows , cols );
+ G_math_f_Ax(C, x, y, rows, cols);
+}
+ G_math_f_asum_norm(y, &c, rows);
+
+ if(c != 4*rows*cols) {
+ G_message("Error in G_math_f_aA_B: %f != %f", c, (double)4*rows*cols);
+ sum++;
+ }
+
+ G_free_fmatrix(A);
+ G_free_fmatrix(B);
+ G_free_fmatrix(C);
+ A = G_alloc_fmatrix(rows, cols);
+ B = G_alloc_fmatrix(cols, rows);
+ C = G_alloc_fmatrix(rows, rows);
+
+ G_free_fvector(x);
+ G_free_fvector(y);
+ x = G_alloc_fvector(rows);
+ y = G_alloc_fvector(rows);
+
+ fill_f_vector_scalar(x, 1, rows);
+ fill_f_vector_scalar(y, 0, rows);
+ fill_f_vector_scalar(A[0], 1, rows*cols);
+ fill_f_vector_scalar(B[0], 2, rows*cols);
+
+#pragma omp parallel default(shared)
+{
+ G_math_f_AB(A, B, C, rows , cols , cols );
+ G_math_f_Ax(C, x, y, rows, cols);
+}
+ G_math_f_asum_norm(y, &d, rows);
+
+
+ if(d != 2*rows*cols*cols) {
+ G_message("Error in G_math_f_AB: %f != %f", d, (double)2*rows*cols*cols);
+ sum++;
+ }
+
+ if(x)
+ G_free_fvector(x);
+ if(y)
+ G_free_fvector(y);
+
+ if(A)
+ G_free_fmatrix(A);
+ if(B)
+ G_free_fmatrix(B);
+ if(C)
+ G_free_fmatrix(C);
+
+ return sum;
+}
Added: grass/trunk/lib/gmath/test/test_ccmath_wrapper.c
===================================================================
--- grass/trunk/lib/gmath/test/test_ccmath_wrapper.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_ccmath_wrapper.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,230 @@
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: Unit tests for les solving
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include "test_gmath_lib.h"
+
+#define EPSILON_DIRECT 1.0E-10
+#define EPSILON_ITER 1.0E-4
+
+/* prototypes */
+static int test_ccmath_wrapper(void);
+
+/* ************************************************************************* */
+/* Performe the solver unit tests ****************************************** */
+/* ************************************************************************* */
+int unit_test_ccmath_wrapper(void)
+{
+ int sum = 0;
+
+ G_message(_("\n++ Running ccmath wrapper unit tests ++"));
+
+ sum += test_ccmath_wrapper();
+
+ if (sum > 0)
+ G_warning(_("\n-- ccmath wrapper unit tests failure --"));
+ else
+ G_message(_("\n-- ccmath wrapper unit tests finished successfully --"));
+
+ return sum;
+}
+
+/* *************************************************************** */
+/* Test all implemented ccmath wrapper *** */
+/* *************************************************************** */
+int test_ccmath_wrapper(void)
+{
+ G_math_les *les;
+ int sum = 0;
+ double val = 0.0, val2 = 0.0;
+
+ G_message("\t * testing ccmath lu solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_d_copy(les->b, les->x, les->rows);
+ G_math_solv(les->A, les->x, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solv abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+ G_message("\t * testing ccmath lu solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+
+ G_math_d_copy(les->b, les->x, les->rows);
+ G_math_solvps(les->A, les->x, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solv abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+ G_message("\t * testing ccmath positive definite solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_d_copy(les->b, les->x, les->rows);
+ G_math_solvps(les->A, les->x, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solvps abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+ G_message("\t * testing ccmath matrix inversion with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_minv(les->A, les->rows);
+ G_math_d_Ax(les->A, les->b, les->x, les->rows, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_minv abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+ G_message("\t * testing ccmath matrix inversion with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+
+ G_math_minv(les->A, les->rows);
+ G_math_d_Ax(les->A, les->b, les->x, les->rows, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_minv abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+
+ G_message("\t * testing ccmath positive definite matrix inversion with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_psinv(les->A, les->rows);
+ G_math_d_Ax(les->A, les->b, les->x, les->rows, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_psinv abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+
+ G_message("\t * testing ccmath eigenvalue solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ // Results of the eigenvalue computation with ocatve
+ les->b[9] = 0.043264;
+ les->b[8] = 0.049529;
+ les->b[7] = 0.057406;
+ les->b[6] = 0.067696;
+ les->b[5] = 0.081639;
+ les->b[4] = 0.101357;
+ les->b[3] = 0.130298;
+ les->b[2] = 0.174596;
+ les->b[1] = 0.256157;
+ les->b[0] = 0.502549;
+
+ G_math_eigval(les->A, les->x, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->b, &val, les->rows);
+ G_math_d_asum_norm(les->x, &val2, les->rows);
+ if ((val - val2) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_eigv abs %2.20f != %i", val,
+ val2);
+ sum++;
+ }
+
+ G_math_free_les(les);
+
+
+ G_message("\t * testing ccmath eigenvector computation with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ // Results of the eigenvalue computation with ocatve
+ les->b[9] = 0.043264;
+ les->b[8] = 0.049529;
+ les->b[7] = 0.057406;
+ les->b[6] = 0.067696;
+ les->b[5] = 0.081639;
+ les->b[4] = 0.101357;
+ les->b[3] = 0.130298;
+ les->b[2] = 0.174596;
+ les->b[1] = 0.256157;
+ les->b[0] = 0.502549;
+
+ G_math_eigen(les->A, les->x, les->rows);
+ G_math_print_les(les);
+ G_math_d_asum_norm(les->b, &val, les->rows);
+ G_math_d_asum_norm(les->x, &val2, les->rows);
+ if ((val - val2) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_eigen abs %2.20f != %i", val,
+ val2);
+ sum++;
+ }
+ G_math_free_les(les);
+
+ G_message("\t * testing ccmath singulare value decomposition with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_svdval(les->x, les->A, les->rows, les->rows);
+ G_math_print_les(les);
+
+
+ G_math_free_les(les);
+
+ return sum;
+}
+
Added: grass/trunk/lib/gmath/test/test_gmath_lib.h
===================================================================
--- grass/trunk/lib/gmath/test/test_gmath_lib.h (rev 0)
+++ grass/trunk/lib/gmath/test/test_gmath_lib.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,133 @@
+
+/*****************************************************************************
+*
+* MODULE: Grass gmath Library
+* AUTHOR(S): Soeren Gebbert, Berlin (GER) Oct 2007
+* soerengebbert <at> gmx <dot> de
+*
+* PURPOSE: Unit and Integration tests
+*
+* COPYRIGHT: (C) 2000 by the GRASS Development Team
+*
+* This program is free software under the GNU General Public
+* License (>=v2). Read the file COPYING that comes with GRASS
+* for details.
+*
+*****************************************************************************/
+
+#ifndef _TEST_GMATH_LIB_H_
+#define _TEST_GMATH_LIB_H_
+
+#include <grass/gmath.h>
+#include <grass/gis.h>
+
+#define TEST_NUM_ROWS 10
+#define TEST_NUM_COLS 9
+#define TEST_NUM_DEPTHS 8
+
+#define G_MATH_NORMAL_LES 0
+#define G_MATH_SPARSE_LES 1
+
+struct timeval;
+
+typedef struct
+{
+ double *x; /*the value vector */
+ double *b; /*the right side of Ax = b */
+ double **A; /*the normal quadratic matrix */
+ double *data; /*the pointer to the quadratic matrix data*/
+ G_math_spvector **Asp; /*the sparse matrix */
+ int rows; /*number of rows */
+ int cols; /*number of cols */
+ int quad; /*is the matrix quadratic (1-quadratic, 0 not)*/
+ int type; /*the type of the les, normal == 0, sparse == 1 */
+ int bandwith; /*the bandwith of the matrix (0 < bandwidth <= cols)*/
+ int symm; /*0 if matrix unsymmetric, 1 if symmetric*/
+} G_math_les;
+
+typedef struct
+{
+ float *x; /*the value vector */
+ float *b; /*the right side of Ax = b */
+ float **A; /*the normal quadratic matrix */
+ float *data; /*the pointer to the quadratic matrix data*/
+ int rows; /*number of rows */
+ int cols; /*number of cols */
+ int quad; /*is the matrix quadratic (1-quadratic, 0 not)*/
+ int type; /*the type of the les, normal == 0, sparse == 1 */
+ int bandwith; /*the bandwith of the matrix (0 < bandwidth <= cols)*/
+ int symm; /*0 if matrix unsymmetric, 1 if symmetric*/
+} G_math_f_les;
+
+extern G_math_les *G_math_alloc_nquad_les(int cols, int rows, int type);
+extern G_math_les *G_math_alloc_nquad_les_Ax(int cols, int rows, int type);
+extern G_math_les *G_math_alloc_nquad_les_A(int cols, int rows, int type);
+extern G_math_les *G_math_alloc_nquad_les_Ax_b(int cols, int rows, int type);
+extern G_math_les *G_math_alloc_les(int rows, int type);
+extern G_math_les *G_math_alloc_les_Ax(int rows, int type);
+extern G_math_les *G_math_alloc_les_A(int rows, int type);
+extern G_math_les *G_math_alloc_les_Ax_b(int rows, int type);
+extern G_math_les *G_math_alloc_les_param(int cols, int rows, int type, int parts);
+extern int G_math_add_spvector_to_les(G_math_les * les, G_math_spvector * spvector, int row);
+extern void G_math_print_les(G_math_les * les);
+extern void G_math_free_les(G_math_les * les);
+
+
+extern void fill_d_vector_range_1(double *x, double a, int rows);
+extern void fill_f_vector_range_1(float *x, float a, int rows);
+extern void fill_i_vector_range_1(int *x, int a, int rows);
+extern void fill_d_vector_range_2(double *x, double a, int rows);
+extern void fill_f_vector_range_2(float *x, float a, int rows);
+extern void fill_i_vector_range_2(int *x, int a, int rows);
+extern void fill_d_vector_scalar(double *x, double a, int rows);
+extern void fill_f_vector_scalar(float *x, float a, int rows);
+extern void fill_i_vector_scalar(int *x, int a, int rows);
+
+extern G_math_les *create_normal_symmetric_les(int rows);
+extern G_math_les *create_normal_symmetric_pivot_les(int rows);
+extern G_math_les *create_normal_unsymmetric_les(int rows);
+extern G_math_les *create_sparse_symmetric_les(int rows);
+extern G_math_les *create_sparse_unsymmetric_les(int rows);
+extern G_math_les *create_normal_unsymmetric_nquad_les_A(int rows, int cols);
+
+
+/*float*/
+extern G_math_f_les *G_math_alloc_f_les(int rows, int type);
+extern G_math_f_les *G_math_alloc_f_nquad_les_A(int rows, int cols, int type);
+extern G_math_f_les *G_math_alloc_f_les_param(int cols, int rows, int type, int parts);
+extern void G_math_free_f_les(G_math_f_les * les);
+extern G_math_f_les *create_normal_symmetric_f_les(int rows);
+extern G_math_f_les *create_normal_unsymmetric_f_les(int rows);
+extern G_math_f_les *create_normal_unsymmetric_f_nquad_les_A(int rows, int cols);
+
+/* direct and iterative solvers */
+extern int unit_test_solvers(void);
+
+/* ccmath wrapper tests*/
+int unit_test_ccmath_wrapper(void);
+
+/* blas level 1 routines */
+extern int unit_test_blas_level_1(void);
+
+/* blas level 2 routines */
+extern int unit_test_blas_level_2(void);
+
+/* blas level 3 routines */
+extern int unit_test_blas_level_3(void);
+
+/* benchmarking iterative krylov solvers */
+extern int bench_solvers_krylov(int);
+
+/* benchmarking direct solvers */
+extern int bench_solvers_direct(int);
+
+/* benchmarking level 2 blas functions */
+int bench_blas_level_2(int rows);
+
+/* benchmarking level 3 blas functions */
+int bench_blas_level_3(int rows);
+
+/* Compute time difference */
+extern double compute_time_difference(struct timeval start, struct timeval end);
+
+#endif
Added: grass/trunk/lib/gmath/test/test_main.c
===================================================================
--- grass/trunk/lib/gmath/test/test_main.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_main.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,197 @@
+/****************************************************************************
+ *
+ * MODULE: test.gpde.lib
+ *
+ * AUTHOR(S): Original author
+ * Soeren Gebbert soerengebbert <at> gmx <dot> de
+ * 05 Sep 2007 Berlin
+ *
+ * PURPOSE: Unit and integration tests for the gmath library
+ *
+ * COPYRIGHT: (C) 2007 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+#include <stdlib.h>
+#include <string.h>
+#include <grass/gis.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include "test_gmath_lib.h"
+#include "grass/gmath.h"
+
+/*- Parameters and global variables -----------------------------------------*/
+typedef struct {
+ struct Option *unit, *integration, *solverbenchmark, *blasbenchmark, *rows;
+ struct Flag *full, *testunit, *testint;
+} paramType;
+
+paramType param; /*Parameters */
+
+/*- prototypes --------------------------------------------------------------*/
+static void set_params(void); /*Fill the paramType structure */
+
+/* ************************************************************************* */
+/* Set up the arguments we are expecting ********************************** */
+
+/* ************************************************************************* */
+void set_params(void) {
+ param.unit = G_define_option();
+ param.unit->key = "unit";
+ param.unit->type = TYPE_STRING;
+ param.unit->required = NO;
+ param.unit->options = "blas1,blas2,blas3,solver,ccmath";
+ param.unit->description = _("Choose the unit tests to run");
+
+ param.integration = G_define_option();
+ param.integration->key = "integration";
+ param.integration->type = TYPE_STRING;
+ param.integration->required = NO;
+ param.integration->options = "";
+ param.integration->description = _("Choose the integration tests to run");
+
+ param.rows = G_define_option();
+ param.rows->key = "rows";
+ param.rows->type = TYPE_INTEGER;
+ param.rows->required = NO;
+ param.rows->answer = "1000";
+ param.rows->description = _("The size of the matrices and vectors for benchmarking");
+
+ param.solverbenchmark = G_define_option();
+ param.solverbenchmark->key = "solverbench";
+ param.solverbenchmark->type = TYPE_STRING;
+ param.solverbenchmark->required = NO;
+ param.solverbenchmark->options = "krylov,direct";
+ param.solverbenchmark->description = _("Choose solver benchmark");
+
+ param.blasbenchmark = G_define_option();
+ param.blasbenchmark->key = "blasbench";
+ param.blasbenchmark->type = TYPE_STRING;
+ param.blasbenchmark->required = NO;
+ param.blasbenchmark->options = "blas2,blas3";
+ param.blasbenchmark->description = _("Choose blas benchmark");
+
+ param.testunit = G_define_flag();
+ param.testunit->key = 'u';
+ param.testunit->description = _("Run all unit tests");
+
+ param.testint = G_define_flag();
+ param.testint->key = 'i';
+ param.testint->description = _("Run all integration tests");
+
+ param.full = G_define_flag();
+ param.full->key = 'a';
+ param.full->description = _("Run all unit and integration tests");
+
+}
+
+/* ************************************************************************* */
+/* ************************************************************************* */
+
+/* ************************************************************************* */
+int main(int argc, char *argv[]) {
+ struct GModule *module;
+ int returnstat = 0, i;
+ int rows = 3000;
+
+
+ /* Initialize GRASS */
+ G_gisinit(argv[0]);
+
+ module = G_define_module();
+ module->keywords = _("test, gmath");
+ module->description
+ = _("Performs benchmarks, unit and integration tests for the gmath library");
+
+ /* Get parameters from user */
+ set_params();
+
+ if (G_parser(argc, argv))
+ exit(EXIT_FAILURE);
+
+
+ if (param.rows->answer)
+ sscanf(param.rows->answer, "%i", &rows);
+
+ /*Run the unit tests */
+ if (param.testunit->answer || param.full->answer) {
+ returnstat += unit_test_blas_level_1();
+ returnstat += unit_test_blas_level_2();
+ returnstat += unit_test_blas_level_3();
+ returnstat += unit_test_solvers();
+ returnstat += unit_test_ccmath_wrapper();
+
+ }
+
+ /*Run the integration tests */
+ if (param.testint->answer || param.full->answer) {
+ ;
+ }
+
+ /*Run single tests */
+ if (!param.full->answer) {
+ /*unit tests */
+ if (!param.testunit->answer) {
+ i = 0;
+ if (param.unit->answers)
+ while (param.unit->answers[i]) {
+ if (strcmp(param.unit->answers[i], "blas1") == 0)
+ returnstat += unit_test_blas_level_1();
+
+ if (strcmp(param.unit->answers[i], "blas2") == 0)
+ returnstat += unit_test_blas_level_2();
+
+ if (strcmp(param.unit->answers[i], "blas3") == 0)
+ returnstat += unit_test_blas_level_3();
+
+ if (strcmp(param.unit->answers[i], "solver") == 0)
+ returnstat += unit_test_solvers();
+
+ if (strcmp(param.unit->answers[i], "ccmath") == 0)
+ returnstat += unit_test_ccmath_wrapper();
+
+ i++;
+ }
+ }
+ /*integration tests */
+ if (!param.testint->answer) {
+ i = 0;
+ if (param.integration->answers)
+ while (param.integration->answers[i]) {
+ ;
+ }
+
+ }
+ }
+
+ i = 0;
+ if (param.solverbenchmark->answers)
+ while (param.solverbenchmark->answers[i]) {
+ if (strcmp(param.solverbenchmark->answers[i], "krylov") == 0)
+ bench_solvers_krylov(rows);
+ if (strcmp(param.solverbenchmark->answers[i], "direct") == 0)
+ bench_solvers_direct(rows);
+ i++;
+ }
+
+ i = 0;
+ if (param.blasbenchmark->answers)
+ while (param.blasbenchmark->answers[i]) {
+ if (strcmp(param.blasbenchmark->answers[i], "blas2") == 0)
+ bench_blas_level_2(rows);
+ if (strcmp(param.blasbenchmark->answers[i], "blas3") == 0)
+ bench_blas_level_3(rows);
+
+ i++;
+ }
+
+ if (returnstat != 0)
+ G_warning("Errors detected while testing the gmath lib");
+ else
+ G_message("\n-- gmath lib tests finished successfully --");
+
+ return (returnstat);
+}
Added: grass/trunk/lib/gmath/test/test_solvers.c
===================================================================
--- grass/trunk/lib/gmath/test/test_solvers.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_solvers.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,457 @@
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: Unit tests for les solving
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include "test_gmath_lib.h"
+
+#define EPSILON_DIRECT 1.0E-10
+#define EPSILON_ITER 1.0E-4
+
+/* prototypes */
+static int test_solvers(void);
+
+/* ************************************************************************* */
+/* Performe the solver unit tests ****************************************** */
+/* ************************************************************************* */
+int unit_test_solvers(void)
+{
+ int sum = 0;
+
+ G_message(_("\n++ Running solver unit tests ++"));
+
+ sum += test_solvers();
+
+ if (sum > 0)
+ G_warning(_("\n-- Solver unit tests failure --"));
+ else
+ G_message(_("\n-- Solver unit tests finished successfully --"));
+
+ return sum;
+}
+
+/* *************************************************************** */
+/* Test all implemented solvers for sparse and normal matrix *** */
+/* *************************************************************** */
+int test_solvers(void)
+{
+ G_math_les *les;
+ G_math_les *sples;
+ int sum = 0;
+ double val = 0.0;
+
+ G_message("\t * testing jacobi solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_jacobi(les->A, les->x, les->b, les->rows, 250, 1, 0.1e-10);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_jacobi abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_solver_sparse_jacobi(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 1, 0.1e-10);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_jacobi abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing jacobi solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_unsymmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_jacobi(les->A, les->x, les->b, les->rows, 250, 1, 0.1e-10);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_jacobi abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+
+ G_math_solver_sparse_jacobi(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 1, 0.1e-10);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_jacobi abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing gauss seidel solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_gs(les->A, les->x, les->b, les->rows, 150, 1, 0.1e-9);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_gs abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+
+ G_math_solver_sparse_gs(sples->Asp, sples->x, sples->b, les->rows, 150, 1,
+ 0.1e-9);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_gs abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing gauss seidel solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_unsymmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_gs(les->A, les->x, les->b, les->rows, 150, 1, 0.1e-9);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_gs abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+
+ G_math_solver_sparse_gs(sples->Asp, sples->x, sples->b, les->rows, 150, 1,
+ 0.1e-9);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_gs abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing pcg solver with symmetric bad conditioned matrix and preconditioner 3\n");
+
+ les = create_normal_symmetric_pivot_les(TEST_NUM_ROWS);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 250, 0.1e-9, 3);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_pcg abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing pcg solver with symmetric matrix and preconditioner 1\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 250, 0.1e-9, 1);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_pcg abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+
+ G_math_solver_sparse_pcg(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 0.1e-9, 1);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_pcg abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+ G_math_print_les(sples);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing pcg solver with symmetric matrix and preconditioner 2\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 250, 0.1e-9, 2);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_pcg abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+
+ G_math_solver_sparse_pcg(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 0.1e-9, 2);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_pcg abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+ G_math_print_les(sples);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing pcg solver with symmetric matrix and preconditioner 3\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 250, 0.1e-9, 3);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_pcg abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+
+ G_math_solver_sparse_pcg(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 0.1e-9, 3);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_pcg abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+ G_math_print_les(sples);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing cg solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 250, 0.1e-9);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_cg abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+
+ G_math_solver_sparse_cg(sples->Asp, sples->x, sples->b, les->rows, 250,
+ 0.1e-9);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_cg abs %2.20f != %i", val,
+ sples->rows);
+ sum++;
+ }
+ G_math_print_les(sples);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing cg solver with symmetric bad conditioned matrix\n");
+
+ les = create_normal_symmetric_pivot_les(TEST_NUM_ROWS);
+
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 250, 0.1e-9);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_cg abs %2.20f != %i", val, les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing bicgstab solver with symmetric matrix\n");
+
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_symmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 250, 0.1e-9);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_bicgstab abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+
+ G_math_solver_sparse_bicgstab(sples->Asp, sples->x, sples->b, les->rows,
+ 250, 0.1e-9);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)sples->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_bicgstab abs %2.20f != %i",
+ val, sples->rows);
+ sum++;
+ }
+ G_math_print_les(sples);
+
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing bicgstab solver with unsymmetric matrix\n");
+
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+ sples = create_sparse_unsymmetric_les(TEST_NUM_ROWS);
+
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 250, 0.1e-9);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_bicgstab abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+
+ G_math_solver_sparse_bicgstab(sples->Asp, sples->x, sples->b, les->rows,
+ 250, 0.1e-9);
+ G_math_d_asum_norm(sples->x, &val, sples->rows);
+ if ((val - (double)les->rows) > EPSILON_ITER)
+ {
+ G_warning("Error in G_math_solver_sparse_bicgstab abs %2.20f != %i",
+ val, sples->rows);
+ sum++;
+ }
+
+ G_math_print_les(sples);
+ G_math_free_les(les);
+ G_math_free_les(sples);
+
+ G_message("\t * testing gauss elimination solver with symmetric matrix\n");
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing lu decomposition solver with symmetric matrix\n");
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing gauss elimination solver with unsymmetric matrix\n");
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing lu decomposition solver with unsymmetric matrix\n");
+ les = create_normal_unsymmetric_les(TEST_NUM_ROWS);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
+
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing gauss elimination solver with symmetric bad conditioned matrix\n");
+ les = create_normal_symmetric_pivot_les(TEST_NUM_ROWS);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing lu decomposition solver with symmetric bad conditioned matrix\n");
+ les = create_normal_symmetric_pivot_les(TEST_NUM_ROWS);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ G_message("\t * testing cholesky decomposition solver with symmetric matrix\n");
+ les = create_normal_symmetric_les(TEST_NUM_ROWS);
+ /*cholesky*/G_math_solver_cholesky(les->A, les->x, les->b, les->rows,
+ les->rows);
+ G_math_d_asum_norm(les->x, &val, les->rows);
+ if ((val - (double)les->rows) > EPSILON_DIRECT)
+ {
+ G_warning("Error in G_math_solver_gauss abs %2.20f != %i", val,
+ les->rows);
+ sum++;
+ }
+ G_math_print_les(les);
+ G_math_free_les(les);
+
+ return sum;
+}
+
Added: grass/trunk/lib/gmath/test/test_tools.c
===================================================================
--- grass/trunk/lib/gmath/test/test_tools.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_tools.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,458 @@
+/*****************************************************************************
+ *
+ * MODULE: Grass PDE Numerical Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: Unit tests for les solving
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <grass/glocale.h>
+#include <grass/gmath.h>
+#include "test_gmath_lib.h"
+#include <sys/time.h>
+
+/* *************************************************************** */
+/* Compute the difference between two time steps ***************** */
+
+/* *************************************************************** */
+double compute_time_difference(struct timeval start, struct timeval end) {
+ int sec;
+ int usec;
+
+ sec = end.tv_sec - start.tv_sec;
+ usec = end.tv_usec - start.tv_usec;
+
+ return (double) sec + (double) usec / 1000000;
+}
+
+/* *************************************************************** */
+/* create a normal matrix with values ** Hilbert matrix ********** */
+/* *************************************************************** */
+G_math_les *create_normal_symmetric_les(int rows)
+{
+ G_math_les *les;
+ int i, j;
+ int size =rows;
+ double val;
+
+ les = G_math_alloc_les(rows, G_MATH_NORMAL_LES);
+ for (i = 0; i < size; i++)
+ {
+ val = 0.0;
+ for (j = 0; j < size; j++)
+ {
+ if (j == i)
+ les->A[i][j] = (double)(1.0/(((double)i + 1.0) + ((double)j
+ + 1.0)));
+ else
+ les->A[i][j] = (double)(1.0/((((double)i + 1.0) + ((double)j
+ + 1.0) + 100.0)));
+
+ val += les->A[i][j];
+ }
+ les->b[i] = val;
+ les->x[i] = 0.5;
+ }
+
+ return les;
+}
+
+/* ********************************************************************* */
+/* create a bad conditioned normal matrix with values ** Hilbert matrix */
+/* ********************************************************************* */
+G_math_les *create_normal_symmetric_pivot_les(int rows)
+{
+ G_math_les *les;
+ int i, ii, j, jj;
+ double val;
+
+ les = G_math_alloc_les(rows, G_MATH_NORMAL_LES);
+ for (i = 0, ii = rows - 1; i < rows; i++, ii--)
+ {
+ val = 0.0;
+ for (j = 0, jj = rows - 1; j < rows; j++, jj--)
+ {
+ if (j == i)
+ les->A[i][j] = (double)(1.0/(((double)ii*ii*ii*ii*ii + 1.0)*1.1
+ + ((double)jj*jj*jj*jj*jj + 1.0)*1.1));
+ else
+ les->A[i][j] = (double)(1.0/((((double)ii*ii*ii + 1.0)
+ + ((double)jj*jj*jj + 1.0))));
+
+ val += les->A[i][j];
+ }
+ les->b[i] = val;
+ les->x[i] = 0.0;
+ }
+
+ return les;
+}
+
+/* *************************************************************** */
+/* create a normal matrix with values ** Hilbert matrix ********** */
+/* *************************************************************** */
+G_math_f_les *create_normal_symmetric_f_les(int rows)
+{
+ G_math_f_les *les;
+ int i, j;
+ int size =rows;
+ float val;
+
+ les = G_math_alloc_f_les(rows, G_MATH_NORMAL_LES);
+ for (i = 0; i < size; i++)
+ {
+ val = 0.0;
+ for (j = 0; j < size; j++)
+ {
+ if (j == i)
+ les->A[i][j] = (float)(1.0
+ /(((float)i + 1.0) + ((float)j + 1.0)));
+ else
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 100.0)));
+
+ val += les->A[i][j];
+ }
+ les->b[i] = val;
+ les->x[i] = 0.5;
+ }
+
+ return les;
+}
+
+/* *************************************************************** */
+/* create a sparse matrix with values ** Hilbert matrix ********** */
+/* *************************************************************** */
+G_math_les *create_sparse_unsymmetric_les(int rows)
+{
+ G_math_les *les;
+ G_math_spvector *spvector;
+ int i, j;
+ double val;
+
+ les = G_math_alloc_les(rows, G_MATH_SPARSE_LES);
+
+ for (i = 0; i < rows; i++)
+ {
+ spvector = G_math_alloc_spvector(rows);
+ val = 0;
+
+ for (j = 0; j < rows; j++)
+ {
+ if (j == i)
+ {
+ spvector->values[j] = (double)(1.0/((((double)i + 1.0)
+ + ((double)j))));
+ spvector->index[j] = j;
+ }
+ if (j < i)
+ {
+ spvector->values[j] = (double)(1.0/((((double)i + 1.0)
+ + ((double)j + 1.0) + 100)));
+ spvector->index[j] = j;
+ }
+ if (j > i)
+ {
+ spvector->values[j] = (double)(1.0/((((double)i + 1.0)
+ + ((double)j + 1.0) + 120)));
+ spvector->index[j] = j;
+ }
+
+ val += spvector->values[j];
+ }
+
+ G_math_add_spvector_to_les(les, spvector, i);
+ les->b[i] = val;
+ les->x[i] = 0.5;
+ }
+
+ return les;
+}
+
+/* *************************************************************** */
+/* create a normal matrix with values ** Hilbert matrix ********** */
+/* *************************************************************** */
+G_math_les *create_normal_unsymmetric_les(int rows)
+{
+ G_math_les *les;
+ int i, j;
+ int size =rows;
+ double val;
+
+ les = G_math_alloc_les(rows, G_MATH_NORMAL_LES);
+ for (i = 0; i < size; i++)
+ {
+ val = 0.0;
+ for (j = 0; j < size; j++)
+ {
+ if (j == i)
+ les->A[i][j]
+ = (double)(1.0/((((double)i + 1.0) + ((double)j))));
+ if (j < i)
+ les->A[i][j] = (double)(1.0/((((double)i + 1.0) + ((double)j
+ + 1.0) + 100)));
+ if (j > i)
+ les->A[i][j] = (double)(1.0/((((double)i + 1.0) + ((double)j
+ + 1.0) + 120)));
+
+ val += les->A[i][j];
+ }
+ les->b[i] = val;
+ les->x[i] = 0.5;
+ }
+
+ return les;
+}
+
+/* *********************************************************************** */
+/* create a non quadratic unsymmetric matrix with values ** Hilbert matrix */
+/* *********************************************************************** */
+G_math_les *create_normal_unsymmetric_nquad_les_A(int rows, int cols)
+{
+ G_math_les *les;
+ int i, j;
+
+ les = G_math_alloc_nquad_les_A(rows, cols, G_MATH_NORMAL_LES);
+ for (i = 0; i < rows; i++)
+ {
+ for (j = 0; j < cols; j++)
+ {
+ if (j == i)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0) + ((float)j))));
+ if (j < i && j < cols && i < rows)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 100)));
+ if (j > i && j < cols && i < rows)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 120)));
+ }
+ }
+
+ return les;
+}
+
+/* ***************************************************************************** */
+/* create a non quadratic unsymmetric float matrix with values ** Hilbert matrix */
+/* ***************************************************************************** */
+G_math_f_les *create_normal_unsymmetric_f_nquad_les_A(int rows, int cols)
+{
+ G_math_f_les *les;
+ int i, j;
+
+ les = G_math_alloc_f_nquad_les_A(rows, cols, G_MATH_NORMAL_LES);
+ for (i = 0; i < rows; i++)
+ {
+ for (j = 0; j < cols; j++)
+ {
+ if (j == i)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0) + ((float)j))));
+ if (j < i&& j < cols && i < rows)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 100)));
+ if (j > i&& j < cols && i < rows)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 120)));
+ }
+ }
+
+ return les;
+}
+
+/* *************************************************************** */
+/* create a normal matrix with values ** Hilbert matrix ********** */
+/* *************************************************************** */
+G_math_f_les *create_normal_unsymmetric_f_les(int rows)
+{
+ G_math_f_les *les;
+ int i, j;
+ int size =rows;
+ float val;
+
+ les = G_math_alloc_f_les(rows, G_MATH_NORMAL_LES);
+ for (i = 0; i < size; i++)
+ {
+ val = 0.0;
+ for (j = 0; j < size; j++)
+ {
+ if (j == i)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0) + ((float)j))));
+ if (j < i)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 100)));
+ if (j > i)
+ les->A[i][j] = (float)(1.0/((((float)i + 1.0)
+ + ((float)j + 1.0) + 120)));
+
+ val += les->A[i][j];
+ }
+ les->b[i] = val;
+ les->x[i] = 0.5;
+ }
+
+ return les;
+}
+
+/* *************************************************************** */
+/* create a sparse matrix with values ** Hilbert matrix ********** */
+/* *************************************************************** */
+G_math_les *create_sparse_symmetric_les(int rows)
+{
+ G_math_les *les;
+ G_math_spvector *spvector;
+ int i, j;
+ double val;
+
+ les = G_math_alloc_les(rows, G_MATH_SPARSE_LES);
+
+ for (i = 0; i < rows; i++)
+ {
+ spvector = G_math_alloc_spvector(rows);
+ val = 0;
+
+ for (j = 0; j < rows; j++)
+ {
+ if (j == i)
+ {
+ spvector->values[j] = (double)(1.0/((((double)i + 1.0)
+ + ((double)j + 1.0))));
+ spvector->index[j] = j;
+ }
+ else
+ {
+ spvector->values[j] = (double)(1.0/(((((double)i + 1.0)
+ + ((double)j + 1.0)) + 100)));
+ spvector->index[j] = j;
+ }
+
+ val += spvector->values[j];
+ }
+
+ G_math_add_spvector_to_les(les, spvector, i);
+ les->b[i] = val;
+ les->x[i] = 0.5;
+ }
+
+ return les;
+}
+
+/* *************************************************************** */
+void fill_d_vector_range_1(double *x, double a, int rows)
+{
+ int i = 0;
+
+ for (i = 0; i < rows; i++)
+ {
+ x[i] = a*(double)i;
+ }
+
+}
+
+/* *************************************************************** */
+void fill_d_vector_range_2(double *x, double a, int rows)
+{
+ int i = 0, count = 0;
+
+ for (i = rows - 1; i >= 0; i--)
+ {
+ x[i] = a*(double)count;
+ count ++;
+ }
+
+}
+
+/* *************************************************************** */
+void fill_d_vector_scalar(double *x, double a, int rows)
+{
+ int i = 0;
+
+ for (i = 0; i < rows; i++)
+ {
+ x[i] = a;
+ }
+}
+
+/* *************************************************************** */
+void fill_f_vector_range_1(float *x, float a, int rows)
+{
+ int i = 0;
+
+ for (i = 0; i < rows; i++)
+ {
+ x[i] = a*(float)i;
+ //printf("%f ", x[i]);
+ }
+}
+
+/* *************************************************************** */
+void fill_f_vector_range_2(float *x, float a, int rows)
+{
+ int i = 0, count = 0;
+
+ for (i = rows - 1; i >= 0; i--)
+ {
+ x[i] = a*(float)count;
+ //printf("%f ", x[i]);
+ count ++;
+ }
+
+}
+
+/* *************************************************************** */
+void fill_f_vector_scalar(float *x, float a, int rows)
+{
+ int i = 0;
+
+ for (i = 0; i < rows; i++)
+ {
+ x[i] = a;
+ //printf("%f ", x[i]);
+ }
+}
+
+/* *************************************************************** */
+void fill_i_vector_range_1(int *x, int a, int rows)
+{
+ int i = 0;
+
+ for (i = 0; i < rows; i++)
+ {
+ x[i] = a*i;
+ }
+}
+
+/* *************************************************************** */
+void fill_i_vector_range_2(int *x, int a, int rows)
+{
+ int i = 0, count = 0;
+
+ for (i = rows - 1; i >= 0; i--)
+ {
+ x[i] = a*count;
+ count ++;
+ }
+
+}
+
+/* *************************************************************** */
+void fill_i_vector_scalar(int *x, int a, int rows)
+{
+ int i = 0;
+
+ for (i = 0; i < rows; i++)
+ {
+ x[i] = a;
+ }
+}
+
Added: grass/trunk/lib/gmath/test/test_tools_les.c
===================================================================
--- grass/trunk/lib/gmath/test/test_tools_les.c (rev 0)
+++ grass/trunk/lib/gmath/test/test_tools_les.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -0,0 +1,479 @@
+/*****************************************************************************
+ *
+ * MODULE: Grass Gmath Library
+ * AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
+ * soerengebbert <at> gmx <dot> de
+ *
+ * PURPOSE: functions to manage linear equation systems
+ * part of the gmath library
+ *
+ * COPYRIGHT: (C) 2000 by the GRASS Development Team
+ *
+ * This program is free software under the GNU General Public
+ * License (>=v2). Read the file COPYING that comes with GRASS
+ * for details.
+ *
+ *****************************************************************************/
+
+#include "test_gmath_lib.h"
+#include <stdlib.h>
+#include <math.h>
+
+/*!
+ * \brief Allocate memory for a (not) quadratic linear equation system which includes the Matrix A, vector x and vector b
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param cols int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_nquad_les(int rows, int cols, int type)
+{
+ return G_math_alloc_les_param(rows, cols, type, 2);
+}
+
+/*!
+ * \brief Allocate memory for a (not) quadratic linear equation system which includes the Matrix A and vector x
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param cols int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_nquad_les_Ax(int rows, int cols, int type)
+{
+ return G_math_alloc_les_param(rows, cols, type, 1);
+}
+
+/*!
+ * \brief Allocate memory for a (not) quadratic linear equation system which includes the Matrix A
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param cols int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_nquad_les_A(int rows, int cols, int type)
+{
+ return G_math_alloc_les_param(rows, cols, type, 0);
+}
+
+/*!
+ * \brief Allocate memory for a (not) quadratic linear equation system which includes the Matrix A, vector x and vector b
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param cols int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_nquad_les_Ax_b(int rows, int cols, int type)
+{
+ return G_math_alloc_les_param(rows, cols, type, 2);
+}
+
+/*!
+ * \brief Allocate memory for a quadratic linear equation system which includes the Matrix A, vector x and vector b
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_les(int rows, int type)
+{
+ return G_math_alloc_les_param(rows, rows, type, 2);
+}
+
+/*!
+ * \brief Allocate memory for a quadratic linear equation system which includes the Matrix A and vector x
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_les_Ax(int rows, int type)
+{
+ return G_math_alloc_les_param(rows, rows, type, 1);
+}
+
+/*!
+ * \brief Allocate memory for a quadratic linear equation system which includes the Matrix A
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_les_A(int rows, int type)
+{
+ return G_math_alloc_les_param(rows, rows, type, 0);
+}
+
+/*!
+ * \brief Allocate memory for a quadratic linear equation system which includes the Matrix A, vector x and vector b
+ *
+ * This function calls #G_math_alloc_les_param
+ *
+ * \param rows int
+ * \param type int
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_les_Ax_b(int rows, int type)
+{
+ return G_math_alloc_les_param(rows, rows, type, 2);
+}
+
+/*!
+ * \brief Allocate memory for a quadratic or not quadratic linear equation system
+ *
+ * The type of the linear equation system must be G_MATH_NORMAL_LES for
+ * a regular quadratic matrix or G_MATH_SPARSE_LES for a sparse matrix
+ *
+ * <p>
+ * In case of G_MATH_NORMAL_LES
+ *
+ * A quadratic matrix of size rows*rows*sizeof(double) will allocated
+ *
+ * <p>
+ * In case of G_MATH_SPARSE_LES
+ *
+ * a vector of size row will be allocated, ready to hold additional allocated sparse vectors.
+ * each sparse vector may have a different size.
+ *
+ * Parameter parts defines which parts of the les should be allocated.
+ * The number of columns and rows defines if the matrix is quadratic.
+ *
+ * \param rows int
+ * \param cols int
+ * \param type int
+ * \param parts int -- 2 = A, x and b; 1 = A and x; 0 = A allocated
+ * \return G_math_les *
+ *
+ * */
+G_math_les *G_math_alloc_les_param(int rows, int cols, int type, int parts)
+{
+ G_math_les *les;
+
+ if (type == G_MATH_SPARSE_LES)
+ G_debug(
+ 2,
+ "Allocate memory for a sparse linear equation system with %i rows\n",
+ rows);
+ else
+ G_debug(
+ 2,
+ "Allocate memory for a regular linear equation system with %i rows and %i cols\n",
+ rows, cols);
+
+ les = (G_math_les *) G_calloc(1, sizeof(G_math_les));
+ les->x = NULL;
+ les->b = NULL;
+
+ if (parts > 0)
+ {
+ les->x = (double *)G_calloc(cols, sizeof(double));
+ }
+
+ if (parts > 1)
+ {
+ les->b = (double *)G_calloc(cols, sizeof(double));
+ }
+
+ les->A = NULL;
+ les->data = NULL;
+ les->Asp = NULL;
+ les->rows = rows;
+ les->cols = cols;
+ les->symm = 0;
+ les->bandwith = cols;
+ if (rows == cols)
+ les->quad = 1;
+ else
+ les->quad = 0;
+
+ if (type == G_MATH_SPARSE_LES)
+ {
+ les->Asp = (G_math_spvector **) G_calloc(rows,
+ sizeof(G_math_spvector *));
+ les->type = G_MATH_SPARSE_LES;
+ }
+ else
+ {
+ les->A = G_alloc_matrix(rows, cols);
+ /*save the start pointer of the matrix*/
+ les->data = les->A[0];
+ les->type = G_MATH_NORMAL_LES;
+ }
+
+ return les;
+}
+
+/***************** Floating point version ************************/
+
+G_math_f_les *G_math_alloc_f_les(int rows, int type)
+{
+ return G_math_alloc_f_les_param(rows, rows, type, 2);
+}
+
+G_math_f_les *G_math_alloc_f_nquad_les_A(int rows, int cols, int type)
+{
+ return G_math_alloc_f_les_param(rows, cols, type, 0);
+}
+
+G_math_f_les *G_math_alloc_f_les_param(int rows, int cols, int type, int parts)
+{
+ G_math_f_les *les;
+
+ G_debug(
+ 2,
+ "Allocate memory for a regular float linear equation system with %i rows\n",
+ rows);
+
+ les = (G_math_f_les *) G_calloc(1, sizeof(G_math_f_les));
+ les->x = NULL;
+ les->b = NULL;
+
+ if (parts > 0)
+ {
+ les->x = (float *)G_calloc(cols, sizeof(float));
+ }
+
+ if (parts > 1)
+ {
+ les->b = (float *)G_calloc(cols, sizeof(float));
+ }
+
+ les->A = NULL;
+ les->data = NULL;
+ les->rows = rows;
+ les->cols = cols;
+ les->symm = 0;
+ les->bandwith = cols;
+ if (rows == cols)
+ les->quad = 1;
+ else
+ les->quad = 0;
+
+ les->A = G_alloc_fmatrix(rows, cols);
+ /*save the start pointer of the matrix*/
+ les->data = les->A[0];
+ les->type = G_MATH_NORMAL_LES;
+
+ return les;
+}
+
+/*!
+ * \brief Adds a sparse vector to a sparse linear equation system at position row
+ *
+ * Return 1 for success and -1 for failure
+ *
+ * \param les G_math_les *
+ * \param spvector G_math_spvector *
+ * \param row int
+ * \return int 0 success, -1 failure
+ *
+ * */
+int G_math_add_spvector_to_les(G_math_les * les, G_math_spvector * spvector,
+ int row)
+{
+
+ if (les != NULL)
+ {
+ if (les->type != G_MATH_SPARSE_LES)
+ return -1;
+
+ if (les->rows > row)
+ {
+ G_debug(
+ 5,
+ "Add sparse vector %p to the sparse linear equation system at row %i\n",
+ spvector, row);
+ les->Asp[row] = spvector;
+ }
+ else
+ return -1;
+
+ }
+ else
+ {
+ return -1;
+ }
+
+ return 1;
+}
+
+/*!
+ *
+ * \brief prints the linear equation system to stdout
+ *
+ * <p>
+ * Format:
+ * A*x = b
+ *
+ * <p>
+ * Example
+ \verbatim
+
+ 2 1 1 1 * 2 = 0.1
+ 1 2 0 0 * 3 = 0.2
+ 1 0 2 0 * 3 = 0.2
+ 1 0 0 2 * 2 = 0.1
+
+ \endverbatim
+ *
+ * \param les G_math_les *
+ * \return void
+ *
+ * */
+void G_math_print_les(G_math_les * les)
+{
+ int i, j, k, out;
+
+ if (les->type == G_MATH_SPARSE_LES)
+ {
+ for (i = 0; i < les->rows; i++)
+ {
+ for (j = 0; j < les->cols; j++)
+ {
+ out = 0;
+ for (k = 0; k < les->Asp[i]->cols; k++)
+ {
+ if (les->Asp[i]->index[k] == j)
+ {
+ fprintf(stdout, "%4.5f ", les->Asp[i]->values[k]);
+ out = 1;
+ }
+ }
+ if (!out)
+ fprintf(stdout, "%4.5f ", 0.0);
+ }
+ if (les->x)
+ fprintf(stdout, " * %4.5f", les->x[i]);
+ if (les->b)
+ fprintf(stdout, " = %4.5f ", les->b[i]);
+
+ fprintf(stdout, "\n");
+ }
+ }
+ else
+ {
+
+ for (i = 0; i < les->rows; i++)
+ {
+ for (j = 0; j < les->cols; j++)
+ {
+ fprintf(stdout, "%4.5f ", les->A[i][j]);
+ }
+ if (les->x)
+ fprintf(stdout, " * %4.5f", les->x[i]);
+ if (les->b)
+ fprintf(stdout, " = %4.5f ", les->b[i]);
+
+ fprintf(stdout, "\n");
+ }
+
+ }
+ return;
+}
+
+/*!
+ * \brief Release the memory of the linear equation system
+ *
+ * \param les G_math_les *
+ * \return void
+ *
+ * */
+
+void G_math_free_les(G_math_les * les)
+{
+ int i;
+
+ if (les->type == G_MATH_SPARSE_LES)
+ G_debug(2, "Releasing memory of a sparse linear equation system\n");
+ else
+ G_debug(2, "Releasing memory of a regular linear equation system\n");
+
+ if (les)
+ {
+
+ if (les->x)
+ G_free(les->x);
+ if (les->b)
+ G_free(les->b);
+
+ if (les->type == G_MATH_SPARSE_LES)
+ {
+
+ if (les->Asp)
+ {
+ for (i = 0; i < les->rows; i++)
+ if (les->Asp[i])
+ G_math_free_spvector(les->Asp[i]);
+
+ G_free(les->Asp);
+ }
+ }
+ else
+ {
+ /*We dont know if the rows have been changed by pivoting,
+ * so we restore the data pointer*/
+ les->A[0] = les->data;
+ G_free_matrix(les->A);
+ }
+
+ free(les);
+ }
+
+ return;
+}
+
+/*!
+ * \brief Release the memory of the float linear equation system
+ *
+ * \param les G_math_f_les *
+ * \return void
+ *
+ * */
+
+void G_math_free_f_les(G_math_f_les * les)
+{
+ G_debug(2, "Releasing memory of a regular float linear equation system\n");
+
+ if (les)
+ {
+
+ if (les->x)
+ G_free(les->x);
+ if (les->b)
+ G_free(les->b);
+
+ /*We dont know if the rows have been changed by pivoting,
+ * so we restore the data pointer*/
+ les->A[0] = les->data;
+ G_free_fmatrix(les->A);
+
+ free(les);
+ }
+
+ return;
+}
Modified: grass/trunk/lib/gpde/N_arrays.c
===================================================================
--- grass/trunk/lib/gpde/N_arrays.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_arrays.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -4,8 +4,8 @@
* MODULE: Grass PDE Numerical Library
* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: Array managment functions
+*
+* PURPOSE: Array managment functions
* part of the gpde library
*
* COPYRIGHT: (C) 2000 by the GRASS Development Team
@@ -26,21 +26,21 @@
/* ******************** 2D ARRAY FUNCTIONS *********************** */
/*!
- * \brief Allocate memory for a N_array_2d data structure.
+ * \brief Allocate memory for a N_array_2d data structure.
*
- * This function allocates memory for an array of type N_array_2d
+ * This function allocates memory for an array of type N_array_2d
* and returns the pointer to the new allocated memory.
* <br><br>
- * The data type of this array is set by "type" and must be
+ * The data type of this array is set by "type" and must be
* CELL_TYPE, FCELL_TYPE or DCELL_TYPE accordingly to the raster map data types.
- * The offset sets the number of boundary cols and rows.
- * This option is useful to generate homogeneous Neumann boundary conditions around
+ * The offset sets the number of boundary cols and rows.
+ * This option is useful to generate homogeneous Neumann boundary conditions around
* an array or to establish overlapping boundaries. The array is initialized with 0 by default.
* <br><br>
* If the offset is greater then 0, negative indices are possible.
* <br><br>
*
- * The data structure of a array with 3 rows and cols and an offset of 1
+ * The data structure of a array with 3 rows and cols and an offset of 1
* will looks like this:
* <br><br>
*
@@ -55,19 +55,19 @@
* 0 is the boundary.
* <br><br>
* Internal a one dimensional array is allocated to save memory and to speed up the memory access.
- * To access the one dimensional array with a two dimensional index use the provided
+ * To access the one dimensional array with a two dimensional index use the provided
* get and put functions. The internal representation of the above data will look like this:
*
\verbatim
- 0 0 0 0 0 0 0 1 2 0 0 3 4 5 0 0 6 7 8 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 1 2 0 0 3 4 5 0 0 6 7 8 0 0 0 0 0 0
\endverbatim
*
- * \param cols int
- * \param rows int
+ * \param cols int
+ * \param rows int
* \param offset int
* \param type int
* \return N_array_2d *
- *
+ *
* */
N_array_2d *N_alloc_array_2d(int cols, int rows, int offset, int type)
{
@@ -124,7 +124,7 @@
/*!
* \brief Release the memory of a N_array_2d structure
*
- * \param data N_array_2d *
+ * \param data N_array_2d *
* \return void
* */
void N_free_array_2d(N_array_2d * data)
@@ -158,7 +158,7 @@
*
* The data type can be CELL_TYPE, FCELL_TYPE or DCELL_TYPE accordingly to the raster map data types.
*
- * \param array N_array_2d *
+ * \param array N_array_2d *
* \return type int
* */
int N_get_array_2d_type(N_array_2d * array)
@@ -169,9 +169,9 @@
/*!
* \brief Write the value of the N_array_2d struct at position col, row to value
*
- * The value must be from the same type as the array. Otherwise you will risk data losses.
+ * The value must be from the same type as the array. Otherwise you will risk data losses.
*
- * \param data N_array_2d *
+ * \param data N_array_2d *
* \param col int
* \param row int
* \param value void * - this variable contains the array value at col, row position
@@ -217,13 +217,13 @@
}
/*!
- * \brief Returns 1 if the value of N_array_2d struct at postion col, row
- * is of type null, otherwise 0
+ * \brief Returns 1 if the value of N_array_2d struct at postion col, row
+ * is of type null, otherwise 0
*
* This function checks automatically the type of the array and checks for the
* data type null value.
*
- * \param data N_array_2d *
+ * \param data N_array_2d *
* \param col int
* \param row int
* \return int - 1 = is null, 0 otherwise
@@ -301,15 +301,15 @@
/*!
- * \brief Returns the value of type CELL at position col, row
+ * \brief Returns the value of type CELL at position col, row
*
* The data array can be of type CELL, FCELL or DCELL, the value will be casted to the CELL type.
*
- * \param data N_array_2d *
+ * \param data N_array_2d *
* \param col int
* \param row int
* \return CELL
- *
+ *
* */
CELL N_get_array_2d_c_value(N_array_2d * data, int col, int row)
{
@@ -333,11 +333,11 @@
}
/*!
- * \brief Returns the value of type FCELL at position col, row
- *
+ * \brief Returns the value of type FCELL at position col, row
+ *
* The data array can be of type CELL, FCELL or DCELL, the value will be casted to the FCELL type.
*
- * \param data N_array_2d *
+ * \param data N_array_2d *
* \param col int
* \param row int
* \return FCELL
@@ -365,15 +365,15 @@
}
/*!
- * \brief Returns the value of type DCELL at position col, row
+ * \brief Returns the value of type DCELL at position col, row
*
* The data array can be of type CELL, FCELL or DCELL, the value will be casted to the DCELL type.
- *
+ *
* \param data N_array_2d *
* \param col int
* \param row int
* \return DCELL
- *
+ *
* */
DCELL N_get_array_2d_d_value(N_array_2d * data, int col, int row)
{
@@ -515,7 +515,7 @@
/*!
* \brief Writes a CELL value to the N_array_2d struct at position col, row
*
- * \param data N_array_2d *
+ * \param data N_array_2d *
* \param col int
* \param row int
* \param value CELL
@@ -660,19 +660,19 @@
/* ******************** 3D ARRAY FUNCTIONS *********************** */
/*!
- * \brief Allocate memory for a N_array_3d data structure.
+ * \brief Allocate memory for a N_array_3d data structure.
*
- * This functions allocates an array of type N_array_3d and returns a pointer
+ * This functions allocates an array of type N_array_3d and returns a pointer
* to the new allocated memory.
* <br><br>
- * The data type of this array set by "type" must be
+ * The data type of this array set by "type" must be
* FCELL_TYPE or DCELL_TYPE accordingly to the raster3d map data types.
- * The offsets sets the number of boundary cols, rows and depths.
- * This option is useful to generate homogeneous Neumann boundary conditions around
+ * The offsets sets the number of boundary cols, rows and depths.
+ * This option is useful to generate homogeneous Neumann boundary conditions around
* an array or to establish overlapping boundaries. The arrays are initialized with 0 by default.
* <br><br>
* If the offset is greater then 0, negative indices are possible.
- * The data structure of a array with 3 depths, rows and cols and an offset of 1
+ * The data structure of a array with 3 depths, rows and cols and an offset of 1
* will looks like this:
*
\verbatim
@@ -712,16 +712,16 @@
* <br><br>
* Internal a one dimensional array is allocated to speed up the memory access.
- * To access the dimensional array with a three dimensional indexing use the provided
+ * To access the dimensional array with a three dimensional indexing use the provided
* get and put functions.
*
* \param cols int
* \param rows int
* \param depths int
- * \param offset int
+ * \param offset int
* \param type int
* \return N_array_3d *
- *
+ *
* */
N_array_3d *N_alloc_array_3d(int cols, int rows, int depths, int offset,
int type)
@@ -772,7 +772,7 @@
}
/*!
- * \brief Release the memory of a N_array_3d
+ * \brief Release the memory of a N_array_3d
*
* \param data N_array_3d *
* \return void
@@ -816,7 +816,7 @@
* \brief This function writes the value of N_array_3d data at position col, row, depth
* to the variable value
*
- * The value must be from the same type as the array. Otherwise you will risk data losses.
+ * The value must be from the same type as the array. Otherwise you will risk data losses.
*
* \param data N_array_3d *
* \param col int
@@ -1012,7 +1012,7 @@
*
* \param data N_array_3d *
* \param col int
- * \param row int
+ * \param row int
* \param depth int
* \param value cahr *
* \return void
@@ -1069,7 +1069,7 @@
*
* \param data N_array_3d *
* \param col int
- * \param row int
+ * \param row int
* \param depth int
* \return void
* */
Modified: grass/trunk/lib/gpde/N_gradient_calc.c
===================================================================
--- grass/trunk/lib/gpde/N_gradient_calc.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_gradient_calc.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -245,10 +245,15 @@
N_array_2d * y_comp)
{
int i, j;
+
int rows, cols;
+
double vx, vy;
+
N_array_2d *x = x_comp;
+
N_array_2d *y = y_comp;
+
N_gradient_2d grad;
@@ -300,8 +305,11 @@
void N_calc_gradient_field_3d_stats(N_gradient_field_3d * field)
{
double minx, miny, minz;
+
double maxx, maxy, maxz;
+
double sumx, sumy, sumz;
+
int nonullx, nonully, nonullz;
G_debug(3,
@@ -392,8 +400,11 @@
gradfield)
{
int i, j, k;
+
int cols, rows, depths;
+
double dx, dy, dz, p1, p2, r1, r2, mean, grad, res;
+
N_gradient_field_3d *field = gradfield;
@@ -582,11 +593,17 @@
N_array_3d * z_comp)
{
int i, j, k;
+
int rows, cols, depths;
+
double vx, vy, vz;
+
N_array_3d *x = x_comp;
+
N_array_3d *y = y_comp;
+
N_array_3d *z = z_comp;
+
N_gradient_3d grad;
Modified: grass/trunk/lib/gpde/N_heatflow.h
===================================================================
--- grass/trunk/lib/gpde/N_heatflow.h 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_heatflow.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -62,6 +62,8 @@
extern N_heatflow_data3d *N_alloc_heatflow_data3d(int depths, int rows,
int cols);
extern N_heatflow_data2d *N_alloc_heatflow_data2d(int rows, int cols);
+
extern void N_free_heatflow_data3d(N_heatflow_data3d * data);
+
extern void N_free_heatflow_data2d(N_heatflow_data2d * data);
#endif
Modified: grass/trunk/lib/gpde/N_les.c
===================================================================
--- grass/trunk/lib/gpde/N_les.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_les.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -17,30 +17,10 @@
*****************************************************************************/
#include "grass/N_pde.h"
+#include "grass/gmath.h"
#include <stdlib.h>
-/*!
- * \brief Allocate memory for a sparse vector
- *
- * \param cols int
- * \return N_spvector *
- *
- * */
-N_spvector *N_alloc_spvector(int cols)
-{
- N_spvector *spvector;
- G_debug(4, "Allocate memory for a sparse vector with %i cols\n", cols);
-
- spvector = (N_spvector *) G_calloc(1, sizeof(N_spvector));
-
- spvector->cols = cols;
- spvector->index = (int *)G_calloc(cols, sizeof(int));
- spvector->values = (double *)G_calloc(cols, sizeof(double));
-
- return spvector;
-}
-
/*!
* \brief Allocate memory for a (not) quadratic linear equation system which includes the Matrix A, vector x and vector b
*
@@ -198,6 +178,7 @@
N_les *N_alloc_les_param(int cols, int rows, int type, int parts)
{
N_les *les;
+
int i;
if (type == N_SPARSE_LES)
@@ -234,60 +215,19 @@
les->quad = 0;
if (type == N_SPARSE_LES) {
- les->Asp = (N_spvector **) G_calloc(rows, sizeof(N_spvector *));
+ les->Asp = G_math_alloc_spmatrix(rows);
les->type = N_SPARSE_LES;
}
else {
- les->A = (double **)G_calloc(rows, sizeof(double *));
- for (i = 0; i < rows; i++) {
- les->A[i] = (double *)G_calloc(cols, sizeof(double));
- }
+ les->A = G_alloc_matrix(rows, cols);
les->type = N_NORMAL_LES;
}
return les;
}
-
/*!
- * \brief Adds a sparse vector to a sparse linear equation system at position row
*
- * Return 1 for success and -1 for failure
- *
- * \param les N_les *
- * \param spvector N_spvector *
- * \param row int
- * \return int
- *
- * */
-int N_add_spvector_to_les(N_les * les, N_spvector * spvector, int row)
-{
-
-
- if (les != NULL) {
- if (les->type != N_SPARSE_LES)
- return -1;
-
- if (les->rows > row) {
- G_debug(5,
- "Add sparse vector %p to the sparse linear equation system at row %i\n",
- spvector, row);
- les->Asp[row] = spvector;
- }
- else
- return -1;
-
- }
- else {
- return -1;
- }
-
-
- return 1;
-}
-
-/*!
- *
* \brief prints the linear equation system to stdout
*
* <p>
@@ -354,29 +294,6 @@
}
/*!
- * \brief Release the memory of the sparse vector
- *
- * \param spvector N_spvector *
- * \return void
- *
- * */
-void N_free_spvector(N_spvector * spvector)
-{
- if (spvector) {
- if (spvector->values)
- G_free(spvector->values);
- if (spvector->index)
- G_free(spvector->index);
- G_free(spvector);
-
- spvector = NULL;
- }
-
- return;
-}
-
-
-/*!
* \brief Release the memory of the linear equation system
*
* \param les N_les *
@@ -386,8 +303,6 @@
void N_free_les(N_les * les)
{
- int i;
-
if (les->type == N_SPARSE_LES)
G_debug(2, "Releasing memory of a sparse linear equation system\n");
else
@@ -403,21 +318,13 @@
if (les->type == N_SPARSE_LES) {
if (les->Asp) {
- for (i = 0; i < les->rows; i++)
- if (les->Asp[i])
- N_free_spvector(les->Asp[i]);
-
- G_free(les->Asp);
+ G_math_free_spmatrix(les->Asp, les->rows);
}
}
else {
if (les->A) {
- for (i = 0; i < les->rows; i++)
- if (les->A[i])
- G_free(les->A[i]);
-
- G_free(les->A);
+ G_free_matrix(les->A);
}
}
Modified: grass/trunk/lib/gpde/N_les_assemble.c
===================================================================
--- grass/trunk/lib/gpde/N_les_assemble.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_les_assemble.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -23,15 +23,17 @@
/* local protos */
static int make_les_entry_2d(int i, int j, int offset_i, int offset_j,
int count, int pos, N_les * les,
- N_spvector * spvect, N_array_2d * cell_count,
- N_array_2d * status, N_array_2d * start_val,
- double entry, int cell_type);
+ G_math_spvector * spvect,
+ N_array_2d * cell_count, N_array_2d * status,
+ N_array_2d * start_val, double entry,
+ int cell_type);
static int make_les_entry_3d(int i, int j, int k, int offset_i, int offset_j,
int offset_k, int count, int pos, N_les * les,
- N_spvector * spvect, N_array_3d * cell_count,
- N_array_3d * status, N_array_3d * start_val,
- double entry, int cell_type);
+ G_math_spvector * spvect,
+ N_array_3d * cell_count, N_array_3d * status,
+ N_array_3d * start_val, double entry,
+ int cell_type);
/* *************************************************************** *
* ********************** N_alloc_5star ************************** *
@@ -658,11 +660,11 @@
N_data_star *items = call->callback(data, geom, i, j);
/* we need a sparse vector pointer anytime */
- N_spvector *spvect = NULL;
+ G_math_spvector *spvect = NULL;
/*allocate a sprase vector */
if (les_type == N_SPARSE_LES) {
- spvect = N_alloc_spvector(items->count);
+ spvect = G_math_alloc_spvector(items->count);
}
/* initial conditions */
les->x[count] = N_get_array_2d_d_value(start_val, i, j);
@@ -737,7 +739,7 @@
/*How many entries in the les */
if (les->type == N_SPARSE_LES) {
spvect->cols = pos + 1;
- N_add_spvector_to_les(les, spvect, count);
+ G_math_add_spvector(les->Asp, spvect, count);
}
if (items)
@@ -818,11 +820,11 @@
#pragma omp parallel default(shared)
{
- /*performe the matrix vector product */
+ /*performe the matrix vector product and */
if (les->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(les, dvect1, dvect2);
+ G_math_Ax_sparse(les->Asp, dvect1, dvect2, les->rows);
else
- N_matrix_vector_product(les, dvect1, dvect2);
+ G_math_d_Ax(les->A, dvect1, dvect2, les->rows, les->cols);
#pragma omp for schedule (static) private(i)
for (i = 0; i < les->cols; i++)
les->b[i] = les->b[i] - dvect2[i];
@@ -876,7 +878,7 @@
/* **** make an entry in the les (2d) ***************************** */
/* **************************************************************** */
int make_les_entry_2d(int i, int j, int offset_i, int offset_j, int count,
- int pos, N_les * les, N_spvector * spvect,
+ int pos, N_les * les, G_math_spvector * spvect,
N_array_2d * cell_count, N_array_2d * status,
N_array_2d * start_val, double entry, int cell_type)
{
@@ -1121,11 +1123,11 @@
/*create the entries for the */
N_data_star *items = call->callback(data, geom, i, j, k);
- N_spvector *spvect = NULL;
+ G_math_spvector *spvect = NULL;
/*allocate a sprase vector */
if (les_type == N_SPARSE_LES)
- spvect = N_alloc_spvector(items->count);
+ spvect = G_math_alloc_spvector(items->count);
/* initial conditions */
les->x[count] = N_get_array_3d_d_value(start_val, i, j, k);
@@ -1191,7 +1193,7 @@
/*How many entries in the les */
if (les->type == N_SPARSE_LES) {
spvect->cols = pos + 1;
- N_add_spvector_to_les(les, spvect, count);
+ G_math_add_spvector(les->Asp, spvect, count);
}
if (items)
@@ -1277,9 +1279,9 @@
{
/*performe the matrix vector product and */
if (les->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(les, dvect1, dvect2);
+ G_math_Ax_sparse(les->Asp, dvect1, dvect2, les->rows);
else
- N_matrix_vector_product(les, dvect1, dvect2);
+ G_math_d_Ax(les->A, dvect1, dvect2, les->rows, les->cols);
#pragma omp for schedule (static) private(i)
for (i = 0; i < les->cols; i++)
les->b[i] = les->b[i] - dvect2[i];
@@ -1335,7 +1337,7 @@
/* **************************************************************** */
int make_les_entry_3d(int i, int j, int k, int offset_i, int offset_j,
int offset_k, int count, int pos, N_les * les,
- N_spvector * spvect, N_array_3d * cell_count,
+ G_math_spvector * spvect, N_array_3d * cell_count,
N_array_3d * status, N_array_3d * start_val,
double entry, int cell_type)
{
@@ -1344,8 +1346,8 @@
int dj = offset_j;
int dk = offset_k;
- K = N_get_array_3d_d_value(cell_count, i + di, j + dj, k + dk) -
- N_get_array_3d_d_value(cell_count, i, j, k);
+ K = (int)N_get_array_3d_d_value(cell_count, i + di, j + dj, k + dk) -
+ (int)N_get_array_3d_d_value(cell_count, i, j, k);
if (cell_type == N_CELL_ACTIVE) {
if ((int)N_get_array_3d_d_value(status, i + di, j + dj, k + dk) >
Deleted: grass/trunk/lib/gpde/N_les_pivot.c
===================================================================
--- grass/trunk/lib/gpde/N_les_pivot.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_les_pivot.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,92 +0,0 @@
-
-/*****************************************************************************
-*
-* MODULE: Grass PDE Numerical Library
-* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
-* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: linear equation system pivoting strategy
-* part of the gpde library
-*
-* COPYRIGHT: (C) 2000 by the GRASS Development Team
-*
-* This program is free software under the GNU General Public
-* License (>=v2). Read the file COPYING that comes with GRASS
-* for details.
-*
-*****************************************************************************/
-
-#include <math.h>
-#include <unistd.h>
-#include <stdio.h>
-#include <string.h>
-#include "grass/N_pde.h"
-#include "solvers_local_proto.h"
-
-
-#define TINY 1.0e-20
-
-
-
-/*!
- * \brief Optimize the structure of the linear equation system with a common pivoting strategy
- *
- * Create a optimized linear equation system for
- * direct solvers: gauss and lu decomposition.
- *
- * The rows are permuted based on the pivot elements.
- *
- * This algorithm will modify the provided linear equation system
- * and should only be used with the gauss elimination and lu decomposition solver.
- *
- * \param les * N_les -- the linear equation system
- * \return int - the number of swapped rows
- *
- *
- * */
-int N_les_pivot_create(N_les * les)
-{
- int num = 0; /*number of changed rows */
- int i, j, k;
- double max;
- int number = 0;
- double tmpval = 0.0, s = 0.0;
- double *link = NULL;
-
- G_debug(2, "N_les_pivot_create: swap rows if needed");
- for (i = 0; i < les->rows; i++) {
- max = fabs(les->A[i][i]);
- number = i;
- for (j = i; j < les->rows; j++) {
- s = 0.0;
- for (k = i; k < les->rows; k++) {
- s += fabs(les->A[j][i]);
- }
- /*search for the pivot element */
- if (max < fabs(les->A[j][i]) / s) {
- max = fabs(les->A[j][i]);
- number = j;
- }
- }
- if (max == 0) {
- max = TINY;
- G_warning("Matrix is singular");
- }
- /*if an pivot element was found, swap the les entries */
- if (number != i) {
-
- G_debug(4, "swap row %i with row %i", i, number);
-
- tmpval = les->b[number];
- les->b[number] = les->b[i];
- les->b[i] = tmpval;
-
- link = les->A[number];
- les->A[number] = les->A[i];
- les->A[i] = link;
- num++;
- }
- }
-
- return num;
-}
Modified: grass/trunk/lib/gpde/N_parse_options.c
===================================================================
--- grass/trunk/lib/gpde/N_parse_options.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_parse_options.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -55,7 +55,7 @@
Opt->answer = "cg";
Opt->options = "gauss,lu,cholesky,jacobi,sor,cg,bicgstab,pcg";
Opt->description =
- _("The type of solver which should solve the symmetric linear equation system");
+ ("The type of solver which should solve the symmetric linear equation system");
break;
/*solver for unsymmetric linear equation systems */
case N_OPT_SOLVER_UNSYMM:
@@ -66,7 +66,7 @@
Opt->answer = "bicgstab";
Opt->options = "gauss,lu,jacobi,sor,bicgstab";
Opt->description =
- _("The type of solver which should solve the linear equation system");
+ ("The type of solver which should solve the linear equation system");
break;
case N_OPT_MAX_ITERATIONS:
Opt->key = "maxit";
@@ -74,7 +74,7 @@
Opt->required = NO;
Opt->answer = "100000";
Opt->description =
- _("Maximum number of iteration used to solver the linear equation system");
+ ("Maximum number of iteration used to solver the linear equation system");
break;
case N_OPT_ITERATION_ERROR:
Opt->key = "error";
@@ -82,7 +82,7 @@
Opt->required = NO;
Opt->answer = "0.0000000001";
Opt->description =
- _("Error break criteria for iterative solvers (jacobi, sor, cg or bicgstab)");
+ ("Error break criteria for iterative solvers (jacobi, sor, cg or bicgstab)");
break;
case N_OPT_SOR_VALUE:
Opt->key = "relax";
@@ -90,7 +90,7 @@
Opt->required = NO;
Opt->answer = "1";
Opt->description =
- _("The relaxation parameter used by the jacobi and sor solver for speedup or stabilizing");
+ ("The relaxation parameter used by the jacobi and sor solver for speedup or stabilizing");
break;
case N_OPT_CALC_TIME:
Opt->key = "dt";
Modified: grass/trunk/lib/gpde/N_pde.h
===================================================================
--- grass/trunk/lib/gpde/N_pde.h 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_pde.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -16,32 +16,18 @@
*****************************************************************************/
#include <grass/gis.h>
-#include <grass/raster.h>
#include <grass/G3d.h>
#include <grass/glocale.h>
+#include <grass/gmath.h>
#ifndef _N_PDE_H_
#define _N_PDE_H_
-/*solver names */
-#define N_SOLVER_DIRECT_GAUSS "gauss"
-#define N_SOLVER_DIRECT_LU "lu"
-#define N_SOLVER_DIRECT_CHOLESKY "cholesky"
-#define N_SOLVER_ITERATIVE_JACOBI "jacobi"
-#define N_SOLVER_ITERATIVE_SOR "sor"
-#define N_SOLVER_ITERATIVE_CG "cg"
-#define N_SOLVER_ITERATIVE_PCG "pcg"
-#define N_SOLVER_ITERATIVE_BICGSTAB "bicgstab"
-
-/*preconditioner */
-#define N_DIAGONAL_PRECONDITION 1
-#define N_ROWSCALE_ABSSUMNORM_PRECONDITION 2
-#define N_ROWSCALE_EUKLIDNORM_PRECONDITION 3
-#define N_ROWSCALE_MAXNORM_PRECONDITION 4
-
#define N_NORMAL_LES 0
#define N_SPARSE_LES 1
-
+/*!
+ * Boundary conditions for cells
+ */
#define N_CELL_INACTIVE 0
#define N_CELL_ACTIVE 1
#define N_CELL_DIRICHLET 2
@@ -75,17 +61,6 @@
/* *************************************************************** */
/*!
- * \brief The row vector of the sparse matrix
- * */
-typedef struct
-{
- int cols; /*Number of entries */
- double *values; /*The non null values of the row */
- int *index; /*the index number */
-} N_spvector;
-
-
-/*!
* \brief The linear equation system (les) structure
*
* This structure manages the Ax = b system.
@@ -99,14 +74,13 @@
double *x; /*the value vector */
double *b; /*the right side of Ax = b */
double **A; /*the normal quadratic matrix */
- N_spvector **Asp; /*the sparse matrix */
+ G_math_spvector **Asp; /*the sparse matrix */
int rows; /*number of rows */
int cols; /*number of cols */
int quad; /*is the matrix quadratic (1-quadratic, 0 not) */
int type; /*the type of the les, normal == 0, sparse == 1 */
} N_les;
-extern N_spvector *N_alloc_spvector(int cols);
extern N_les *N_alloc_les_param(int cols, int rows, int type, int param);
extern N_les *N_alloc_les(int rows, int type);
extern N_les *N_alloc_les_A(int rows, int type);
@@ -117,8 +91,6 @@
extern N_les *N_alloc_nquad_les_Ax(int cols, int rows, int type);
extern N_les *N_alloc_nquad_les_Ax_b(int cols, int rows, int type);
extern void N_print_les(N_les * les);
-extern int N_add_spvector_to_les(N_les * les, N_spvector * vector, int row);
-extern void N_free_spvector(N_spvector * vector);
extern void N_free_les(N_les * les);
/* *************************************************************** */
@@ -148,31 +120,11 @@
extern N_geom_data *N_alloc_geom_data(void);
extern void N_free_geom_data(N_geom_data * geodata);
-extern N_geom_data *N_init_geom_data_3d(G3D_Region * region3d,
- N_geom_data * geodata);
-extern N_geom_data *N_init_geom_data_2d(struct Cell_head *region,
- N_geom_data * geodata);
+extern N_geom_data *N_init_geom_data_3d(G3D_Region * region3d, N_geom_data * geodata);
+extern N_geom_data *N_init_geom_data_2d(struct Cell_head *region, N_geom_data * geodata);
extern double N_get_geom_data_area_of_cell(N_geom_data * geom, int row);
-
/* *************************************************************** */
-/* *************** LINEARE EQUATION SOLVER PART ****************** */
-/* *************************************************************** */
-extern int N_solver_gauss(N_les * les);
-extern int N_solver_lu(N_les * les);
-extern int N_solver_cholesky(N_les * les);
-extern int N_solver_jacobi(N_les * L, int maxit, double sor, double error);
-extern int N_solver_SOR(N_les * L, int maxit, double sor, double error);
-extern int N_solver_cg(N_les * les, int maxit, double error);
-extern int N_solver_pcg(N_les * les, int maxit, double error, int prec);
-extern int N_solver_bicgstab(N_les * les, int maxit, double error);
-extern void N_matrix_vector_product(N_les * les, double *source,
- double *result);
-extern void N_sparse_matrix_vector_product(N_les * les, double *source,
- double *result);
-extern N_les *N_create_diag_precond_matrix(N_les * les, int prec);
-
-/* *************************************************************** */
/* *************** READING RASTER AND VOLUME DATA **************** */
/* *************************************************************** */
@@ -190,33 +142,25 @@
extern N_array_2d *N_alloc_array_2d(int cols, int rows, int offset, int type);
extern void N_free_array_2d(N_array_2d * data_array);
extern int N_get_array_2d_type(N_array_2d * array2d);
-extern void N_get_array_2d_value(N_array_2d * array2d, int col, int row,
- void *value);
+extern void N_get_array_2d_value(N_array_2d * array2d, int col, int row, void *value);
extern CELL N_get_array_2d_c_value(N_array_2d * array2d, int col, int row);
extern FCELL N_get_array_2d_f_value(N_array_2d * array2d, int col, int row);
extern DCELL N_get_array_2d_d_value(N_array_2d * array2d, int col, int row);
-extern void N_put_array_2d_value(N_array_2d * array2d, int col, int row,
- char *value);
-extern void N_put_array_2d_c_value(N_array_2d * array2d, int col, int row,
- CELL value);
-extern void N_put_array_2d_f_value(N_array_2d * array2d, int col, int row,
- FCELL value);
-extern void N_put_array_2d_d_value(N_array_2d * array2d, int col, int row,
- DCELL value);
-extern int N_is_array_2d_value_null(N_array_2d * array2d, int col, int row);
+extern void N_put_array_2d_value(N_array_2d * array2d, int col, int row, char *value);
+extern void N_put_array_2d_c_value(N_array_2d * array2d, int col, int row, CELL value);
+extern void N_put_array_2d_f_value(N_array_2d * array2d, int col, int row, FCELL value);
+extern void N_put_array_2d_d_value(N_array_2d * array2d, int col, int row, DCELL value);
+extern int N_is_array_2d_value_null(N_array_2d * array2d, int col, int row);
extern void N_put_array_2d_value_null(N_array_2d * array2d, int col, int row);
extern void N_print_array_2d(N_array_2d * data);
extern void N_print_array_2d_info(N_array_2d * data);
extern void N_copy_array_2d(N_array_2d * source, N_array_2d * target);
-extern double N_norm_array_2d(N_array_2d * array1, N_array_2d * array2,
- int type);
-extern N_array_2d *N_math_array_2d(N_array_2d * array1, N_array_2d * array2,
- N_array_2d * result, int type);
+extern double N_norm_array_2d(N_array_2d * array1, N_array_2d * array2, int type);
+extern N_array_2d *N_math_array_2d(N_array_2d * array1, N_array_2d * array2, N_array_2d * result, int type);
extern int N_convert_array_2d_null_to_zero(N_array_2d * a);
extern N_array_2d *N_read_rast_to_array_2d(char *name, N_array_2d * array);
extern void N_write_array_2d_to_rast(N_array_2d * array, char *name);
-extern void N_calc_array_2d_stats(N_array_2d * a, double *min, double *max,
- double *sum, int *nonzero, int withoffset);
+extern void N_calc_array_2d_stats(N_array_2d * a, double *min, double *max, double *sum, int *nonzero, int withoffset);
typedef struct
{
@@ -228,40 +172,26 @@
double *dcell_array; /*The data is stored in an one dimensional array internally */
} N_array_3d;
-extern N_array_3d *N_alloc_array_3d(int cols, int rows, int depths,
- int offset, int type);
+extern N_array_3d *N_alloc_array_3d(int cols, int rows, int depths, int offset, int type);
extern void N_free_array_3d(N_array_3d * data_array);
extern int N_get_array_3d_type(N_array_3d * array3d);
-extern void N_get_array_3d_value(N_array_3d * array3d, int col, int row,
- int depth, void *value);
-extern float N_get_array_3d_f_value(N_array_3d * array3d, int col, int row,
- int depth);
-extern double N_get_array_3d_d_value(N_array_3d * array3d, int col, int row,
- int depth);
-extern void N_put_array_3d_value(N_array_3d * array3d, int col, int row,
- int depth, char *value);
-extern void N_put_array_3d_f_value(N_array_3d * array3d, int col, int row,
- int depth, float value);
-extern void N_put_array_3d_d_value(N_array_3d * array3d, int col, int row,
- int depth, double value);
-extern int N_is_array_3d_value_null(N_array_3d * array3d, int col, int row,
- int depth);
-extern void N_put_array_3d_value_null(N_array_3d * array3d, int col, int row,
- int depth);
+extern void N_get_array_3d_value(N_array_3d * array3d, int col, int row, int depth, void *value);
+extern float N_get_array_3d_f_value(N_array_3d * array3d, int col, int row, int depth);
+extern double N_get_array_3d_d_value(N_array_3d * array3d, int col, int row, int depth);
+extern void N_put_array_3d_value(N_array_3d * array3d, int col, int row, int depth, char *value);
+extern void N_put_array_3d_f_value(N_array_3d * array3d, int col, int row, int depth, float value);
+extern void N_put_array_3d_d_value(N_array_3d * array3d, int col, int row, int depth, double value);
+extern int N_is_array_3d_value_null(N_array_3d * array3d, int col, int row, int depth);
+extern void N_put_array_3d_value_null(N_array_3d * array3d, int col, int row, int depth);
extern void N_print_array_3d(N_array_3d * data);
extern void N_print_array_3d_info(N_array_3d * data);
extern void N_copy_array_3d(N_array_3d * source, N_array_3d * target);
-extern double N_norm_array_3d(N_array_3d * array1, N_array_3d * array2,
- int type);
-extern N_array_3d *N_math_array_3d(N_array_3d * array1, N_array_3d * array2,
- N_array_3d * result, int type);
+extern double N_norm_array_3d(N_array_3d * array1, N_array_3d * array2, int type);
+extern N_array_3d *N_math_array_3d(N_array_3d * array1, N_array_3d * array2, N_array_3d * result, int type);
extern int N_convert_array_3d_null_to_zero(N_array_3d * a);
-extern N_array_3d *N_read_rast3d_to_array_3d(char *name, N_array_3d * array,
- int mask);
-extern void N_write_array_3d_to_rast3d(N_array_3d * array, char *name,
- int mask);
-extern void N_calc_array_3d_stats(N_array_3d * a, double *min, double *max,
- double *sum, int *nonzero, int withoffset);
+extern N_array_3d *N_read_rast3d_to_array_3d(char *name, N_array_3d * array, int mask);
+extern void N_write_array_3d_to_rast3d(N_array_3d * array, char *name, int mask);
+extern void N_calc_array_3d_stats(N_array_3d * a, double *min, double *max, double *sum, int *nonzero, int withoffset);
/* *************************************************************** */
/* *************** MATRIX ASSEMBLING METHODS ********************* */
@@ -367,10 +297,8 @@
} N_les_callback_2d;
-extern void N_set_les_callback_3d_func(N_les_callback_3d * data,
- N_data_star * (*callback_func_3d) ());
-extern void N_set_les_callback_2d_func(N_les_callback_2d * data,
- N_data_star * (*callback_func_2d) ());
+extern void N_set_les_callback_3d_func(N_les_callback_3d * data, N_data_star * (*callback_func_3d) ());
+extern void N_set_les_callback_2d_func(N_les_callback_2d * data, N_data_star * (*callback_func_2d) ());
extern N_les_callback_3d *N_alloc_les_callback_3d(void);
extern N_les_callback_2d *N_alloc_les_callback_2d(void);
extern N_data_star *N_alloc_5star(void);
@@ -393,49 +321,19 @@
double E_B, double N_B, double S_B,
double NW_B, double SW_B, double NE_B,
double SE_B, double V);
-
-extern N_data_star *N_callback_template_3d(void *data, N_geom_data * geom,
- int col, int row, int depth);
-extern N_data_star *N_callback_template_2d(void *data, N_geom_data * geom,
- int col, int row);
-extern N_les *N_assemble_les_3d(int les_type, N_geom_data * geom,
- N_array_3d * status, N_array_3d * start_val,
- void *data, N_les_callback_3d * callback);
-extern N_les *N_assemble_les_3d_active(int les_type, N_geom_data * geom,
- N_array_3d * status,
- N_array_3d * start_val, void *data,
- N_les_callback_3d * callback);
-extern N_les *N_assemble_les_3d_dirichlet(int les_type, N_geom_data * geom,
- N_array_3d * status,
- N_array_3d * start_val, void *data,
- N_les_callback_3d * callback);
-extern N_les *N_assemble_les_3d_param(int les_type, N_geom_data * geom,
- N_array_3d * status,
- N_array_3d * start_val, void *data,
- N_les_callback_3d * callback,
- int cell_type);
-extern N_les *N_assemble_les_2d(int les_type, N_geom_data * geom,
- N_array_2d * status, N_array_2d * start_val,
- void *data, N_les_callback_2d * callback);
-extern N_les *N_assemble_les_2d_active(int les_type, N_geom_data * geom,
- N_array_2d * status,
- N_array_2d * start_val, void *data,
- N_les_callback_2d * callback);
-extern N_les *N_assemble_les_2d_dirichlet(int les_type, N_geom_data * geom,
- N_array_2d * status,
- N_array_2d * start_val, void *data,
- N_les_callback_2d * callback);
-extern N_les *N_assemble_les_2d_param(int les_type, N_geom_data * geom,
- N_array_2d * status,
- N_array_2d * start_val, void *data,
- N_les_callback_2d * callback,
- int cell_Type);
-
+extern N_data_star *N_callback_template_3d(void *data, N_geom_data * geom, int col, int row, int depth);
+extern N_data_star *N_callback_template_2d(void *data, N_geom_data * geom, int col, int row);
+extern N_les *N_assemble_les_3d(int les_type, N_geom_data * geom, N_array_3d * status, N_array_3d * start_val, void *data, N_les_callback_3d * callback);
+extern N_les *N_assemble_les_3d_active(int les_type, N_geom_data * geom, N_array_3d * status, N_array_3d * start_val, void *data, N_les_callback_3d * callback);
+extern N_les *N_assemble_les_3d_dirichlet(int les_type, N_geom_data * geom, N_array_3d * status, N_array_3d * start_val, void *data, N_les_callback_3d * callback);
+extern N_les *N_assemble_les_3d_param(int les_type, N_geom_data * geom, N_array_3d * status, N_array_3d * start_val, void *data, N_les_callback_3d * callback, int cell_type);
+extern N_les *N_assemble_les_2d(int les_type, N_geom_data * geom, N_array_2d * status, N_array_2d * start_val, void *data, N_les_callback_2d * callback);
+extern N_les *N_assemble_les_2d_active(int les_type, N_geom_data * geom, N_array_2d * status, N_array_2d * start_val, void *data, N_les_callback_2d * callback);
+extern N_les *N_assemble_les_2d_dirichlet(int les_type, N_geom_data * geom, N_array_2d * status, N_array_2d * start_val, void *data, N_les_callback_2d * callback);
+extern N_les *N_assemble_les_2d_param(int les_type, N_geom_data * geom, N_array_2d * status, N_array_2d * start_val, void *data, N_les_callback_2d * callback, int cell_Type);
extern int N_les_pivot_create(N_les * les);
-int N_les_integrate_dirichlet_2d(N_les * les, N_geom_data * geom,
- N_array_2d * status, N_array_2d * start_val);
-int N_les_integrate_dirichlet_3d(N_les * les, N_geom_data * geom,
- N_array_3d * status, N_array_3d * start_val);
+int N_les_integrate_dirichlet_2d(N_les * les, N_geom_data * geom, N_array_2d * status, N_array_2d * start_val);
+int N_les_integrate_dirichlet_3d(N_les * les, N_geom_data * geom, N_array_3d * status, N_array_3d * start_val);
/* *************************************************************** */
/* *************** GPDE STANDARD OPTIONS ************************* */
@@ -646,22 +544,14 @@
extern N_gradient_2d *N_alloc_gradient_2d(void);
extern void N_free_gradient_2d(N_gradient_2d * grad);
-extern N_gradient_2d *N_create_gradient_2d(double NC, double SC, double WC,
- double EC);
+extern N_gradient_2d *N_create_gradient_2d(double NC, double SC, double WC, double EC);
extern int N_copy_gradient_2d(N_gradient_2d * source, N_gradient_2d * target);
-extern N_gradient_2d *N_get_gradient_2d(N_gradient_field_2d * field,
- N_gradient_2d * gradient, int col,
- int row);
-
+extern N_gradient_2d *N_get_gradient_2d(N_gradient_field_2d * field, N_gradient_2d * gradient, int col, int row);
extern N_gradient_3d *N_alloc_gradient_3d(void);
extern void N_free_gradient_3d(N_gradient_3d * grad);
-extern N_gradient_3d *N_create_gradient_3d(double NC, double SC, double WC,
- double EC, double TC, double BC);
+extern N_gradient_3d *N_create_gradient_3d(double NC, double SC, double WC, double EC, double TC, double BC);
extern int N_copy_gradient_3d(N_gradient_3d * source, N_gradient_3d * target);
-extern N_gradient_3d *N_get_gradient_3d(N_gradient_field_3d * field,
- N_gradient_3d * gradient, int col,
- int row, int depth);
-
+extern N_gradient_3d *N_get_gradient_3d(N_gradient_field_3d * field, N_gradient_3d * gradient, int col, int row, int depth);
extern N_gradient_neighbours_x *N_alloc_gradient_neighbours_x(void);
extern void N_free_gradient_neighbours_x(N_gradient_neighbours_x * grad);
extern N_gradient_neighbours_x *N_create_gradient_neighbours_x(double NWN,
@@ -670,9 +560,7 @@
double EC,
double SWS,
double SES);
-extern int N_copy_gradient_neighbours_x(N_gradient_neighbours_x * source,
- N_gradient_neighbours_x * target);
-
+extern int N_copy_gradient_neighbours_x(N_gradient_neighbours_x * source, N_gradient_neighbours_x * target);
extern N_gradient_neighbours_y *N_alloc_gradient_neighbours_y(void);
extern void N_free_gradient_neighbours_y(N_gradient_neighbours_y * grad);
extern N_gradient_neighbours_y *N_create_gradient_neighbours_y(double NWW,
@@ -681,9 +569,7 @@
double SC,
double SWW,
double SEE);
-extern int N_copy_gradient_neighbours_y(N_gradient_neighbours_y * source,
- N_gradient_neighbours_y * target);
-
+extern int N_copy_gradient_neighbours_y(N_gradient_neighbours_y * source, N_gradient_neighbours_y * target);
extern N_gradient_neighbours_z *N_alloc_gradient_neighbours_z(void);
extern void N_free_gradient_neighbours_z(N_gradient_neighbours_z * grad);
extern N_gradient_neighbours_z *N_create_gradient_neighbours_z(double NWZ,
@@ -695,62 +581,41 @@
double SWZ,
double SZ,
double SEZ);
-extern int N_copy_gradient_neighbours_z(N_gradient_neighbours_z * source,
- N_gradient_neighbours_z * target);
-
+extern int N_copy_gradient_neighbours_z(N_gradient_neighbours_z * source, N_gradient_neighbours_z * target);
extern N_gradient_neighbours_2d *N_alloc_gradient_neighbours_2d(void);
extern void N_free_gradient_neighbours_2d(N_gradient_neighbours_2d * grad);
-extern N_gradient_neighbours_2d
- *N_create_gradient_neighbours_2d(N_gradient_neighbours_x * x,
- N_gradient_neighbours_y * y);
-extern int N_copy_gradient_neighbours_2d(N_gradient_neighbours_2d * source,
- N_gradient_neighbours_2d * target);
-extern N_gradient_neighbours_2d
- *N_get_gradient_neighbours_2d(N_gradient_field_2d * field,
- N_gradient_neighbours_2d * gradient,
- int col, int row);
-
-
+extern N_gradient_neighbours_2d * N_create_gradient_neighbours_2d(N_gradient_neighbours_x * x, N_gradient_neighbours_y * y);
+extern int N_copy_gradient_neighbours_2d(N_gradient_neighbours_2d * source, N_gradient_neighbours_2d * target);
+extern N_gradient_neighbours_2d * N_get_gradient_neighbours_2d(N_gradient_field_2d * field, N_gradient_neighbours_2d * gradient, int col, int row);
extern N_gradient_neighbours_3d *N_alloc_gradient_neighbours_3d(void);
extern void N_free_gradient_neighbours_3d(N_gradient_neighbours_3d * grad);
extern N_gradient_neighbours_3d
- *N_create_gradient_neighbours_3d(N_gradient_neighbours_x * xt,
- N_gradient_neighbours_x * xc,
- N_gradient_neighbours_x * xb,
- N_gradient_neighbours_y * yt,
- N_gradient_neighbours_y * yc,
- N_gradient_neighbours_y * yb,
- N_gradient_neighbours_z * zt,
- N_gradient_neighbours_z * zb);
-extern int N_copy_gradient_neighbours_3d(N_gradient_neighbours_3d * source,
- N_gradient_neighbours_3d * target);
-
+ * N_create_gradient_neighbours_3d(N_gradient_neighbours_x * xt,
+ N_gradient_neighbours_x * xc,
+ N_gradient_neighbours_x * xb,
+ N_gradient_neighbours_y * yt,
+ N_gradient_neighbours_y * yc,
+ N_gradient_neighbours_y * yb,
+ N_gradient_neighbours_z * zt,
+ N_gradient_neighbours_z * zb);
+extern int N_copy_gradient_neighbours_3d(N_gradient_neighbours_3d * source, N_gradient_neighbours_3d * target);
extern void N_print_gradient_field_2d_info(N_gradient_field_2d * field);
extern void N_calc_gradient_field_2d_stats(N_gradient_field_2d * field);
-
-
extern N_gradient_field_2d *N_alloc_gradient_field_2d(int cols, int rows);
extern void N_free_gradient_field_2d(N_gradient_field_2d * field);
-extern int N_copy_gradient_field_2d(N_gradient_field_2d * source,
- N_gradient_field_2d * target);
+extern int N_copy_gradient_field_2d(N_gradient_field_2d * source, N_gradient_field_2d * target);
extern N_gradient_field_2d *N_compute_gradient_field_2d(N_array_2d * pot,
N_array_2d * weight_x,
N_array_2d * weight_y,
N_geom_data * geom,
N_gradient_field_2d *
gradfield);
-extern void N_compute_gradient_field_components_2d(N_gradient_field_2d *
- field, N_array_2d * x_comp,
- N_array_2d * y_comp);
-
+extern void N_compute_gradient_field_components_2d(N_gradient_field_2d * field, N_array_2d * x_comp, N_array_2d * y_comp);
extern void N_print_gradient_field_3d_info(N_gradient_field_3d * field);
extern void N_calc_gradient_field_3d_stats(N_gradient_field_3d * field);
-
-extern N_gradient_field_3d *N_alloc_gradient_field_3d(int cols, int rows,
- int depths);
+extern N_gradient_field_3d *N_alloc_gradient_field_3d(int cols, int rows, int depths);
extern void N_free_gradient_field_3d(N_gradient_field_3d * field);
-extern int N_copy_gradient_field_3d(N_gradient_field_3d * source,
- N_gradient_field_3d * target);
+extern int N_copy_gradient_field_3d(N_gradient_field_3d * source, N_gradient_field_3d * target);
extern N_gradient_field_3d *N_compute_gradient_field_3d(N_array_3d * pot,
N_array_3d * weight_x,
N_array_3d * weight_y,
@@ -758,9 +623,6 @@
N_geom_data * geom,
N_gradient_field_3d *
gradfield);
-extern void N_compute_gradient_field_components_3d(N_gradient_field_3d *
- field, N_array_3d * x_comp,
- N_array_3d * y_comp,
- N_array_3d * z_comp);
+extern void N_compute_gradient_field_components_3d(N_gradient_field_3d * field, N_array_3d * x_comp, N_array_3d * y_comp, N_array_3d * z_comp);
#endif
Deleted: grass/trunk/lib/gpde/N_solvers.c
===================================================================
--- grass/trunk/lib/gpde/N_solvers.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_solvers.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,429 +0,0 @@
-
-/*****************************************************************************
-*
-* MODULE: Grass PDE Numerical Library
-* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
-* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: direkt linear equation system solvers
-* part of the gpde library
-*
-* COPYRIGHT: (C) 2000 by the GRASS Development Team
-*
-* This program is free software under the GNU General Public
-* License (>=v2). Read the file COPYING that comes with GRASS
-* for details.
-*
-*****************************************************************************/
-
-#include <math.h>
-#include <unistd.h>
-#include <stdio.h>
-#include <string.h>
-#include "grass/N_pde.h"
-#include "solvers_local_proto.h"
-
-/*prototypes */
-static void gauss_elimination(double **A, double *b, int rows);
-static void lu_decomposition(double **A, int rows);
-static int cholesky_decomposition(double **A, int rows);
-static void backward_solving(double **A, double *x, double *b, int rows);
-static void forward_solving(double **A, double *x, double *b, int rows);
-
-/***********************************************************
- * GAUSS elimination solver for Ax = b *********************
- * ********************************************************/
-/*!
- * \brief The gauss elimination solver for quardatic matrices
- *
- * This solver does not support sparse matrices
- * The matrix A will be overwritten.
- * The result is written to the vector x in the N_les structure
- *
- * \param les N_les *
- * \return int -- 1 success, 0 solver does not work with sprase matrices, -1 matrix is not quadratic, -2 unable to solve the les
- * */
-int N_solver_gauss(N_les * les)
-{
-
- if (les->type != N_NORMAL_LES) {
- G_warning(_("The gauss elimination solver does not work with sparse matrices"));
- return 0;
- }
-
- if (les->quad != 1) {
- G_fatal_error(_("The linear equation system is not quadratic"));
- return 0;
- }
-
-
- G_message(_("Starting direct gauss elimination solver"));
-
- N_les_pivot_create(les);
- gauss_elimination(les->A, les->b, les->rows);
- backward_solving(les->A, les->x, les->b, les->rows);
-
- return 1;
-}
-
-/***********************************************************
- * LU solver for Ax = b ************************************
- * ********************************************************/
-/*!
- * \brief The LU solver for quardatic matrices
- *
- * This solver does not support sparse matrices
- * The matrix A will be overwritten.
- * The result is written to the vector x in the N_les structure
- *
- * \param les N_les *
- * \return int -- 1 success, 0 solver does not work with sprase matrices, -1 matrix is not quadratic, -2 unable to solve the les
- * */
-int N_solver_lu(N_les * les)
-{
- int i;
- double *c, *tmpv;
-
- if (les->type != N_NORMAL_LES) {
- G_warning(_("The lu solver does not work with sparse matrices"));
- return 0;
- }
-
- if (les->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
-
- G_message(_("Starting direct lu decomposition solver"));
-
- tmpv = vectmem(les->rows);
- c = vectmem(les->rows);
-
- N_les_pivot_create(les);
- lu_decomposition(les->A, les->rows);
-
-#pragma omp parallel
- {
-
-#pragma omp for schedule (static) private(i)
- for (i = 0; i < les->rows; i++) {
- tmpv[i] = les->A[i][i];
- les->A[i][i] = 1;
- }
-
-#pragma omp single
- {
- forward_solving(les->A, les->b, les->b, les->rows);
- }
-
-#pragma omp for schedule (static) private(i)
- for (i = 0; i < les->rows; i++) {
- les->A[i][i] = tmpv[i];
- }
-
-#pragma omp single
- {
- backward_solving(les->A, les->x, les->b, les->rows);
- }
- }
-
- G_free(c);
- G_free(tmpv);
-
-
- return 1;
-}
-
-/***********************************************************
- * cholesky solver for Ax = b ******************************
- * ********************************************************/
-/*!
- * \brief The choleksy decomposition solver for quardatic, symmetric
- * positiv definite matrices
- *
- * This solver does not support sparse matrices
- * The matrix A will be overwritten.
- * The result is written to the vector x in the N_les structure
- *
- * \param les N_les *
- * \return int -- 1 success, 0 solver does not work with sprase matrices, -1 matrix is not quadratic, -2 unable to solve the les, -3 matrix is not symmetric
- * */
-int N_solver_cholesky(N_les * les)
-{
- if (les->type != N_NORMAL_LES) {
- G_warning(_("The cholesky solver does not work with sparse matrices"));
- return 0;
- }
-
- if (les->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
- /* check for symmetry */
- if (check_symmetry(les) != 1) {
- G_warning(_("Matrix is not symmetric!"));
- return -3;
- }
-
- G_message(_("Starting cholesky decomposition solver"));
-
- if (cholesky_decomposition(les->A, les->rows) != 1) {
- G_warning(_("Unable to solve the linear equation system"));
- return -2;
- }
-
- forward_solving(les->A, les->b, les->b, les->rows);
- backward_solving(les->A, les->x, les->b, les->rows);
-
- return 1;
-}
-
-
-/***********************************************************
- * gauss elimination ***************************************
- * ********************************************************/
-/*!
- * \brief Gauss elimination
- *
- * The matrix will be overwritten with the decomposite form
- *
- * \param A double **
- * \param b double *
- * \param rows int
- * \return void
- *
- * */
-void gauss_elimination(double **A, double *b, int rows)
-{
- int i, j, k;
- double tmpval = 0.0;
-
- for (k = 0; k < rows - 1; k++) {
-#pragma omp parallel for schedule (static) private(i, j, tmpval) shared(k, A, b, rows)
- for (i = k + 1; i < rows; i++) {
- tmpval = A[i][k] / A[k][k];
- b[i] = b[i] - tmpval * b[k];
- for (j = k + 1; j < rows; j++) {
- A[i][j] = A[i][j] - tmpval * A[k][j];
- }
- }
- }
-
- return;
-}
-
-/***********************************************************
- * lu decomposition ****************************************
- * ********************************************************/
-/*!
- * \brief lu decomposition
- *
- * The matrix will be overwritten with the decomposite form
- *
- * \param A double **
- * \param rows int
- * \return void
- *
- * */
-void lu_decomposition(double **A, int rows)
-{
-
- int i, j, k;
-
- for (k = 0; k < rows - 1; k++) {
-#pragma omp parallel for schedule (static) private(i, j) shared(k, A, rows)
- for (i = k + 1; i < rows; i++) {
- A[i][k] = A[i][k] / A[k][k];
- for (j = k + 1; j < rows; j++) {
- A[i][j] = A[i][j] - A[i][k] * A[k][j];
- }
- }
- }
-
- return;
-}
-
-/***********************************************************
- * cholesky decomposition **********************************
- * ********************************************************/
-/*!
- * \brief cholesky decomposition for symmetric, positiv definite matrices
- *
- * The provided matrix will be overwritten with the lower and
- * upper triangle matrix A = LL^T
- *
- * \param A double **
- * \param rows int
- * \return void
- *
- * */
-int cholesky_decomposition(double **A, int rows)
-{
-
- int i, j, k;
- double sum_1 = 0.0;
- double sum_2 = 0.0;
- int error = 0;
-
-
- for (k = 0; k < rows; k++) {
-#pragma omp parallel private(i, j, sum_2) shared(A, rows, sum_1)
- {
-#pragma omp for schedule (static) private(j) reduction(+:sum_1)
- for (j = 0; j < k; j++) {
- sum_1 += A[k][j] * A[k][j];
- }
-#pragma omp single
- {
- if ((A[k][k] - sum_1) < 0) {
- error++; /*not allowed to exit the OpenMP region */
- }
- A[k][k] = sqrt(A[k][k] - sum_1);
- sum_1 = 0.0;
- }
-#pragma omp for schedule (static) private(i, j, sum_2)
- for (i = k + 1; i < rows; i++) {
- sum_2 = 0.0;
- for (j = 0; j < k; j++) {
- sum_2 += A[i][j] * A[k][j];
- }
- A[i][k] = (A[i][k] - sum_2) / A[k][k];
- }
- }
- }
-
- /*we need to copy the lower triangle matrix to the upper trianle */
-#pragma omp parallel for schedule (static) private(i, k) shared(A, rows)
- for (k = 0; k < rows; k++) {
- for (i = k + 1; i < rows; i++) {
- A[k][i] = A[i][k];
- }
- }
-
- if (error > 0) {
- G_warning("Matrix is not positive definite");
- return -1;
- }
-
- return 1;
-}
-
-
-/***********************************************************
- * backward solving ****************************************
- * ********************************************************/
-/*!
- * \brief backward solving
- *
- * \param A double **
- * \param x double *
- * \param b double *
- * \param rows int
- * \return void
- *
- * */
-void backward_solving(double **A, double *x, double *b, int rows)
-{
- int i, j;
- double tmpval = 0.0;
-
- for (i = rows - 1; i >= 0; i--) {
- tmpval = 0;
- for (j = i + 1; j < rows; j++) {
- /*tmpval += A[i][j] * x[j]; */
- b[i] = b[i] - A[i][j] * x[j];
- }
- /*x[i] = (b[i] - tmpval) / A[i][i]; */
- x[i] = (b[i]) / A[i][i];
- }
-
- return;
-}
-
-
-/***********************************************************
- * forward solving *****************************************
- * ********************************************************/
-/*!
- * \brief forward solving
- *
- * \param A double **
- * \param x double *
- * \param b double *
- * \param rows int
- * \return void
- *
- * */
-void forward_solving(double **A, double *x, double *b, int rows)
-{
- int i, j;
- double tmpval = 0.0;
-
- for (i = 0; i < rows; i++) {
- tmpval = 0;
- for (j = 0; j < i; j++) {
- tmpval += A[i][j] * x[j];
- }
- x[i] = (b[i] - tmpval) / A[i][i];
- }
-
- return;
-}
-
-
-/* ******************************************************* *
- * ***** solving a tridiagonal eq system ***************** *
- * ******************************************************* */
-void thomalg(double **M, double *V, int rows)
-{
- double *Vtmp;
- double *g;
- double b;
- int i;
-
- Vtmp = vectmem(rows);
- g = vectmem(rows);
-
- for (i = 0; i < rows; i++) {
- if (i == 0) {
- b = M[i][i];
- Vtmp[i] = V[i] / b;
- }
- else {
- b = M[i][i] - M[i][i - 1] * g[i - 1];
- Vtmp[i] = (V[i] - Vtmp[i - 1] * M[i][i - 1]) / b;
- }
- if (i < rows - 1) {
- g[i] = M[i][i + 1] / b;
- }
- }
-
- V[rows - 1] = Vtmp[rows - 1];
- for (i = rows - 2; i >= 0; i--) {
- V[i] = Vtmp[i] - g[i] * V[i + 1];
- }
-
- G_free(Vtmp);
- G_free(g);
-}
-
-
-/***********************************************************
- * vectmem *************************************************
- * ********************************************************/
-/*!
- * \brief Allocate vector memory
- *
- * \param rows int
- * \return double *
- *
- * */
-double *vectmem(int rows)
-{
- double *vector;
-
- vector = (double *)(G_calloc(rows, (sizeof(double))));
- return vector;
-}
Deleted: grass/trunk/lib/gpde/N_solvers_classic_iter.c
===================================================================
--- grass/trunk/lib/gpde/N_solvers_classic_iter.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_solvers_classic_iter.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,241 +0,0 @@
-
-/*****************************************************************************
-*
-* MODULE: Grass PDE Numerical Library
-* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
-* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: linear equation system solvers
-* part of the gpde library
-*
-* COPYRIGHT: (C) 2000 by the GRASS Development Team
-*
-* This program is free software under the GNU General Public
-* License (>=v2). Read the file COPYING that comes with GRASS
-* for details.
-*
-*****************************************************************************/
-
-#include <math.h>
-#include <unistd.h>
-#include <stdio.h>
-#include <string.h>
-#include "grass/N_pde.h"
-#include "solvers_local_proto.h"
-
-static int sparse_jacobi_gauss(N_les * L, int maxit, double sor, double error,
- const char *type);
-static int jacobi(double **M, double *b, double *x, int rows, int maxit,
- double sor, double error);
-static int gauss_seidel(double **M, double *b, double *x, int rows, int maxit,
- double sor, double error);
-
-/* ******************************************************* *
- * ******** overrelaxed jacobian ************************* *
- * ******************************************************* */
-/*!
- * \brief The iterative jacobian solver for regular matrices
- *
- * The result is written to the vector L->x of the les.
- * This iterative solver works with sparse matrices and regular quadratic matrices.
- *
- * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
- * solver will abort the calculation and writes the current result into the vector L->x.
- * The parameter <i>err</i> defines the error break criteria for the solver.
- *
- * \param L N_les * -- the linear equatuin system
- * \param maxit int -- the maximum number of iterations
- * \param sor double -- defines the successive overrelaxion parameter [0:1]
- * \param error double -- defines the error break criteria
- * \return int -- 1=success, -1=could not solve the les
- *
- * */
-int N_solver_jacobi(N_les * L, int maxit, double sor, double error)
-{
-
- if (L->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
- if (L->type == N_NORMAL_LES)
- return jacobi(L->A, L->b, L->x, L->rows, maxit, sor, error);
- else
- return sparse_jacobi_gauss(L, maxit, sor, error,
- N_SOLVER_ITERATIVE_JACOBI);
-}
-
-
-/* ******************************************************* *
- * ********* overrelaxed gauss seidel ******************** *
- * ******************************************************* */
-/*!
- * \brief The iterative overrelaxed gauss seidel solver for regular matrices
- *
- * The result is written to the vector L->x of the les.
- * This iterative solver works with sparse matrices and regular quadratic matrices.
- *
- * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
- * solver will abort the calculation and writes the current result into the vector L->x.
- * The parameter <i>err</i> defines the error break criteria for the solver.
- *
- * \param L N_les * -- the linear equatuin system
- * \param maxit int -- the maximum number of iterations
- * \param sor double -- defines the successive overrelaxion parameter [0:1]
- * \param error double -- defines the error break criteria
- * \return int -- 1=success, -1=could not solve the les
- *
- * */
-
-int N_solver_SOR(N_les * L, int maxit, double sor, double error)
-{
-
- if (L->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
- if (L->type == N_NORMAL_LES)
- return gauss_seidel(L->A, L->b, L->x, L->rows, maxit, sor, error);
- else
- return sparse_jacobi_gauss(L, maxit, sor, error,
- N_SOLVER_ITERATIVE_SOR);
-}
-
-/* ******************************************************* *
- * ****** sparse jacobi and SOR algorithm **************** *
- * ******************************************************* */
-int
-sparse_jacobi_gauss(N_les * L, int maxit, double sor, double error,
- const char *type)
-{
- int i, j, k, rows, finished = 0;
- double *Enew, *x, *b;
- double E, err = 0;
-
- x = L->x;
- b = L->b;
- rows = L->rows;
-
- Enew = vectmem(rows);
-
- for (k = 0; k < maxit; k++) {
- err = 0;
- {
- if (k == 0) {
- for (j = 0; j < rows; j++) {
- Enew[j] = x[j];
- }
- }
- for (i = 0; i < rows; i++) {
- E = 0;
- if (strcmp(type, N_SOLVER_ITERATIVE_JACOBI) == 0) {
- for (j = 0; j < L->Asp[i]->cols; j++) {
- E += L->Asp[i]->values[j] * x[L->Asp[i]->index[j]];
- }
- }
- else {
- for (j = 0; j < L->Asp[i]->cols; j++) {
- E += L->Asp[i]->values[j] * Enew[L->Asp[i]->index[j]];
- }
- }
- Enew[i] = x[i] - sor * (E - b[i]) / L->Asp[i]->values[0];
- }
- for (j = 0; j < rows; j++) {
- err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
-
- x[j] = Enew[j];
- }
- }
-
- if (strcmp(type, N_SOLVER_ITERATIVE_JACOBI) == 0)
- G_message(_("sparse Jacobi -- iteration %5i error %g\n"), k, err);
- else if (strcmp(type, N_SOLVER_ITERATIVE_SOR) == 0)
- G_message(_("sparse SOR -- iteration %5i error %g\n"), k, err);
-
- if (err < error) {
- finished = 1;
- break;
- }
- }
-
- G_free(Enew);
-
- return finished;
-}
-
-/* ******************************************************* *
- * ******* direct jacobi ********************************* *
- * ******************************************************* */
-int jacobi(double **M, double *b, double *x, int rows, int maxit, double sor,
- double error)
-{
- int i, j, k;
- double *Enew;
- double E, err = 0;
-
- Enew = vectmem(rows);
-
- for (j = 0; j < rows; j++) {
- Enew[j] = x[j];
- }
-
- for (k = 0; k < maxit; k++) {
- for (i = 0; i < rows; i++) {
- E = 0;
- for (j = 0; j < rows; j++) {
- E += M[i][j] * x[j];
- }
- Enew[i] = x[i] - sor * (E - b[i]) / M[i][i];
- }
- err = 0;
- for (j = 0; j < rows; j++) {
- err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
-
- x[j] = Enew[j];
- }
- G_message(_("Jacobi -- iteration %5i error %g\n"), k, err);
- if (err < error)
- break;
- }
-
- return 1;
-}
-
-/* ******************************************************* *
- * ******* direct gauss seidel *************************** *
- * ******************************************************* */
-int gauss_seidel(double **M, double *b, double *x, int rows, int maxit,
- double sor, double error)
-{
- int i, j, k;
- double *Enew;
- double E, err = 0;
-
- Enew = vectmem(rows);
-
- for (j = 0; j < rows; j++) {
- Enew[j] = x[j];
- }
-
- for (k = 0; k < maxit; k++) {
- for (i = 0; i < rows; i++) {
- E = 0;
- for (j = 0; j < rows; j++) {
- E += M[i][j] * Enew[j];
- }
- Enew[i] = x[i] - sor * (E - b[i]) / M[i][i];
- }
- err = 0;
- for (j = 0; j < rows; j++) {
- err += (x[j] - Enew[j]) * (x[j] - Enew[j]);
-
- x[j] = Enew[j];
- }
- G_message(_("SOR -- iteration %5i error %g\n"), k, err);
- if (err < error)
- break;
- }
-
- return 1;
-}
Deleted: grass/trunk/lib/gpde/N_solvers_krylov.c
===================================================================
--- grass/trunk/lib/gpde/N_solvers_krylov.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/N_solvers_krylov.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,982 +0,0 @@
-
-/*****************************************************************************
-*
-* MODULE: Grass PDE Numerical Library
-* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
-* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: linear equation system solvers
-* part of the gpde library
-*
-* COPYRIGHT: (C) 2000 by the GRASS Development Team
-*
-* This program is free software under the GNU General Public
-* License (>=v2). Read the file COPYING that comes with GRASS
-* for details.
-*
-*****************************************************************************/
-
-#include <math.h>
-#include <unistd.h>
-#include <stdio.h>
-#include <string.h>
-#include "grass/N_pde.h"
-#include "solvers_local_proto.h"
-
-/*local protos */
-static void scalar_product(double *a, double *b, double *scalar, int rows);
-static void sub_vectors(double *source_a, double *source_b, double *result,
- int row);
-static void sub_vectors_scalar(double *source_a, double *source_b,
- double *result, double scalar_b, int rows);
-static void add_vectors(double *source_a, double *source_b, double *result,
- int rows);
-static void add_vectors_scalar(double *source_a, double *source_b,
- double *result, double scalar_b, int rows);
-static void add_vectors_scalar2(double *source_a, double *source_b,
- double *result, double scalar_a,
- double scalar_b, int rows);
-static void scalar_vector_product(double *a, double *result, double scalar,
- int rows);
-static void sync_vectors(double *source, double *target, int rows);
-
-
-/* ******************************************************* *
- * *** preconditioned conjugate gradients **************** *
- * ******************************************************* */
-/*!
- * \brief The iterative preconditioned conjugate gradients solver for symmetric positive definite matrices
- *
- * This iterative solver works with symmetric positive definite sparse matrices and
- * symmetric positive definite regular quadratic matrices.
- *
- * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
- * solver will abort the calculation and writes the current result into the vector L->x.
- * The parameter <i>err</i> defines the error break criteria for the solver.
- *
- * \param L N_les * -- the linear equatuin system
- * \param maxit int -- the maximum number of iterations
- * \param err double -- defines the error break criteria
- * \param prec int -- the preconditioner which shoudl be used N_DIAGONAL_PRECONDITION, N_ROWSUM_PRECONDITION
- * \return int -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
- *
- * */
-int N_solver_pcg(N_les * L, int maxit, double err, int prec)
-{
- double *r, *z;
- double *p;
- double *v;
- double *x, *b;
- double s = 0.0;
- double a0 = 0, a1 = 0, mygamma, tmp = 0;
- int m, rows, i;
- int finished = 2;
- int error_break;
- N_les *M;
-
- if (L->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
- /* check for symmetry */
- if (check_symmetry(L) != 1) {
- G_warning(_("Matrix is not symmetric!"));
- }
-
- x = L->x;
- b = L->b;
- rows = L->rows;
-
- r = vectmem(rows);
- p = vectmem(rows);
- v = vectmem(rows);
- z = vectmem(rows);
-
- error_break = 0;
-
- /*compute the preconditioning matrix */
- M = N_create_diag_precond_matrix(L, prec);
-
- /*
- * residual calculation
- */
-#pragma omp parallel
- {
- /* matrix vector multiplication */
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, x, v);
- else
- N_matrix_vector_product(L, x, v);
-
- sub_vectors(b, v, r, rows);
- /*performe the preconditioning */
- N_sparse_matrix_vector_product(M, r, p);
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += p[i] * r[i];
- }
- }
-
- a0 = s;
- s = 0.0;
-
- /* ******************* */
- /* start the iteration */
- /* ******************* */
- for (m = 0; m < maxit; m++) {
-#pragma omp parallel default(shared)
- {
- /* matrix vector multiplication */
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, p, v);
- else
- N_matrix_vector_product(L, p, v);
-
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += v[i] * p[i];
- }
-
- /* barrier */
-#pragma omp single
- {
- tmp = s;
- mygamma = a0 / tmp;
- s = 0.0;
- }
-
- add_vectors_scalar(x, p, x, mygamma, rows);
-
- if (m % 50 == 1) {
- /* matrix vector multiplication */
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, x, v);
- else
- N_matrix_vector_product(L, x, v);
-
- sub_vectors(b, v, r, rows);
-
- }
- else {
- sub_vectors_scalar(r, v, r, mygamma, rows);
- }
-
- /*performe the preconditioning */
- N_sparse_matrix_vector_product(M, r, z);
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += z[i] * r[i];
- }
-
- /* barrier */
-#pragma omp single
- {
- a1 = s;
- tmp = a1 / a0;
- a0 = a1;
- s = 0.0;
-
- if (a1 < 0 || a1 == 0 || a1 > 0) {
- ;
- }
- else {
- G_warning(_("Unable to solve the linear equation system"));
- error_break = 1;
- }
- }
- add_vectors_scalar(z, p, p, tmp, rows);
- }
-
- if (L->type == N_SPARSE_LES)
- G_message(_("Sparse PCG -- iteration %i error %g\n"), m, a0);
- else
- G_message(_("PCG -- iteration %i error %g\n"), m, a0);
-
- if (error_break == 1) {
- finished = -1;
- break;
- }
-
-
- if (a0 < err) {
- finished = 1;
- break;
- }
- }
-
- G_free(r);
- G_free(p);
- G_free(v);
- G_free(z);
-
- return finished;
-}
-
-
-/* ******************************************************* *
- * ****************** conjugate gradients **************** *
- * ******************************************************* */
-/*!
- * \brief The iterative conjugate gradients solver for symmetric positive definite matrices
- *
- * This iterative solver works with symmetric positive definite sparse matrices and
- * symmetric positive definite regular quadratic matrices.
- *
- * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
- * solver will abort the calculation and writes the current result into the vector L->x.
- * The parameter <i>err</i> defines the error break criteria for the solver.
- *
- * \param L N_les * -- the linear equatuin system
- * \param maxit int -- the maximum number of iterations
- * \param err double -- defines the error break criteria
- * \return int -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
- *
- * */
-int N_solver_cg(N_les * L, int maxit, double err)
-{
- double *r;
- double *p;
- double *v;
- double *x, *b;
- double s = 0.0;
- double a0 = 0, a1 = 0, mygamma, tmp = 0;
- int m, rows, i;
- int finished = 2;
- int error_break;
-
- if (L->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
- /* check for symmetry */
- if (check_symmetry(L) != 1) {
- G_warning(_("Matrix is not symmetric!"));
- }
-
- x = L->x;
- b = L->b;
- rows = L->rows;
-
- r = vectmem(rows);
- p = vectmem(rows);
- v = vectmem(rows);
-
- error_break = 0;
- /*
- * residual calculation
- */
-#pragma omp parallel
- {
- /* matrix vector multiplication */
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, x, v);
- else
- N_matrix_vector_product(L, x, v);
-
- sub_vectors(b, v, r, rows);
- sync_vectors(r, p, rows);
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += r[i] * r[i];
- }
- }
-
- a0 = s;
- s = 0.0;
-
- /* ******************* */
- /* start the iteration */
- /* ******************* */
- for (m = 0; m < maxit; m++) {
-#pragma omp parallel default(shared)
- {
- /* matrix vector multiplication */
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, p, v);
- else
- N_matrix_vector_product(L, p, v);
-
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += v[i] * p[i];
- }
-
- /* barrier */
-#pragma omp single
- {
- tmp = s;
- mygamma = a0 / tmp;
- s = 0.0;
- }
-
- add_vectors_scalar(x, p, x, mygamma, rows);
-
- if (m % 50 == 1) {
- /* matrix vector multiplication */
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, x, v);
- else
- N_matrix_vector_product(L, x, v);
-
- sub_vectors(b, v, r, rows);
- }
- else {
- sub_vectors_scalar(r, v, r, mygamma, rows);
- }
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += r[i] * r[i];
- }
-
- /* barrier */
-#pragma omp single
- {
- a1 = s;
- tmp = a1 / a0;
- a0 = a1;
- s = 0.0;
-
- if (a1 < 0 || a1 == 0 || a1 > 0) {
- ;
- }
- else {
- G_warning(_("Unable to solve the linear equation system"));
- error_break = 1;
- }
- }
- add_vectors_scalar(r, p, p, tmp, rows);
- }
-
- if (L->type == N_SPARSE_LES)
- G_message(_("Sparse CG -- iteration %i error %g\n"), m, a0);
- else
- G_message(_("CG -- iteration %i error %g\n"), m, a0);
-
- if (error_break == 1) {
- finished = -1;
- break;
- }
-
- if (a0 < err) {
- finished = 1;
- break;
- }
- }
-
- G_free(r);
- G_free(p);
- G_free(v);
-
- return finished;
-}
-
-/* ******************************************************* *
- * ************ biconjugate gradients ******************** *
- * ******************************************************* */
-/*!
- * \brief The iterative biconjugate gradients solver with stabilization for unsymmetric non-definite matrices
- *
- * The result is written to the vector L->x of the les.
- * This iterative solver works with sparse matrices and regular quadratic matrices.
- *
- * The parameter <i>maxit</i> specifies the maximum number of iterations. If the maximum is reached, the
- * solver will abort the calculation and writes the current result into the vector L->x.
- * The parameter <i>err</i> defines the error break criteria for the solver.
- *
- * \param L N_les * -- the linear equatuin system
- * \param maxit int -- the maximum number of iterations
- * \param err double -- defines the error break criteria
- * \return int -- 1 - success, 2 - not finisehd but success, 0 - matrix singular, -1 - could not solve the les
- *
- *
- * */
-int N_solver_bicgstab(N_les * L, int maxit, double err)
-{
- double *r;
- double *r0;
- double *p;
- double *v;
- double *s;
- double *t;
- double *x, *b;
- double s1 = 0.0, s2 = 0.0, s3 = 0.0;
- double alpha = 0, beta = 0, omega, rr0 = 0, error;
- int m, rows, i;
- int finished = 2;
- int error_break;
-
- if (L->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return -1;
- }
-
-
- x = L->x;
- b = L->b;
- rows = L->rows;
- r = vectmem(rows);
- r0 = vectmem(rows);
- p = vectmem(rows);
- v = vectmem(rows);
- s = vectmem(rows);
- t = vectmem(rows);
-
- error_break = 0;
-
-#pragma omp parallel
- {
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, x, v);
- else
- N_matrix_vector_product(L, x, v);
- sub_vectors(b, v, r, rows);
- sync_vectors(r, r0, rows);
- sync_vectors(r, p, rows);
- }
-
- s1 = s2 = s3 = 0.0;
-
- /* ******************* */
- /* start the iteration */
- /* ******************* */
- for (m = 0; m < maxit; m++) {
-
-#pragma omp parallel default(shared)
- {
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, p, v);
- else
- N_matrix_vector_product(L, p, v);
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s1, s2, s3)
- for (i = 0; i < rows; i++) {
- s1 += r[i] * r[i];
- s2 += r[i] * r0[i];
- s3 += v[i] * r0[i];
- }
-
-#pragma omp single
- {
- error = s1;
-
- if (error < 0 || error == 0 || error > 0) {
- ;
- }
- else {
- G_warning(_("Unable to solve the linear equation system"));
- error_break = 1;
- }
-
- rr0 = s2;
- alpha = rr0 / s3;
- s1 = s2 = s3 = 0.0;
- }
-
- sub_vectors_scalar(r, v, s, alpha, rows);
- if (L->type == N_SPARSE_LES)
- N_sparse_matrix_vector_product(L, s, t);
- else
- N_matrix_vector_product(L, s, t);
-
- /* scalar product */
-#pragma omp for schedule (static) private(i) reduction(+:s1, s2)
- for (i = 0; i < rows; i++) {
- s1 += t[i] * s[i];
- s2 += t[i] * t[i];
- }
-
-#pragma omp single
- {
- omega = s1 / s2;
- s1 = s2 = 0.0;
- }
-
- add_vectors_scalar2(p, s, r, alpha, omega, rows);
- add_vectors(x, r, x, rows);
- sub_vectors_scalar(s, t, r, omega, rows);
-
-#pragma omp for schedule (static) private(i) reduction(+:s1)
- for (i = 0; i < rows; i++) {
- s1 += r[i] * r0[i];
- }
-
-#pragma omp single
- {
- beta = alpha / omega * s1 / rr0;
- s1 = s2 = s3 = 0.0;
- }
-
- sub_vectors_scalar(p, v, p, omega, rows);
- add_vectors_scalar(r, p, p, beta, rows);
- }
-
-
- if (L->type == N_SPARSE_LES)
- G_message(_("Sparse BiCGStab -- iteration %i error %g\n"), m,
- error);
- else
- G_message(_("BiCGStab -- iteration %i error %g\n"), m, error);
-
- if (error_break == 1) {
- finished = -1;
- break;
- }
-
- if (error < err) {
- finished = 1;
- break;
- }
- }
-
- G_free(r);
- G_free(r0);
- G_free(p);
- G_free(v);
- G_free(s);
- G_free(t);
-
- return finished;
-}
-
-/*!
- * \brief Calculates the scalar product of vector a and b
- *
- * The result is written to variable scalar
- *
- * \param a double *
- * \param b double *
- * \param scalar double *
- * \param rows int
- * \return void
- *
- * */
-void scalar_product(double *a, double *b, double *scalar, int rows)
-{
- int i;
- double s = 0.0;
-
-#pragma omp parallel for schedule (static) reduction(+:s)
- for (i = 0; i < rows; i++) {
- s += a[i] * b[i];
- }
-
- *scalar = s;
- return;
-}
-
-/*!
- * \brief Calculates the matrix - vector product of matrix L->A and vector x
- *
- * The result is written to vector named result. This function only works with
- * regular quadratic matrices.
- *
- * \param L N_les *
- * \param x double *
- * \param result double *
- * \return void
- *
- * */
-void N_matrix_vector_product(N_les * L, double *x, double *result)
-{
- int i, j;
- double tmp;
-
-#pragma omp for schedule (static) private(i, j, tmp)
- for (i = 0; i < L->rows; i++) {
- tmp = 0;
- for (j = 0; j < L->cols; j++) {
- tmp += L->A[i][j] * x[j];
- }
- result[i] = tmp;
- }
- return;
-}
-
-/*!
- * \brief Calculates the matrix - vector product of sparse matrix L->Asp and vector x
- *
- * The result is written to vector named result. This function only works with
- * sparse matrices matrices.
- *
- * \param L N_les *
- * \param x double *
- * \param result double *
- * \return void
- *
- * */
-void N_sparse_matrix_vector_product(N_les * L, double *x, double *result)
-{
- int i, j;
- double tmp;
-
-#pragma omp for schedule (static) private(i, j, tmp)
- for (i = 0; i < L->rows; i++) {
- tmp = 0;
- for (j = 0; j < L->Asp[i]->cols; j++) {
- tmp += L->Asp[i]->values[j] * x[L->Asp[i]->index[j]];
- }
- result[i] = tmp;
- }
- return;
-}
-
-/*!
- * \brief Multipiles the vector a and b with the scalars scalar_a and scalar_b and adds them
- *
- *
- * The result is written to the vector named result.
- *
- * \param a double *
- * \param b double *
- * \param result double *
- * \param scalar_a double
- * \param scalar_b double
- * \param rows int
- *
- * */
-void
-add_vectors_scalar2(double *a, double *b, double *result, double scalar_a,
- double scalar_b, int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- result[i] = scalar_a * a[i] + scalar_b * b[i];
- }
-
- return;
-}
-
-/*!
- * \brief Multipiles the vector b with the scalar scalar_b and adds a to b
- *
- *
- * The result is written to the vector named result.
- *
- * \param a double *
- * \param b double *
- * \param result double *
- * \param scalar_b double
- * \param rows int
- *
- * */
-void
-add_vectors_scalar(double *a, double *b, double *result, double scalar_b,
- int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- result[i] = a[i] + scalar_b * b[i];
- }
-
- return;
-}
-
-/*!
- * \brief Multipiles the vector b with the scalar scalar_b and substracts b from a
- *
- *
- * The result is written to the vector named result.
- *
- * \param a double *
- * \param b double *
- * \param result double *
- * \param scalar_b double
- * \param rows int
- *
- * */
-void
-sub_vectors_scalar(double *a, double *b, double *result, double scalar_b,
- int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- result[i] = a[i] - scalar_b * b[i];
- }
-
- return;
-}
-
-/*!
- * \brief Adds a to b
- *
- *
- * The result is written to the vector named result.
- *
- * \param a double *
- * \param b double *
- * \param result double *
- * \param rows int
- *
- * */
-void add_vectors(double *a, double *b, double *result, int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- result[i] = a[i] + b[i];
- }
-
- return;
-}
-
-/*!
- * \brief Substracts b from a
- *
- *
- * The result is written to the vector named result.
- *
- * \param a double *
- * \param b double *
- * \param result double *
- * \param rows int
- *
- * */
-void sub_vectors(double *a, double *b, double *result, int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- result[i] = a[i] - b[i];
- }
-
- return;
-}
-
-/*!
- * \brief Multipiles the vector a with the scalar named scalar
- *
- *
- * The result is written to the vector named result.
- *
- * \param a double *
- * \param result double *
- * \param scalar double *
- * \param rows int
- *
- * */
-void scalar_vector_product(double *a, double *result, double scalar, int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- result[i] = scalar * a[i];
- }
-
- return;
-}
-
-/*!
- * \brief Copies the source vector to the target vector
- *
- * \param source double *
- * \param target double *
- * \param rows int
- *
- * */
-void sync_vectors(double *source, double *target, int rows)
-{
- int i;
-
-#pragma omp for schedule (static)
- for (i = 0; i < rows; i++) {
- target[i] = source[i];
- }
-
- return;
-}
-
-/* ******************************************************* *
- * ***** Check if matrix is symmetric ******************** *
- * ******************************************************* */
-/*!
- * \brief Check if the matrix in les is symmetric
- *
- * \param L N_les* -- the linear equation system
- * \return int -- 1 = symmetric, 0 = unsymmetric
- *
- * */
-
-int check_symmetry(N_les * L)
-{
- int i, j, k;
- double value1 = 0;
- double value2 = 0;
- int index;
- int symm = 0;
-
- if (L->quad != 1) {
- G_warning(_("The linear equation system is not quadratic"));
- return 0;
- }
-
- G_debug(2, "check_symmetry: Check if matrix is symmetric");
-
- if (L->type == N_SPARSE_LES) {
-#pragma omp parallel for schedule (static) private(i, j, k, value1, value2, index) reduction(+:symm) shared(L)
- for (j = 0; j < L->rows; j++) {
- for (i = 1; i < L->Asp[j]->cols; i++) {
- value1 = 0;
- value2 = 0;
- index = 0;
-
- index = L->Asp[j]->index[i];
- value1 = L->Asp[j]->values[i];
-
- for (k = 1; k < L->Asp[index]->cols; k++) {
- if (L->Asp[index]->index[k] == j) {
- value2 = L->Asp[index]->values[k];
- if ((value1 != value2)) {
- if ((fabs((fabs(value1) - fabs(value2))) <
- SYMM_TOLERANCE)) {
- G_debug(5,
- "check_symmetry: sparse matrix is unsymmetric, but within tolerance");
- }
- else {
- G_warning
- ("Matrix unsymmetric: Position [%i][%i] : [%i][%i] \nError: %12.18lf != %12.18lf \ndifference = %12.18lf\nStop symmetry calculation.\n",
- j, index, index, L->Asp[index]->index[k],
- value1, value2,
- fabs(fabs(value1) - fabs(value2)));
- symm++;
- }
- }
- }
- }
- }
- }
- }
- else {
-#pragma omp parallel for schedule (static) private(i, j, k, value1, value2, index) reduction(+:symm) shared(L)
- for (i = 0; i < L->rows; i++) {
- for (j = i + 1; j < L->rows; j++) {
- if (L->A[i][j] != L->A[j][i]) {
- if ((fabs(fabs(L->A[i][j]) - fabs(L->A[j][i])) <
- SYMM_TOLERANCE)) {
- G_debug(5,
- "check_symmetry: matrix is unsymmetric, but within tolerance");
- }
- else {
- G_warning
- ("Matrix unsymmetric: Position [%i][%i] : [%i][%i] \nError: %12.18lf != %12.18lf\ndifference = %12.18lf\nStop symmetry calculation.\n",
- i, j, j, i, L->A[i][j], L->A[j][i],
- fabs(fabs(L->A[i][j]) - fabs(L->A[j][i])));
- symm++;
- }
- }
- }
- }
- }
-
- if (symm > 0)
- return 0;
-
- return 1;
-}
-
-
-/*!
- * \brief Compute a diagonal preconditioning matrix for krylov space solver
- *
- * \param L N_les*
- * \pram prec int -- the preconditioner which should be choosen N_DIAGONAL_PRECONDITION, N_ROWSUM_PRECONDITION
- * \return M N_les* -- the preconditioning matrix
- *
- * */
-N_les *N_create_diag_precond_matrix(N_les * L, int prec)
-{
- N_les *L_new;
- int rows = L->rows;
- int cols = L->cols;
- int i, j;
- double sum;
-
- L_new = N_alloc_les_A(rows, N_SPARSE_LES);
-
- if (L->type == N_NORMAL_LES) {
-#pragma omp parallel for schedule (static) private(i, sum) shared(L_new, L, rows, prec)
- for (i = 0; i < rows; i++) {
- N_spvector *spvect = N_alloc_spvector(1);
-
- switch (prec) {
- case N_ROWSCALE_EUKLIDNORM_PRECONDITION:
- sum = 0;
- for (j = 0; j < cols; j++)
- sum += L->A[i][j] * L->A[i][j];
- spvect->values[0] = 1.0 / sqrt(sum);
- break;
- case N_ROWSCALE_ABSSUMNORM_PRECONDITION:
- sum = 0;
- for (j = 0; j < cols; j++)
- sum += fabs(L->A[i][j]);
- spvect->values[0] = 1.0 / (sum);
- break;
- case N_DIAGONAL_PRECONDITION:
- spvect->values[0] = 1.0 / L->A[i][i];
- break;
- default:
- spvect->values[0] = 1.0 / L->A[i][i];
- }
-
-
- spvect->index[0] = i;
- spvect->cols = 1;;
- N_add_spvector_to_les(L_new, spvect, i);
-
- }
- }
- else {
-#pragma omp parallel for schedule (static) private(i, sum) shared(L_new, L, rows, prec)
- for (i = 0; i < rows; i++) {
- N_spvector *spvect = N_alloc_spvector(1);
-
- switch (prec) {
- case N_ROWSCALE_EUKLIDNORM_PRECONDITION:
- sum = 0;
- for (j = 0; j < L->Asp[i]->cols; j++)
- sum += L->Asp[i]->values[j] * L->Asp[i]->values[j];
- spvect->values[0] = 1.0 / sqrt(sum);
- break;
- case N_ROWSCALE_ABSSUMNORM_PRECONDITION:
- sum = 0;
- for (j = 0; j < L->Asp[i]->cols; j++)
- sum += fabs(L->Asp[i]->values[j]);
- spvect->values[0] = 1.0 / (sum);
- break;
- case N_DIAGONAL_PRECONDITION:
- spvect->values[0] = 1.0 / L->Asp[i]->values[0];
- break;
- default:
- spvect->values[0] = 1.0 / L->Asp[i]->values[0];
- }
-
- spvect->index[0] = i;
- spvect->cols = 1;;
- N_add_spvector_to_les(L_new, spvect, i);
- }
- }
- return L_new;
-}
Deleted: grass/trunk/lib/gpde/solvers_local_proto.h
===================================================================
--- grass/trunk/lib/gpde/solvers_local_proto.h 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/solvers_local_proto.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,22 +0,0 @@
-
-/*****************************************************************************
-*
-* MODULE: Grass PDE Numerical Library
-* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
-* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: local prototypes for linear equation system solvers
-* part of the gpde library
-*
-* COPYRIGHT: (C) 2000 by the GRASS Development Team
-*
-* This program is free software under the GNU General Public
-* License (>=v2). Read the file COPYING that comes with GRASS
-* for details.
-*
-*****************************************************************************/
-
-#define SYMM_TOLERANCE 1.0e-18
-
-double *vectmem(int size);
-int check_symmetry(N_les * les);
Modified: grass/trunk/lib/gpde/test/Makefile
===================================================================
--- grass/trunk/lib/gpde/test/Makefile 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -2,7 +2,7 @@
PGM=test.gpde.lib
-LIBES = $(GISLIB) $(G3DLIB) $(GPDELIB)
+LIBES = $(GISLIB) $(G3DLIB) $(GPDELIB) $(GMATHLIB)
DEPENDENCIES = $(GISDEP) $(G3DDEP) $(GPDEDEP)
include $(MODULE_TOPDIR)/include/Make/Module.make
Modified: grass/trunk/lib/gpde/test/test_arrays.c
===================================================================
--- grass/trunk/lib/gpde/test/test_arrays.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_arrays.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -332,12 +332,10 @@
data11 = N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, CELL_TYPE);
data2 = N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, FCELL_TYPE);
N_print_array_2d_info(data2);
- data22 =
- N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, FCELL_TYPE);
+ data22 = N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, FCELL_TYPE);
data3 = N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, DCELL_TYPE);
N_print_array_2d_info(data3);
- data33 =
- N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, DCELL_TYPE);
+ data33 = N_alloc_array_2d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, 1, DCELL_TYPE);
/*Fill the first arrays with data */
@@ -529,8 +527,7 @@
N_math_array_2d(data2, data22, tmp, N_ARRAY_SUM);
res = N_convert_array_2d_null_to_zero(tmp);
if (res == 0) {
- G_warning
- ("test_array_2d: error in N_convert_array_2d_null_to_zero ");
+ G_warning("test_array_2d: error in N_convert_array_2d_null_to_zero ");
sum++;
}
N_free_array_2d(tmp);
@@ -627,19 +624,19 @@
/*Alloacte memory for all arrays */
data1 =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 2, FCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 2,
+ FCELL_TYPE);
N_print_array_3d_info(data1);
data11 =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 2, FCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 2,
+ FCELL_TYPE);
data2 =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 2, DCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 2,
+ DCELL_TYPE);
N_print_array_3d_info(data2);
data22 =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 2, DCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 2,
+ DCELL_TYPE);
/*Fill the first arrays with data */
Modified: grass/trunk/lib/gpde/test/test_assemble.c
===================================================================
--- grass/trunk/lib/gpde/test/test_assemble.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_assemble.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -73,7 +73,7 @@
N_put_array_2d_c_value(data, i, j, 2);
}
else {
- N_put_array_2d_c_value(data, i, j, 1);
+ N_put_array_2d_c_value(data, i, j, 1);
}
}
}
@@ -98,7 +98,7 @@
N_put_array_2d_d_value(data, i, j, 50);
}
else {
- N_put_array_2d_d_value(data, i, j, 1);
+ N_put_array_2d_d_value(data, i, j, 1);
}
}
}
@@ -114,8 +114,8 @@
int i, j, k;
data =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 1, FCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 1,
+ FCELL_TYPE);
#pragma omp parallel for private (i, j, k) shared (data)
for (k = 0; k < TEST_N_NUM_DEPTHS; k++)
@@ -127,7 +127,7 @@
}
else {
- N_put_array_3d_f_value(data, i, j, k, 1.0);
+ N_put_array_3d_f_value(data, i, j, k, 1.0);
}
}
}
@@ -145,8 +145,8 @@
int i, j, k;
data =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 1, DCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 1,
+ DCELL_TYPE);
#pragma omp parallel for private (i, j, k) shared (data)
for (k = 0; k < TEST_N_NUM_DEPTHS; k++)
@@ -159,7 +159,7 @@
}
else {
- N_put_array_3d_f_value(data, i, j, k, 1);
+ N_put_array_3d_f_value(data, i, j, k, 1);
}
}
}
@@ -199,29 +199,19 @@
geom->cols = TEST_N_NUM_COLS;
/*Assemble the matrix */
- les =
- N_assemble_les_3d(N_SPARSE_LES, geom, status, start_val, NULL, call);
+ les = N_assemble_les_3d(N_SPARSE_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_3d_active(N_SPARSE_LES, geom, status, start_val, NULL,
- call);
+ les = N_assemble_les_3d_active(N_SPARSE_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_3d_dirichlet(N_SPARSE_LES, geom, status, start_val,
- NULL, call);
+ les = N_assemble_les_3d_dirichlet(N_SPARSE_LES, geom, status, start_val, NULL, call);
N_les_integrate_dirichlet_3d(les, geom, status, start_val);
N_free_les(les);
- les =
- N_assemble_les_3d(N_NORMAL_LES, geom, status, start_val, NULL, call);
+ les = N_assemble_les_3d(N_NORMAL_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_3d_active(N_NORMAL_LES, geom, status, start_val, NULL,
- call);
+ les = N_assemble_les_3d_active(N_NORMAL_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, status, start_val,
- NULL, call);
+ les = N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, status, start_val, NULL, call);
N_les_integrate_dirichlet_3d(les, geom, status, start_val);
N_free_les(les);
@@ -261,29 +251,19 @@
geom->cols = TEST_N_NUM_COLS;
/*Assemble the matrix */
- les =
- N_assemble_les_2d(N_SPARSE_LES, geom, status, start_val, NULL, call);
+ les = N_assemble_les_2d(N_SPARSE_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_2d_active(N_SPARSE_LES, geom, status, start_val, NULL,
- call);
+ les = N_assemble_les_2d_active(N_SPARSE_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, status, start_val,
- NULL, call);
+ les = N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, status, start_val, NULL, call);
N_les_integrate_dirichlet_2d(les, geom, status, start_val);
N_free_les(les);
- les =
- N_assemble_les_2d(N_NORMAL_LES, geom, status, start_val, NULL, call);
+ les = N_assemble_les_2d(N_NORMAL_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_2d_active(N_NORMAL_LES, geom, status, start_val, NULL,
- call);
+ les = N_assemble_les_2d_active(N_NORMAL_LES, geom, status, start_val, NULL, call);
N_free_les(les);
- les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, status, start_val,
- NULL, call);
+ les = N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, status, start_val, NULL, call);
N_les_integrate_dirichlet_2d(les, geom, status, start_val);
N_free_les(les);
Modified: grass/trunk/lib/gpde/test/test_geom.c
===================================================================
--- grass/trunk/lib/gpde/test/test_geom.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_geom.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -111,8 +111,7 @@
area += N_get_geom_data_area_of_cell(geom, i);
if (area == 0) {
- G_warning
- ("Wrong area calculation in N_get_geom_data_area_of_cell");
+ G_warning("Wrong area calculation in N_get_geom_data_area_of_cell");
sum++;
}
}
@@ -149,8 +148,7 @@
area += N_get_geom_data_area_of_cell(geom, i);
if (area == 0) {
- G_warning
- ("Wrong area calculation in N_get_geom_data_area_of_cell");
+ G_warning("Wrong area calculation in N_get_geom_data_area_of_cell");
sum++;
}
}
@@ -161,8 +159,7 @@
area += N_get_geom_data_area_of_cell(geom, i);
if (area == 0) {
- G_warning
- ("Wrong area calculation in N_get_geom_data_area_of_cell");
+ G_warning("Wrong area calculation in N_get_geom_data_area_of_cell");
sum++;
}
}
Modified: grass/trunk/lib/gpde/test/test_gpde_lib.h
===================================================================
--- grass/trunk/lib/gpde/test/test_gpde_lib.h 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_gpde_lib.h 2009-10-03 19:05:32 UTC (rev 39389)
@@ -24,7 +24,7 @@
#define TEST_N_NUM_DEPTHS 10
/* Array test functions */
-extern int unit_test_arrays(void);
+extern int unit_test_arrays (void);
/* matrix assembling */
extern int unit_test_assemble(void);
@@ -32,9 +32,6 @@
/* gradient creation and handling tests */
extern int unit_test_gradient(void);
-/* direct and iterative solvers */
-extern int unit_test_solvers(void);
-
/* test the meth tools of gpde */
extern int unit_test_tools(void);
@@ -42,10 +39,10 @@
extern int unit_test_geom_data(void);
/* les creation */
-extern int unit_test_les_creation(void);
+extern int unit_test_les_creation (void);
-/*gwflow */
-extern int integration_test_gwflow(void);
+/*gwflow*/
+extern int integration_test_gwflow (void);
/* solute transport */
extern int integration_test_solute_transport(void);
Modified: grass/trunk/lib/gpde/test/test_gradient.c
===================================================================
--- grass/trunk/lib/gpde/test/test_gradient.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_gradient.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -68,7 +68,7 @@
#pragma omp parallel for private (i, j) shared (data)
for (j = 0; j < TEST_N_NUM_ROWS; j++) {
for (i = 0; i < TEST_N_NUM_COLS; i++) {
- N_put_array_2d_c_value(data, i, j, 1);
+ N_put_array_2d_c_value(data, i, j, 1);
}
}
return data;
@@ -87,7 +87,7 @@
#pragma omp parallel for private (i, j) shared (data)
for (j = 0; j < TEST_N_NUM_ROWS; j++) {
for (i = 0; i < TEST_N_NUM_COLS; i++) {
- N_put_array_2d_d_value(data, i, j, (double)i * j);
+ N_put_array_2d_d_value(data, i, j, (double)i*j);
}
}
return data;
@@ -102,17 +102,17 @@
int i, j, k;
data =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 1, FCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 1,
+ FCELL_TYPE);
#pragma omp parallel for private (i, j, k) shared (data)
for (k = 0; k < TEST_N_NUM_DEPTHS; k++) {
for (j = 0; j < TEST_N_NUM_ROWS; j++) {
for (i = 0; i < TEST_N_NUM_COLS; i++) {
- N_put_array_3d_f_value(data, i, j, k, 1.0);
+ N_put_array_3d_f_value(data, i, j, k, 1.0);
+ }
}
}
- }
return data;
@@ -127,16 +127,16 @@
int i, j, k;
data =
- N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS,
- 1, DCELL_TYPE);
+ N_alloc_array_3d(TEST_N_NUM_COLS, TEST_N_NUM_ROWS, TEST_N_NUM_DEPTHS, 1,
+ DCELL_TYPE);
#pragma omp parallel for private (i, j, k) shared (data)
for (k = 0; k < TEST_N_NUM_DEPTHS; k++)
for (j = 0; j < TEST_N_NUM_ROWS; j++) {
for (i = 0; i < TEST_N_NUM_COLS; i++) {
- N_put_array_3d_f_value(data, i, j, k, (double)i * j * k);
+ N_put_array_3d_f_value(data, i, j, k, (float)i*j*k);
+ }
}
- }
return data;
@@ -174,10 +174,9 @@
pot = create_potential_array_3d();
field = N_compute_gradient_field_3d(pot, relax, relax, relax, geom, NULL);
- field =
- N_compute_gradient_field_3d(pot, relax, relax, relax, geom, field);
+ field = N_compute_gradient_field_3d(pot, relax, relax, relax, geom, field);
- /*compute stats */
+ /*compute stats*/
N_calc_gradient_field_3d_stats(field);
N_print_gradient_field_3d_info(field);
@@ -187,7 +186,7 @@
N_free_array_3d(pot);
relax = N_alloc_array_3d(3, 3, 3, 0, DCELL_TYPE);
- pot = N_alloc_array_3d(3, 3, 3, 0, DCELL_TYPE);
+ pot = N_alloc_array_3d(3, 3, 3, 0, DCELL_TYPE);
xcomp = N_alloc_array_3d(3, 3, 3, 0, DCELL_TYPE);
ycomp = N_alloc_array_3d(3, 3, 3, 0, DCELL_TYPE);
zcomp = N_alloc_array_3d(3, 3, 3, 0, DCELL_TYPE);
@@ -267,8 +266,7 @@
geom->cols = 3;
field = N_compute_gradient_field_3d(pot, relax, relax, relax, geom, NULL);
- field =
- N_compute_gradient_field_3d(pot, relax, relax, relax, geom, field);
+ field = N_compute_gradient_field_3d(pot, relax, relax, relax, geom, field);
N_print_gradient_field_3d_info(field);
grad = N_get_gradient_3d(field, NULL, 0, 0, 0);
@@ -302,10 +300,10 @@
N_compute_gradient_field_components_3d(field, xcomp, ycomp, zcomp);
/*
- N_print_array_3d(xcomp);
- N_print_array_3d(ycomp);
- N_print_array_3d(zcomp);
- */
+ N_print_array_3d(xcomp);
+ N_print_array_3d(ycomp);
+ N_print_array_3d(zcomp);
+ */
N_free_gradient_field_3d(field);
G_free(geom);
@@ -354,7 +352,7 @@
field = N_compute_gradient_field_2d(pot, relax, relax, geom, field);
field = N_compute_gradient_field_2d(pot, relax, relax, geom, field);
- /*compute stats */
+ /*compute stats*/
N_calc_gradient_field_2d_stats(field);
N_print_gradient_field_2d_info(field);
@@ -364,7 +362,7 @@
N_free_array_2d(pot);
relax = N_alloc_array_2d(3, 3, 0, DCELL_TYPE);
- pot = N_alloc_array_2d(3, 3, 0, DCELL_TYPE);
+ pot = N_alloc_array_2d(3, 3, 0, DCELL_TYPE);
xcomp = N_alloc_array_2d(3, 3, 0, DCELL_TYPE);
ycomp = N_alloc_array_2d(3, 3, 0, DCELL_TYPE);
@@ -401,55 +399,46 @@
field = N_compute_gradient_field_2d(pot, relax, relax, geom, field);
N_print_gradient_field_2d_info(field);
- /*common gradient calculation */
+ /*common gradient calculation*/
grad = N_get_gradient_2d(field, NULL, 0, 0);
- G_message
- ("Gradient 2d: pos 0,0 NC %g == 0 ; SC %g == 2 ; WC %g == 0 ; EC %g == -1\n",
- grad->NC, grad->SC, grad->WC, grad->EC);
+ G_message("Gradient 2d: pos 0,0 NC %g == 0 ; SC %g == 2 ; WC %g == 0 ; EC %g == -1\n",
+ grad->NC, grad->SC, grad->WC, grad->EC);
grad = N_get_gradient_2d(field, grad, 1, 0);
- G_message
- ("Gradient 2d: pos 1,0 NC %g == 0 ; SC %g == 5 ; WC %g == -1 ; EC %g == -4\n",
- grad->NC, grad->SC, grad->WC, grad->EC);
+ G_message("Gradient 2d: pos 1,0 NC %g == 0 ; SC %g == 5 ; WC %g == -1 ; EC %g == -4\n",
+ grad->NC, grad->SC, grad->WC, grad->EC);
N_free_gradient_2d(grad);
grad = N_get_gradient_2d(field, NULL, 1, 1);
- G_message
- ("Gradient 2d: pos 1,1 NC %g == 5 ; SC %g == 8 ; WC %g == -4 ; EC %g == -3\n",
- grad->NC, grad->SC, grad->WC, grad->EC);
+ G_message("Gradient 2d: pos 1,1 NC %g == 5 ; SC %g == 8 ; WC %g == -4 ; EC %g == -3\n",
+ grad->NC, grad->SC, grad->WC, grad->EC);
grad = N_get_gradient_2d(field, grad, 1, 2);
- G_message
- ("Gradient 2d: pos 1,2 NC %g == 8 ; SC %g == 0 ; WC %g == -7 ; EC %g == -10\n",
- grad->NC, grad->SC, grad->WC, grad->EC);
+ G_message("Gradient 2d: pos 1,2 NC %g == 8 ; SC %g == 0 ; WC %g == -7 ; EC %g == -10\n",
+ grad->NC, grad->SC, grad->WC, grad->EC);
N_free_gradient_2d(grad);
grad = N_get_gradient_2d(field, NULL, 2, 2);
- G_message
- ("Gradient 2d: pos 2,2 NC %g ==15 ; SC %g == 0 ; WC %g == -10 ; EC %g == 0\n",
- grad->NC, grad->SC, grad->WC, grad->EC);
+ G_message("Gradient 2d: pos 2,2 NC %g ==15 ; SC %g == 0 ; WC %g == -10 ; EC %g == 0\n",
+ grad->NC, grad->SC, grad->WC, grad->EC);
N_free_gradient_2d(grad);
N_compute_gradient_field_components_2d(field, xcomp, ycomp);
- /*gradient neighbour calculation */
+ /*gradient neighbour calculation*/
grad_2d = N_get_gradient_neighbours_2d(field, NULL, 1, 1);
grad_2d = N_get_gradient_neighbours_2d(field, grad_2d, 1, 1);
- G_message
- ("N_gradient_neighbours_x; pos 1,1 NWN %g NEN %g WC %g EC %g SWS %g SES %g\n",
- grad_2d->x->NWN, grad_2d->x->NEN, grad_2d->x->WC, grad_2d->x->EC,
- grad_2d->x->SWS, grad_2d->x->SES);
- G_message
- ("N_gradient_neighbours_y: pos 1,1 NWW %g NEE %g NC %g SC %g SWW %g SEE %g\n",
- grad_2d->y->NWW, grad_2d->y->NEE, grad_2d->y->NC, grad_2d->y->SC,
- grad_2d->y->SWW, grad_2d->y->SEE);
-
+ G_message("N_gradient_neighbours_x; pos 1,1 NWN %g NEN %g WC %g EC %g SWS %g SES %g\n",
+ grad_2d->x->NWN, grad_2d->x->NEN, grad_2d->x->WC, grad_2d->x->EC, grad_2d->x->SWS, grad_2d->x->SES);
+ G_message("N_gradient_neighbours_y: pos 1,1 NWW %g NEE %g NC %g SC %g SWW %g SEE %g\n",
+ grad_2d->y->NWW, grad_2d->y->NEE, grad_2d->y->NC, grad_2d->y->SC, grad_2d->y->SWW, grad_2d->y->SEE);
+
N_free_gradient_neighbours_2d(grad_2d);
/*
- N_print_array_2d(xcomp);
- N_print_array_2d(ycomp);
- */
+ N_print_array_2d(xcomp);
+ N_print_array_2d(ycomp);
+ */
N_free_gradient_field_2d(field);
G_free(geom);
Modified: grass/trunk/lib/gpde/test/test_gwflow.c
===================================================================
--- grass/trunk/lib/gpde/test/test_gwflow.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_gwflow.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -15,9 +15,13 @@
*
*****************************************************************************/
+#include <grass/gmath.h>
+
+
#include <grass/gis.h>
#include <grass/glocale.h>
#include <grass/N_pde.h>
+#include <grass/gmath.h>
#include <grass/N_gwflow.h>
#include "test_gpde_lib.h"
@@ -108,9 +112,7 @@
int i, j;
N_gwflow_data2d *data;
- data =
- N_alloc_gwflow_data2d(TEST_N_NUM_COLS_LOCAL, TEST_N_NUM_ROWS_LOCAL, 1,
- 1);
+ data = N_alloc_gwflow_data2d(TEST_N_NUM_COLS_LOCAL, TEST_N_NUM_ROWS_LOCAL, 1, 1);
#pragma omp parallel for private (i, j) shared (data)
for (j = 0; j < TEST_N_NUM_ROWS_LOCAL; j++) {
@@ -179,37 +181,37 @@
/*CG*/ les =
N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_cg(les, 100, 0.1e-8);
+ G_math_solver_sparse_cg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
- /*PCG N_DIAGONAL_PRECONDITION */ les =
+ /*PCG G_MATH_DIAGONAL_PRECONDITION*/ les =
N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_pcg(les, 100, 0.1e-8, N_DIAGONAL_PRECONDITION);
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_DIAGONAL_PRECONDITION);
N_print_les(les);
N_free_les(les);
- /*PCG N_ROWSCALE_EUKLIDNORM_PRECONDITION */ les =
+ /*PCG G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION*/ les =
N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_pcg(les, 100, 0.1e-8, N_ROWSCALE_EUKLIDNORM_PRECONDITION);
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION);
N_print_les(les);
N_free_les(les);
- /*PCG N_ROWSCALE_ABSSUMNORM_PRECONDITION */ les =
+ /*PCG G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION*/ les =
N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_pcg(les, 100, 0.1e-8, N_ROWSCALE_ABSSUMNORM_PRECONDITION);
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION);
N_print_les(les);
N_free_les(les);
/*CG*/ les =
- N_assemble_les_3d_dirichlet(N_SPARSE_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_3d_dirichlet(N_SPARSE_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_cg(les, 100, 0.1e-8);
+ G_math_solver_sparse_cg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
@@ -217,41 +219,41 @@
/*CG*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
-
- N_solver_cg(les, 100, 0.1e-8);
+
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
- /*PCG N_DIAGONAL_PRECONDITION */ les =
+ /*PCG G_MATH_DIAGONAL_PRECONDITION*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
-
- N_solver_pcg(les, 100, 0.1e-8, N_DIAGONAL_PRECONDITION);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_DIAGONAL_PRECONDITION);
N_print_les(les);
N_free_les(les);
- /*PCG N_ROWSCALE_EUKLIDNORM_PRECONDITION */ les =
+ /*PCG G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
-
- N_solver_pcg(les, 100, 0.1e-8, N_ROWSCALE_EUKLIDNORM_PRECONDITION);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION);
N_print_les(les);
N_free_les(les);
- /*PCG N_ROWSCALE_ABSSUMNORM_PRECONDITION */ les =
+ /*PCG G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
-
- N_solver_pcg(les, 100, 0.1e-8, N_ROWSCALE_ABSSUMNORM_PRECONDITION);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION);
N_print_les(les);
N_free_les(les);
/*CG*/ les =
- N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_cg(les, 100, 0.1e-8);
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
@@ -259,30 +261,30 @@
/*BICG*/ les =
N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_sparse_bicgstab(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*BICG*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*BICG*/ les =
- N_assemble_les_3d_dirichlet(N_SPARSE_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_3d_dirichlet(N_SPARSE_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_sparse_bicgstab(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*BICG*/ les =
- N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
@@ -290,45 +292,45 @@
/*GUASS*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_gauss(les);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
/*LU*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_lu(les);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
/*GUASS*/ les =
- N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_gauss(les);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
/*LU*/ les =
- N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_lu(les);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
- /*Cholesky */ les =
+ /*Cholesky*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_cholesky(les);
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows, les->rows);
N_print_les(les);
N_free_les(les);
- /*Cholesky */ les =
- N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ /*Cholesky*/ les =
+ N_assemble_les_3d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_3d(les, geom, data->status, data->phead_start);
- N_solver_cholesky(les);
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows, les->rows);
N_print_les(les);
N_free_les(les);
@@ -365,53 +367,85 @@
geom->cols = TEST_N_NUM_COLS_LOCAL;
- /*Assemble the matrix */
+ /*Assemble the matrix */
/*
*/
/*CG*/ les =
N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_cg(les, 100, 0.1e-8);
+ G_math_solver_sparse_cg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
+ /*PCG G_MATH_DIAGONAL_PRECONDITION*/ les =
+ N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_DIAGONAL_PRECONDITION);
+ N_print_les(les);
+ N_free_les(les);
+
+ /*PCG G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION*/ les =
+ N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION);
+ N_print_les(les);
+ N_free_les(les);
+
+ /*PCG G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION*/ les =
+ N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION);
+ N_print_les(les);
+ N_free_les(les);
+
+
/*CG*/ les =
- N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_cg(les, 100, 0.1e-8);
+ G_math_solver_sparse_cg(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
+
/*CG*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_cg(les, 100, 0.1e-8);
+
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
+ /*PCG G_MATH_DIAGONAL_PRECONDITION*/ les =
+ N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_DIAGONAL_PRECONDITION);
+ N_print_les(les);
+ N_free_les(les);
- /*CG*/ les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
- N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_cg(les, 100, 0.1e-8);
+ /*PCG G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION*/ les =
+ N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_EUKLIDNORM_PRECONDITION);
N_print_les(les);
N_free_les(les);
- /*PCG*/ les =
+ /*PCG G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_pcg(les, 100, 0.1e-8, N_DIAGONAL_PRECONDITION);
+
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, 100, 0.1e-8, G_MATH_ROWSCALE_ABSSUMNORM_PRECONDITION);
N_print_les(les);
N_free_les(les);
- /*PCG*/ les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ /*CG*/ les =
+ N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_pcg(les, 100, 0.1e-8, N_DIAGONAL_PRECONDITION);
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
@@ -419,83 +453,79 @@
/*BICG*/ les =
N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_sparse_bicgstab(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*BICG*/ les =
- N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, data->status,
- data->phead_start, (void *)data, call);
- N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
-
/*BICG*/ les =
- N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
+ N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
+ G_math_solver_sparse_bicgstab(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*BICG*/ les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
- /*GAUSS*/ les =
+
+ /*GUASS*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_gauss(les);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
- /*GAUSS*/ les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
- N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_gauss(les);
+ /*LU*/ les =
+ N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
-
- /*LU*/ les =
- N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
+ /*GUASS*/ les =
+ N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_lu(les);
+ N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
/*LU*/ les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_lu(les);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
- /*Cholesky */ les =
+ /*Cholesky*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->phead_start,
(void *)data, call);
- N_solver_cholesky(les);
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows, les->rows);
N_print_les(les);
N_free_les(les);
- /*Cholesky */ les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead_start, (void *)data, call);
+ /*Cholesky*/ les =
+ N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead_start,
+ (void *)data, call);
N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead_start);
- N_solver_cholesky(les);
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows, les->rows);
N_print_les(les);
N_free_les(les);
-
-
-
-
+
N_free_gwflow_data2d(data);
G_free(geom);
G_free(call);
Modified: grass/trunk/lib/gpde/test/test_les.c
===================================================================
--- grass/trunk/lib/gpde/test/test_les.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_les.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -17,6 +17,7 @@
#include <grass/gis.h>
#include <grass/glocale.h>
+#include <grass/gmath.h>
#include <grass/N_pde.h>
#include "test_gpde_lib.h"
@@ -49,7 +50,7 @@
/* *************************************************************** */
int test_les(void)
{
- N_spvector *spvector = NULL;
+ G_math_spvector *spvector = NULL;
N_les *les = NULL;
N_les *sples = NULL;
int i, j;
@@ -106,7 +107,7 @@
#pragma omp parallel for private(i, j) shared(sples, spvector)
for (i = 0; i < TEST_N_NUM_ROWS; i++) {
- spvector = N_alloc_spvector(TEST_N_NUM_ROWS);
+ spvector = G_math_alloc_spvector(TEST_N_NUM_ROWS);
for (j = 0; j < TEST_N_NUM_ROWS; j++)
if (i != j)
@@ -115,7 +116,7 @@
spvector->index[0] = i;
spvector->values[0] = -1e2 - i;
- N_add_spvector_to_les(sples, spvector, i);
+ G_math_add_spvector(sples->Asp, spvector, i);
sples->x[i] = 273.15 + i;
sples->b[i] = 1e2 - i;
}
@@ -139,7 +140,7 @@
}
for (i = 0; i < TEST_N_NUM_ROWS; i++) {
- spvector = N_alloc_spvector(TEST_N_NUM_ROWS);
+ spvector = G_math_alloc_spvector(TEST_N_NUM_ROWS);
for (j = 0; j < TEST_N_NUM_ROWS; j++)
if (i != j)
@@ -148,7 +149,7 @@
spvector->index[0] = i;
spvector->values[0] = -1e2 - i;
- N_add_spvector_to_les(sples, spvector, i);
+ G_math_add_spvector(sples->Asp, spvector, i);
sples->x[i] = 273.15 + i;
sples->b[i] = 1e2 - i;
}
Modified: grass/trunk/lib/gpde/test/test_main.c
===================================================================
--- grass/trunk/lib/gpde/test/test_main.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_main.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -21,6 +21,7 @@
#include <grass/gis.h>
#include <grass/glocale.h>
#include <grass/N_pde.h>
+#include <grass/gmath.h>
#include "test_gpde_lib.h"
@@ -34,7 +35,7 @@
paramType param; /*Parameters */
/*- prototypes --------------------------------------------------------------*/
-static void set_params(void); /*Fill the paramType structure */
+static void set_params(void); /*Fill the paramType structure */
/* ************************************************************************* */
/* Set up the arguments we are expecting ********************************** */
@@ -45,7 +46,7 @@
param.unit->key = "unit";
param.unit->type = TYPE_STRING;
param.unit->required = NO;
- param.unit->options = "array,assemble,geom,gradient,les,solver,tools";
+ param.unit->options = "array,assemble,geom,gradient,les,tools";
param.unit->description = _("Choose the unit tests to run");
param.integration = G_define_option();
@@ -82,7 +83,8 @@
G_gisinit(argv[0]);
module = G_define_module();
- module->keywords = _("test, gpde");
+ G_add_keyword("test");
+ G_add_keyword("gpde");
module->description =
_("Performs unit and integration tests for gpde library");
@@ -100,7 +102,6 @@
returnstat += unit_test_gradient();
returnstat += unit_test_geom_data();
returnstat += unit_test_les_creation();
- returnstat += unit_test_solvers();
returnstat += unit_test_tools();
}
@@ -133,9 +134,6 @@
if (strcmp(param.unit->answers[i], "les") == 0)
returnstat += unit_test_les_creation();
- if (strcmp(param.unit->answers[i], "solver") == 0)
- returnstat += unit_test_solvers();
-
if (strcmp(param.unit->answers[i], "tools") == 0)
returnstat += unit_test_tools();
@@ -150,11 +148,10 @@
if (strcmp(param.integration->answers[i], "gwflow") == 0)
returnstat += integration_test_gwflow();
- if (strcmp(param.integration->answers[i], "heatflow") == 0) ; /*nothing to do for now */
+ if (strcmp(param.integration->answers[i], "heatflow") == 0); /*nothing to do for now */
- if (strcmp(param.integration->answers[i], "transport") ==
- 0)
- returnstat += integration_test_solute_transport();
+ if (strcmp(param.integration->answers[i], "transport") == 0)
+ returnstat += integration_test_solute_transport();
i++;
}
@@ -162,10 +159,10 @@
}
}
- if (returnstat != 0)
- G_warning("Errors detected while testing the gpde lib");
+ if(returnstat != 0)
+ G_warning("Errors detected while testing the gpde lib");
else
- G_message("\n-- gpde lib tests finished successfully --");
+ G_message("\n-- gpde lib tests finished successfully --");
return (returnstat);
}
Modified: grass/trunk/lib/gpde/test/test_solute_transport.c
===================================================================
--- grass/trunk/lib/gpde/test/test_solute_transport.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_solute_transport.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -51,7 +51,8 @@
if (sum > 0)
G_warning(_("\n-- solute_transport integration tests failure --"));
else
- G_message(_("\n-- solute_transport integration tests finished successfully --"));
+ G_message(_
+ ("\n-- solute_transport integration tests finished successfully --"));
return sum;
}
@@ -143,9 +144,9 @@
N_put_array_2d_d_value(data->cs, i, j, 1.0);
}
}
- /*dispersivity length */
- data->al = 0.2;
- data->at = 0.02;
+ /*dispersivity length*/
+ data->al = 0.2;
+ data->at = 0.02;
@@ -168,7 +169,7 @@
N_set_les_callback_3d_func(call, (*N_callback_solute_transport_3d)); /*solute_transport 3d */
data = create_solute_transport_data_3d();
-
+
N_calc_solute_transport_disptensor_3d(data);
data->dt = 86400;
@@ -187,59 +188,32 @@
/*Assemble the matrix */
/*
*/
- /*Jacobi */ les =
- N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_jacobi(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
- /*jacobi */ les =
- N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_jacobi(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
- /*SOR*/ les =
- N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_SOR(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
- /*SOR*/ les =
- N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_SOR(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
/*BICG*/ les =
N_assemble_les_3d(N_SPARSE_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_sparse_bicgstab(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*BICG*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
/*GUASS*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_gauss(les);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
/*LU*/ les =
N_assemble_les_3d(N_NORMAL_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_lu(les);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
@@ -302,65 +276,37 @@
N_free_gradient_field_2d(field);
N_compute_gradient_field_2d(pot, relax, relax, geom, data->grad);
- /*The dispersivity tensor */
+ /*The dispersivity tensor*/
N_calc_solute_transport_disptensor_2d(data);
/*Assemble the matrix */
/*
*/
- /*Jacobi */ les =
+ /*BICG*/ les =
N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_jacobi(les, 100, 1, 0.1e-8);
+ G_math_solver_sparse_bicgstab(les->Asp, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
- /*jacobi */ les =
- N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_jacobi(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
- /*SOR*/ les =
- N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_SOR(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
- /*SOR*/ les =
- N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_SOR(les, 100, 1, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
/*BICG*/ les =
- N_assemble_les_2d(N_SPARSE_LES, geom, data->status, data->c_start,
- (void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
- N_print_les(les);
- N_free_les(les);
-
- /*BICG*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_bicgstab(les, 100, 0.1e-8);
+ G_math_solver_bicgstab(les->A, les->x, les->b, les->rows, 100, 0.1e-8);
N_print_les(les);
N_free_les(les);
- /*GAUSS*/ les =
+ /*GUASS*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_gauss(les);
+ G_math_solver_gauss(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
/*LU*/ les =
N_assemble_les_2d(N_NORMAL_LES, geom, data->status, data->c_start,
(void *)data, call);
- N_solver_lu(les);
+ G_math_solver_lu(les->A, les->x, les->b, les->rows);
N_print_les(les);
N_free_les(les);
Deleted: grass/trunk/lib/gpde/test/test_solvers.c
===================================================================
--- grass/trunk/lib/gpde/test/test_solvers.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_solvers.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -1,235 +0,0 @@
-
-/*****************************************************************************
-*
-* MODULE: Grass PDE Numerical Library
-* AUTHOR(S): Soeren Gebbert, Berlin (GER) Dec 2006
-* soerengebbert <at> gmx <dot> de
-*
-* PURPOSE: Unit tests for les solving
-*
-* COPYRIGHT: (C) 2000 by the GRASS Development Team
-*
-* This program is free software under the GNU General Public
-* License (>=v2). Read the file COPYING that comes with GRASS
-* for details.
-*
-*****************************************************************************/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <grass/glocale.h>
-#include <grass/N_pde.h>
-#include "test_gpde_lib.h"
-
-/* prototypes */
-static int test_solvers(void);
-static N_les *create_normal_les(int rows);
-static N_les *create_sparse_les(int rows);
-
-/* ************************************************************************* */
-/* Performe the solver unit tests ****************************************** */
-/* ************************************************************************* */
-int unit_test_solvers(void)
-{
- int sum = 0;
-
- G_message(_("\n++ Running solver unit tests ++"));
-
- sum += test_solvers();
-
- if (sum > 0)
- G_warning(_("\n-- Solver unit tests failure --"));
- else
- G_message(_("\n-- Solver unit tests finished successfully --"));
-
- return sum;
-}
-
-/* *************************************************************** */
-/* create a normal matrix with values ** Hilbert matrix ********** */
-/* *************************************************************** */
-N_les *create_normal_les(int rows)
-{
- N_les *les;
- int i, j;
- int size = rows;
- double val;
-
- les = N_alloc_les(rows, N_NORMAL_LES);
- for (i = 0; i < size; i++) {
- val = 0.0;
- for (j = 0; j < size; j++) {
- les->A[i][j] = (double)(1.0 / (((double)i + 1.0) +
- ((double)j + 1.0) - 1.0));
- val += les->A[i][j];
- }
- les->b[i] = val;
- }
-
- return les;
-}
-
-/* *************************************************************** */
-/* create a sparse matrix with values ** Hilbert matrix ********** */
-/* *************************************************************** */
-N_les *create_sparse_les(int rows)
-{
- N_les *les;
- N_spvector *spvector;
- int i, j;
- double val;
-
- les = N_alloc_les(rows, N_SPARSE_LES);
-
- for (i = 0; i < rows; i++) {
- spvector = N_alloc_spvector(rows);
- val = 0;
-
- for (j = 0; j < rows; j++) {
- spvector->values[j] =
- (double)(1.0 / (((double)i + 1.0) + ((double)j + 1.0) - 1.0));
- spvector->index[j] = j;
- val += spvector->values[j];
- }
-
- N_add_spvector_to_les(les, spvector, i);
- les->b[i] = val;
- }
-
-
- return les;
-}
-
-
-/* *************************************************************** */
-/* Test all implemented solvers for sparse and normal matrices *** */
-/* *************************************************************** */
-int test_solvers(void)
-{
- N_les *les;
- N_les *sples;
-
- G_message("\t * testing jacobi solver\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_jacobi(les, 100, 1, 0.1e-4);
- /*N_print_les(les); */
- N_solver_jacobi(sples, 100, 1, 0.1e-4);
- /*N_print_les(sples); */
-
- N_free_les(les);
- N_free_les(sples);
-
-
- G_message("\t * testing SOR solver\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_SOR(les, 100, 1, 0.1e-4);
- /*N_print_les(les); */
- N_solver_SOR(sples, 100, 1, 0.1e-4);
- /*N_print_les(sples); */
-
- N_free_les(les);
- N_free_les(sples);
-
- G_message("\t * testing cg solver\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_cg(les, 100, 0.1e-8);
- /*N_print_les(les); */
- N_solver_cg(sples, 100, 0.1e-8);
- /*N_print_les(sples); */
-
- N_free_les(les);
- N_free_les(sples);
-
- G_message("\t * testing pcg solver with N_DIAGONAL_PRECONDITION\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_pcg(les, 100, 0.1e-8, N_DIAGONAL_PRECONDITION);
- N_print_les(les);
- N_solver_pcg(sples, 100, 0.1e-8, N_DIAGONAL_PRECONDITION);
- N_print_les(sples);
-
- N_free_les(les);
- N_free_les(sples);
-
- G_message
- ("\t * testing pcg solver with N_ROWSCALE_EUKLIDNORM_PRECONDITION\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_pcg(les, 100, 0.1e-8, N_ROWSCALE_EUKLIDNORM_PRECONDITION);
- N_print_les(les);
- N_solver_pcg(sples, 100, 0.1e-8, N_ROWSCALE_EUKLIDNORM_PRECONDITION);
- N_print_les(sples);
-
- N_free_les(les);
- N_free_les(sples);
-
- G_message
- ("\t * testing pcg solver with N_ROWSCALE_ABSSUMNORM_PRECONDITION\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_pcg(les, 100, 0.1e-8, N_ROWSCALE_ABSSUMNORM_PRECONDITION);
- N_print_les(les);
- N_solver_pcg(sples, 100, 0.1e-8, N_ROWSCALE_ABSSUMNORM_PRECONDITION);
- N_print_les(sples);
-
- N_free_les(les);
- N_free_les(sples);
-
-
- G_message("\t * testing bicgstab solver\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
- sples = create_sparse_les(TEST_N_NUM_ROWS);
-
- N_solver_bicgstab(les, 100, 0.1e-8);
- /*N_print_les(les); */
- N_solver_bicgstab(sples, 100, 0.1e-8);
- /*N_print_les(sples); */
-
- N_free_les(les);
- N_free_les(sples);
-
- G_message("\t * testing gauss elimination solver\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
-
- /*GAUSS*/ N_solver_gauss(les);
- N_print_les(les);
-
- N_free_les(les);
-
- G_message("\t * testing lu decomposition solver\n");
-
- les = create_normal_les(TEST_N_NUM_ROWS);
-
- /*LU*/ N_solver_lu(les);
- N_print_les(les);
-
- N_free_les(les);
-
- les = create_normal_les(TEST_N_NUM_ROWS);
-
- /*cholesky */ N_solver_cholesky(les);
- N_print_les(les);
-
- N_free_les(les);
-
-
- return 0;
-}
Modified: grass/trunk/lib/gpde/test/test_tools.c
===================================================================
--- grass/trunk/lib/gpde/test/test_tools.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/lib/gpde/test/test_tools.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -48,149 +48,139 @@
/* *************************************************************** */
int test_mean_calc(void)
{
- double a, b, mean_n, mean, vector, distance, D, weight;
- double v[2];
- double array[10] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 };
- int i;
- int sum = 0;
- char buff1[10];
+ double a, b, mean_n, mean, vector, distance, D, weight;
+ double v[2];
+ double array[10] = {0,0,0,0,0,0,0,0,0,0};
+ int i;
+ int sum = 0;
+ char buff1[10];
- for (i = 0; i < 10; i++)
- array[i] += i;
+ for(i = 0; i < 10; i++)
+ array[i] += i;
- a = 1.0 / 3.0;
- b = 3.0;
- v[0] = a;
- v[1] = b;
+ a = 1.0/3.0;
+ b = 3.0;
+ v[0] = a; v[1] = b;
- /*arith mean */
- mean = N_calc_arith_mean(a, b);
- G_message("N_calc_arith_mean: calc a %g and b %g = %12.18lf", a, b, mean);
- mean_n = N_calc_arith_mean_n(v, 2);
- G_message("N_calc_arith_mean_n: calc a %g and b %g = %12.18lf", v[0],
- v[1], mean_n);
- if (mean != mean_n)
- sum++;
+ /*arith mean*/
+ mean = N_calc_arith_mean(a, b);
+ G_message("N_calc_arith_mean: calc a %g and b %g = %12.18lf", a, b, mean);
+ mean_n = N_calc_arith_mean_n(v, 2);
+ G_message("N_calc_arith_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1], mean_n);
+ if(mean != mean_n)
+ sum++;
- /*geom mean */
- mean = N_calc_geom_mean(a, b);
- G_message("N_calc_geom_mean: calc a %g and b %g = %12.18lf", a, b, mean);
- mean_n = N_calc_geom_mean_n(v, 2);
- G_message("N_calc_geom_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1],
- mean_n);
- if (mean != mean_n)
- sum++;
+ /*geom mean*/
+ mean = N_calc_geom_mean(a, b);
+ G_message("N_calc_geom_mean: calc a %g and b %g = %12.18lf", a, b, mean);
+ mean_n = N_calc_geom_mean_n(v, 2);
+ G_message("N_calc_geom_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1], mean_n);
+ if(mean != mean_n)
+ sum++;
- /*harmonic mean */
- mean = N_calc_harmonic_mean(a, b);
- G_message("N_calc_harmonic_mean: calc a %g and b %g = %12.18lf", a, b,
- mean);
- mean_n = N_calc_harmonic_mean_n(v, 2);
- G_message("N_calc_harmonic_mean_n: calc a %g and b %g = %12.18lf", v[0],
- v[1], mean_n);
- if (mean != mean_n)
- sum++;
- /*null test */
- a = 2;
- b = 0;
- v[0] = a;
- v[1] = b;
- mean = N_calc_harmonic_mean(a, b);
- G_message("N_calc_harmonic_mean: calc a %g and b %g = %12.18lf", a, b,
- mean);
- mean_n = N_calc_harmonic_mean_n(v, 2);
- G_message("N_calc_harmonic_mean_n: calc a %g and b %g = %12.18lf", v[0],
- v[1], mean_n);
- if (mean != mean_n)
- sum++;
+ /*harmonic mean*/
+ mean = N_calc_harmonic_mean(a, b);
+ G_message("N_calc_harmonic_mean: calc a %g and b %g = %12.18lf", a, b, mean);
+ mean_n = N_calc_harmonic_mean_n(v, 2);
+ G_message("N_calc_harmonic_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1], mean_n);
+ if(mean != mean_n)
+ sum++;
+ /*null test*/
+ a = 2;
+ b = 0;
+ v[0] = a; v[1] = b;
+ mean = N_calc_harmonic_mean(a, b);
+ G_message("N_calc_harmonic_mean: calc a %g and b %g = %12.18lf", a, b, mean);
+ mean_n = N_calc_harmonic_mean_n(v, 2);
+ G_message("N_calc_harmonic_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1], mean_n);
+ if(mean != mean_n)
+ sum++;
+
+ /*quadratic mean*/
+ a = 1.0/3.0;
+ b = 3.0;
+ v[0] = a; v[1] = b;
- /*quadratic mean */
- a = 1.0 / 3.0;
- b = 3.0;
- v[0] = a;
- v[1] = b;
+ mean = N_calc_quad_mean(a, b);
+ G_message("N_calc_quad_mean: calc a %g and b %g = %12.18lf", a, b, mean);
+ mean_n = N_calc_quad_mean_n(v, 2);
+ G_message("N_calc_quad_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1], mean_n);
+ if(mean != mean_n)
+ sum++;
- mean = N_calc_quad_mean(a, b);
- G_message("N_calc_quad_mean: calc a %g and b %g = %12.18lf", a, b, mean);
- mean_n = N_calc_quad_mean_n(v, 2);
- G_message("N_calc_quad_mean_n: calc a %g and b %g = %12.18lf", v[0], v[1],
- mean_n);
- if (mean != mean_n)
- sum++;
+ /*Test the full upwind stabailization*/
+ vector= -0.000001;
+ distance = 20;
+ D = 0.000001;
- /*Test the full upwind stabailization */
- vector = -0.000001;
- distance = 20;
- D = 0.000001;
+ weight = N_full_upwinding(vector, distance, D);
+ G_message("N_full_upwinding: vector %g distance %g D %g weight %g\n", vector, distance, D, weight);
- weight = N_full_upwinding(vector, distance, D);
- G_message("N_full_upwinding: vector %g distance %g D %g weight %g\n",
- vector, distance, D, weight);
-
- if (weight != 0) {
+ if(weight != 0)
+ {
G_warning("Error detected in N_full_upwinding");
sum++;
- }
+ }
- vector = 0.000001;
+ vector= 0.000001;
- weight = N_full_upwinding(vector, distance, D);
- G_message("N_full_upwinding: vector %g distance %g D %g weight %g\n",
- vector, distance, D, weight);
- if (weight != 1) {
+ weight = N_full_upwinding(vector, distance, D);
+ G_message("N_full_upwinding: vector %g distance %g D %g weight %g\n", vector, distance, D, weight);
+ if(weight != 1)
+ {
G_warning("Error detected in N_full_upwinding");
sum++;
- }
+ }
- D = 0.0;
+ D = 0.0;
- weight = N_full_upwinding(vector, distance, D);
- G_message("N_full_upwinding: vector %g distance %g D %g weight %g\n",
- vector, distance, D, weight);
- if (weight != 0.5) {
+ weight = N_full_upwinding(vector, distance, D);
+ G_message("N_full_upwinding: vector %g distance %g D %g weight %g\n", vector, distance, D, weight);
+ if(weight != 0.5)
+ {
G_warning("Error detected in N_full_upwinding");
sum++;
- }
+ }
- /*Test the exponential upwind stabailization */
- vector = -0.000001;
- distance = 20;
- D = 0.000001;
+ /*Test the exponential upwind stabailization*/
+ vector= -0.000001;
+ distance = 20;
+ D = 0.000001;
- weight = N_exp_upwinding(vector, distance, D);
- G_message("N_exp_upwinding: vector %g distance %g D %g weight %g\n",
- vector, distance, D, weight);
- sprintf(buff1, "%1.2lf", weight);
- sscanf(buff1, "%lf", &weight);
+ weight = N_exp_upwinding(vector, distance, D);
+ G_message("N_exp_upwinding: vector %g distance %g D %g weight %g\n", vector, distance, D, weight);
+ sprintf(buff1, "%1.2lf", weight);
+ sscanf(buff1, "%lf", &weight);
- if (weight != 0.05) {
+ if(weight != 0.05)
+ {
G_warning("Error detected in N_exp_upwinding");
sum++;
- }
+ }
- vector = 0.000001;
+ vector= 0.000001;
- weight = N_exp_upwinding(vector, distance, D);
- G_message("N_exp_upwinding: vector %g distance %g D %g weight %g\n",
- vector, distance, D, weight);
- sprintf(buff1, "%1.2lf", weight);
- sscanf(buff1, "%lf", &weight);
+ weight = N_exp_upwinding(vector, distance, D);
+ G_message("N_exp_upwinding: vector %g distance %g D %g weight %g\n", vector, distance, D, weight);
+ sprintf(buff1, "%1.2lf", weight);
+ sscanf(buff1, "%lf", &weight);
- if (weight != 0.95) {
+ if(weight != 0.95)
+ {
G_warning("Error detected in N_exp_upwinding");
sum++;
- }
+ }
- D = 0.0;
+ D = 0.0;
- weight = N_exp_upwinding(vector, distance, D);
- G_message("N_exp_upwinding: vector %g distance %g D %g weight %g\n",
- vector, distance, D, weight);
- if (weight != 0.5) {
+ weight = N_exp_upwinding(vector, distance, D);
+ G_message("N_exp_upwinding: vector %g distance %g D %g weight %g\n", vector, distance, D, weight);
+ if(weight != 0.5)
+ {
G_warning("Error detected in N_exp_upwinding");
sum++;
- }
+ }
- return sum;
+ return sum;
}
Property changes on: grass/trunk/lib/vector/Vlib
___________________________________________________________________
Modified: svn:ignore
- *OBJ*
+ *OBJ*
.break_polygons.c.swp
.write.c.swp
Modified: grass/trunk/raster/r.gwflow/Makefile
===================================================================
--- grass/trunk/raster/r.gwflow/Makefile 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/raster/r.gwflow/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -2,8 +2,8 @@
PGM=r.gwflow
-LIBES = $(GPDELIB) $(RASTERLIB) $(GISLIB)
-DEPENDENCIES = $(GPDEDEP) $(RASTERDEP) $(GISDEP)
+LIBES = $(GPDELIB) $(RASTERLIB) $(GISLIB) $(GMATHLIB)
+DEPENDENCIES = $(GPDEDEP) $(RASTERDEP) $(GISDEP) $(GMATHDEP)
include $(MODULE_TOPDIR)/include/Make/Module.make
Modified: grass/trunk/raster/r.gwflow/main.c
===================================================================
--- grass/trunk/raster/r.gwflow/main.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/raster/r.gwflow/main.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -21,6 +21,7 @@
#include <math.h>
#include <grass/gis.h>
#include <grass/raster.h>
+#include <grass/gmath.h>
#include <grass/glocale.h>
#include <grass/N_pde.h>
#include <grass/N_gwflow.h>
@@ -42,9 +43,10 @@
void copy_result(N_array_2d * status, N_array_2d * phead_start,
double *result, struct Cell_head *region,
N_array_2d * target);
+
N_les *create_solve_les(N_geom_data * geom, N_gwflow_data2d * data,
- N_les_callback_2d * call, const char *solver,
- int maxit, double error, double sor);
+ N_les_callback_2d * call, const char *solver, int maxit,
+ double error);
/* ************************************************************************* */
/* Set up the arguments we are expecting ********************************** */
@@ -185,7 +187,6 @@
param.maxit = N_define_standard_option(N_OPT_MAX_ITERATIONS);
param.error = N_define_standard_option(N_OPT_ITERATION_ERROR);
param.solver = N_define_standard_option(N_OPT_SOLVER_SYMM);
- param.sor = N_define_standard_option(N_OPT_SOR_VALUE);
param.sparse = G_define_flag();
param.sparse->key = 's';
@@ -206,7 +207,7 @@
N_les_callback_2d *call = NULL;
double *tmp_vect = NULL;
struct Cell_head region;
- double error, sor, max_norm = 0, tmp;
+ double error, max_norm = 0, tmp;
int maxit, i, inner_count = 0;
char *solver;
int x, y, stat;
@@ -264,15 +265,14 @@
sscanf(param.maxit->answer, "%i", &(maxit));
/*Set the calculation error break criteria */
sscanf(param.error->answer, "%lf", &(error));
- sscanf(param.sor->answer, "%lf", &(sor));
/*set the solver */
solver = param.solver->answer;
- if (strcmp(solver, N_SOLVER_DIRECT_LU) == 0 && param.sparse->answer)
+ if (strcmp(solver, G_MATH_SOLVER_DIRECT_LU) == 0 && param.sparse->answer)
G_fatal_error(_("The direct LU solver do not work with sparse matrices"));
- if (strcmp(solver, N_SOLVER_DIRECT_GAUSS) == 0 && param.sparse->answer)
+ if (strcmp(solver, G_MATH_SOLVER_DIRECT_GAUSS) == 0 && param.sparse->answer)
G_fatal_error(_("The direct Gauss solver do not work with sparse matrices"));
- if (strcmp(solver, N_SOLVER_DIRECT_CHOLESKY) == 0 && param.sparse->answer)
+ if (strcmp(solver, G_MATH_SOLVER_DIRECT_CHOLESKY) == 0 && param.sparse->answer)
G_fatal_error(_("The direct cholesky solver do not work with sparse matrices"));
@@ -364,7 +364,7 @@
/*assemble the linear equation system and solve it */
- les = create_solve_les(geom, data, call, solver, maxit, error, sor);
+ les = create_solve_les(geom, data, call, solver, maxit, error);
/* copy the result into the phead array for output or unconfined calculation */
copy_result(data->status, data->phead_start, les->x, ®ion,
@@ -397,7 +397,7 @@
/*assemble the linear equation system and solve it */
les =
- create_solve_les(geom, data, call, solver, maxit, error, sor);
+ create_solve_les(geom, data, call, solver, maxit, error);
/*calculate the maximum norm of the groundwater height difference */
tmp = 0;
@@ -510,56 +510,46 @@
return;
}
-
/* *************************************************************** */
/* ***** create and solve the linear equation system ************* */
/* *************************************************************** */
N_les *create_solve_les(N_geom_data * geom, N_gwflow_data2d * data,
- N_les_callback_2d * call, const char *solver,
- int maxit, double error, double sor)
+ N_les_callback_2d * call, const char *solver, int maxit,
+ double error)
{
N_les *les;
/*assemble the linear equation system */
if (param.sparse->answer)
- les =
- N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, data->status,
- data->phead, (void *)data, call);
+ les = N_assemble_les_2d_dirichlet(N_SPARSE_LES, geom, data->status, data->phead, (void *)data, call);
else
- les =
- N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status,
- data->phead, (void *)data, call);
+ les = N_assemble_les_2d_dirichlet(N_NORMAL_LES, geom, data->status, data->phead, (void *)data, call);
N_les_integrate_dirichlet_2d(les, geom, data->status, data->phead);
- /*solve the equation system */
- if (strcmp(solver, N_SOLVER_ITERATIVE_JACOBI) == 0)
- N_solver_jacobi(les, maxit, sor, error);
+ /*solve the linear equation system */
+ if(les && les->type == N_NORMAL_LES)
+ {
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_CG) == 0)
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, maxit, error);
- if (strcmp(solver, N_SOLVER_ITERATIVE_SOR) == 0)
- N_solver_SOR(les, maxit, sor, error);
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_PCG) == 0)
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, maxit, error, G_MATH_DIAGONAL_PRECONDITION);
- if (strcmp(solver, N_SOLVER_ITERATIVE_CG) == 0)
- N_solver_cg(les, maxit, error);
+ if (strcmp(solver, G_MATH_SOLVER_DIRECT_CHOLESKY) == 0)
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows, les->rows);
+ } else if (les && les->type == N_SPARSE_LES)
+ {
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_CG) == 0)
+ G_math_solver_sparse_cg(les->Asp, les->x, les->b, les->rows, maxit, error);
- if (strcmp(solver, N_SOLVER_ITERATIVE_PCG) == 0)
- N_solver_pcg(les, maxit, error, N_DIAGONAL_PRECONDITION);
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_PCG) == 0)
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows, maxit, error, G_MATH_DIAGONAL_PRECONDITION);
- if (strcmp(solver, N_SOLVER_ITERATIVE_BICGSTAB) == 0)
- N_solver_bicgstab(les, maxit, error);
-
- if (strcmp(solver, N_SOLVER_DIRECT_LU) == 0)
- N_solver_lu(les);
-
- if (strcmp(solver, N_SOLVER_DIRECT_CHOLESKY) == 0)
- N_solver_cholesky(les);
-
- if (strcmp(solver, N_SOLVER_DIRECT_GAUSS) == 0)
- N_solver_gauss(les);
-
+ }
if (les == NULL)
- G_fatal_error(_("Unable to create and solve the linear equation system"));
+ G_fatal_error(_("Unable to create and solve the linear equation system"));
return les;
}
Modified: grass/trunk/raster/r.gwflow/valid_calc_7x7.sh
===================================================================
--- grass/trunk/raster/r.gwflow/valid_calc_7x7.sh 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/raster/r.gwflow/valid_calc_7x7.sh 2009-10-03 19:05:32 UTC (rev 39389)
@@ -9,15 +9,15 @@
# set the region
g.region res=100 n=700 s=0 w=0 e=700
-r.mapcalc "phead=50"
-r.mapcalc "status=if(col() == 1 || col() == 7 , 2, 1)"
-r.mapcalc "well=if((row() == 4 && col() == 4), -0.1, 0)"
-r.mapcalc "hydcond=0.0005"
-r.mapcalc "recharge=0"
-r.mapcalc "top_conf=20"
-r.mapcalc "bottom=0"
-r.mapcalc "syield=0.0001"
-r.mapcalc "null=0.0"
+r.mapcalc --o expression="phead=50"
+r.mapcalc --o expression="status=if(col() == 1 || col() == 7 , 2, 1)"
+r.mapcalc --o expression="well=if((row() == 4 && col() == 4), -0.1, 0)"
+r.mapcalc --o expression="hydcond=0.0005"
+r.mapcalc --o expression="recharge=0"
+r.mapcalc --o expression="top_conf=20"
+r.mapcalc --o expression="bottom=0"
+r.mapcalc --o expression="syield=0.0001"
+r.mapcalc --o expression="null=0.0"
#First compute the steady state groundwater flow
r.gwflow --o solver=cholesky top=top_conf bottom=bottom phead=phead\
@@ -33,27 +33,15 @@
count=`expr $count + 500`
done
-#create the visualization
-d.mon start=x0
-d.mon select=x0
-d.erase
-d.rast gwresult_conf
-d.rast.num gwresult_conf dp=2
-d.barscale at=1,10 &
-echo "Groundwater flow 10.000s" | d.text size=6 color=black
-
export GRASS_WIDTH=640
export GRASS_HEIGHT=480
#export as png and convert into eps and pdf
export GRASS_TRUECOLOR=TRUE
export GRASS_PNGFILE=valid_calc_7x7.png
-d.mon start=PNG
-d.mon select=PNG
d.rast gwresult_conf
d.rast.num gwresult_conf dp=2
d.barscale at=1,10 &
echo "Groundwater flow 10.000s" | d.text size=6 color=black
-d.mon stop=PNG
convert valid_calc_7x7.png valid_calc_7x7.eps
convert valid_calc_7x7.png valid_calc_7x7.pdf
Modified: grass/trunk/raster/r.gwflow/valid_calc_excavation.sh
===================================================================
--- grass/trunk/raster/r.gwflow/valid_calc_excavation.sh 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/raster/r.gwflow/valid_calc_excavation.sh 2009-10-03 19:05:32 UTC (rev 39389)
@@ -9,20 +9,20 @@
# set the region
g.region res=50 n=950 s=0 w=0 e=2000
-r.mapcalc "phead= if(row() == 19, 5, 3)"
-r.mapcalc "status=if((col() == 1 && row() == 13) ||\
+r.mapcalc --o expression="phead= if(row() == 19, 5, 3)"
+r.mapcalc --o expression="status=if((col() == 1 && row() == 13) ||\
(col() == 1 && row() == 14) ||\
(col() == 2 && row() == 13) ||\
(col() == 2 && row() == 14) ||\
(row() == 19), 2, 1)"
-r.mapcalc "well=0.0"
-r.mapcalc "hydcond=0.001"
-r.mapcalc "recharge=0.000000006"
-r.mapcalc "top=20"
-r.mapcalc "bottom=0"
-r.mapcalc "syield=0.001"
-r.mapcalc "null=0.0"
+r.mapcalc --o expression="well=0.0"
+r.mapcalc --o expression="hydcond=0.001"
+r.mapcalc --o expression="recharge=0.000000006"
+r.mapcalc --o expression="top=20"
+r.mapcalc --o expression="bottom=0"
+r.mapcalc --o expression="syield=0.001"
+r.mapcalc --o expression="null=0.0"
#compute a steady state groundwater flow
r.gwflow --o solver=cholesky top=top bottom=bottom phead=phead \
@@ -34,31 +34,17 @@
#create flow lines
r.flow elevin=gwresult flout=gwresult_flow skip=3 --o
-#create the visualization
-d.mon start=x0
-d.mon select=x0
-d.erase
-d.rast gwresult
-d.vect gwresult_flow render=l color=grey
-d.vect gwresult_contour render=l color=black display=attr,shape attrcol=level lsize=16 lcolor=black
-d.legend at=8,12,15,85 map=gwresult
-d.barscale at=1,10 &
-echo "Groundwater flow steady state" | d.text size=6 color=black
-
export GRASS_WIDTH=640
export GRASS_HEIGHT=480
#export as png and convert into eps and pdf
export GRASS_TRUECOLOR=TRUE
export GRASS_PNGFILE=Excavation_pit.png
-d.mon start=PNG
-d.mon select=PNG
d.rast gwresult
-d.vect gwresult_flow render=l color=grey
-d.vect gwresult_contour render=l color=black display=attr,shape attrcol=level lsize=16 lcolor=black
+d.vect gwresult_flow color=grey
+d.vect gwresult_contour color=black display=attr,shape attrcol=level lsize=16 lcolor=black
d.legend at=8,12,15,85 map=gwresult
d.barscale at=1,10 &
echo "Groundwater flow steady state" | d.text size=6 color=black
-d.mon stop=PNG
convert Excavation_pit.png Excavation_pit.eps
convert Excavation_pit.png Excavation_pit.pdf
Modified: grass/trunk/raster3d/r3.gwflow/Makefile
===================================================================
--- grass/trunk/raster3d/r3.gwflow/Makefile 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/raster3d/r3.gwflow/Makefile 2009-10-03 19:05:32 UTC (rev 39389)
@@ -2,8 +2,8 @@
PGM=r3.gwflow
-LIBES = $(GPDELIB) $(G3DLIB) $(GISLIB)
-DEPENDENCIES = $(GPDEDEP) $(G3DDEP) $(GISDEP)
+LIBES = $(GPDELIB) $(G3DLIB) $(GISLIB) $(GMATHLIB)
+DEPENDENCIES = $(GPDEDEP) $(G3DDEP) $(GISDEP) $(GMATHDEP)
include $(MODULE_TOPDIR)/include/Make/Module.make
Modified: grass/trunk/raster3d/r3.gwflow/main.c
===================================================================
--- grass/trunk/raster3d/r3.gwflow/main.c 2009-10-03 06:57:26 UTC (rev 39388)
+++ grass/trunk/raster3d/r3.gwflow/main.c 2009-10-03 19:05:32 UTC (rev 39389)
@@ -20,6 +20,7 @@
#include <string.h>
#include <grass/gis.h>
#include <grass/G3d.h>
+#include <grass/gmath.h>
#include <grass/glocale.h>
#include <grass/N_pde.h>
#include <grass/N_gwflow.h>
@@ -29,7 +30,7 @@
typedef struct
{
struct Option *output, *phead, *status, *hc_x, *hc_y, *hc_z, *q, *s, *r,
- *vector, *dt, *maxit, *error, *solver, *sor;
+ *vector, *dt, *maxit, *error, *solver;
struct Flag *mask;
struct Flag *sparse;
} paramType;
@@ -37,11 +38,12 @@
paramType param; /*Parameters */
/*- prototypes --------------------------------------------------------------*/
-void set_params(void); /*Fill the paramType structure */
-void write_result(N_array_3d * status, N_array_3d * phead_start,
- N_array_3d * phead, double *result, G3D_Region * region,
- char *name);
+static void set_params(void); /*Fill the paramType structure */
+static void write_result(N_array_3d * status, N_array_3d * phead_start,
+ N_array_3d * phead, double *result,
+ G3D_Region * region, char *name);
+
/* ************************************************************************* */
/* Set up the arguments we are expecting ********************************** */
/* ************************************************************************* */
@@ -60,7 +62,8 @@
param.status->required = YES;
param.status->gisprompt = "old,grid3,3d-raster";
param.status->description =
- _("The status for each cell, = 0 - inactive, 1 - active, 2 - dirichlet");
+ _
+ ("The status for each cell, = 0 - inactive, 1 - active, 2 - dirichlet");
param.hc_x = G_define_option();
param.hc_x->key = "hc_x";
@@ -112,23 +115,23 @@
param.output->type = TYPE_STRING;
param.output->required = YES;
param.output->gisprompt = "new,grid3,3d-raster";
- param.output->description =
- _("The piezometric head result of the numerical calculation will be written to this map");
+ param.output->description = _("The piezometric head result of the numerical calculation will be written to this map");
param.vector = G_define_option();
param.vector->key = "velocity";
param.vector->type = TYPE_STRING;
param.vector->required = NO;
param.vector->gisprompt = "new,grid3,3d-raster";
- param.vector->description =
- _("Calculate the groundwater distance velocity vector field and write the x, y, and z components to maps named name_[xyz]. Name is basename for the new raster3d maps");
+ param.vector->description = _("Calculate the groundwater distance velocity vector field \n"
+ "and write the x, y, and z components to maps named name_[xyz].\n"
+ "Name is basename for the new raster3d maps");
param.dt = N_define_standard_option(N_OPT_CALC_TIME);
param.maxit = N_define_standard_option(N_OPT_MAX_ITERATIONS);
param.error = N_define_standard_option(N_OPT_ITERATION_ERROR);
param.solver = N_define_standard_option(N_OPT_SOLVER_SYMM);
- param.sor = N_define_standard_option(N_OPT_SOR_VALUE);
+ param.solver->options = "cg,pcg,cholesky";
param.mask = G_define_flag();
param.mask->key = 'm';
@@ -136,8 +139,7 @@
param.sparse = G_define_flag();
param.sparse->key = 's';
- param.sparse->description =
- _("Use a sparse linear equation system, only available with iterative solvers");
+ param.sparse->description = _("Use a sparse linear equation system, only available with iterative solvers");
}
/* ************************************************************************* */
@@ -146,19 +148,33 @@
int main(int argc, char *argv[])
{
struct GModule *module = NULL;
+
N_gwflow_data3d *data = NULL;
+
N_geom_data *geom = NULL;
+
N_les *les = NULL;
+
N_les_callback_3d *call = NULL;
+
G3D_Region region;
+
N_gradient_field_3d *field = NULL;
+
N_array_3d *xcomp = NULL;
+
N_array_3d *ycomp = NULL;
+
N_array_3d *zcomp = NULL;
- double error, sor;
+
+ double error;
+
int maxit;
+
const char *solver;
+
int x, y, z, stat;
+
char *buff = NULL;
/* Initialize GRASS */
@@ -167,8 +183,7 @@
module = G_define_module();
G_add_keyword(_("raster3d"));
G_add_keyword(_("voxel"));
- module->description =
- _("Numerical calculation program for transient, confined groundwater flow in three dimensions");
+ module->description = _("Numerical calculation program for transient, confined groundwater flow in three dimensions");
/* Get parameters from user */
set_params();
@@ -181,15 +196,10 @@
sscanf(param.maxit->answer, "%i", &(maxit));
/*Set the calculation error break criteria */
sscanf(param.error->answer, "%lf", &(error));
- sscanf(param.sor->answer, "%lf", &(sor));
/*Set the solver */
solver = param.solver->answer;
- if (strcmp(solver, N_SOLVER_DIRECT_LU) == 0 && param.sparse->answer)
- G_fatal_error(_("The direct LU solver do not work with sparse matrices"));
- if (strcmp(solver, N_SOLVER_DIRECT_GAUSS) == 0 && param.sparse->answer)
- G_fatal_error(_("The direct Gauss solver do not work with sparse matrices"));
- if (strcmp(solver, N_SOLVER_DIRECT_CHOLESKY) == 0 && param.sparse->answer)
+ if (strcmp(solver, G_MATH_SOLVER_DIRECT_CHOLESKY) == 0 && param.sparse->answer)
G_fatal_error(_("The direct cholesky solver do not work with sparse matrices"));
@@ -265,32 +275,28 @@
(void *)data, call);
}
+ if (les && les->type == N_NORMAL_LES) {
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_CG) == 0)
+ G_math_solver_cg(les->A, les->x, les->b, les->rows, maxit, error);
- /*solve the equation system */
- if (strcmp(solver, N_SOLVER_ITERATIVE_JACOBI) == 0)
- N_solver_jacobi(les, maxit, sor, error);
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_PCG) == 0)
+ G_math_solver_pcg(les->A, les->x, les->b, les->rows, maxit, error,
+ G_MATH_DIAGONAL_PRECONDITION);
- if (strcmp(solver, N_SOLVER_ITERATIVE_SOR) == 0)
- N_solver_SOR(les, maxit, sor, error);
+ if (strcmp(solver, G_MATH_SOLVER_DIRECT_CHOLESKY) == 0)
+ G_math_solver_cholesky(les->A, les->x, les->b, les->rows,
+ les->rows);
+ }
+ else if (les && les->type == N_SPARSE_LES) {
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_CG) == 0)
+ G_math_solver_sparse_cg(les->Asp, les->x, les->b, les->rows,
+ maxit, error);
- if (strcmp(solver, N_SOLVER_ITERATIVE_CG) == 0)
- N_solver_cg(les, maxit, error);
+ if (strcmp(solver, G_MATH_SOLVER_ITERATIVE_PCG) == 0)
+ G_math_solver_sparse_pcg(les->Asp, les->x, les->b, les->rows,
+ maxit, error, G_MATH_DIAGONAL_PRECONDITION);
+ }
- if (strcmp(solver, N_SOLVER_ITERATIVE_PCG) == 0)
- N_solver_pcg(les, maxit, error, N_DIAGONAL_PRECONDITION);
-
- if (strcmp(solver, N_SOLVER_ITERATIVE_BICGSTAB) == 0)
- N_solver_bicgstab(les, maxit, error);
-
- if (strcmp(solver, N_SOLVER_DIRECT_LU) == 0)
- N_solver_lu(les);
-
- if (strcmp(solver, N_SOLVER_DIRECT_GAUSS) == 0)
- N_solver_gauss(les);
-
- if (strcmp(solver, N_SOLVER_DIRECT_CHOLESKY) == 0)
- N_solver_cholesky(les);
-
if (les == NULL)
G_fatal_error(_("Unable to create and solve the linear equation system"));
@@ -357,8 +363,11 @@
char *name)
{
void *map = NULL;
+
int changemask = 0;
+
int z, y, x, rows, cols, depths, count, stat;
+
double d1 = 0;
rows = region->rows;
More information about the grass-commit
mailing list