RandomFieldsUtils/0000755000175100001440000000000013074162660013665 5ustar hornikusersRandomFieldsUtils/inst/0000755000175100001440000000000013074063617014644 5ustar hornikusersRandomFieldsUtils/inst/CITATION0000644000175100001440000000122313074063617015777 0ustar hornikuserscitHeader("To cite RandomFieldsUtils in publications use:") year <- sub("-.*", "", meta$Date) note <- sprintf("R package version %s", meta$Version) bibentry(bibtype="Manual", header="For general purposes please refer to", footer="", title = "{RandomFieldsUtils}: Utilites for the Simulation and Analysis of Random Fields", author = c(person("Martin", "Schlather", role=c("cre", "aut")), person("Reinhard", "Furrer", role="ctb"), person("Martin", "Kroll", role="ctb")), year = year, note = note, url = "https://cran.r-project.org/package=RandomFieldsUtils" ) RandomFieldsUtils/inst/include/0000755000175100001440000000000013074063617016267 5ustar hornikusersRandomFieldsUtils/inst/include/Solve.h0000644000175100001440000000343013074063617017530 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_solve_H #define rfutils_solve_H 1 typedef enum InversionMethod { Cholesky, SVD, Eigen, Sparse, NoInversionMethod, // last user available method QR, LU, // currently not propagated NoFurtherInversionMethod, // local values direct_formula, Diagonal // always last one! } InversionMethod; #define SOLVE_METHODS 3 typedef struct solve_storage { int SICH_n, MM_n, workspaceD_n, workspaceU_n, VT_n, U_n, D_n, iwork_n, work_n, w2_n, ipiv_n, workLU_n, pivot_n, xlnz_n, snode_n, xsuper_n, xlindx_n, invp_n, cols_n, rows_n, DD_n, lindx_n, xja_n, lnz_n, w3_n, result_n; //t_cols_n, t_rows_n, t_DD_n; InversionMethod method, newMethods[SOLVE_METHODS]; int nsuper, nnzlindx, size, *iwork, *ipiv, *pivot, *xlnz, *snode, *xsuper, *xlindx, *invp, *cols, *rows, *lindx, *xja; //*t_cols, *t_rows; double *SICH, *MM, *workspaceD, *workspaceU, *VT, *work, *w2, *U, *D, *workLU, *lnz, *DD, *w3, *result, *to_be_deleted; //, *t_DD; } solve_storage; #endif RandomFieldsUtils/inst/include/kleinkram.h0000644000175100001440000001217613074063617020424 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef kleinkram_rfutils_h #define kleinkram_rfutils_h 1 #include "Basic_utils.h" typedef char name_type[][MAXCHAR]; void strcopyN(char *dest, const char *src, int n); usr_bool UsrBool(SEXP p, char *name, int idx); #define INT Integer(el, name, 0) #define LOG Logical(el, name, 0) #define NUM Real(el, name, 0) #define USRLOG UsrBool(el, name, 0) #define CHR Char(el, name) #define STR(X, N) strcopyN(X, CHAR(STRING_ELT(el, 0)), N); #define POS0INT NonNegInteger(el, name) /* better: non-negative */ #define POS0NUM NonNegReal(el, name) #define NEG0NUM NonPosReal(el, name) #define POSINT PositiveInteger(el, name) /* better: non-negative */ #define POSNUM PositiveReal(el, name) SEXP Logic(bool* V, int n, int max) ; SEXP Num(double* V, int n, int max) ; SEXP Int(int *V, int n, int max) ; SEXP Char(const char **V, int n, int max) ; SEXP Mat(double* V, int row, int col, int max); SEXP Mat_t(double* V, int row, int col, int max); SEXP MatInt(int* V, int row, int col, int max) ; SEXP Array3D(int** V, int depth, int row, int col, int max) ; SEXP String(char *V); SEXP Logic(bool* V, int n) ; SEXP Num(double* V, int n) ; SEXP Int(int *V, int n) ; SEXP Char(const char **V, int n) ; SEXP Mat(double* V, int row, int col); SEXP Mat_t(double* V, int row, int col); SEXP MatInt(int* V, int row, int col) ; SEXP Array3D(int** V, int depth, int row, int col) ; SEXP String(char V[][MAXCHAR], int n, int max); SEXP String(int *V, const char * List[], int n, int endvalue); SEXP TooLarge(int *n, int l); SEXP TooSmall(); double Real(SEXP p, char *name, int idx); void Real(SEXP el, char *name, double *vec, int maxn) ; int Integer(SEXP p, char *name, int idx, bool nulltoNA) ; int Integer(SEXP p, char *name, int idx); void Integer(SEXP el, char *name, int *vec, int maxn) ; void Integer2(SEXP el, char *name, int *vec) ; bool Logical(SEXP p, char *name, int idx); char Char(SEXP el, char *name) ; double NonNegInteger(SEXP el, char *name) ; double NonNegReal(SEXP el, char *name) ; double NonPosReal(SEXP el, char *name) ; double PositiveInteger(SEXP el, char *name) ; double PositiveReal(SEXP el, char *name) ; void String(SEXP el, char *name, char names[][MAXCHAR], int maxlen); #define MULTIPLEMATCHING -2 #define NOMATCHING -1 #define MATCHESINTERNAL -3 int Match(char *name, const char * List[], int n); int Match(char *name, name_type List, int n); SEXP ExtendedInteger(double x); SEXP ExtendedBoolean(double x); SEXP ExtendedBooleanUsr(usr_bool x); double XkCXtl(double *X, double *C, int nrow, int dim, int k, int l); void XCXt(double *X, double *C, double *V, int nrow, int dim); void AtA(double *a, int nrow, int ncol, double *A); void xA(double *x, double*A, int nrow, int ncol, double *y); void xA(double *x1, double *x2, double*A, int nrow, int ncol, double *y1, double *y2); void Ax(double *A, double*x, int nrow, int ncol, double *y); void Ax(double *A, double*x1, double*x2, int nrow, int ncol, double *y1, double *y2); double xUy(double *x, double *U, double *y, int dim); double xUxz(double *x, double *U, int dim, double *z); double x_UxPz(double *x, double *U, double *z, int dim); double xUx(double *x, double *U, int dim); void matmult(double *A, double *B, double *C, int l, int m, int n); void matmulttransposed(double *A, double *B, double *C, int m, int l, int n); void matmult_2ndtransp(double *A, double *B, double *C, int m, int l, int n); void matmult_tt(double *A, double *B, double *C, int m, int l, int n); double * matrixmult(double *m1, double *m2, int dim1, int dim2, int dim3); void GetName(SEXP el, char *name, const char * List[], int n, int defaultvalue, int endvalue, int *ans, int maxlen_ans); int GetName(SEXP el, char *name, const char * List[], int n) ; int GetName(SEXP el, char *name, const char * List[], int n, int defaultvalue) ; #define SCALAR_PROD(A, B, N, ANS) { \ int k_ =0, \ end_ = N - 4; \ ANS = 0.0; \ for (; k_ #include #include #include #include "Basic_utils.h" #include "errors_messages.h" #include "kleinkram.h" #include "Solve.h" #define DOPRINTF if (DOPRINT) Rprintf #define PRINTF Rprintf #define print PRINTF /* // */ #ifdef HIDE_UNUSED_VARIABLE #define VARIABLE_IS_NOT_USED __attribute__ ((unused)) #else #ifdef __GNUC__ #define VARIABLE_IS_NOT_USED __attribute__ ((unused)) #else #define VARIABLE_IS_NOT_USED #endif #endif // not SCHLATHERS_MACHINE #ifndef SCHLATHERS_MACHINE #define INTERNAL SERR("Sorry. This functionality does not exist currently. There is work in progress at the moment by the maintainer.") #define assert(X) {} #define BUG { \ SPRINTF(BUG_MSG, "Severe error occured in function '%s' (file '%s', line %d). Please contact maintainer martin.schlather@math.uni-mannheim.de .", \ __FUNCTION__, __FILE__, __LINE__); \ RFERROR(BUG_MSG); \ } #define DO_TESTS false //#define MEMCOPY(A,B,C) {memcpy(A,B,C); printf("memcpy %s %d\n", __FILE__, __LINE__);} #define MEMCOPY(A,B,C) MEMCOPYX(A,B,C) #define MALLOC MALLOCX #define CALLOC CALLOCX #define FREE(X) if ((X) != NULL) {FREEX(X); (X)=NULL;} #define UNCONDFREE(X) {FREEX(X); (X)=NULL;} #endif // not SCHLATHERS_MACHINE // SCHLATHERS_MACHINE #ifdef SCHLATHERS_MACHINE #define MAXALLOC 1e9 // __extension__ unterdrueckt Fehlermeldung wegen geklammerter Argumente #define INTERNAL \ SPRINTF(BUG_MSG, \ "made to be an internal function '%s' ('%s', line %d).", /* // */ \ __FUNCTION__, __FILE__, __LINE__); \ /* warning(BUG_MSG) */ \ SERR(BUG_MSG) #define assert(X) if (!__extension__ (X)) { \ SPRINTF(BUG_MSG,"'assert(%s)' failed in function '%s'.",#X,__FUNCTION__); \ ERR(BUG_MSG); \ } #define SHOW_ADDRESSES 1 #define BUG { PRINTF("BUG in '%s'.", __FUNCTION__); ERR(BUG_MSG); } #define DO_TESTS true #define MEMCOPY(A,B,C) __extension__ ({ assert((A)!=NULL && (B)!=NULL); MEMCOPYX(A,B,C); }) //#define MEMCOPY(A,B,C) memory_copy(A, B, C) #define MALLOC(X) __extension__ ({assert((X)>0 && (X)<=MAXALLOC); MALLOCX(X);}) #define CALLOC(X, Y) __extension__({assert((X)>0 && (X)<=MAXALLOC && (Y)>0 && (Y)<=64); CALLOCX(X,Y);}) #define FREE(X) { if ((X) != NULL) {if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;}} #define UNCONDFREE(X) { if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;} #endif // SCHLATHERS_MACHINE #ifdef RANDOMFIELDS_DEBUGGING #undef MALLOC #define MALLOC(X) __extension__({DOPRINTF("(MALL %s, line %d)\n", __FILE__, __LINE__);assert((X)>0 && (X)<=3e9); MALLOCX(X);}) // #undef CALLOC #define CALLOC(X, Y) __extension__({DOPRINTF("(CALL %s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)0 && (Y)<=64); CALLOCX(X,Y);}) //#define MALLOC malloc //#define CALLOC calloc #define DEBUGINFOERR { \ errorstring_type dummy_; strcpy(dummy_, ERRORSTRING); \ SPRINTF(ERRORSTRING, "%s (%s, line %d)\n", dummy_, __FILE__, __LINE__); \ } #define DEBUGINFO DOPRINTF("(currently at %s, line %d)\n", __FILE__, __LINE__) #else #define DEBUGINFO #define DEBUGINFOERR if (PL >= PL_ERRORS) PRINTF("error: %s\n", ERRORSTRING); #endif #define PL_IMPORTANT 1 #define PL_BRANCHING 2 #define PL_DETAILSUSER 3 #define PL_RECURSIVE 4 #define PL_STRUCTURE 5 // see also initNerror.ERROROUTOFMETHOD #define PL_ERRORS 6 // only those that are caught internally #define PL_FCTN_DETAILS 7 // R #define PL_FCTN_SUBDETAILS 8 #define PL_COV_STRUCTURE 7 // C #define PL_DIRECT_SEQU 8 #define PL_DETAILS 9 #define PL_SUBDETAILS 10 #define MATERN_NU_THRES 100 #endif RandomFieldsUtils/inst/include/errors_messages.h0000644000175100001440000001366613074063617021657 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ // Datei wi #ifndef rfutils_error_H #define rfutils_error_H 1 #define NOERROR 0 #define ERRORMEMORYALLOCATION 1 #define ERRORFAILED 2 /* method didn't work for the specified parameters */ #define ERRORM 3 /* a single error message */ #define ERRORNOTPROGRAMMEDYET 4 #ifdef SCHLATHERS_MACHINE #define ERRLINE PRINTF("(ERROR in %s, line %d)\n", __FILE__, __LINE__); #else #define ERRLINE #endif #define LENMSG 250 #define MAXERRORSTRING 1000 #define nErrorLoc 1000 #define LENERRMSG 2000 typedef char errorstring_type[MAXERRORSTRING]; typedef char errorloc_type[nErrorLoc]; extern char ERRMSG[LENERRMSG], // used by Error_utils.h. Never use elsewhere MSG[LENERRMSG], // used by RandomFields in intermediate steps BUG_MSG[LENMSG],// not much used MSG2[LENERRMSG];// used at the same time with MSG and ERR() extern errorstring_type ERRORSTRING; // used by ERRORM in RandomFields extern errorloc_type ERROR_LOC; #define ERRMSG(X) if (PL>=PL_ERRORS){errorMSG(X,MSG); PRINTF("error: %s%s\n",ERROR_LOC,MSG);} #define RFERROR error #define ERR(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFERROR(ERRMSG);} #define ERR1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y); \ RFERROR(MSG2);} #define ERR2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\ SPRINTF(MSG2, ERRMSG, Y, Z); \ RFERROR(MSG2);} #define ERR3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A); \ RFERROR(MSG2);} #define ERR4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \ RFERROR(MSG2);} #define ERR5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \ RFERROR(MSG2);} #define ERR6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \ RFERROR(MSG2);} #define ERR7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \ RFERROR(MSG2);} #define ERR8(X,Y,Z,A,B,C,D,E,F) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E, F); \ RFERROR(MSG2);} #define FERR(X) strcpy(ERRORSTRING, X); DEBUGINFOERR #define SERR(X) { FERR(X); return ERRORM;} #define CERR(X) { FERR(X); err=ERRORM; continue;} #define FERR1(X,Y) SPRINTF(ERRORSTRING, X, Y); DEBUGINFOERR #define SERR1(X,Y) { FERR1(X, Y); return ERRORM;} #define CERR1(X,Y) { FERR1(X, Y); err=ERRORM; continue; } #define FERR2(X,Y,Z) SPRINTF(ERRORSTRING, X, Y, Z); DEBUGINFOERR #define SERR2(X, Y, Z) { FERR2(X, Y, Z); return ERRORM;} #define CERR2(X, Y, Z) { FERR2(X, Y, Z); err=ERRORM; continue;} #define FERR3(X,Y,Z,A) SPRINTF(ERRORSTRING, X, Y, Z, A); DEBUGINFOERR #define SERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); return ERRORM;} #define CERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); err=ERRORM; continue;} #define FERR4(X,Y,Z,A,B) SPRINTF(ERRORSTRING, X, Y, Z, A, B); DEBUGINFOERR #define SERR4(X, Y, Z, A, B) { FERR4(X, Y, Z, A, B); return ERRORM;} #define FERR5(X,Y,Z,A,B,C) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C); DEBUGINFOERR #define SERR5(X, Y, Z, A, B, C) {FERR5(X, Y, Z, A, B, C); return ERRORM;} #define FERR6(X,Y,Z,A,B,C,D) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D); DEBUGINFOERR #define SERR6(X, Y, Z, A, B, C, D) {FERR6(X, Y, Z, A, B, C,D); return ERRORM;} #define FERR7(X,Y,Z,A,B,C,D,E) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D,E);DEBUGINFOERR #define SERR7(X, Y, Z, A, B, C, D, E) {FERR7(X,Y,Z,A,B,C,D,E); return ERRORM;} #define GERR(X) {FERR(X); err = ERRORM; goto ErrorHandling;} #define GERR1(X,Y) {FERR1(X,Y);err = ERRORM; goto ErrorHandling;} #define GERR2(X,Y,Z) {FERR2(X,Y,Z); err = ERRORM; goto ErrorHandling;} #define GERR3(X,Y,Z,A) {FERR3(X,Y,Z,A); err = ERRORM; goto ErrorHandling;} #define GERR4(X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); err = ERRORM; goto ErrorHandling;} #define GERR5(X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); err=ERRORM; goto ErrorHandling;} #define GERR6(X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); err=ERRORM; goto ErrorHandling;} #define RFWARNING warning #define warn(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFWARNING(ERRMSG);} #define WARN1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y); \ RFWARNING(MSG2);} #define WARN2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\ SPRINTF(MSG2, ERRMSG, Y, Z); \ RFWARNING(MSG2);} #define WARN3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A); \ RFWARNING(MSG2);} #define WARN4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \ RFWARNING(MSG2);} #define WARN5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \ RFWARNING(MSG2);} #define WARN6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \ RFWARNING(MSG2);} #define WARN7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \ RFWARNING(MSG2);} #endif RandomFieldsUtils/inst/include/Options_utils.h0000644000175100001440000000502513074063617021315 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_options_H #define rfutils_options_H 1 #include #include #include "Basic_utils.h" #include "Solve.h" #define R_PRINTLEVEL 1 #define C_PRINTLEVEL 1 extern int PL; #define LEN_OPTIONNAME 201 #define basicN 7 // IMPORTANT: all names of basic must be at least 3 letters long !!! extern const char *basic[basicN]; typedef struct basic_param { bool skipchecks, asList; int Rprintlevel, Cprintlevel, seed, cores; } basic_param; #define basic_START \ { false, true, \ R_PRINTLEVEL, C_PRINTLEVEL, NA_INTEGER, 1 \ } #define nr_InversionMethods ((int) Diagonal + 1) #define nr_user_InversionMethods ((int) NoInversionMethod + 1) extern const char * InversionNames[nr_InversionMethods]; #define PIVOT_NONE 0 #define PIVOT_MMD 1 #define PIVOT_RCM 2 #define SOLVE_SVD_TOL 3 #define solveN 12 typedef struct solve_param { usr_bool sparse; double spam_tol, spam_min_p, svd_tol, eigen2zero; InversionMethod Methods[SOLVE_METHODS]; int spam_min_n, spam_sample_n, spam_factor, pivot, max_chol, max_svd; // bool tmp_delete; } solve_param; #ifdef SCHLATHERS_MACHINE #define svd_tol_start 1e-08 #else #define svd_tol_start 0 #endif #define solve_START \ { Nan, DBL_EPSILON, 0.8, svd_tol_start, 1e-12, \ {NoInversionMethod, NoInversionMethod}, \ 400, 500, 4294967, PIVOT_MMD, 16384, 10000} extern const char * solve[solveN]; typedef struct utilsparam{ basic_param basic; solve_param solve; } utilsparam; typedef void (*setparameterfct) (int, int, SEXP, char[200], bool); typedef void (*getparameterfct) (SEXP*); typedef void (*finalsetparameterfct) (); #define ADD(ELT) SET_VECTOR_ELT(sublist[i], k++, ELT); #define ADDCHAR(ELT) x[0] = ELT; ADD(ScalarString(mkChar(x))); #endif RandomFieldsUtils/inst/include/Basic_utils.h0000644000175100001440000001057313074063617020707 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef basic_rfutils_h #define basic_rfutils_h 1 #ifndef __cplusplus #include #endif #include #include #ifdef _OPENMP #define DO_PARALLEL 1 #else #ifdef DO_PARALLEL #undef DO_PARALLEL #endif #endif #define MULTIMINSIZE(S) ((S) > 20) // #define MULTIMINSIZE(S) false // #define MULTIMINSIZE(S) true #ifndef showfree #define showfree !true #endif #define DOPRINT true // #define SCHLATHERS_MACHINE 1 // // 1 // #define HIDE_UNUSED_VARIABLE 1 #ifdef __cplusplus extern "C" { #endif // Fortran Code by Reinhard Furrer void spamcsrdns_(int*, double *, int *, int*, double*); void spamdnscsr_(int*, int*, double *, int*, double*, int*, int*, double*); void cholstepwise_(int*, int*, double*, int*, int*, int*, int*, int*, int*, int*, int*, int*, int*, int*, double*, int*, int*, int*, int*, int*); void backsolves_(int*, int*, int*, int*, int*, double*, int*, int*, int*, int*, double*, double*); void calcja_(int*, int*, int*, int*, int*, int*, int*); void amuxmat_(int*, int*, int*, double*, double*, double*, int*, int*); // void transpose_(int *, int *, double *, int * int *, double*, int*, int*); // void spamback_(); // void spamforward(); #ifdef __cplusplus } #endif typedef enum usr_bool { // NOTE: if more options are included, change ExtendedBoolean in // userinterface.cc of RandomFields False=false, True=true, //Exception=2, // for internal use only Nan=INT_MIN } usr_bool; #define RF_NA NA_REAL #define RF_NAN R_NaN #define RF_NEGINF R_NegInf #define RF_INF R_PosInf #define T_PI M_2_PI #define MAXUNITS 4 #define MAXCHAR 18 // max number of characters for (covariance) names #define OBSOLETENAME "obsolete" #define RFOPTIONS "RFoptions" #define MAXINT 2147483647 #define INFDIM MAXINT #define INFTY INFDIM #define LENGTH length // safety, in order not to use LENGTH defined by R #define complex Rcomplex #define DOT "." #define GAUSS_RANDOM(SIGMA) rnorm(0.0, SIGMA) #define UNIFORM_RANDOM unif_rand() #define POISSON_RANDOM(x) rpois(x) #define SQRT2 M_SQRT2 #define SQRTPI M_SQRT_PI #define INVPI M_1_PI #define PIHALF M_PI_2 #define ONETHIRD 0.333333333333333333333333 #define TWOTHIRD 0.6666666666666666666666667 #define TWOPI 6.283185307179586476925286766559 #define INVLOG2 1.442695040888963 #define INVSQRTTWO 0.70710678118654752440084436210 #define INVSQRTTWOPI 0.39894228040143270286 #define SQRTTWOPI 2.5066282746310002416 #define SQRTINVLOG005 0.5777613700268771079749 //#define LOG05 -0.69314718055994528623 #define LOG3 1.0986122886681096913952452369225257046474905578227 #define LOG2 M_LN2 #define EPSILON 0.00000000001 #define EPSILON1000 0.000000001 #define MIN(A,B) ((A) < (B) ? (A) : (B)) #define MAX(A,B) ((A) > (B) ? (A) : (B)) #define ACOS(X) std::acos(X) #define ASIN(X) std::asin(X) #define ATAN(X) std::atan(X) #define CEIL(X) std::ceil((double) X) // keine Klammern um X! #define COS(X) std::cos(X) #define EXP(X) std::exp(X) #define FABS(X) std::fabs((double) X) // keine Klammern um X! #define FLOOR(X) std::floor(X) #define Log(X) std::log(X) #define POW(X, Y) R_pow((double) X, (double) Y) // keine Klammern um X! #define SIN(X) std::sin(X) #define SQRT(X) std::sqrt((double) X) #define STRCMP(A, B) std::strcmp(A, B) #define STRCPY(A, B) std::strcpy(A, B) #define STRLEN(X) std::strlen(X) #define STRNCMP(A, B, C) std::strncmp(A, B, C) #define TAN(X) std::tan(X) #define MEMCOPYX std::memcpy #define CALLOCX std::calloc #define MALLOCX std::malloc #define FREEX std::free #define SPRINTF std::sprintf // #define ROUND(X) std::round(X) #define TRUNC(X) ftrunc((double) X) // keine Klammern um X! #define QSORT std::qsort #endif RandomFieldsUtils/src/0000755000175100001440000000000013074063617014456 5ustar hornikusersRandomFieldsUtils/src/own.h0000644000175100001440000000221713074063617015434 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_own_H #define rfutil_own_H 1 #include "Options_utils.h" void setparameterUtils(int i, int j, SEXP el, char name[200], bool isList); void getparameterUtils(SEXP *sublist); void set_num_threads(); extern utilsparam GLOBAL; #define ownprefixN 2 extern const char * ownprefixlist[ownprefixN], **ownall[ownprefixN]; extern int ownallN[ownprefixN]; #endif RandomFieldsUtils/src/Makevars0000644000175100001440000000016413074063617016153 0ustar hornikusersPKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) RandomFieldsUtils/src/win_linux_aux.cc0000644000175100001440000000334413074063617017662 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Collection of system specific auxiliary functions Copyright (C) 2001 -- 2015 Martin Schlather, This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 PURSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifdef WIN32 // #define WIN32_LEAN_AND_MEAN #define VC_EXTRALEAN #include #endif // achtung! windows.h zusammen mit // gibt warnung, da ERROR mehrfach definiert ! // deshalb auch in auxiliary.h nicht basic.h einbinden // obsolette ?!! #include #include #include "win_linux_aux.h" /* #include #include #include #include "RF.h" #include */ void sleepMilli(int *milli) { #ifdef WIN32 Sleep((long) *milli); #else usleep((useconds_t) (1000 * (unsigned long) *milli)); #endif } void sleepMicro(int *micro) { #ifdef WIN32 Sleep((long) ((*micro + 500) / 1000)); #else usleep((useconds_t) *micro); #endif } void pid(int *i) { #ifndef WIN32 *i = getpid(); #else *i = 0; #endif } void hostname(char **h, int *i){ #ifdef WIN32 *h[0]=0; #else gethostname(*h, *i); #endif } RandomFieldsUtils/src/Solve.h0000644000175100001440000000343013074063617015717 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_solve_H #define rfutils_solve_H 1 typedef enum InversionMethod { Cholesky, SVD, Eigen, Sparse, NoInversionMethod, // last user available method QR, LU, // currently not propagated NoFurtherInversionMethod, // local values direct_formula, Diagonal // always last one! } InversionMethod; #define SOLVE_METHODS 3 typedef struct solve_storage { int SICH_n, MM_n, workspaceD_n, workspaceU_n, VT_n, U_n, D_n, iwork_n, work_n, w2_n, ipiv_n, workLU_n, pivot_n, xlnz_n, snode_n, xsuper_n, xlindx_n, invp_n, cols_n, rows_n, DD_n, lindx_n, xja_n, lnz_n, w3_n, result_n; //t_cols_n, t_rows_n, t_DD_n; InversionMethod method, newMethods[SOLVE_METHODS]; int nsuper, nnzlindx, size, *iwork, *ipiv, *pivot, *xlnz, *snode, *xsuper, *xlindx, *invp, *cols, *rows, *lindx, *xja; //*t_cols, *t_rows; double *SICH, *MM, *workspaceD, *workspaceU, *VT, *work, *w2, *U, *D, *workLU, *lnz, *DD, *w3, *result, *to_be_deleted; //, *t_DD; } solve_storage; #endif RandomFieldsUtils/src/RFoptions.cc0000644000175100001440000002520013074063617016707 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2016 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "RandomFieldsUtils.h" #include "General_utils.h" #include "own.h" #include "init_RandomFieldsUtils.h" void setpDef(int VARIABLE_IS_NOT_USED i, int VARIABLE_IS_NOT_USED j, SEXP VARIABLE_IS_NOT_USED el, char VARIABLE_IS_NOT_USED name[LEN_OPTIONNAME], bool VARIABLE_IS_NOT_USED isList) { BUG; } void getpDef(SEXP VARIABLE_IS_NOT_USED *sublist) { BUG; } bool RELAX_UNKNOWN_RFOPTION=false; // auf keinen Fall aendern! void relaxUnknownRFoption(bool relax){ RELAX_UNKNOWN_RFOPTION = relax; } void RelaxUnknownRFoption(int *relax){ relaxUnknownRFoption((bool) *relax); } #define MAXNLIST 5 int NList = 0; // originally 1 int AllprefixN[MAXNLIST] = {ownprefixN, 0, 0, 0, 0}, *AllallN[MAXNLIST] = {ownallN, NULL, NULL, NULL, NULL}; const char **Allprefix[MAXNLIST] = {ownprefixlist, NULL, NULL, NULL, NULL}, ***Allall[MAXNLIST] = { ownall, NULL, NULL, NULL, NULL}; setparameterfct setparam[MAXNLIST] = {setparameterUtils, setpDef, setpDef, setpDef, setpDef}; getparameterfct getparam[MAXNLIST] = {getparameterUtils, getpDef, getpDef, getpDef, getpDef}; finalsetparameterfct finalparam[MAXNLIST] = { NULL, NULL, NULL, NULL, NULL }; void setparameter(SEXP el, char *prefix, char *mainname, bool isList) { int j = NOMATCHING, i = NOMATCHING, ListNr = NOMATCHING; char name[LEN_OPTIONNAME]; SPRINTF(name, "%s%s%s", prefix, strlen(prefix)==0 ? "" : ".", mainname); // print("set param: %s.%s.%s\n",prefix, strlen(prefix)==0 ? "" : ".", mainname); // print("relax=%d\n", RELAX_UNKNOWN_RFOPTION); if (mainname[0] >= 'A' && mainname[0] <= 'Z' && RELAX_UNKNOWN_RFOPTION) { if (PL > PL_IMPORTANT) PRINTF("'%s' is not considered as an RFoption, but will be passed to evaluate the model formula.\n", mainname); return; } if (STRCMP(prefix, "")) { for (ListNr=0; ListNr= 0 && STRCMP(prefix, Allprefix[k][ii])==0) { ListNr = k; i = ii; break; } // ii >0 } // for k if (i == MULTIPLEMATCHING) ERR1("option prefix name '%s' is ambiguous.", prefix); } // prefix == List // printf("ListNr = %d %s %d %s\n", ListNr, Allprefix[ListNr][i], i, // mainname); j = Match(mainname, Allall[ListNr][i], AllallN[ListNr][i]); } else { // (i==0), no prefix given #define MinNameLength 3 for (ListNr=0; ListNr=0 ? Allall[ListNr][i][j] : "multi"); if (j < 0 || STRCMP(mainname, Allall[ListNr][i][j])) { int starti = i + 1; for (int k = ListNr; k= 0 && STRCMP(mainname, Allall[k][ii][jj])==0) { ListNr = k; i = ii; j = jj; break; } // jj } // for ii if (j >= 0) break; } // for k } // if j < 0 || != } // no prefix given if (j<0) ERR1("Multiple matching for '%s'.", name); // printf("%s %d %d %d %ld \n", name, ListNr, i, j, (long) setparam[ListNr]); setparam[ListNr](i, j, el, name, isList); } SEXP getRFoptions() { SEXP list, names; int i, ListNr, itot = 0, k = 0; int trueprefixN, totalN; for (totalN=ListNr=0; ListNr 0) PRINTF("options starting with prefix '%s' have been already attached.", prefixlist[0]); return; } } if (NList >= MAXNLIST) BUG; Allprefix[NList] = prefixlist; AllprefixN[NList] = N; Allall[NList] = all; AllallN[NList] = allN; setparam[NList] = set; finalparam[NList] = final; getparam[NList] = get; NList++; } void detachRFoptions(const char **prefixlist, int N) { int ListNr; for (ListNr=0; ListNr= NList) { ERR1("options starting with prefix '%s' have been already attached.", prefixlist[0]); } for (ListNr++; ListNr #include "General_utils.h" #include "kleinkram.h" void strcopyN(char *dest, const char *src, int n) { if (n > 1) { n--; strncpy(dest, src, n); } dest[n] = '\0'; } double scalar(double *A, double *B, int N) { double ANS; SCALAR_PROD(A, B, N, ANS); return ANS; } void AtA(double *a, int nrow, int ncol, double *C) { // C = A^T %*% A #ifdef DO_PARALLEL //#pragma omp parallel for num_threads(2) schedule(dynamic) if (MULTIMINSIZE(ncol)) #pragma omp parallel for schedule(dynamic) if (MULTIMINSIZE(ncol)) #endif for (int i=0; imax) return TooLarge(&n, 1); if (n<0) return TooSmall(); PROTECT(dummy=allocVector(INTSXP, n)); for (int i=0; imax) return TooLarge(&n, 1); if (n<0) return TooSmall(); PROTECT(dummy=allocVector(LGLSXP, n)); for (int i=0; imax) return TooLarge(&n, 1); if (n<0) return TooSmall(); PROTECT(dummy=allocVector(REALSXP, n)); for (int i=0; imax) return TooLarge(&n, 1); if (n<0) return TooSmall(); PROTECT(dummy=allocVector(REALSXP, n)); for (int i=0; imax) return TooLarge(&n, 1); if (n<0) return TooSmall(); PROTECT(dummy=allocVector(STRSXP, n)); for (int i=0; imax) { int nn[2]; nn[0] = row; nn[1] = col; return TooLarge(nn, 2); } SEXP dummy; PROTECT(dummy=allocMatrix(REALSXP, row, col)); for (int i=0; imax) { int nn[2]; nn[0] = row; nn[1] = col; return TooLarge(nn, 2); } SEXP dummy; PROTECT(dummy=allocMatrix(REALSXP, row, col)); for (int k=0, j=0; jmax) { int nn[2]; nn[0] = row; nn[1] = col; return TooLarge(nn, 2); } SEXP dummy; PROTECT(dummy=allocMatrix(INTSXP, row, col)); for (int i=0; imax) { int nn[3]; nn[0] = row; nn[1] = col; nn[2] = depth; return TooLarge(nn, 3); } SEXP dummy; PROTECT(dummy=alloc3DArray(REALSXP, depth, row, col)); for (int j=0; jmax) return TooLarge(&n, 1); if (n<0) return TooSmall(); PROTECT(str = allocVector(STRSXP, n)); for (int i=0; i= n) j=0; } return; } int Integer(SEXP p, char *name, int idx, bool nulltoNA) { if (p != R_NilValue) { assert(idx < length(p)); switch(TYPEOF(p)) { case INTSXP : return INTEGER(p)[idx]; case REALSXP : double value; value = REAL(p)[idx]; if (ISNAN(value)) { return NA_INTEGER; } if (value == TRUNC(value)) return (int) value; else { ERR2("%s: integer value expected. Got %e.", name, value); } case LGLSXP : return LOGICAL(p)[idx]==NA_LOGICAL ? NA_INTEGER : (int) LOGICAL(p)[idx]; default : {} } } else if (nulltoNA) return NA_INTEGER; ERR2("%s: unmatched type of parameter [type=%d]", name, TYPEOF(p)); return NA_INTEGER; // compiler warning vermeiden } int Integer(SEXP p, char *name, int idx) { return Integer(p, name, idx, false); } void Integer(SEXP el, char *name, int *vec, int maxn) { if (el == R_NilValue) { ERR1("'%s' cannot be transformed to integer.\n",name); } int n = length(el); for (int j=0, i=0; i= n) j=0; } } void Integer2(SEXP el, char *name, int *vec) { int n; if (el == R_NilValue || (n = length(el))==0) { ERR1("'%s' cannot be transformed to integer.\n",name); } vec[0] = Integer(el, name, 0); if (n==1) vec[1] = vec[0]; else { vec[1] = Integer(el, name, n-1); if (n > 2) { int v = vec[0] + 1; for (int i = 1; i maxlen) { ERR1("number of variable names exceeds %d. Take abbreviations?", maxlen); } type = TYPEOF(el); // printf("type=%d %d %d %d\n", TYPEOF(el), INTSXP, REALSXP, LGLSXP); if (type == CHARSXP) { for (int i=0; i0.0) { num=0.0; WARN1("%s which has been positive is set 0.\n",name); } return num; } double PositiveInteger(SEXP el, char *name) { int num; num = INT; if (num<=0) { num=0; WARN1("'%s' which has been negative is set 0.\n",name); } return num; } double PositiveReal(SEXP el, char *name) { double num; num = NUM; if (num<=0.0) { num=0.0; WARN1("%s which has been negative is set 0.\n",name); } return num; } SEXP ExtendedInteger(double x) { return ScalarInteger(R_FINITE(x) ? x : NA_INTEGER); } SEXP ExtendedBoolean(double x) { return ScalarLogical(ISNAN(x) ? NA_LOGICAL : x != 0.0); } SEXP ExtendedBooleanUsr(usr_bool x) { return ScalarLogical((int) x); } int Match(char *name, name_type List, int n) { // == -1 if no matching name is found // == -2 if multiple matching names are found, without one matching exactly unsigned int ln; int Nr; Nr=0; ln=strlen(name); // print("Match %d %d %s %s %d\n", Nr, n, name, List[Nr], ln); while ( Nr < n && strncmp(name, List[Nr], ln)) { Nr++; } if (Nr < n) { if (ln==strlen(List[Nr])) // exactmatching -- take first -- changed 1/7/07 return Nr; // a matching function is found. Are there other functions that match? int j; bool multiplematching=false; j=Nr+1; // if two or more covariance functions have the same name // the last one is taken while (j maxlen_ans) ERR2("option '%s' is too long. Maximum length is %d.", name, maxlen_ans); if (TYPEOF(el) == STRSXP) { for (k=0; k= 0) { ans[0] = defaultvalue; for (k=1; k nnzlmax when calling sfinit c 5 -- nsub > nsubmax when calling sfinit c 6 -- insufficient work space in iwork when calling symfct c 7 -- inconsistancy in input when calling symfct c 8 -- tmpsiz > tmpmax when calling symfct; increase tmpmax c 9 -- nonpositive diagonal encountered when calling c blkfct c 10 -- insufficient work storage in tmpvec when calling c blkfct c 11 -- insufficient work storage in iwork when calling c blkfct c OUTPUT: c y -- an m-vector of least squares solution c nsub -- number of subscripts in lindx c WORK ARRAYS: c adjncy -- the indices of non diag elements c iwsiz -- set at 7*m+3 c iwork -- an iwsiz-vector of integer as work space c c implicit none integer m,nnzd,doperm integer nsub,nsuper,nnzl,iwsiz,tmpsiz, & nnzlmax,nsubmax,cachsz,ierr, & adj(m+1),adjncy(nnzd-m+1),jd(nnzd), c fix introduced in 29-3 c & adj(m+1),adjncy(nnzd-m),jd(nnzd), & id(m+1),lindx(nsubmax),xlindx(m+1), & invp(m),perm(m),xlnz(m+1), & colcnt(m),snode(m),xsuper(m+1),split(m) double precision d(nnzd),lnz(nnzlmax) c temp and working stuff, loops, etc integer i,j,k, nnzadj, jtmp integer iwork(7*m+3) c iwsiz is used temporalily iwsiz=0 c Create the adjacency matrix: eliminate the diagonal elements from c (d,id,jd) and make two copies: (*,xlindx,lindx),(*,adj,adjncy) c Also to lindx and xlindx, because the matrix structure is destroyed c by the minimum degree ordering routine. nsub = 0 c the adj matrix has m elements less than d nnzadj = nnzd - m k=1 do i=1,m c copy id, but ajust for the missing diagonal. xlindx(i) = id(i)-i+1 adj(i) = xlindx(i) c now cycle over all rows do j=id(i),id(i+1)-1 jtmp=jd(j) if (jtmp.ne.i) then lindx(k) = jtmp adjncy(k) = jtmp k=k+1 else if ( d(j) .le. 0) then ierr = 1 return endif iwsiz = iwsiz + 1 endif enddo enddo jtmp=m+1 xlindx(jtmp) = id(jtmp)-m adj(jtmp) = xlindx(jtmp) c check if we actually had m elements on the diagonal... if ( iwsiz .lt. m) then ierr = 1 return endif c initialize iwsiz to the later used value... iwsiz=7*m+3 c c c reorder the matrix using minimum degree ordering routine. c we call the genmmd function directly (do not pass via ordmmd). if (doperm.eq.1) then c delta - tolerance value for multiple elimination. c set to 0 below c maxint - maximum machine representable (short) integer c (any smaller estimate will do) for marking c nodes. c set to 32767 below call genmmd ( m, xlindx,lindx, invp,perm,0, 1 iwork(1), iwork(m+1), iwork(2*m+1), iwork(3*m+1) , 1 32767, nsub ) endif if (doperm.eq.2) then call genrcm ( m, nnzadj, xlindx,lindx, perm ) do i=1,m invp(perm(i))=i enddo endif if (doperm.eq.0) then do i=1,m invp(perm(i))=i enddo endif c c Call sfinit: Symbolic factorization initialization c to compute supernode partition and storage requirements c for symbolic factorization. New ordering is a postordering c of the nodal elimination tree c call sfinit(m,nnzadj,adj(1),adjncy(1),perm, & invp,colcnt,nnzl,nsub,nsuper,snode,xsuper,iwsiz, & iwork,ierr) c we do not have to test ierr, as we have hardwired iwsiz to 7*m+3 if (nnzl .gt. nnzlmax) then ierr = 4 go to 100 endif if (nsub .gt. nsubmax) then ierr = 5 go to 100 endif c c Call symfct: Perform supernodal symbolic factorization c iwsiz = nsuper + 2 * m + 1 call symfc2(m,nnzadj,adj(1),adjncy(1),perm,invp, & colcnt,nsuper,xsuper,snode,nsub,xlindx,lindx, & xlnz, & iwork(1), iwork(nsuper+1), iwork(nsuper+m+2) ,ierr) c ierr = -2 "inconsistency in the input" if (ierr .eq. -2) then ierr = 6 go to 100 endif c c Input numerical values into data structures of L call inpnv(id,jd,d,perm,invp,nsuper,xsuper,xlindx,lindx, & xlnz,lnz,iwork) c c Initialization for block factorization call bfinit(m,nsuper,xsuper,snode,xlindx,lindx,cachsz,tmpsiz, & split) c c Numerical factorization call blkfc2(nsuper,xsuper,snode,split,xlindx,lindx,xlnz, & lnz,iwork(1),iwork(nsuper+1),iwork(2*nsuper+1), & iwork(2*nsuper+m+1),tmpsiz,ierr) if (ierr .eq. -1) then ierr = 1 go to 100 elseif (ierr .eq. -2) then ierr = 3 go to 100 endif 100 continue c WRITE(6,699) nnzd c699 FORMAT(1X,' FOUND ',I6,' RETURNING!') return end C*********************************************************************** C*********************************************************************** C C Authors: Reinhard Furrer, based on inpnv C C C*********************************************************************** C*********************************************************************** C C ------------------------------------------------------ C Clean the array lnz C ------------------------------------------------------ C SUBROUTINE CLEANLNZ (NSUPER, XSUPER, XLNZ, LNZ) C IMPLICIT NONE INTEGER NSUPER INTEGER XSUPER(*), XLNZ(*) DOUBLE PRECISION LNZ(*) C INTEGER II, J, JSUPER C DO 500 JSUPER = 1, NSUPER DO 400 J = XSUPER(JSUPER), XSUPER(JSUPER+1)-1 DO 200 II = XLNZ(J), XLNZ(J+1)-1 LNZ(II) = 0.0 200 CONTINUE 400 CONTINUE C 500 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************ ASSMB .... INDEXED ASSEMBLY OPERATION ************ C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS ROUTINE PERFORMS AN INDEXED ASSEMBLY (I.E., SCATTER-ADD) C OPERATION, ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE C CHOLESKY CODES. C C INPUT PARAMETERS: C M - NUMBER OF ROWS IN Y. C Q - NUMBER OF COLUMNS IN Y. C Y - BLOCK UPDATE TO BE INCORPORATED INTO FACTOR C STORAGE. C RELIND - RELATIVE INDICES FOR MAPPING THE UPDATES C ONTO THE TARGET COLUMNS. C XLNZ - POINTERS TO THE START OF EACH COLUMN IN THE C TARGET MATRIX. C C OUTPUT PARAMETERS: C LNZ - CONTAINS COLUMNS MODIFIED BY THE UPDATE C MATRIX. C C*********************************************************************** C SUBROUTINE ASSMB ( M , Q , Y , RELIND, XLNZ , & LNZ , LDA ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER LDA , M , Q INTEGER XLNZ(*) INTEGER RELIND(*) DOUBLE PRECISION LNZ(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER ICOL , IL1 , IR , IY1 , LBOT1 , & YCOL , YOFF1 C C*********************************************************************** C C YOFF1 = 0 DO 200 ICOL = 1, Q YCOL = LDA - RELIND(ICOL) LBOT1 = XLNZ(YCOL+1) - 1 CDIR$ IVDEP DO 100 IR = ICOL, M IL1 = LBOT1 - RELIND(IR) IY1 = YOFF1 + IR LNZ(IL1) = LNZ(IL1) + Y(IY1) Y(IY1) = 0.0D0 100 CONTINUE YOFF1 = IY1 - ICOL 200 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** BETREE ..... BINARY TREE REPRESENTATION OF ETREE ******* C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO DETERMINE THE BINARY TREE REPRESENTATION OF THE ELIMINATION C TREE GIVEN BY THE PARENT VECTOR. THE RETURNED REPRESENTATION C WILL BE GIVEN BY THE FIRST-SON AND BROTHER VECTORS. THE ROOT C OF THE BINARY TREE IS ALWAYS NEQNS. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE. C IT IS ASSUMED THAT PARENT(I) > I EXCEPT OF C THE ROOTS. C C OUTPUT PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C C*********************************************************************** C SUBROUTINE BETREE ( NEQNS , PARENT, FSON , BROTHR ) C C*********************************************************************** C INTEGER(4) BROTHR(*) , FSON(*) , & PARENT(*) C INTEGER(4) NEQNS C C*********************************************************************** C INTEGER(4) LROOT , NODE , NDPAR C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C DO 100 NODE = 1, NEQNS FSON(NODE) = 0 BROTHR(NODE) = 0 100 CONTINUE LROOT = NEQNS C ------------------------------------------------------------ C FOR EACH NODE := NEQNS-1 STEP -1 DOWNTO 1, DO THE FOLLOWING. C ------------------------------------------------------------ IF ( NEQNS .LE. 1 ) RETURN DO 300 NODE = NEQNS-1, 1, -1 NDPAR = PARENT(NODE) IF ( NDPAR .LE. 0 .OR. NDPAR .EQ. NODE ) THEN C ------------------------------------------------- C NODE HAS NO PARENT. GIVEN STRUCTURE IS A FOREST. C SET NODE TO BE ONE OF THE ROOTS OF THE TREES. C ------------------------------------------------- BROTHR(LROOT) = NODE LROOT = NODE ELSE C ------------------------------------------- C OTHERWISE, BECOMES FIRST SON OF ITS PARENT. C ------------------------------------------- BROTHR(NODE) = FSON(NDPAR) FSON(NDPAR) = NODE ENDIF 300 CONTINUE BROTHR(LROOT) = 0 C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** BFINIT ..... INITIALIZATION FOR BLOCK FACTORIZATION ****** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE COMPUTES ITEMS NEEDED BY THE LEFT-LOOKING C BLOCK-TO-BLOCK CHOLESKY FACTORITZATION ROUTINE BLKFCT. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C NSUPER - NUMBER OF SUPERNODES. C XSUPER - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C THE SUPERNODE PARTITIONING. C SNODE - SUPERNODE MEMBERSHIP. C (XLINDX,LINDX) - ARRAYS DESCRIBING THE SUPERNODAL STRUCTURE. C CACHSZ - CACHE SIZE (IN KBYTES). C C OUTPUT PARAMETERS: C TMPSIZ - SIZE OF WORKING STORAGE REQUIRED BY BLKFCT. C SPLIT - SPLITTING OF SUPERNODES SO THAT THEY FIT C INTO CACHE. C C*********************************************************************** C SUBROUTINE BFINIT ( NEQNS , NSUPER, XSUPER, SNODE , XLINDX, & LINDX , CACHSZ, TMPSIZ, SPLIT ) C C*********************************************************************** C INTEGER CACHSZ, NEQNS , NSUPER, TMPSIZ INTEGER XLINDX(*) , XSUPER(*) INTEGER LINDX (*) , SNODE (*) , & SPLIT(*) C C*********************************************************************** C C --------------------------------------------------- C DETERMINE FLOATING POINT WORKING SPACE REQUIREMENT. C --------------------------------------------------- CALL FNTSIZ ( NSUPER, XSUPER, SNODE , XLINDX, LINDX , & TMPSIZ ) C C ------------------------------- C PARTITION SUPERNODES FOR CACHE. C ------------------------------- CALL FNSPLT ( NEQNS , NSUPER, XSUPER, XLINDX, CACHSZ, & SPLIT ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.3 C Last modified: March 6, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C RF eliminated dependence on SMXPY and MMPY C C Mathematical Sciences Section, Oak Ridge National Laboratoy C C*********************************************************************** C*********************************************************************** C********* BLKFC2 ..... BLOCK GENERAL SPARSE CHOLESKY ********* C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE FACTORS A SPARSE POSITIVE DEFINITE MATRIX. C THE COMPUTATION IS ORGANIZED AROUND KERNELS THAT PERFORM C SUPERNODE-TO-SUPERNODE UPDATES, I.E., BLOCK-TO-BLOCK UPDATES. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C SNODE - MAPS EACH COLUMN TO THE SUPERNODE CONTAINING C IT. C SPLIT - SPLITTING OF SUPERNODES SO THAT THEY FIT C INTO CACHE. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE (INCLUDING C THE DIAGONAL ELEMENTS). C (XLNZ,LNZ) - ON INPUT, CONTAINS MATRIX TO BE FACTORED. C TMPSIZ - SIZE OF TEMPORARY WORKING STORAGE. C C OUTPUT PARAMETERS: C LNZ - ON OUTPUT, CONTAINS CHOLESKY FACTOR. C IFLAG - ERROR FLAG. C 0: SUCCESSFUL FACTORIZATION. C -1: NONPOSITIVE DIAGONAL ENCOUNTERED, C MATRIX IS NOT POSITIVE DEFINITE. C -2: INSUFFICIENT WORKING STORAGE C [TEMP(*)]. C C WORKING PARAMETERS: C LINK - LINKS TOGETHER THE SUPERNODES IN A SUPERNODE C ROW. C LENGTH - LENGTH OF THE ACTIVE PORTION OF EACH C SUPERNODE. C INDMAP - VECTOR OF SIZE NEQNS INTO WHICH THE GLOBAL C INDICES ARE SCATTERED. C RELIND - MAPS LOCATIONS IN THE UPDATING COLUMNS TO C THE CORRESPONDING LOCATIONS IN THE UPDATED C COLUMNS. (RELIND IS GATHERED FROM INDMAP). C TEMP - REAL VECTOR FOR ACCUMULATING UPDATES. MUST C ACCOMODATE ALL COLUMNS OF A SUPERNODE. C C*********************************************************************** C SUBROUTINE BLKFC2 ( NSUPER, XSUPER, SNODE , SPLIT , XLINDX, & LINDX , XLNZ , LNZ , LINK , LENGTH, & INDMAP, RELIND, TMPSIZ, IFLAG ) C C********************************************************************* C C ----------- C PARAMETERS. C ----------- C INTEGER XLINDX(*) , XLNZ(*) INTEGER INDMAP(*) , LENGTH(*) , & LINDX(*) , LINK(*) , & RELIND(*) , SNODE(*) , & SPLIT(*) , XSUPER(*) INTEGER IFLAG , NSUPER, TMPSIZ DOUBLE PRECISION LNZ(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER FJCOL , FKCOL , I , ILEN , ILPNT , & INDDIF, JLEN , JLPNT , JSUP , JXPNT , & KFIRST, KLAST , KLEN , KLPNT , KSUP , & KXPNT , LJCOL , NCOLUP, NJCOLS, NKCOLS, & NXKSUP, NXTCOL, NXTSUP, STORE DOUBLE PRECISION TEMP(TMPSIZ) C RF: put TEMP(*) into a local variable DOUBLE PRECISION MXDIAG INTEGER NTINY C********************************************************************* C IFLAG = 0 NTINY = 0 C C ----------------------------------------------------------- C INITIALIZE EMPTY ROW LISTS IN LINK(*) AND ZERO OUT TEMP(*). C ----------------------------------------------------------- DO 100 JSUP = 1, NSUPER LINK(JSUP) = 0 100 CONTINUE DO 200 I = 1, TMPSIZ TEMP(I) = 0.0D+00 200 CONTINUE C COMPUTE MAXIMUM DIAGONAL ELEMENT IN INPUT MATRIX MXDIAG = 0.D0 DO 201 I = 1, XSUPER(NSUPER+1)-1 FJCOL = XLNZ(I) MXDIAG = MAX(MXDIAG, LNZ(FJCOL)) 201 CONTINUE C C --------------------------- C FOR EACH SUPERNODE JSUP ... C --------------------------- DO 600 JSUP = 1, NSUPER C C ------------------------------------------------ C FJCOL ... FIRST COLUMN OF SUPERNODE JSUP. C LJCOL ... LAST COLUMN OF SUPERNODE JSUP. C NJCOLS ... NUMBER OF COLUMNS IN SUPERNODE JSUP. C JLEN ... LENGTH OF COLUMN FJCOL. C JXPNT ... POINTER TO INDEX OF FIRST C NONZERO IN COLUMN FJCOL. C ------------------------------------------------ FJCOL = XSUPER(JSUP) NJCOLS = XSUPER(JSUP+1) - FJCOL LJCOL = FJCOL + NJCOLS - 1 JLEN = XLNZ(FJCOL+1) - XLNZ(FJCOL) JXPNT = XLINDX(JSUP) C print *, 'Super Node: ', JSUP, ' first: ', FJCOL, C . ' last: ', LJCOL C C C ----------------------------------------------------- C SET UP INDMAP(*) TO MAP THE ENTRIES IN UPDATE COLUMNS C TO THEIR CORRESPONDING POSITIONS IN UPDATED COLUMNS, C RELATIVE THE THE BOTTOM OF EACH UPDATED COLUMN. C ----------------------------------------------------- CALL LDINDX ( JLEN, LINDX(JXPNT), INDMAP ) C C ----------------------------------------- C FOR EVERY SUPERNODE KSUP IN ROW(JSUP) ... C ----------------------------------------- KSUP = LINK(JSUP) 300 IF ( KSUP .GT. 0 ) THEN NXKSUP = LINK(KSUP) C C ------------------------------------------------------- C GET INFO ABOUT THE CMOD(JSUP,KSUP) UPDATE. C C FKCOL ... FIRST COLUMN OF SUPERNODE KSUP. C NKCOLS ... NUMBER OF COLUMNS IN SUPERNODE KSUP. C KLEN ... LENGTH OF ACTIVE PORTION OF COLUMN FKCOL. C KXPNT ... POINTER TO INDEX OF FIRST NONZERO IN ACTIVE C PORTION OF COLUMN FJCOL. C ------------------------------------------------------- FKCOL = XSUPER(KSUP) NKCOLS = XSUPER(KSUP+1) - FKCOL KLEN = LENGTH(KSUP) KXPNT = XLINDX(KSUP+1) - KLEN C C ------------------------------------------- C PERFORM CMOD(JSUP,KSUP), WITH SPECIAL CASES C HANDLED DIFFERENTLY. C ------------------------------------------- C IF ( KLEN .NE. JLEN ) THEN C C ------------------------------------------- C SPARSE CMOD(JSUP,KSUP). C C NCOLUP ... NUMBER OF COLUMNS TO BE UPDATED. C ------------------------------------------- C DO 400 I = 0, KLEN-1 NXTCOL = LINDX(KXPNT+I) IF ( NXTCOL .GT. LJCOL ) GO TO 500 400 CONTINUE I = KLEN 500 CONTINUE NCOLUP = I C IF ( NKCOLS .EQ. 1 ) THEN C C ---------------------------------------------- C UPDATING TARGET SUPERNODE BY TRIVIAL C SUPERNODE (WITH ONE COLUMN). C C KLPNT ... POINTER TO FIRST NONZERO IN ACTIVE C PORTION OF COLUMN FKCOL. C ---------------------------------------------- KLPNT = XLNZ(FKCOL+1) - KLEN CALL MMPYI ( KLEN, NCOLUP, LINDX(KXPNT), & LNZ(KLPNT), XLNZ, LNZ, INDMAP ) C ELSE C C -------------------------------------------- C KFIRST ... FIRST INDEX OF ACTIVE PORTION OF C SUPERNODE KSUP (FIRST COLUMN TO C BE UPDATED). C KLAST ... LAST INDEX OF ACTIVE PORTION OF C SUPERNODE KSUP. C -------------------------------------------- C KFIRST = LINDX(KXPNT) KLAST = LINDX(KXPNT+KLEN-1) INDDIF = INDMAP(KFIRST) - INDMAP(KLAST) C IF ( INDDIF .LT. KLEN ) THEN C C --------------------------------------- C DENSE CMOD(JSUP,KSUP). C C ILPNT ... POINTER TO FIRST NONZERO IN C COLUMN KFIRST. C ILEN ... LENGTH OF COLUMN KFIRST. C --------------------------------------- ILPNT = XLNZ(KFIRST) ILEN = XLNZ(KFIRST+1) - ILPNT CALL MMPY ( KLEN, NKCOLS, NCOLUP, & SPLIT(FKCOL), XLNZ(FKCOL), & LNZ, LNZ(ILPNT), ILEN ) C ELSE C C ------------------------------- C GENERAL SPARSE CMOD(JSUP,KSUP). C COMPUTE CMOD(JSUP,KSUP) UPDATE C IN WORK STORAGE. C ------------------------------- STORE = KLEN * NCOLUP - NCOLUP * & (NCOLUP-1) / 2 IF ( STORE .GT. TMPSIZ ) THEN IFLAG = -2 RETURN ENDIF CALL MMPY ( KLEN, NKCOLS, NCOLUP, & SPLIT(FKCOL), XLNZ(FKCOL), & LNZ, TEMP, KLEN ) C ---------------------------------------- C GATHER INDICES OF KSUP RELATIVE TO JSUP. C ---------------------------------------- CALL IGATHR ( KLEN, LINDX(KXPNT), & INDMAP, RELIND ) C -------------------------------------- C INCORPORATE THE CMOD(JSUP,KSUP) BLOCK C UPDATE INTO THE TO APPROPRIATE COLUMNS C OF L. C -------------------------------------- CALL ASSMB ( KLEN, NCOLUP, TEMP, RELIND, & XLNZ(FJCOL), LNZ, JLEN ) C ENDIF C ENDIF C ELSE C C ---------------------------------------------- C DENSE CMOD(JSUP,KSUP). C JSUP AND KSUP HAVE IDENTICAL STRUCTURE. C C JLPNT ... POINTER TO FIRST NONZERO IN COLUMN C FJCOL. C ---------------------------------------------- JLPNT = XLNZ(FJCOL) CALL MMPY ( KLEN, NKCOLS, NJCOLS, SPLIT(FKCOL), & XLNZ(FKCOL), LNZ, LNZ(JLPNT), JLEN) NCOLUP = NJCOLS IF ( KLEN .GT. NJCOLS ) THEN NXTCOL = LINDX(JXPNT+NJCOLS) ENDIF C ENDIF C C ------------------------------------------------ C LINK KSUP INTO LINKED LIST OF THE NEXT SUPERNODE C IT WILL UPDATE AND DECREMENT KSUP'S ACTIVE C LENGTH. C ------------------------------------------------ IF ( KLEN .GT. NCOLUP ) THEN NXTSUP = SNODE(NXTCOL) LINK(KSUP) = LINK(NXTSUP) LINK(NXTSUP) = KSUP LENGTH(KSUP) = KLEN - NCOLUP ELSE LENGTH(KSUP) = 0 ENDIF C C ------------------------------- C NEXT UPDATING SUPERNODE (KSUP). C ------------------------------- KSUP = NXKSUP GO TO 300 C ENDIF C C ---------------------------------------------- C APPLY PARTIAL CHOLESKY TO THE COLUMNS OF JSUP. C ---------------------------------------------- CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC CALL CHLSUP ( JLEN, NJCOLS, SPLIT(FJCOL), XLNZ(FJCOL), LNZ, & MXDIAG, NTINY ) IF ( IFLAG .NE. 0 ) THEN IFLAG = -1 RETURN ENDIF C C ----------------------------------------------- C INSERT JSUP INTO LINKED LIST OF FIRST SUPERNODE C IT WILL UPDATE. C ----------------------------------------------- IF ( JLEN .GT. NJCOLS ) THEN NXTCOL = LINDX(JXPNT+NJCOLS) NXTSUP = SNODE(NXTCOL) LINK(JSUP) = LINK(NXTSUP) LINK(NXTSUP) = JSUP LENGTH(JSUP) = JLEN - NJCOLS ELSE LENGTH(JSUP) = 0 ENDIF C 600 CONTINUE C CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC C IF(NTINY .NE. 0) WRITE(6,699) NTINY C 699 FORMAT(1X,' FOUND ',I6,' TINY DIAGONALS; REPLACED WITH INF') C C SET IFLAG TO -1 TO INDICATE PRESENCE OF TINY DIAGONALS C IF(NTINY .NE. 0) IFLAG = -1 CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC RETURN END C*********************************************************************** C*********************************************************************** C C Written: October 6, 1996 by SJW. Based on routine BLKSLV of C Esmond G. Ng and Barry W. Peyton. C C Modified: Sept 30, 1999 to improve efficiency in the case C in which the right-hand side and solution are both C expected to be sparse. Happens a lot in "dense" C column handling. C C*********************************************************************** C*********************************************************************** C********* BLKSLB ... BACK TRIANGULAR SUBSTITUTION ********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC C POSITIVE DEFINITE MATRIX, THIS SUBROUTINE PERFORMS THE C BACKWARD TRIANGULAR SUBSTITUTION. IT USES OUTPUT FROM BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE. C (XLNZ,LNZ) - CHOLESKY FACTOR. C C UPDATED PARAMETERS: C RHS - ON INPUT, CONTAINS THE RIGHT HAND SIDE. ON C OUTPUT, CONTAINS THE SOLUTION. C C*********************************************************************** C SUBROUTINE BLKSLB ( NSUPER, XSUPER, XLINDX, LINDX , XLNZ , & LNZ , RHS ) C C*********************************************************************** C INTEGER NSUPER INTEGER LINDX(*) , XSUPER(*) INTEGER XLINDX(*) , XLNZ(*) DOUBLE PRECISION LNZ(*) , RHS(*) C C*********************************************************************** C INTEGER FJCOL , I , IPNT , IX , IXSTOP, & IXSTRT, JCOL , JPNT , JSUP , LJCOL DOUBLE PRECISION T C C*********************************************************************** C IF ( NSUPER .LE. 0 ) RETURN C ------------------------- C BACKWARD SUBSTITUTION ... C ------------------------- LJCOL = XSUPER(NSUPER+1) - 1 DO 600 JSUP = NSUPER, 1, -1 FJCOL = XSUPER(JSUP) IXSTOP = XLNZ(LJCOL+1) - 1 JPNT = XLINDX(JSUP) + (LJCOL - FJCOL) DO 500 JCOL = LJCOL, FJCOL, -1 IXSTRT = XLNZ(JCOL) IPNT = JPNT + 1 T = RHS(JCOL) CDIR$ IVDEP DO 400 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) IF(RHS(I) .NE. 0.D0) T = T - LNZ(IX)*RHS(I) IPNT = IPNT + 1 400 CONTINUE IF(T .NE. 0.D0) THEN RHS(JCOL) = T/LNZ(IXSTRT) ELSE RHS(JCOL) = 0.D0 ENDIF IXSTOP = IXSTRT - 1 JPNT = JPNT - 1 500 CONTINUE LJCOL = FJCOL - 1 600 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Written: October 6, 1996 by SJW. Based on routine BLKSLV of C Esmond G. Ng and Barry W. Peyton. C C Modified: Sept 30, 1999 to improve efficiency in the case C in which the right-hand side and solution are both C expected to be sparse. Happens a lot in "dense" C column handling. C C*********************************************************************** C*********************************************************************** C********* BLKSLF ... FORWARD TRIANGULAR SUBSTITUTION ********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC C POSITIVE DEFINITE MATRIX, THIS SUBROUTINE PERFORMS THE C FORWARD TRIANGULAR SUBSTITUTIOn. IT USES OUTPUT FROM BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE. C (XLNZ,LNZ) - CHOLESKY FACTOR. C C UPDATED PARAMETERS: C RHS - ON INPUT, CONTAINS THE RIGHT HAND SIDE. ON C OUTPUT, CONTAINS THE SOLUTION. C C*********************************************************************** C SUBROUTINE BLKSLF ( NSUPER, XSUPER, XLINDX, LINDX , XLNZ , & LNZ , RHS ) C C*********************************************************************** C INTEGER NSUPER INTEGER LINDX(*) , XSUPER(*) INTEGER XLINDX(*) , XLNZ(*) DOUBLE PRECISION LNZ(*) , RHS(*) C C*********************************************************************** C INTEGER FJCOL , I , IPNT , IX , IXSTOP, & IXSTRT, JCOL , JPNT , JSUP , LJCOL DOUBLE PRECISION T C C*********************************************************************** C IF ( NSUPER .LE. 0 ) RETURN C C ------------------------ C FORWARD SUBSTITUTION ... C ------------------------ FJCOL = XSUPER(1) DO 300 JSUP = 1, NSUPER LJCOL = XSUPER(JSUP+1) - 1 IXSTRT = XLNZ(FJCOL) JPNT = XLINDX(JSUP) DO 200 JCOL = FJCOL, LJCOL IXSTOP = XLNZ(JCOL+1) - 1 IF(RHS(JCOL) .NE. 0.D0) THEN T = RHS(JCOL)/LNZ(IXSTRT) RHS(JCOL) = T IPNT = JPNT + 1 CDIR$ IVDEP DO 100 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) RHS(I) = RHS(I) - T*LNZ(IX) IPNT = IPNT + 1 100 CONTINUE ENDIF IXSTRT = IXSTOP + 1 JPNT = JPNT + 1 200 CONTINUE FJCOL = LJCOL + 1 300 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C Modified: Sept 30, 1999 to improve efficiency in the case C in which the right-hand side and solution are both C expected to be sparse. Happens a lot in "dense" C column handling. C C*********************************************************************** C*********************************************************************** C********* BLKSLV ... BLOCK TRIANGULAR SOLUTIONS ********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C GIVEN THE CHOLESKY FACTORIZATION OF A SPARSE SYMMETRIC C POSITIVE DEFINITE MATRIX, THIS SUBROUTINE PERFORMS THE C TRIANGULAR SOLUTION. IT USES OUTPUT FROM BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - SUPERNODE PARTITION. C (XLINDX,LINDX) - ROW INDICES FOR EACH SUPERNODE. C (XLNZ,LNZ) - CHOLESKY FACTOR. C C UPDATED PARAMETERS: C RHS - ON INPUT, CONTAINS THE RIGHT HAND SIDE. ON C OUTPUT, CONTAINS THE SOLUTION. C C*********************************************************************** C SUBROUTINE BLKSLV ( NSUPER, XSUPER, XLINDX, LINDX , XLNZ , & LNZ , RHS ) C C*********************************************************************** C INTEGER NSUPER INTEGER LINDX(*) , XSUPER(*) INTEGER XLINDX(*) , XLNZ(*) DOUBLE PRECISION LNZ(*) , RHS(*) C C*********************************************************************** C INTEGER FJCOL , I , IPNT , IX , IXSTOP, & IXSTRT, JCOL , JPNT , JSUP , LJCOL DOUBLE PRECISION T C C*********************************************************************** C IF ( NSUPER .LE. 0 ) RETURN C C ------------------------ C FORWARD SUBSTITUTION ... C ------------------------ FJCOL = XSUPER(1) DO 300 JSUP = 1, NSUPER LJCOL = XSUPER(JSUP+1) - 1 IXSTRT = XLNZ(FJCOL) JPNT = XLINDX(JSUP) C print *, "JSUP", JSUP, FJCOL, LJCOL DO 200 JCOL = FJCOL, LJCOL IXSTOP = XLNZ(JCOL+1) - 1 C print *, JSUP, JCOL C print *, RHS(JCOL) IF(RHS(JCOL) .NE. 0.D0) THEN T = RHS(JCOL)/LNZ(IXSTRT) RHS(JCOL) = T IPNT = JPNT + 1 CDIR$ IVDEP DO 100 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) RHS(I) = RHS(I) - T*LNZ(IX) IPNT = IPNT + 1 100 CONTINUE ENDIF IXSTRT = IXSTOP + 1 JPNT = JPNT + 1 200 CONTINUE FJCOL = LJCOL + 1 300 CONTINUE C C ------------------------- C BACKWARD SUBSTITUTION ... C ------------------------- LJCOL = XSUPER(NSUPER+1) - 1 DO 600 JSUP = NSUPER, 1, -1 FJCOL = XSUPER(JSUP) IXSTOP = XLNZ(LJCOL+1) - 1 JPNT = XLINDX(JSUP) + (LJCOL - FJCOL) DO 500 JCOL = LJCOL, FJCOL, -1 IXSTRT = XLNZ(JCOL) IPNT = JPNT + 1 T = RHS(JCOL) CDIR$ IVDEP DO 400 IX = IXSTRT+1, IXSTOP I = LINDX(IPNT) IF(RHS(I) .NE. 0.D0) T = T - LNZ(IX)*RHS(I) IPNT = IPNT + 1 400 CONTINUE IF(T .NE. 0.D0) THEN RHS(JCOL) = T/LNZ(IXSTRT) ELSE RHS(JCOL) = 0.D0 ENDIF IXSTOP = IXSTRT - 1 JPNT = JPNT - 1 500 CONTINUE LJCOL = FJCOL - 1 600 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: January 12, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** BTREE2 ..... BINARY TREE REPRESENTATION OF ETREE ******* C*********************************************************************** C*********************************************************************** C C PURPOSE: C TO DETERMINE A BINARY TREE REPRESENTATION OF THE ELIMINATION C TREE, FOR WHICH EVERY "LAST CHILD" HAS THE MAXIMUM POSSIBLE C COLUMN NONZERO COUNT IN THE FACTOR. THE RETURNED REPRESENTATION C WILL BE GIVEN BY THE FIRST-SON AND BROTHER VECTORS. THE ROOT OF C THE BINARY TREE IS ALWAYS NEQNS. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE. C IT IS ASSUMED THAT PARENT(I) > I EXCEPT OF C THE ROOTS. C COLCNT - COLUMN NONZERO COUNTS OF THE FACTOR. C C OUTPUT PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C C WORKING PARAMETERS: C LSON - LAST SON VECTOR. C C*********************************************************************** C SUBROUTINE BTREE2 ( NEQNS , PARENT, COLCNT, FSON , BROTHR, & LSON ) C C*********************************************************************** C INTEGER BROTHR(*) , COLCNT(*) , & FSON(*) , LSON(*) , & PARENT(*) C INTEGER NEQNS C C*********************************************************************** C INTEGER(4) LROOT , NODE , NDLSON, NDPAR C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C DO 100 NODE = 1, NEQNS FSON(NODE) = 0 BROTHR(NODE) = 0 LSON(NODE) = 0 100 CONTINUE LROOT = NEQNS C ------------------------------------------------------------ C FOR EACH NODE := NEQNS-1 STEP -1 DOWNTO 1, DO THE FOLLOWING. C ------------------------------------------------------------ IF ( NEQNS .LE. 1 ) RETURN DO 300 NODE = NEQNS-1, 1, -1 NDPAR = PARENT(NODE) IF ( NDPAR .LE. 0 .OR. NDPAR .EQ. NODE ) THEN C ------------------------------------------------- C NODE HAS NO PARENT. GIVEN STRUCTURE IS A FOREST. C SET NODE TO BE ONE OF THE ROOTS OF THE TREES. C ------------------------------------------------- BROTHR(LROOT) = NODE LROOT = NODE ELSE C ------------------------------------------- C OTHERWISE, BECOMES FIRST SON OF ITS PARENT. C ------------------------------------------- NDLSON = LSON(NDPAR) IF ( NDLSON .NE. 0 ) THEN IF ( COLCNT(NODE) .GE. COLCNT(NDLSON) ) THEN BROTHR(NODE) = FSON(NDPAR) FSON(NDPAR) = NODE ELSE BROTHR(NDLSON) = NODE LSON(NDPAR) = NODE ENDIF ELSE FSON(NDPAR) = NODE LSON(NDPAR) = NODE ENDIF ENDIF 300 CONTINUE BROTHR(LROOT) = 0 C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.3 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Modified by RF: Eliminated the MMPYN, SMXPY as arguments C C Mathematical Sciences Section, Oak Ridge National Laboratoy C C*********************************************************************** C*********************************************************************** C****** CHLSUP .... DENSE CHOLESKY WITHIN SUPERNODE ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS CHOLESKY C FACTORIZATION ON THE COLUMNS OF A SUPERNODE C THAT HAVE RECEIVED ALL UPDATES FROM COLUMNS C EXTERNAL TO THE SUPERNODE. C C INPUT PARAMETERS - C M - NUMBER OF ROWS (LENGTH OF THE FIRST COLUMN). C N - NUMBER OF COLUMNS IN THE SUPERNODE. C XPNT - XPNT(J+1) POINTS ONE LOCATION BEYOND THE END C OF THE J-TH COLUMN OF THE SUPERNODE. C X(*) - CONTAINS THE COLUMNS OF OF THE SUPERNODE TO C BE FACTORED. C C EXTERNAL ROUTINES - C MMPY8 - MATRIX-MATRIX MULTIPLY WITH 8 LOOP UNROLLING. C C OUTPUT PARAMETERS - C X(*) - ON OUTPUT, CONTAINS THE FACTORED COLUMNS OF C THE SUPERNODE. C IFLAG - UNCHANGED IF THERE IS NO ERROR. C =1 IF NONPOSITIVE DIAGONAL ENTRY IS ENCOUNTERED. C C*********************************************************************** C SUBROUTINE CHLSUP ( M, N, SPLIT, XPNT, X, MXDIAG, NTINY & ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C EXTERNAL MMPY8 C INTEGER M, N C INTEGER XPNT(*), SPLIT(*) C DOUBLE PRECISION X(*), MXDIAG INTEGER NTINY C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER FSTCOL, JBLK , JPNT , MM , NN , & NXTCOL, Q C C*********************************************************************** C JBLK = 0 FSTCOL = 1 MM = M JPNT = XPNT(FSTCOL) C C ---------------------------------------- C FOR EACH BLOCK JBLK IN THE SUPERNODE ... C ---------------------------------------- 100 CONTINUE IF ( FSTCOL .LE. N ) THEN JBLK = JBLK + 1 NN = SPLIT(JBLK) C ------------------------------------------ C ... PERFORM PARTIAL CHOLESKY FACTORIZATION C ON THE BLOCK. C ------------------------------------------ CALL PCHOL ( MM, NN, XPNT(FSTCOL), X, MXDIAG, NTINY) C ---------------------------------------------- C ... APPLY THE COLUMNS IN JBLK TO ANY COLUMNS C OF THE SUPERNODE REMAINING TO BE COMPUTED. C ---------------------------------------------- NXTCOL = FSTCOL + NN Q = N - NXTCOL + 1 MM = MM - NN JPNT = XPNT(NXTCOL) IF ( Q .GT. 0 ) THEN CALL MMPY8( MM, NN, Q, XPNT(FSTCOL), X, X(JPNT), MM ) ENDIF FSTCOL = NXTCOL GO TO 100 ENDIF C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C********** CHORDR ..... CHILD REORDERING *********** C*********************************************************************** C*********************************************************************** C C PURPOSE: C REARRANGE THE CHILDREN OF EACH VERTEX SO THAT THE LAST ONE C MAXIMIZES (AMONG THE CHILDREN) THE NUMBER OF NONZEROS IN THE C CORRESPONDING COLUMN OF L. ALSO DETERMINE AN NEW POSTORDERING C BASED ON THE STRUCTURE OF THE MODIFIED ELIMINATION TREE. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C C UPDATED PARAMETERS: C (PERM,INVP) - ON INPUT, THE GIVEN PERM AND INVERSE PERM C VECTORS. ON OUTPUT, THE NEW PERM AND C INVERSE PERM VECTORS OF THE NEW C POSTORDERING. C COLCNT - COLUMN COUNTS IN L UNDER INITIAL ORDERING; C MODIFIED TO REFLECT THE NEW ORDERING. C C OUTPUT PARAMETERS: C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE C ASSOCIATED WITH THE NEW ORDERING. C C WORKING PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C INVPOS - THE INVERSE PERM VECTOR FOR THE C POSTORDERING. C C PROGRAM SUBROUTINES: C BTREE2, EPOST2, INVINV. C C*********************************************************************** C SUBROUTINE CHORDR ( NEQNS , PERM , INVP , & COLCNT, PARENT, FSON , BROTHR, INVPOS ) C C*********************************************************************** C INTEGER BROTHR(*) , & COLCNT(*) , FSON(*) , & INVP(*) , INVPOS(*) , & PARENT(*) , PERM(*) C INTEGER NEQNS C C*********************************************************************** C C ---------------------------------------------------------- C COMPUTE A BINARY REPRESENTATION OF THE ELIMINATION TREE, C SO THAT EACH "LAST CHILD" MAXIMIZES AMONG ITS SIBLINGS THE C NUMBER OF NONZEROS IN THE CORRESPONDING COLUMNS OF L. C ---------------------------------------------------------- CALL BTREE2 ( NEQNS , PARENT, COLCNT, FSON , BROTHR, & INVPOS ) C C ---------------------------------------------------- C POSTORDER THE ELIMINATION TREE (USING THE NEW BINARY C REPRESENTATION. C ---------------------------------------------------- CALL EPOST2 ( NEQNS , FSON , BROTHR, INVPOS, PARENT, & COLCNT, PERM ) C C -------------------------------------------------------- C COMPOSE THE ORIGINAL ORDERING WITH THE NEW POSTORDERING. C -------------------------------------------------------- CALL INVINV ( NEQNS , INVP , INVPOS, PERM ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** DSCAL1 .... SCALE A VECTOR ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE COMPUTES A <-- AX, WHERE A IS A C SCALAR AND X IS A VECTOR. C C INPUT PARAMETERS - C N - LENGTH OF THE VECTOR X. C A - SCALAR MULIPLIER. C X - VECTOR TO BE SCALED. C C OUTPUT PARAMETERS - C X - REPLACED BY THE SCALED VECTOR, AX. C C*********************************************************************** C SUBROUTINE DSCAL1 ( N, A, X ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER N DOUBLE PRECISION A, X(N) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER I C C*********************************************************************** C DO 100 I = 1, N X(I) = A * X(I) 100 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C*************** EPOST2 ..... ETREE POSTORDERING #2 *************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C BASED ON THE BINARY REPRESENTATION (FIRST-SON,BROTHER) OF THE C ELIMINATION TREE, A POSTORDERING IS DETERMINED. THE C CORRESPONDING PARENT AND COLCNT VECTORS ARE ALSO MODIFIED TO C REFLECT THE REORDERING. C C INPUT PARAMETERS: C ROOT - ROOT OF THE ELIMINATION TREE (USUALLY IT C IS NEQNS). C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHR VECTOR. C C UPDATED PARAMETERS: C PARENT - THE PARENT VECTOR. C COLCNT - COLUMN NONZERO COUNTS OF THE FACTOR. C C OUTPUT PARAMETERS: C INVPOS - INVERSE PERMUTATION FOR THE POSTORDERING. C C WORKING PARAMETERS: C STACK - THE STACK FOR POSTORDER TRAVERSAL OF THE C TREE. C C*********************************************************************** C SUBROUTINE EPOST2 ( ROOT , FSON , BROTHR, INVPOS, PARENT, & COLCNT, STACK ) C C*********************************************************************** C INTEGER(4) BROTHR(*) , COLCNT(*) , & FSON(*) , INVPOS(*) , & PARENT(*) , STACK(*) C INTEGER(4) ROOT C C*********************************************************************** C INTEGER(4) ITOP , NDPAR , NODE , NUM , NUNODE C C*********************************************************************** C NUM = 0 ITOP = 0 NODE = ROOT C ------------------------------------------------------------- C TRAVERSE ALONG THE FIRST SONS POINTER AND PUSH THE TREE NODES C ALONG THE TRAVERSAL INTO THE STACK. C ------------------------------------------------------------- 100 CONTINUE ITOP = ITOP + 1 STACK(ITOP) = NODE NODE = FSON(NODE) IF ( NODE .GT. 0 ) GO TO 100 C ---------------------------------------------------------- C IF POSSIBLE, POP A TREE NODE FROM THE STACK AND NUMBER IT. C ---------------------------------------------------------- 200 CONTINUE IF ( ITOP .LE. 0 ) GO TO 300 NODE = STACK(ITOP) ITOP = ITOP - 1 NUM = NUM + 1 INVPOS(NODE) = NUM C ---------------------------------------------------- C THEN, TRAVERSE TO ITS YOUNGER BROTHER IF IT HAS ONE. C ---------------------------------------------------- NODE = BROTHR(NODE) IF ( NODE .LE. 0 ) GO TO 200 GO TO 100 C 300 CONTINUE C ------------------------------------------------------------ C DETERMINE THE NEW PARENT VECTOR OF THE POSTORDERING. BROTHR C IS USED TEMPORARILY FOR THE NEW PARENT VECTOR. C ------------------------------------------------------------ DO 400 NODE = 1, NUM NUNODE = INVPOS(NODE) NDPAR = PARENT(NODE) IF ( NDPAR .GT. 0 ) NDPAR = INVPOS(NDPAR) BROTHR(NUNODE) = NDPAR 400 CONTINUE C DO 500 NUNODE = 1, NUM PARENT(NUNODE) = BROTHR(NUNODE) 500 CONTINUE C C ---------------------------------------------- C PERMUTE COLCNT(*) TO REFLECT THE NEW ORDERING. C ---------------------------------------------- DO 600 NODE = 1, NUM NUNODE = INVPOS(NODE) STACK(NUNODE) = COLCNT(NODE) 600 CONTINUE C DO 700 NODE = 1, NUM COLCNT(NODE) = STACK(NODE) 700 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C********** ETORDR ..... ELIMINATION TREE REORDERING *********** C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO DETERMINE AN EQUIVALENT REORDERING BASED ON THE STRUCTURE OF C THE ELIMINATION TREE. A POSTORDERING OF THE GIVEN ELIMINATION C TREE IS RETURNED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C C UPDATED PARAMETERS: C (PERM,INVP) - ON INPUT, THE GIVEN PERM AND INVERSE PERM C VECTORS. ON OUTPUT, THE NEW PERM AND C INVERSE PERM VECTORS OF THE EQUIVALENT C ORDERING. C C OUTPUT PARAMETERS: C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE C ASSOCIATED WITH THE NEW ORDERING. C C WORKING PARAMETERS: C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHER VECTOR. C INVPOS - THE INVERSE PERM VECTOR FOR THE C POSTORDERING. C C PROGRAM SUBROUTINES: C BETREE, ETPOST, ETREE , INVINV. C C*********************************************************************** C SUBROUTINE ETORDR ( NEQNS , XADJ , ADJNCY, PERM , INVP , & PARENT, FSON , BROTHR, INVPOS ) C C*********************************************************************** C INTEGER(4) ADJNCY(*) , BROTHR(*) , & FSON(*) , INVP(*) , & INVPOS(*) , PARENT(*) , & PERM(*) C INTEGER(4) XADJ(*) INTEGER(4) NEQNS C C*********************************************************************** C C ----------------------------- C COMPUTE THE ELIMINATION TREE. C ----------------------------- CALL ETREE ( NEQNS, XADJ, ADJNCY, PERM, INVP, PARENT, INVPOS ) C C -------------------------------------------------------- C COMPUTE A BINARY REPRESENTATION OF THE ELIMINATION TREE. C -------------------------------------------------------- CALL BETREE ( NEQNS, PARENT, FSON, BROTHR ) C C ------------------------------- C POSTORDER THE ELIMINATION TREE. C ------------------------------- CALL ETPOST ( NEQNS, FSON, BROTHR, INVPOS, PARENT, PERM ) C C -------------------------------------------------------- C COMPOSE THE ORIGINAL ORDERING WITH THE NEW POSTORDERING. C -------------------------------------------------------- CALL INVINV ( NEQNS, INVP, INVPOS, PERM ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C*************** ETPOST ..... ETREE POSTORDERING *************** C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (SEPT 17, 1986) C C PURPOSE: C BASED ON THE BINARY REPRESENTATION (FIRST-SON,BROTHER) OF C THE ELIMINATION TREE, A POSTORDERING IS DETERMINED. THE C CORRESPONDING PARENT VECTOR IS ALSO MODIFIED TO REFLECT C THE REORDERING. C C INPUT PARAMETERS: C ROOT - ROOT OF THE ELIMINATION TREE (USUALLY IT C IS NEQNS). C FSON - THE FIRST SON VECTOR. C BROTHR - THE BROTHR VECTOR. C C UPDATED PARAMETERS: C PARENT - THE PARENT VECTOR. C C OUTPUT PARAMETERS: C INVPOS - INVERSE PERMUTATION FOR THE POSTORDERING. C C WORKING PARAMETERS: C STACK - THE STACK FOR POSTORDER TRAVERSAL OF THE C TREE. C C*********************************************************************** C SUBROUTINE ETPOST ( ROOT , FSON , BROTHR, INVPOS, PARENT, & STACK ) C C*********************************************************************** C INTEGER(4) BROTHR(*) , FSON(*) , & INVPOS(*) , PARENT(*) , & STACK(*) C INTEGER(4) ROOT C C*********************************************************************** C INTEGER(4) ITOP , NDPAR , NODE , NUM , NUNODE C C*********************************************************************** C NUM = 0 ITOP = 0 NODE = ROOT C ------------------------------------------------------------- C TRAVERSE ALONG THE FIRST SONS POINTER AND PUSH THE TREE NODES C ALONG THE TRAVERSAL INTO THE STACK. C ------------------------------------------------------------- 100 CONTINUE ITOP = ITOP + 1 STACK(ITOP) = NODE NODE = FSON(NODE) IF ( NODE .GT. 0 ) GO TO 100 C ---------------------------------------------------------- C IF POSSIBLE, POP A TREE NODE FROM THE STACK AND NUMBER IT. C ---------------------------------------------------------- 200 CONTINUE IF ( ITOP .LE. 0 ) GO TO 300 NODE = STACK(ITOP) ITOP = ITOP - 1 NUM = NUM + 1 INVPOS(NODE) = NUM C ---------------------------------------------------- C THEN, TRAVERSE TO ITS YOUNGER BROTHER IF IT HAS ONE. C ---------------------------------------------------- NODE = BROTHR(NODE) IF ( NODE .LE. 0 ) GO TO 200 GO TO 100 C 300 CONTINUE C ------------------------------------------------------------ C DETERMINE THE NEW PARENT VECTOR OF THE POSTORDERING. BROTHR C IS USED TEMPORARILY FOR THE NEW PARENT VECTOR. C ------------------------------------------------------------ DO 400 NODE = 1, NUM NUNODE = INVPOS(NODE) NDPAR = PARENT(NODE) IF ( NDPAR .GT. 0 ) NDPAR = INVPOS(NDPAR) BROTHR(NUNODE) = NDPAR 400 CONTINUE C DO 500 NUNODE = 1, NUM PARENT(NUNODE) = BROTHR(NUNODE) 500 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**************** ETREE ..... ELIMINATION TREE ***************** C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO DETERMINE THE ELIMINATION TREE FROM A GIVEN ORDERING AND C THE ADJACENCY STRUCTURE. THE PARENT VECTOR IS RETURNED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C (PERM,INVP) - PERMUTATION AND INVERSE PERMUTATION VECTORS C C OUTPUT PARAMETERS: C PARENT - THE PARENT VECTOR OF THE ELIMINATION TREE. C C WORKING PARAMETERS: C ANCSTR - THE ANCESTOR VECTOR. C C*********************************************************************** C SUBROUTINE ETREE ( NEQNS , XADJ , ADJNCY, PERM , INVP , & PARENT, ANCSTR ) C C*********************************************************************** C INTEGER(4) ADJNCY(*) , ANCSTR(*) , & INVP(*) , PARENT(*) , & PERM(*) C INTEGER(4) NEQNS INTEGER(4) XADJ(*) C C*********************************************************************** C INTEGER(4) I , J , JSTOP , JSTRT , NBR , & NEXT , NODE C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C DO 400 I = 1, NEQNS PARENT(I) = 0 ANCSTR(I) = 0 NODE = PERM(I) C JSTRT = XADJ(NODE) JSTOP = XADJ(NODE+1) - 1 IF ( JSTRT .LE. JSTOP ) THEN DO 300 J = JSTRT, JSTOP NBR = ADJNCY(J) NBR = INVP(NBR) IF ( NBR .LT. I ) THEN C ------------------------------------------- C FOR EACH NBR, FIND THE ROOT OF ITS CURRENT C ELIMINATION TREE. PERFORM PATH COMPRESSION C AS THE SUBTREE IS TRAVERSED. C ------------------------------------------- 100 CONTINUE IF ( ANCSTR(NBR) .EQ. I ) GO TO 300 IF ( ANCSTR(NBR) .GT. 0 ) THEN NEXT = ANCSTR(NBR) ANCSTR(NBR) = I NBR = NEXT GO TO 100 ENDIF C -------------------------------------------- C NOW, NBR IS THE ROOT OF THE SUBTREE. MAKE I C THE PARENT NODE OF THIS ROOT. C -------------------------------------------- PARENT(NBR) = I ANCSTR(NBR) = I ENDIF 300 CONTINUE ENDIF 400 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: January 12, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************** FCNTHN ..... FIND NONZERO COUNTS *************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE DETERMINES THE ROW COUNTS AND COLUMN COUNTS IN C THE CHOLESKY FACTOR. IT USES A DISJOINT SET UNION ALGORITHM. C C TECHNIQUES: C 1) SUPERNODE DETECTION. C 2) PATH HALVING. C 3) NO UNION BY RANK. C C NOTES: C 1) ASSUMES A POSTORDERING OF THE ELIMINATION TREE. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS. C (I) ADJLEN - LENGTH OF ADJACENCY STRUCTURE. C (I) XADJ(*) - ARRAY OF LENGTH NEQNS+1, CONTAINING POINTERS C TO THE ADJACENCY STRUCTURE. C (I) ADJNCY(*) - ARRAY OF LENGTH XADJ(NEQNS+1)-1, CONTAINING C THE ADJACENCY STRUCTURE. C (I) PERM(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C POSTORDERING. C (I) INVP(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C INVERSE OF THE POSTORDERING. C (I) ETPAR(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C ELIMINATION TREE OF THE POSTORDERED MATRIX. C C OUTPUT PARAMETERS: C (I) ROWCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH ROW OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C (I) COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH COLUMN OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C (I) NLNZ - NUMBER OF NONZEROS IN THE FACTOR, INCLUDING C THE DIAGONAL ENTRIES. C C WORK PARAMETERS: C (I) SET(*) - ARRAY OF LENGTH NEQNS USED TO MAINTAIN THE C DISJOINT SETS (I.E., SUBTREES). C (I) PRVLF(*) - ARRAY OF LENGTH NEQNS USED TO RECORD THE C PREVIOUS LEAF OF EACH ROW SUBTREE. C (I) LEVEL(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING THE LEVEL C (DISTANCE FROM THE ROOT). C (I) WEIGHT(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING WEIGHTS C USED TO COMPUTE COLUMN COUNTS. C (I) FDESC(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING THE C FIRST (I.E., LOWEST-NUMBERED) DESCENDANT. C (I) NCHILD(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING THE C NUMBER OF CHILDREN. C (I) PRVNBR(*) - ARRAY OF LENGTH NEQNS USED TO RECORD THE C PREVIOUS ``LOWER NEIGHBOR'' OF EACH NODE. C C FIRST CREATED ON APRIL 12, 1990. C LAST UPDATED ON JANUARY 12, 1995. C C*********************************************************************** C SUBROUTINE FCNTHN ( NEQNS , ADJLEN, XADJ , ADJNCY, PERM , & INVP , ETPAR , ROWCNT, COLCNT, NLNZ , & SET , PRVLF , LEVEL , WEIGHT, FDESC , & NCHILD, PRVNBR ) C C ----------- C PARAMETERS. C ----------- INTEGER ADJLEN, NEQNS , NLNZ INTEGER ADJNCY(ADJLEN) , COLCNT(NEQNS) , & ETPAR(NEQNS) , FDESC(0:NEQNS), & INVP(NEQNS) , LEVEL(0:NEQNS), & NCHILD(0:NEQNS) , PERM(NEQNS) , & PRVLF(NEQNS) , PRVNBR(NEQNS) , & ROWCNT(NEQNS) , SET(NEQNS) , & WEIGHT(0:NEQNS) INTEGER XADJ(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER HINBR , IFDESC, J , JSTOP , JSTRT , & K , LAST1 , LAST2 , LCA , LFLAG , & LOWNBR, OLDNBR, PARENT, PLEAF , TEMP , & XSUP C C*********************************************************************** C C -------------------------------------------------- C COMPUTE LEVEL(*), FDESC(*), NCHILD(*). C INITIALIZE XSUP, ROWCNT(*), COLCNT(*), C SET(*), PRVLF(*), WEIGHT(*), PRVNBR(*). C -------------------------------------------------- XSUP = 1 LEVEL(0) = 0 DO 100 K = NEQNS, 1, -1 ROWCNT(K) = 1 COLCNT(K) = 0 SET(K) = K PRVLF(K) = 0 LEVEL(K) = LEVEL(ETPAR(K)) + 1 WEIGHT(K) = 1 FDESC(K) = K NCHILD(K) = 0 PRVNBR(K) = 0 100 CONTINUE NCHILD(0) = 0 FDESC(0) = 0 DO 200 K = 1, NEQNS PARENT = ETPAR(K) WEIGHT(PARENT) = 0 NCHILD(PARENT) = NCHILD(PARENT) + 1 IFDESC = FDESC(K) IF ( IFDESC .LT. FDESC(PARENT) ) THEN FDESC(PARENT) = IFDESC ENDIF 200 CONTINUE C ------------------------------------ C FOR EACH ``LOW NEIGHBOR'' LOWNBR ... C ------------------------------------ DO 600 LOWNBR = 1, NEQNS LFLAG = 0 IFDESC = FDESC(LOWNBR) OLDNBR = PERM(LOWNBR) JSTRT = XADJ(OLDNBR) JSTOP = XADJ(OLDNBR+1) - 1 C ----------------------------------------------- C FOR EACH ``HIGH NEIGHBOR'', HINBR OF LOWNBR ... C ----------------------------------------------- DO 500 J = JSTRT, JSTOP HINBR = INVP(ADJNCY(J)) IF ( HINBR .GT. LOWNBR ) THEN IF ( IFDESC .GT. PRVNBR(HINBR) ) THEN C ------------------------- C INCREMENT WEIGHT(LOWNBR). C ------------------------- WEIGHT(LOWNBR) = WEIGHT(LOWNBR) + 1 PLEAF = PRVLF(HINBR) C ----------------------------------------- C IF HINBR HAS NO PREVIOUS ``LOW NEIGHBOR'' C THEN ... C ----------------------------------------- IF ( PLEAF .EQ. 0 ) THEN C ----------------------------------------- C ... ACCUMULATE LOWNBR-->HINBR PATH LENGTH C IN ROWCNT(HINBR). C ----------------------------------------- ROWCNT(HINBR) = ROWCNT(HINBR) + & LEVEL(LOWNBR) - LEVEL(HINBR) ELSE C ----------------------------------------- C ... OTHERWISE, LCA <-- FIND(PLEAF), WHICH C IS THE LEAST COMMON ANCESTOR OF PLEAF C AND LOWNBR. C (PATH HALVING.) C ----------------------------------------- LAST1 = PLEAF LAST2 = SET(LAST1) LCA = SET(LAST2) 300 CONTINUE IF ( LCA .NE. LAST2 ) THEN SET(LAST1) = LCA LAST1 = LCA LAST2 = SET(LAST1) LCA = SET(LAST2) GO TO 300 ENDIF C ------------------------------------- C ACCUMULATE PLEAF-->LCA PATH LENGTH IN C ROWCNT(HINBR). C DECREMENT WEIGHT(LCA). C ------------------------------------- ROWCNT(HINBR) = ROWCNT(HINBR) & + LEVEL(LOWNBR) - LEVEL(LCA) WEIGHT(LCA) = WEIGHT(LCA) - 1 ENDIF C ---------------------------------------------- C LOWNBR NOW BECOMES ``PREVIOUS LEAF'' OF HINBR. C ---------------------------------------------- PRVLF(HINBR) = LOWNBR LFLAG = 1 ENDIF C -------------------------------------------------- C LOWNBR NOW BECOMES ``PREVIOUS NEIGHBOR'' OF HINBR. C -------------------------------------------------- PRVNBR(HINBR) = LOWNBR ENDIF 500 CONTINUE C ---------------------------------------------------- C DECREMENT WEIGHT ( PARENT(LOWNBR) ). C SET ( P(LOWNBR) ) <-- SET ( P(LOWNBR) ) + SET(XSUP). C ---------------------------------------------------- PARENT = ETPAR(LOWNBR) WEIGHT(PARENT) = WEIGHT(PARENT) - 1 IF ( LFLAG .EQ. 1 .OR. & NCHILD(LOWNBR) .GE. 2 ) THEN XSUP = LOWNBR ENDIF SET(XSUP) = PARENT 600 CONTINUE C --------------------------------------------------------- C USE WEIGHTS TO COMPUTE COLUMN (AND TOTAL) NONZERO COUNTS. C --------------------------------------------------------- NLNZ = 0 DO 700 K = 1, NEQNS TEMP = COLCNT(K) + WEIGHT(K) COLCNT(K) = TEMP NLNZ = NLNZ + TEMP PARENT = ETPAR(K) IF ( PARENT .NE. 0 ) THEN COLCNT(PARENT) = COLCNT(PARENT) + TEMP ENDIF 700 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: May 26, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**** FNSPLT ..... COMPUTE FINE PARTITIONING OF SUPERNODES ***** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE DETERMINES A FINE PARTITIONING OF SUPERNODES C WHEN THERE IS A CACHE AVAILABLE ON THE MACHINE. THE FINE C PARTITIONING IS CHOSEN SO THAT DATA RE-USE IS MAXIMIZED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C NSUPER - NUMBER OF SUPERNODES. C XSUPER - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C THE SUPERNODE PARTITIONING. C XLINDX - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C POINTERS IN THE SUPERNODE INDICES. C CACHSZ - CACHE SIZE IN KILO BYTES. C IF THERE IS NO CACHE, SET CACHSZ = 0. C C OUTPUT PARAMETERS: C SPLIT - INTEGER ARRAY OF SIZE NEQNS CONTAINING THE C FINE PARTITIONING. C C*********************************************************************** C SUBROUTINE FNSPLT ( NEQNS , NSUPER, XSUPER, XLINDX, & CACHSZ, SPLIT ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER CACHSZ, NEQNS , NSUPER INTEGER XSUPER(*), SPLIT(*) INTEGER XLINDX(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER CACHE , CURCOL, FSTCOL, HEIGHT, KCOL , 1 KSUP , LSTCOL, NCOLS , NXTBLK, USED , 1 WIDTH C C ******************************************************************* C C -------------------------------------------- C COMPUTE THE NUMBER OF 8-BYTE WORDS IN CACHE. C -------------------------------------------- IF ( CACHSZ .LE. 0 ) THEN CACHE = 2 000 000 000 ELSE CACHE = INT(( FLOAT(CACHSZ) * 1024. / 8. ) * 0.9) ENDIF C C --------------- C INITIALIZATION. C --------------- DO 100 KCOL = 1, NEQNS SPLIT(KCOL) = 0 100 CONTINUE C C --------------------------- C FOR EACH SUPERNODE KSUP ... C --------------------------- DO 1000 KSUP = 1, NSUPER C ----------------------- C ... GET SUPERNODE INFO. C ----------------------- HEIGHT = XLINDX(KSUP+1) - XLINDX(KSUP) FSTCOL = XSUPER(KSUP) LSTCOL = XSUPER(KSUP+1) - 1 WIDTH = LSTCOL - FSTCOL + 1 NXTBLK = FSTCOL C -------------------------------------- C ... UNTIL ALL COLUMNS OF THE SUPERNODE C HAVE BEEN PROCESSED ... C -------------------------------------- CURCOL = FSTCOL - 1 200 CONTINUE C ------------------------------------------- C ... PLACE THE FIRST COLUMN(S) IN THE CACHE. C ------------------------------------------- CURCOL = CURCOL + 1 IF ( CURCOL .LT. LSTCOL ) THEN CURCOL = CURCOL + 1 NCOLS = 2 USED = 4 * HEIGHT - 1 HEIGHT = HEIGHT - 2 ELSE NCOLS = 1 USED = 3 * HEIGHT HEIGHT = HEIGHT - 1 ENDIF C C -------------------------------------- C ... WHILE THE CACHE IS NOT FILLED AND C THERE ARE COLUMNS OF THE SUPERNODE C REMAINING TO BE PROCESSED ... C -------------------------------------- 300 CONTINUE IF ( USED+HEIGHT .LT. CACHE .AND. & CURCOL .LT. LSTCOL ) THEN C -------------------------------- C ... ADD ANOTHER COLUMN TO CACHE. C -------------------------------- CURCOL = CURCOL + 1 NCOLS = NCOLS + 1 USED = USED + HEIGHT HEIGHT = HEIGHT - 1 GO TO 300 ENDIF C ------------------------------------- C ... RECORD THE NUMBER OF COLUMNS THAT C FILLED THE CACHE. C ------------------------------------- SPLIT(NXTBLK) = NCOLS NXTBLK = NXTBLK + 1 C -------------------------- C ... GO PROCESS NEXT BLOCK. C -------------------------- IF ( CURCOL .LT. LSTCOL ) GO TO 200 1000 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** FNTSIZ ..... COMPUTE WORK STORAGE SIZE FOR BLKFCT ****** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE DETERMINES THE SIZE OF THE WORKING STORAGE C REQUIRED BY BLKFCT. C C INPUT PARAMETERS: C NSUPER - NUMBER OF SUPERNODES. C XSUPER - INTEGER ARRAY OF SIZE (NSUPER+1) CONTAINING C THE SUPERNODE PARTITIONING. C SNODE - SUPERNODE MEMBERSHIP. C (XLINDX,LINDX) - ARRAYS DESCRIBING THE SUPERNODAL STRUCTURE. C C OUTPUT PARAMETERS: C TMPSIZ - SIZE OF WORKING STORAGE REQUIRED BY BLKFCT. C C*********************************************************************** C SUBROUTINE FNTSIZ ( NSUPER, XSUPER, SNODE , XLINDX, & LINDX , TMPSIZ ) C C*********************************************************************** C INTEGER NSUPER, TMPSIZ INTEGER XLINDX(*) , XSUPER(*) INTEGER LINDX (*) , SNODE (*) C INTEGER BOUND , CLEN , CURSUP, I , IBEGIN, IEND , & KSUP , LENGTH, NCOLS , NXTSUP, & TSIZE , WIDTH C C*********************************************************************** C C RETURNS SIZE OF TEMP ARRAY USED BY BLKFCT FACTORIZATION ROUTINE. C NOTE THAT THE VALUE RETURNED IS AN ESTIMATE, THOUGH IT IS USUALLY C TIGHT. C C ---------------------------------------- C COMPUTE SIZE OF TEMPORARY STORAGE VECTOR C NEEDED BY BLKFCT. C ---------------------------------------- TMPSIZ = 0 DO 500 KSUP = NSUPER, 1, -1 NCOLS = XSUPER(KSUP+1) - XSUPER(KSUP) IBEGIN = XLINDX(KSUP) + NCOLS IEND = XLINDX(KSUP+1) - 1 LENGTH = IEND - IBEGIN + 1 BOUND = LENGTH * (LENGTH + 1) / 2 IF ( BOUND .GT. TMPSIZ ) THEN CURSUP = SNODE(LINDX(IBEGIN)) CLEN = XLINDX(CURSUP+1) - XLINDX(CURSUP) WIDTH = 0 DO 400 I = IBEGIN, IEND NXTSUP = SNODE(LINDX(I)) IF ( NXTSUP .EQ. CURSUP ) THEN WIDTH = WIDTH + 1 IF ( I .EQ. IEND ) THEN IF ( CLEN .GT. LENGTH ) THEN TSIZE = LENGTH * WIDTH - & (WIDTH - 1) * WIDTH / 2 TMPSIZ = MAX ( TSIZE , TMPSIZ ) ENDIF ENDIF ELSE IF ( CLEN .GT. LENGTH ) THEN TSIZE = LENGTH * WIDTH - & (WIDTH - 1) * WIDTH / 2 TMPSIZ = MAX ( TSIZE , TMPSIZ ) ENDIF LENGTH = LENGTH - WIDTH BOUND = LENGTH * (LENGTH + 1) / 2 IF ( BOUND .LE. TMPSIZ ) GO TO 500 WIDTH = 1 CURSUP = NXTSUP CLEN = XLINDX(CURSUP+1) - XLINDX(CURSUP) ENDIF 400 CONTINUE ENDIF 500 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**************** FSUP1 ..... FIND SUPERNODES #1 ***************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE IS THE FIRST OF TWO ROUTINES FOR FINDING A C MAXIMAL SUPERNODE PARTITION. IT RETURNS ONLY THE NUMBER OF C SUPERNODES NSUPER AND THE SUPERNODE MEMBERSHIP VECTOR SNODE(*), C WHICH IS OF LENGTH NEQNS. THE VECTORS OF LENGTH NSUPER ARE C COMPUTED SUBSEQUENTLY BY THE COMPANION ROUTINE FSUP2. C C METHOD AND ASSUMPTIONS: C THIS ROUTINE USES THE ELIMINATION TREE AND THE FACTOR COLUMN C COUNTS TO COMPUTE THE SUPERNODE PARTITION; IT ALSO ASSUMES A C POSTORDERING OF THE ELIMINATION TREE. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS. C (I) ETPAR(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C ELIMINATION TREE OF THE POSTORDERED MATRIX. C (I) COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C FACTOR COLUMN COUNTS: I.E., THE NUMBER OF C NONZERO ENTRIES IN EACH COLUMN OF L C (INCLUDING THE DIAGONAL ENTRY). C C OUTPUT PARAMETERS: C (I) NOFSUB - NUMBER OF SUBSCRIPTS. C (I) NSUPER - NUMBER OF SUPERNODES (<= NEQNS). C (I) SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C C FIRST CREATED ON JANUARY 18, 1992. C LAST UPDATED ON NOVEMBER 11, 1994. C C*********************************************************************** C SUBROUTINE FSUP1 ( NEQNS , ETPAR , COLCNT, NOFSUB, NSUPER, & SNODE ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER NEQNS , NOFSUB, NSUPER INTEGER COLCNT(*) , ETPAR(*) , & SNODE(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER KCOL C C*********************************************************************** C C -------------------------------------------- C COMPUTE THE FUNDAMENTAL SUPERNODE PARTITION. C -------------------------------------------- NSUPER = 1 SNODE(1) = 1 NOFSUB = COLCNT(1) DO 300 KCOL = 2, NEQNS IF ( ETPAR(KCOL-1) .EQ. KCOL ) THEN IF ( COLCNT(KCOL-1) .EQ. COLCNT(KCOL)+1 ) THEN SNODE(KCOL) = NSUPER GO TO 300 ENDIF ENDIF NSUPER = NSUPER + 1 SNODE(KCOL) = NSUPER NOFSUB = NOFSUB + COLCNT(KCOL) 300 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**************** FSUP2 ..... FIND SUPERNODES #2 ***************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE IS THE SECOND OF TWO ROUTINES FOR FINDING A C MAXIMAL SUPERNODE PARTITION. IT'S SOLE PURPOSE IS TO C CONSTRUCT THE NEEDED VECTOR OF LENGTH NSUPER: XSUPER(*). THE C FIRST ROUTINE FSUP1 COMPUTES THE NUMBER OF SUPERNODES AND THE C SUPERNODE MEMBERSHIP VECTOR SNODE(*), WHICH IS OF LENGTH NEQNS. C C C ASSUMPTIONS: C THIS ROUTINE ASSUMES A POSTORDERING OF THE ELIMINATION TREE. IT C ALSO ASSUMES THAT THE OUTPUT FROM FSUP1 IS AVAILABLE. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS. C (I) NSUPER - NUMBER OF SUPERNODES (<= NEQNS). C (I) SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C C OUTPUT PARAMETERS: C (I) XSUPER(*) - ARRAY OF LENGTH NSUPER+1, CONTAINING THE C SUPERNODE PARTITIONING. C C FIRST CREATED ON JANUARY 18, 1992. C LAST UPDATED ON NOVEMEBER 22, 1994. C C*********************************************************************** C SUBROUTINE FSUP2 ( NEQNS , NSUPER, SNODE , XSUPER ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER NEQNS , NSUPER INTEGER SNODE(*) , & XSUPER(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER KCOL , KSUP , LSTSUP C C*********************************************************************** C C ------------------------------------------------- C COMPUTE THE SUPERNODE PARTITION VECTOR XSUPER(*). C ------------------------------------------------- LSTSUP = NSUPER + 1 DO 100 KCOL = NEQNS, 1, -1 KSUP = SNODE(KCOL) IF ( KSUP .NE. LSTSUP ) THEN XSUPER(LSTSUP) = KCOL + 1 ENDIF LSTSUP = KSUP 100 CONTINUE XSUPER(1) = 1 C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = GENMMD C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C**** GENMMD ..... MULTIPLE MINIMUM EXTERNAL DEGREE ************ C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE C ALGORITHM. IT MAKES USE OF THE IMPLICIT REPRESENTATION C OF ELIMINATION GRAPHS BY QUOTIENT GRAPHS, AND THE C NOTION OF INDISTINGUISHABLE NODES. IT ALSO IMPLEMENTS C THE MODIFICATIONS BY MULTIPLE ELIMINATION AND MINIMUM C EXTERNAL DEGREE. C --------------------------------------------- C CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE C DESTROYED. C --------------------------------------------- C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. C MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) INTEGER C (ANY SMALLER ESTIMATE WILL DO) FOR MARKING C NODES. C C OUTPUT PARAMETERS - C PERM - THE MINIMUM DEGREE ORDERING. C INVP - THE INVERSE OF PERM. C NOFSUB - AN UPPER BOUND ON THE NUMBER OF NONZERO C SUBSCRIPTS FOR THE COMPRESSED STORAGE SCHEME. C C WORKING PARAMETERS - C DHEAD - VECTOR FOR HEAD OF DEGREE LISTS. C INVP - USED TEMPORARILY FOR DEGREE FORWARD LINK. C PERM - USED TEMPORARILY FOR DEGREE BACKWARD LINK. C QSIZE - VECTOR FOR SIZE OF SUPERNODES. C LLIST - VECTOR FOR TEMPORARY LINKED LISTS. C MARKER - A TEMPORARY MARKER VECTOR. C C PROGRAM SUBROUTINES - C MMDELM, MMDINT, MMDNUM, MMDUPD. C C*********************************************************************** C SUBROUTINE GENMMD ( NEQNS, XADJ, ADJNCY, INVP, PERM, 1 DELTA, DHEAD, QSIZE, LLIST, MARKER, 1 MAXINT, NOFSUB ) C C*********************************************************************** C INTEGER ADJNCY(*), DHEAD(*) , INVP(*) , LLIST(*) , 1 MARKER(*), PERM(*) , QSIZE(*) INTEGER XADJ(*) INTEGER DELTA , EHEAD , I , MAXINT, MDEG , 1 MDLMT , MDNODE, NEQNS , NEXTMD, NOFSUB, 1 NUM, TAG C C*********************************************************************** C IF ( NEQNS .LE. 0 ) RETURN C C ------------------------------------------------ C INITIALIZATION FOR THE MINIMUM DEGREE ALGORITHM. C ------------------------------------------------ NOFSUB = 0 CALL MMDINT ( NEQNS, XADJ, DHEAD, INVP, PERM, 1 QSIZE, LLIST, MARKER ) C C ---------------------------------------------- C NUM COUNTS THE NUMBER OF ORDERED NODES PLUS 1. C ---------------------------------------------- NUM = 1 C C ----------------------------- C ELIMINATE ALL ISOLATED NODES. C ----------------------------- NEXTMD = DHEAD(1) 100 CONTINUE IF ( NEXTMD .LE. 0 ) GO TO 200 MDNODE = NEXTMD NEXTMD = INVP(MDNODE) MARKER(MDNODE) = MAXINT INVP(MDNODE) = - NUM NUM = NUM + 1 GO TO 100 C 200 CONTINUE C ---------------------------------------- C SEARCH FOR NODE OF THE MINIMUM DEGREE. C MDEG IS THE CURRENT MINIMUM DEGREE; C TAG IS USED TO FACILITATE MARKING NODES. C ---------------------------------------- IF ( NUM .GT. NEQNS ) GO TO 1000 TAG = 1 DHEAD(1) = 0 MDEG = 2 300 CONTINUE IF ( DHEAD(MDEG) .GT. 0 ) GO TO 400 MDEG = MDEG + 1 GO TO 300 400 CONTINUE C ------------------------------------------------- C USE VALUE OF DELTA TO SET UP MDLMT, WHICH GOVERNS C WHEN A DEGREE UPDATE IS TO BE PERFORMED. C ------------------------------------------------- MDLMT = MDEG + DELTA EHEAD = 0 C 500 CONTINUE MDNODE = DHEAD(MDEG) IF ( MDNODE .GT. 0 ) GO TO 600 MDEG = MDEG + 1 IF ( MDEG .GT. MDLMT ) GO TO 900 GO TO 500 600 CONTINUE C ---------------------------------------- C REMOVE MDNODE FROM THE DEGREE STRUCTURE. C ---------------------------------------- NEXTMD = INVP(MDNODE) DHEAD(MDEG) = NEXTMD IF ( NEXTMD .GT. 0 ) PERM(NEXTMD) = - MDEG INVP(MDNODE) = - NUM NOFSUB = NOFSUB + MDEG + QSIZE(MDNODE) - 2 IF ( NUM+QSIZE(MDNODE) .GT. NEQNS ) GO TO 1000 C ---------------------------------------------- C ELIMINATE MDNODE AND PERFORM QUOTIENT GRAPH C TRANSFORMATION. RESET TAG VALUE IF NECESSARY. C ---------------------------------------------- TAG = TAG + 1 IF ( TAG .LT. MAXINT ) GO TO 800 TAG = 1 DO 700 I = 1, NEQNS IF ( MARKER(I) .LT. MAXINT ) MARKER(I) = 0 700 CONTINUE 800 CONTINUE CALL MMDELM ( MDNODE, XADJ, ADJNCY, DHEAD, INVP, 1 PERM, QSIZE, LLIST, MARKER, MAXINT, 1 TAG ) NUM = NUM + QSIZE(MDNODE) LLIST(MDNODE) = EHEAD EHEAD = MDNODE IF ( DELTA .GE. 0 ) GO TO 500 900 CONTINUE C ------------------------------------------- C UPDATE DEGREES OF THE NODES INVOLVED IN THE C MINIMUM DEGREE NODES ELIMINATION. C ------------------------------------------- IF ( NUM .GT. NEQNS ) GO TO 1000 CALL MMDUPD ( EHEAD, NEQNS, XADJ, ADJNCY, DELTA, MDEG, 1 DHEAD, INVP, PERM, QSIZE, LLIST, MARKER, 1 MAXINT, TAG ) GO TO 300 C 1000 CONTINUE CALL MMDNUM ( NEQNS, PERM, INVP, QSIZE ) RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** IGATHR .... INTEGER GATHER OPERATION ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS A STANDARD INTEGER GATHER C OPERATION. C C INPUT PARAMETERS - C KLEN - LENGTH OF THE LIST OF GLOBAL INDICES. C LINDX - LIST OF GLOBAL INDICES. C INDMAP - INDEXED BY GLOBAL INDICES, IT CONTAINS THE C REQUIRED RELATIVE INDICES. C C OUTPUT PARAMETERS - C RELIND - LIST RELATIVE INDICES. C C*********************************************************************** C SUBROUTINE IGATHR ( KLEN , LINDX, INDMAP, RELIND ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER KLEN INTEGER INDMAP(*), LINDX (*), RELIND(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER I C C*********************************************************************** C CDIR$ IVDEP DO 100 I = 1, KLEN RELIND(I) = INDMAP(LINDX(I)) 100 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C C ------------------------------------------------------ C INPUT NUMERICAL VALUES INTO SPARSE DATA STRUCTURES ... C ------------------------------------------------------ C SUBROUTINE INPNV ( XADJF, ADJF, ANZF, PERM, INVP, & NSUPER, XSUPER, XLINDX, LINDX, & XLNZ, LNZ, OFFSET ) C INTEGER XADJF(*), ADJF(*) DOUBLE PRECISION ANZF(*) INTEGER PERM(*), INVP(*) INTEGER NSUPER INTEGER XSUPER(*), XLINDX(*), LINDX(*) INTEGER XLNZ(*) DOUBLE PRECISION LNZ(*) INTEGER OFFSET(*) C INTEGER I, II, J, JLEN, JSUPER, LAST, OLDJ C DO 500 JSUPER = 1, NSUPER C C ---------------------------------------- C FOR EACH SUPERNODE, DO THE FOLLOWING ... C ---------------------------------------- C C ----------------------------------------------- C FIRST GET OFFSET TO FACILITATE NUMERICAL INPUT. C ----------------------------------------------- JLEN = XLINDX(JSUPER+1) - XLINDX(JSUPER) DO 100 II = XLINDX(JSUPER), XLINDX(JSUPER+1)-1 I = LINDX(II) JLEN = JLEN - 1 OFFSET(I) = JLEN 100 CONTINUE C DO 400 J = XSUPER(JSUPER), XSUPER(JSUPER+1)-1 C ----------------------------------------- C FOR EACH COLUMN IN THE CURRENT SUPERNODE, C FIRST INITIALIZE THE DATA STRUCTURE. C ----------------------------------------- c DO 200 II = XLNZ(J), XLNZ(J+1)-1 c LNZ(II) = 0.0 c 200 CONTINUE c The previous lines are not required as R initializes the arrays c Reinhard Furrer, Nov 19, 2007 C C ----------------------------------- C NEXT INPUT THE INDIVIDUAL NONZEROS. C ----------------------------------- OLDJ = PERM(J) LAST = XLNZ(J+1) - 1 DO 300 II = XADJF(OLDJ), XADJF(OLDJ+1)-1 I = INVP(ADJF(II)) IF ( I .GE. J ) THEN LNZ(LAST-OFFSET(I)) = ANZF(II) ENDIF 300 CONTINUE 400 CONTINUE C 500 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C*********** INVINV ..... CONCATENATION OF TWO INVP ************ C*********************************************************************** C*********************************************************************** C C WRITTEN BY JOSEPH LIU (JUL 17, 1985) C C PURPOSE: C TO PERFORM THE MAPPING OF C ORIGINAL-INVP --> INTERMEDIATE-INVP --> NEW INVP C AND THE RESULTING ORDERING REPLACES INVP. THE NEW PERMUTATION C VECTOR PERM IS ALSO COMPUTED. C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C INVP2 - THE SECOND INVERSE PERMUTATION VECTOR. C C UPDATED PARAMETERS: C INVP - THE FIRST INVERSE PERMUTATION VECTOR. ON C OUTPUT, IT CONTAINS THE NEW INVERSE C PERMUTATION. C C OUTPUT PARAMETER: C PERM - NEW PERMUTATION VECTOR (CAN BE THE SAME AS C INVP2). C C*********************************************************************** C SUBROUTINE INVINV ( NEQNS , INVP , INVP2 , PERM ) C C*********************************************************************** C INTEGER(4) INVP(*) , INVP2(*) , & PERM(*) C INTEGER(4) NEQNS C C*********************************************************************** C INTEGER(4) I , INTERM, NODE C C*********************************************************************** C DO 100 I = 1, NEQNS INTERM = INVP(I) INVP(I) = INVP2(INTERM) 100 CONTINUE C DO 200 I = 1, NEQNS NODE = INVP(I) PERM(NODE) = I 200 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** LDINDX .... LOAD INDEX VECTOR ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE COMPUTES THE SECOND INDEX VECTOR C USED TO IMPLEMENT THE DOUBLY-INDIRECT SAXPY-LIKE C LOOPS THAT ALLOW US TO ACCUMULATE UPDATE C COLUMNS DIRECTLY INTO FACTOR STORAGE. C C INPUT PARAMETERS - C JLEN - LENGTH OF THE FIRST COLUMN OF THE SUPERNODE, C INCLUDING THE DIAGONAL ENTRY. C LINDX - THE OFF-DIAGONAL ROW INDICES OF THE SUPERNODE, C I.E., THE ROW INDICES OF THE NONZERO ENTRIES C LYING BELOW THE DIAGONAL ENTRY OF THE FIRST C COLUMN OF THE SUPERNODE. C C OUTPUT PARAMETERS - C INDMAP - THIS INDEX VECTOR MAPS EVERY GLOBAL ROW INDEX C OF NONZERO ENTRIES IN THE FIRST COLUMN OF THE C SUPERNODE TO ITS POSITION IN THE INDEX LIST C RELATIVE TO THE LAST INDEX IN THE LIST. MORE C PRECISELY, IT GIVES THE DISTANCE OF EACH INDEX C FROM THE LAST INDEX IN THE LIST. C C*********************************************************************** C SUBROUTINE LDINDX ( JLEN, LINDX, INDMAP ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER JLEN INTEGER LINDX(*), INDMAP(*) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER CURLEN, J, JSUB C C*********************************************************************** C CURLEN = JLEN DO 200 J = 1, JLEN JSUB = LINDX(J) CURLEN = CURLEN - 1 INDMAP(JSUB) = CURLEN 200 CONTINUE RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDELM C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C** MMDELM ..... MULTIPLE MINIMUM DEGREE ELIMINATION *********** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE ELIMINATES THE NODE MDNODE OF C MINIMUM DEGREE FROM THE ADJACENCY STRUCTURE, WHICH C IS STORED IN THE QUOTIENT GRAPH FORMAT. IT ALSO C TRANSFORMS THE QUOTIENT GRAPH REPRESENTATION OF THE C ELIMINATION GRAPH. C C INPUT PARAMETERS - C MDNODE - NODE OF MINIMUM DEGREE. C MAXINT - ESTIMATE OF MAXIMUM REPRESENTABLE (SHORT) C INTEGER. C TAG - TAG VALUE. C C UPDATED PARAMETERS - C (XADJ,ADJNCY) - UPDATED ADJACENCY STRUCTURE. C (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. C QSIZE - SIZE OF SUPERNODE. C MARKER - MARKER VECTOR. C LLIST - TEMPORARY LINKED LIST OF ELIMINATED NABORS. C C*********************************************************************** C SUBROUTINE MMDELM ( MDNODE, XADJ, ADJNCY, DHEAD, DFORW, 1 DBAKW, QSIZE, LLIST, MARKER, MAXINT, 1 TAG ) C C*********************************************************************** C INTEGER ADJNCY(*), DBAKW(*) , DFORW(*) , DHEAD(*) , 1 LLIST(*) , MARKER(*), QSIZE(*) INTEGER XADJ(*) INTEGER ELMNT , I , ISTOP , ISTRT , J , 1 JSTOP , JSTRT , LINK , MAXINT, MDNODE, 1 NABOR , NODE , NPV , NQNBRS, NXNODE, 1 PVNODE, RLMT , RLOC , RNODE , TAG , 1 XQNBR C C*********************************************************************** C C ----------------------------------------------- C FIND REACHABLE SET AND PLACE IN DATA STRUCTURE. C ----------------------------------------------- MARKER(MDNODE) = TAG ISTRT = XADJ(MDNODE) ISTOP = XADJ(MDNODE+1) - 1 C ------------------------------------------------------- C ELMNT POINTS TO THE BEGINNING OF THE LIST OF ELIMINATED C NABORS OF MDNODE, AND RLOC GIVES THE STORAGE LOCATION C FOR THE NEXT REACHABLE NODE. C ------------------------------------------------------- ELMNT = 0 RLOC = ISTRT RLMT = ISTOP DO 200 I = ISTRT, ISTOP NABOR = ADJNCY(I) IF ( NABOR .EQ. 0 ) GO TO 300 IF ( MARKER(NABOR) .GE. TAG ) GO TO 200 MARKER(NABOR) = TAG IF ( DFORW(NABOR) .LT. 0 ) GO TO 100 ADJNCY(RLOC) = NABOR RLOC = RLOC + 1 GO TO 200 100 CONTINUE LLIST(NABOR) = ELMNT ELMNT = NABOR 200 CONTINUE 300 CONTINUE C ----------------------------------------------------- C MERGE WITH REACHABLE NODES FROM GENERALIZED ELEMENTS. C ----------------------------------------------------- IF ( ELMNT .LE. 0 ) GO TO 1000 ADJNCY(RLMT) = - ELMNT LINK = ELMNT 400 CONTINUE JSTRT = XADJ(LINK) JSTOP = XADJ(LINK+1) - 1 DO 800 J = JSTRT, JSTOP NODE = ADJNCY(J) LINK = - NODE C IF ( NODE ) 400, 900, 500 if ( NODE .LT. 0) GO TO 400 if ( NODE .EQ. 0) GO TO 900 C 500 CONTINUE IF ( MARKER(NODE) .GE. TAG .OR. 1 DFORW(NODE) .LT. 0 ) GO TO 800 MARKER(NODE) = TAG C --------------------------------- C USE STORAGE FROM ELIMINATED NODES C IF NECESSARY. C --------------------------------- 600 CONTINUE IF ( RLOC .LT. RLMT ) GO TO 700 LINK = - ADJNCY(RLMT) RLOC = XADJ(LINK) RLMT = XADJ(LINK+1) - 1 GO TO 600 700 CONTINUE ADJNCY(RLOC) = NODE RLOC = RLOC + 1 800 CONTINUE 900 CONTINUE ELMNT = LLIST(ELMNT) GO TO 300 1000 CONTINUE IF ( RLOC .LE. RLMT ) ADJNCY(RLOC) = 0 C -------------------------------------------------------- C FOR EACH NODE IN THE REACHABLE SET, DO THE FOLLOWING ... C -------------------------------------------------------- LINK = MDNODE 1100 CONTINUE ISTRT = XADJ(LINK) ISTOP = XADJ(LINK+1) - 1 DO 1700 I = ISTRT, ISTOP RNODE = ADJNCY(I) LINK = - RNODE C IF ( RNODE ) 1100, 1800, 1200 if ( RNODE .LT. 0) GO TO 1100 if ( RNODE .EQ. 0) GO TO 1800 C 1200 CONTINUE C -------------------------------------------- C IF RNODE IS IN THE DEGREE LIST STRUCTURE ... C -------------------------------------------- PVNODE = DBAKW(RNODE) IF ( PVNODE .EQ. 0 .OR. 1 PVNODE .EQ. (-MAXINT) ) GO TO 1300 C ------------------------------------- C THEN REMOVE RNODE FROM THE STRUCTURE. C ------------------------------------- NXNODE = DFORW(RNODE) IF ( NXNODE .GT. 0 ) DBAKW(NXNODE) = PVNODE IF ( PVNODE .GT. 0 ) DFORW(PVNODE) = NXNODE NPV = - PVNODE IF ( PVNODE .LT. 0 ) DHEAD(NPV) = NXNODE 1300 CONTINUE C ---------------------------------------- C PURGE INACTIVE QUOTIENT NABORS OF RNODE. C ---------------------------------------- JSTRT = XADJ(RNODE) JSTOP = XADJ(RNODE+1) - 1 XQNBR = JSTRT DO 1400 J = JSTRT, JSTOP NABOR = ADJNCY(J) IF ( NABOR .EQ. 0 ) GO TO 1500 IF ( MARKER(NABOR) .GE. TAG ) GO TO 1400 ADJNCY(XQNBR) = NABOR XQNBR = XQNBR + 1 1400 CONTINUE 1500 CONTINUE C ---------------------------------------- C IF NO ACTIVE NABOR AFTER THE PURGING ... C ---------------------------------------- NQNBRS = XQNBR - JSTRT IF ( NQNBRS .GT. 0 ) GO TO 1600 C ----------------------------- C THEN MERGE RNODE WITH MDNODE. C ----------------------------- QSIZE(MDNODE) = QSIZE(MDNODE) + QSIZE(RNODE) QSIZE(RNODE) = 0 MARKER(RNODE) = MAXINT DFORW(RNODE) = - MDNODE DBAKW(RNODE) = - MAXINT GO TO 1700 1600 CONTINUE C -------------------------------------- C ELSE FLAG RNODE FOR DEGREE UPDATE, AND C ADD MDNODE AS A NABOR OF RNODE. C -------------------------------------- DFORW(RNODE) = NQNBRS + 1 DBAKW(RNODE) = 0 ADJNCY(XQNBR) = MDNODE XQNBR = XQNBR + 1 IF ( XQNBR .LE. JSTOP ) ADJNCY(XQNBR) = 0 C 1700 CONTINUE 1800 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDINT C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C*** MMDINT ..... MULT MINIMUM DEGREE INITIALIZATION *********** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS INITIALIZATION FOR THE C MULTIPLE ELIMINATION VERSION OF THE MINIMUM DEGREE C ALGORITHM. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - ADJACENCY STRUCTURE. C C OUTPUT PARAMETERS - C (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. C QSIZE - SIZE OF SUPERNODE (INITIALIZED TO ONE). C LLIST - LINKED LIST. C MARKER - MARKER VECTOR. C C*********************************************************************** C SUBROUTINE MMDINT ( NEQNS, XADJ, DHEAD, DFORW, 1 DBAKW, QSIZE, LLIST, MARKER ) C C*********************************************************************** C INTEGER DBAKW(*) , DFORW(*) , DHEAD(*) , 1 LLIST(*) , MARKER(*), QSIZE(*) INTEGER XADJ(*) INTEGER FNODE , NDEG , NEQNS , NODE C C*********************************************************************** C DO 100 NODE = 1, NEQNS DHEAD(NODE) = 0 QSIZE(NODE) = 1 MARKER(NODE) = 0 LLIST(NODE) = 0 100 CONTINUE C ------------------------------------------ C INITIALIZE THE DEGREE DOUBLY LINKED LISTS. C ------------------------------------------ DO 200 NODE = 1, NEQNS NDEG = XADJ(NODE+1) - XADJ(NODE) + 1 FNODE = DHEAD(NDEG) DFORW(NODE) = FNODE DHEAD(NDEG) = NODE IF ( FNODE .GT. 0 ) DBAKW(FNODE) = NODE DBAKW(NODE) = - NDEG 200 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDNUM C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C***** MMDNUM ..... MULTI MINIMUM DEGREE NUMBERING ************* C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS THE FINAL STEP IN C PRODUCING THE PERMUTATION AND INVERSE PERMUTATION C VECTORS IN THE MULTIPLE ELIMINATION VERSION OF THE C MINIMUM DEGREE ORDERING ALGORITHM. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C QSIZE - SIZE OF SUPERNODES AT ELIMINATION. C C UPDATED PARAMETERS - C INVP - INVERSE PERMUTATION VECTOR. ON INPUT, C IF QSIZE(NODE)=0, THEN NODE HAS BEEN MERGED C INTO THE NODE -INVP(NODE); OTHERWISE, C -INVP(NODE) IS ITS INVERSE LABELLING. C C OUTPUT PARAMETERS - C PERM - THE PERMUTATION VECTOR. C C*********************************************************************** C SUBROUTINE MMDNUM ( NEQNS, PERM, INVP, QSIZE ) C C*********************************************************************** C INTEGER INVP(*) , PERM(*) , QSIZE(*) INTEGER FATHER, NEQNS , NEXTF , NODE , NQSIZE, 1 NUM , ROOT C C*********************************************************************** C DO 100 NODE = 1, NEQNS NQSIZE = QSIZE(NODE) IF ( NQSIZE .LE. 0 ) PERM(NODE) = INVP(NODE) IF ( NQSIZE .GT. 0 ) PERM(NODE) = - INVP(NODE) 100 CONTINUE C ------------------------------------------------------ C FOR EACH NODE WHICH HAS BEEN MERGED, DO THE FOLLOWING. C ------------------------------------------------------ DO 500 NODE = 1, NEQNS IF ( PERM(NODE) .GT. 0 ) GO TO 500 C ----------------------------------------- C TRACE THE MERGED TREE UNTIL ONE WHICH HAS C NOT BEEN MERGED, CALL IT ROOT. C ----------------------------------------- FATHER = NODE 200 CONTINUE IF ( PERM(FATHER) .GT. 0 ) GO TO 300 FATHER = - PERM(FATHER) GO TO 200 300 CONTINUE C ----------------------- C NUMBER NODE AFTER ROOT. C ----------------------- ROOT = FATHER NUM = PERM(ROOT) + 1 INVP(NODE) = - NUM PERM(ROOT) = NUM C ------------------------ C SHORTEN THE MERGED TREE. C ------------------------ FATHER = NODE 400 CONTINUE NEXTF = - PERM(FATHER) IF ( NEXTF .LE. 0 ) GO TO 500 PERM(FATHER) = - ROOT FATHER = NEXTF GO TO 400 500 CONTINUE C ---------------------- C READY TO COMPUTE PERM. C ---------------------- DO 600 NODE = 1, NEQNS NUM = - INVP(NODE) INVP(NODE) = NUM PERM(NUM) = NODE 600 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Joseph W.H. Liu C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C--- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDUPD C (C) UNIVERSITY OF WATERLOO JANUARY 1984 C*********************************************************************** C*********************************************************************** C***** MMDUPD ..... MULTIPLE MINIMUM DEGREE UPDATE ************* C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE UPDATES THE DEGREES OF NODES C AFTER A MULTIPLE ELIMINATION STEP. C C INPUT PARAMETERS - C EHEAD - THE BEGINNING OF THE LIST OF ELIMINATED C NODES (I.E., NEWLY FORMED ELEMENTS). C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - ADJACENCY STRUCTURE. C DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. C MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) C INTEGER. C C UPDATED PARAMETERS - C MDEG - NEW MINIMUM DEGREE AFTER DEGREE UPDATE. C (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. C QSIZE - SIZE OF SUPERNODE. C LLIST - WORKING LINKED LIST. C MARKER - MARKER VECTOR FOR DEGREE UPDATE. C TAG - TAG VALUE. C C*********************************************************************** C SUBROUTINE MMDUPD ( EHEAD, NEQNS, XADJ, ADJNCY, DELTA, 1 MDEG, DHEAD, DFORW, DBAKW, QSIZE, 1 LLIST, MARKER, MAXINT, TAG ) C C*********************************************************************** C INTEGER ADJNCY(*), DBAKW(*) , DFORW(*) , DHEAD(*) , 1 LLIST(*) , MARKER(*), QSIZE(*) INTEGER XADJ(*) INTEGER DEG , DEG0 , DELTA , EHEAD , ELMNT , 1 ENODE , FNODE , I , IQ2 , ISTOP , 1 ISTRT , J , JSTOP , JSTRT , LINK , 1 MAXINT, MDEG , MDEG0 , MTAG , NABOR , 1 NEQNS , NODE , Q2HEAD, QXHEAD, TAG C C*********************************************************************** C MDEG0 = MDEG + DELTA ELMNT = EHEAD 100 CONTINUE C ------------------------------------------------------- C FOR EACH OF THE NEWLY FORMED ELEMENT, DO THE FOLLOWING. C (RESET TAG VALUE IF NECESSARY.) C ------------------------------------------------------- IF ( ELMNT .LE. 0 ) RETURN MTAG = TAG + MDEG0 IF ( MTAG .LT. MAXINT ) GO TO 300 TAG = 1 DO 200 I = 1, NEQNS IF ( MARKER(I) .LT. MAXINT ) MARKER(I) = 0 200 CONTINUE MTAG = TAG + MDEG0 300 CONTINUE C --------------------------------------------- C CREATE TWO LINKED LISTS FROM NODES ASSOCIATED C WITH ELMNT: ONE WITH TWO NABORS (Q2HEAD) IN C ADJACENCY STRUCTURE, AND THE OTHER WITH MORE C THAN TWO NABORS (QXHEAD). ALSO COMPUTE DEG0, C NUMBER OF NODES IN THIS ELEMENT. C --------------------------------------------- Q2HEAD = 0 QXHEAD = 0 DEG0 = 0 LINK = ELMNT 400 CONTINUE ISTRT = XADJ(LINK) ISTOP = XADJ(LINK+1) - 1 DO 700 I = ISTRT, ISTOP ENODE = ADJNCY(I) LINK = - ENODE C IF ( ENODE ) 400, 800, 500 if ( ENODE .LT. 0) GO TO 400 if ( ENODE .EQ. 0) GO TO 800 C C 500 CONTINUE IF ( QSIZE(ENODE) .EQ. 0 ) GO TO 700 DEG0 = DEG0 + QSIZE(ENODE) MARKER(ENODE) = MTAG C ---------------------------------- C IF ENODE REQUIRES A DEGREE UPDATE, C THEN DO THE FOLLOWING. C ---------------------------------- IF ( DBAKW(ENODE) .NE. 0 ) GO TO 700 C --------------------------------------- C PLACE EITHER IN QXHEAD OR Q2HEAD LISTS. C --------------------------------------- IF ( DFORW(ENODE) .EQ. 2 ) GO TO 600 LLIST(ENODE) = QXHEAD QXHEAD = ENODE GO TO 700 600 CONTINUE LLIST(ENODE) = Q2HEAD Q2HEAD = ENODE 700 CONTINUE 800 CONTINUE C -------------------------------------------- C FOR EACH ENODE IN Q2 LIST, DO THE FOLLOWING. C -------------------------------------------- ENODE = Q2HEAD IQ2 = 1 900 CONTINUE IF ( ENODE .LE. 0 ) GO TO 1500 IF ( DBAKW(ENODE) .NE. 0 ) GO TO 2200 TAG = TAG + 1 DEG = DEG0 C ------------------------------------------ C IDENTIFY THE OTHER ADJACENT ELEMENT NABOR. C ------------------------------------------ ISTRT = XADJ(ENODE) NABOR = ADJNCY(ISTRT) IF ( NABOR .EQ. ELMNT ) NABOR = ADJNCY(ISTRT+1) C ------------------------------------------------ C IF NABOR IS UNELIMINATED, INCREASE DEGREE COUNT. C ------------------------------------------------ LINK = NABOR IF ( DFORW(NABOR) .LT. 0 ) GO TO 1000 DEG = DEG + QSIZE(NABOR) GO TO 2100 1000 CONTINUE C -------------------------------------------- C OTHERWISE, FOR EACH NODE IN THE 2ND ELEMENT, C DO THE FOLLOWING. C -------------------------------------------- ISTRT = XADJ(LINK) ISTOP = XADJ(LINK+1) - 1 DO 1400 I = ISTRT, ISTOP NODE = ADJNCY(I) LINK = - NODE IF ( NODE .EQ. ENODE ) GO TO 1400 C IF ( NODE ) 1000, 2100, 1100 if ( NODE .LT. 0 ) GO TO 1000 if ( NODE .EQ. 0 ) GO TO 2100 C C 1100 CONTINUE IF ( QSIZE(NODE) .EQ. 0 ) GO TO 1400 IF ( MARKER(NODE) .GE. TAG ) GO TO 1200 C ------------------------------------- C CASE WHEN NODE IS NOT YET CONSIDERED. C ------------------------------------- MARKER(NODE) = TAG DEG = DEG + QSIZE(NODE) GO TO 1400 1200 CONTINUE C ---------------------------------------- C CASE WHEN NODE IS INDISTINGUISHABLE FROM C ENODE. MERGE THEM INTO A NEW SUPERNODE. C ---------------------------------------- IF ( DBAKW(NODE) .NE. 0 ) GO TO 1400 IF ( DFORW(NODE) .NE. 2 ) GO TO 1300 QSIZE(ENODE) = QSIZE(ENODE) + 1 QSIZE(NODE) QSIZE(NODE) = 0 MARKER(NODE) = MAXINT DFORW(NODE) = - ENODE DBAKW(NODE) = - MAXINT GO TO 1400 1300 CONTINUE C -------------------------------------- C CASE WHEN NODE IS OUTMATCHED BY ENODE. C -------------------------------------- IF ( DBAKW(NODE) .EQ.0 ) 1 DBAKW(NODE) = - MAXINT 1400 CONTINUE GO TO 2100 1500 CONTINUE C ------------------------------------------------ C FOR EACH ENODE IN THE QX LIST, DO THE FOLLOWING. C ------------------------------------------------ ENODE = QXHEAD IQ2 = 0 1600 CONTINUE IF ( ENODE .LE. 0 ) GO TO 2300 IF ( DBAKW(ENODE) .NE. 0 ) GO TO 2200 TAG = TAG + 1 DEG = DEG0 C --------------------------------- C FOR EACH UNMARKED NABOR OF ENODE, C DO THE FOLLOWING. C --------------------------------- ISTRT = XADJ(ENODE) ISTOP = XADJ(ENODE+1) - 1 DO 2000 I = ISTRT, ISTOP NABOR = ADJNCY(I) IF ( NABOR .EQ. 0 ) GO TO 2100 IF ( MARKER(NABOR) .GE. TAG ) GO TO 2000 MARKER(NABOR) = TAG LINK = NABOR C ------------------------------ C IF UNELIMINATED, INCLUDE IT IN C DEG COUNT. C ------------------------------ IF ( DFORW(NABOR) .LT. 0 ) GO TO 1700 DEG = DEG + QSIZE(NABOR) GO TO 2000 1700 CONTINUE C ------------------------------- C IF ELIMINATED, INCLUDE UNMARKED C NODES IN THIS ELEMENT INTO THE C DEGREE COUNT. C ------------------------------- JSTRT = XADJ(LINK) JSTOP = XADJ(LINK+1) - 1 DO 1900 J = JSTRT, JSTOP NODE = ADJNCY(J) LINK = - NODE C IF ( NODE ) 1700, 2000, 1800 if ( NODE .LT. 0) GO TO 1700 if ( NODE .EQ. 0) GO TO 2000 C C 1800 CONTINUE IF ( MARKER(NODE) .GE. TAG ) 1 GO TO 1900 MARKER(NODE) = TAG DEG = DEG + QSIZE(NODE) 1900 CONTINUE 2000 CONTINUE 2100 CONTINUE C ------------------------------------------- C UPDATE EXTERNAL DEGREE OF ENODE IN DEGREE C STRUCTURE, AND MDEG (MIN DEG) IF NECESSARY. C ------------------------------------------- DEG = DEG - QSIZE(ENODE) + 1 FNODE = DHEAD(DEG) DFORW(ENODE) = FNODE DBAKW(ENODE) = - DEG IF ( FNODE .GT. 0 ) DBAKW(FNODE) = ENODE DHEAD(DEG) = ENODE IF ( DEG .LT. MDEG ) MDEG = DEG 2200 CONTINUE C ---------------------------------- C GET NEXT ENODE IN CURRENT ELEMENT. C ---------------------------------- ENODE = LLIST(ENODE) IF ( IQ2 .EQ. 1 ) GO TO 900 GO TO 1600 2300 CONTINUE C ----------------------------- C GET NEXT ELEMENT IN THE LIST. C ----------------------------- TAG = MTAG ELMNT = LLIST(ELMNT) GO TO 100 C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C RF: modified mmpy8 dependence C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************** MMPY .... MATRIX-MATRIX MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - C THIS ROUTINE PERFORMS A MATRIX-MATRIX MULTIPLY, Y = Y + XA, C ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE CHOLESKY C CODES. C C INPUT PARAMETERS - C M - NUMBER OF ROWS IN X AND IN Y. C N - NUMBER OF COLUMNS IN X AND NUMBER OF ROWS C IN A. C Q - NUMBER OF COLUMNS IN A AND Y. C SPLIT(*) - BLOCK PARTITIONING OF X. C XPNT(*) - XPNT(J+1) POINTS ONE LOCATION BEYOND THE C END OF THE J-TH COLUMN OF X. XPNT IS ALSO C USED TO ACCESS THE ROWS OF A. C X(*) - CONTAINS THE COLUMNS OF X AND THE ROWS OF A. C LDY - LENGTH OF FIRST COLUMN OF Y. C C EXTERNAL ROUTINES: C MMPYN - MATRIX-MATRIX MULTIPLY, C WITH LEVEL 8 LOOP UNROLLING. C C UPDATED PARAMETERS - C Y(*) - ON OUTPUT, Y = Y + AX. C C*********************************************************************** C SUBROUTINE MMPY ( M , N , Q , SPLIT , XPNT , & X , Y , LDY ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C EXTERNAL MMPY8 INTEGER LDY , M , N , Q INTEGER SPLIT(*) , XPNT(*) DOUBLE PRECISION X(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER BLK , FSTCOL, NN C C*********************************************************************** C BLK = 1 FSTCOL = 1 100 CONTINUE IF ( FSTCOL .LE. N ) THEN NN = SPLIT(BLK) CALL MMPY8 ( M, NN, Q, XPNT(FSTCOL), X, Y, LDY ) FSTCOL = FSTCOL + NN BLK = BLK + 1 GO TO 100 ENDIF RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: May 26, 1995 C Authors: Esmond G. Ng, Barry W. Peyton, and Guodong Zhang C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************* MMPY8 .... MATRIX-MATRIX MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - C THIS ROUTINE PERFORMS A MATRIX-MATRIX MULTIPLY, Y = Y + XA, C ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE CHOLESKY C CODES. C C LOOP UNROLLING: LEVEL 8 UPDATING TWO COLUMNS AT A TIME C C INPUT PARAMETERS - C M - NUMBER OF ROWS IN X AND IN Y. C N - NUMBER OF COLUMNS IN X AND NUMBER OF ROWS C IN A. C Q - NUMBER OF COLUMNS IN A AND Y. C XPNT(*) - XPNT(J+1) POINTS ONE LOCATION BEYOND THE C END OF THE J-TH COLUMN OF X. XPNT IS ALSO C USED TO ACCESS THE ROWS OF A. C X(*) - CONTAINS THE COLUMNS OF X AND THE ROWS OF A. C LDY - LENGTH OF FIRST COLUMN OF Y. C C UPDATED PARAMETERS - C Y(*) - ON OUTPUT, Y = Y + AX. C C*********************************************************************** C SUBROUTINE MMPY8 ( M , N , Q , XPNT , X , & Y , LDY ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER LDY , M , N , Q INTEGER XPNT(*) DOUBLE PRECISION X(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER I , J , K , QQ INTEGER I1 , I2 , I3 , I4 , I5 , & I6 , I7 , I8 INTEGER IYBEG , IYBEG1, IYBEG2, LENY , MM DOUBLE PRECISION A1 , A2 , A3 , A4 , A5 , & A6 , A7 , A8 , A9 , A10 , & A11 , A12 , A13 , A14 , A15 , & A16 DOUBLE PRECISION B1 , B2 , B3 , B4 , B5 , & B6 , B7 , B8 , Y1 , Y2 C C*********************************************************************** C C ---------------------------------------------------- C COMPUTE EACH DIAGONAL ENTRY OF THE ODD COLUMNS OF Y. C ---------------------------------------------------- C MM = M QQ = MIN(M,Q) IYBEG = 1 LENY = LDY - 1 DO 200 J = 1, QQ-1 , 2 CDIR$ IVDEP DO 100 I = 1, N I1 = XPNT(I+1) - MM A1 = X(I1) Y(IYBEG) = Y(IYBEG) - A1*A1 100 CONTINUE IYBEG = IYBEG + 2*LENY + 1 LENY = LENY - 2 MM = MM - 2 200 CONTINUE C C ------------------------------------------------------- C UPDATE TWO COLUMNS OF Y AT A TIME, EXCEPT THE DIAGONAL C ELEMENT. C NOTE: THE DIAGONAL ELEMENT OF THE ODD COLUMN HAS C BEEN COMPUTED, SO WE COMPUTE THE SAME NUMBER OF C ELEMENTS FOR THE TWO COLUMNS. C ------------------------------------------------------- C MM = M IYBEG = 1 LENY = LDY - 1 C DO 3000 J = 1, QQ-1, 2 C IYBEG1 = IYBEG IYBEG2 = IYBEG + LENY C DO 400 K = 1, N-7, 8 C C ----------------------------------- C EIGHT COLUMNS UPDATING TWO COLUMNS. C ----------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM I6 = XPNT(K+6) - MM I7 = XPNT(K+7) - MM I8 = XPNT(K+8) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A6 = X(I6) A7 = X(I7) A8 = X(I8) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) A14 = X(I6+1) A15 = X(I7+1) A16 = X(I8+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 - & A6*A14 - A7*A15 - A8*A16 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 - & A14*A14 - A15*A15 - A16*A16 C DO 300 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 B6 = X(I6+I) Y2 = Y2 - B5 * A13 Y1 = Y1 - B6 * A6 B7 = X(I7+I) Y2 = Y2 - B6 * A14 Y1 = Y1 - B7 * A7 B8 = X(I8+I) Y2 = Y2 - B7 * A15 Y1 = Y1 - B8 * A8 Y(IYBEG1+I) = Y1 Y2 = Y2 - B8 * A16 Y(IYBEG2+I) = Y2 300 CONTINUE C 400 CONTINUE C C ----------------------------- C BOUNDARY CODE FOR THE K LOOP. C ----------------------------- C C GO TO ( 2000, 1700, 1500, 1300, C & 1100, 900, 700, 500 ), N-K+2 if (N .LT. K) go to 2000 if (N .EQ. K) go to 1700 if (N .EQ. K + 1) go to 1500 if (N .EQ. K + 2) go to 1300 if (N .EQ. K + 3) go to 1100 if (N .EQ. K + 4) go to 900 if (N .EQ. K + 5) go to 700 C C 500 CONTINUE C C ----------------------------------- C SEVEN COLUMNS UPDATING TWO COLUMNS. C ----------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM I6 = XPNT(K+6) - MM I7 = XPNT(K+7) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A6 = X(I6) A7 = X(I7) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) A14 = X(I6+1) A15 = X(I7+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 - & A6*A14 - A7*A15 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 - & A14*A14 - A15*A15 C DO 600 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 B6 = X(I6+I) Y2 = Y2 - B5 * A13 Y1 = Y1 - B6 * A6 B7 = X(I7+I) Y2 = Y2 - B6 * A14 Y1 = Y1 - B7 * A7 Y(IYBEG1+I) = Y1 Y2 = Y2 - B7 * A15 Y(IYBEG2+I) = Y2 600 CONTINUE C GO TO 2000 C 700 CONTINUE C C --------------------------------- C SIX COLUMNS UPDATING TWO COLUMNS. C --------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM I6 = XPNT(K+6) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A6 = X(I6) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) A14 = X(I6+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 - & A6*A14 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 - & A14*A14 C DO 800 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 B6 = X(I6+I) Y2 = Y2 - B5 * A13 Y1 = Y1 - B6 * A6 Y(IYBEG1+I) = Y1 Y2 = Y2 - B6 * A14 Y(IYBEG2+I) = Y2 800 CONTINUE C GO TO 2000 C 900 CONTINUE C C ---------------------------------- C FIVE COLUMNS UPDATING TWO COLUMNS. C ---------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM I5 = XPNT(K+5) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A5 = X(I5) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) A13 = X(I5+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 - A5*A13 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 - A13*A13 C DO 1000 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 B5 = X(I5+I) Y2 = Y2 - B4 * A12 Y1 = Y1 - B5 * A5 Y(IYBEG1+I) = Y1 Y2 = Y2 - B5 * A13 Y(IYBEG2+I) = Y2 1000 CONTINUE C GO TO 2000 C 1100 CONTINUE C C ---------------------------------- C FOUR COLUMNS UPDATING TWO COLUMNS. C ---------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM I4 = XPNT(K+4) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A4 = X(I4) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) A12 = X(I4+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 - A4*A12 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 - A12*A12 C DO 1200 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 B4 = X(I4+I) Y2 = Y2 - B3 * A11 Y1 = Y1 - B4 * A4 Y(IYBEG1+I) = Y1 Y2 = Y2 - B4 * A12 Y(IYBEG2+I) = Y2 1200 CONTINUE C GO TO 2000 C 1300 CONTINUE C C ----------------------------------- C THREE COLUMNS UPDATING TWO COLUMNS. C ----------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM I3 = XPNT(K+3) - MM A1 = X(I1) A2 = X(I2) A3 = X(I3) A9 = X(I1+1) A10 = X(I2+1) A11 = X(I3+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 - A3*A11 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 - A11*A11 C DO 1400 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 B3 = X(I3+I) Y2 = Y2 - B2 * A10 Y1 = Y1 - B3 * A3 Y(IYBEG1+I) = Y1 Y2 = Y2 - B3 * A11 Y(IYBEG2+I) = Y2 1400 CONTINUE C GO TO 2000 C 1500 CONTINUE C C --------------------------------- C TWO COLUMNS UPDATING TWO COLUMNS. C --------------------------------- C I1 = XPNT(K+1) - MM I2 = XPNT(K+2) - MM A1 = X(I1) A2 = X(I2) A9 = X(I1+1) A10 = X(I2+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 - A2*A10 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 - A10*A10 C DO 1600 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) B2 = X(I2+I) Y2 = Y2 - B1 * A9 Y1 = Y1 - B2 * A2 Y(IYBEG1+I) = Y1 Y2 = Y2 - B2 * A10 Y(IYBEG2+I) = Y2 1600 CONTINUE C GO TO 2000 C 1700 CONTINUE C C -------------------------------- C ONE COLUMN UPDATING TWO COLUMNS. C -------------------------------- C I1 = XPNT(K+1) - MM A1 = X(I1) A9 = X(I1+1) C Y(IYBEG1+1) = Y(IYBEG1+1) - & A1*A9 C Y(IYBEG2+1) = Y(IYBEG2+1) - & A9*A9 C DO 1800 I = 2, MM-1 Y1 = Y(IYBEG1+I) B1 = X(I1+I) Y1 = Y1 - B1 * A1 Y2 = Y(IYBEG2+I) Y(IYBEG1+I) = Y1 Y2 = Y2 - B1 * A9 Y(IYBEG2+I) = Y2 1800 CONTINUE C GO TO 2000 C C ----------------------------------------------- C PREPARE FOR NEXT PAIR OF COLUMNS TO BE UPDATED. C ----------------------------------------------- C 2000 CONTINUE MM = MM - 2 IYBEG = IYBEG2 + LENY + 1 LENY = LENY - 2 C 3000 CONTINUE C C ----------------------------------------------------- C BOUNDARY CODE FOR J LOOP: EXECUTED WHENVER Q IS ODD. C ----------------------------------------------------- C IF ( J .EQ. QQ ) THEN CALL SMXPY8 ( MM, N, Y(IYBEG), XPNT, X ) ENDIF C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************* MMPYI .... MATRIX-MATRIX MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - C THIS ROUTINE PERFORMS A MATRIX-MATRIX MULTIPLY, Y = Y + XA, C ASSUMING DATA STRUCTURES USED IN SOME OF OUR SPARSE CHOLESKY C CODES. C C MATRIX X HAS ONLY 1 COLUMN. C C INPUT PARAMETERS - C M - NUMBER OF ROWS IN X AND IN Y. C Q - NUMBER OF COLUMNS IN A AND Y. C XPNT(*) - XPNT(J+1) POINTS ONE LOCATION BEYOND THE C END OF THE J-TH COLUMN OF X. XPNT IS ALSO C USED TO ACCESS THE ROWS OF A. C X(*) - CONTAINS THE COLUMNS OF X AND THE ROWS OF A. C IY(*) - IY(COL) POINTS TO THE BEGINNING OF COLUMN C RELIND(*) - RELATIVE INDICES. C C UPDATED PARAMETERS - C Y(*) - ON OUTPUT, Y = Y + AX. C C*********************************************************************** C SUBROUTINE MMPYI ( M , Q , XPNT , X , IY , & Y , RELIND ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER M , Q INTEGER IY(*) , RELIND(*) , & XPNT(*) DOUBLE PRECISION X(*) , Y(*) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER COL , I , ISUB , K , YLAST DOUBLE PRECISION A C C*********************************************************************** C DO 200 K = 1, Q COL = XPNT(K) YLAST = IY(COL+1) - 1 A = - X(K) CDIR$ IVDEP DO 100 I = K, M ISUB = XPNT(I) ISUB = YLAST - RELIND(ISUB) Y(ISUB) = Y(ISUB) + A*X(I) 100 CONTINUE 200 CONTINUE RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C**** ORDMMD ..... MULTIPLE MINIMUM EXTERNAL DEGREE ************ C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE CALLS LIU'S MULTIPLE MINIMUM DEGREE C ROUTINE. C C INPUT PARAMETERS - C NEQNS - NUMBER OF EQUATIONS. C (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. C IWSIZ - SIZE OF INTEGER WORKING STORAGE. C C OUTPUT PARAMETERS - C PERM - THE MINIMUM DEGREE ORDERING. C INVP - THE INVERSE OF PERM. C NOFSUB - AN UPPER BOUND ON THE NUMBER OF NONZERO C SUBSCRIPTS FOR THE COMPRESSED STORAGE SCHEME. C IFLAG - ERROR FLAG. C 0: SUCCESSFUL ORDERING C -1: INSUFFICIENT WORKING STORAGE C [IWORK(*)]. C C WORKING PARAMETERS - C IWORK - INTEGER WORKSPACE OF LENGTH 4*NEQNS. C C*********************************************************************** C SUBROUTINE ORDMMD ( NEQNS , XADJ , ADJNCY, INVP , PERM , 1 IWSIZ , IWORK , NOFSUB, IFLAG ) C C*********************************************************************** C INTEGER ADJNCY(*), INVP(*) , IWORK(*) , PERM(*) INTEGER XADJ(*) INTEGER DELTA , IFLAG , IWSIZ , MAXINT, NEQNS , & NOFSUB C C********************************************************************* C IFLAG = 0 IF ( IWSIZ .LT. 4*NEQNS ) THEN IFLAG = -1 RETURN ENDIF C C DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. C MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) INTEGER C (ANY SMALLER ESTIMATE WILL DO) FOR MARKING C NODES. C DELTA = 0 MAXINT = 32767 CALL GENMMD ( NEQNS , XADJ , ADJNCY, INVP , PERM , 1 DELTA , 1 IWORK(1) , 1 IWORK(NEQNS+1) , 1 IWORK(2*NEQNS+1) , 1 IWORK(3*NEQNS+1) , 1 MAXINT, NOFSUB ) RETURN C END C*********************************************************************** C*********************************************************************** C C Version: 0.3 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratoy C C*********************************************************************** C*********************************************************************** C****** PCHOL .... DENSE PARTIAL CHOLESKY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS CHOLESKY C FACTORIZATION ON THE COLUMNS OF A SUPERNODE C THAT HAVE RECEIVED ALL UPDATES FROM COLUMNS C EXTERNAL TO THE SUPERNODE. C C INPUT PARAMETERS - C M - NUMBER OF ROWS (LENGTH OF THE FIRST COLUMN). C N - NUMBER OF COLUMNS IN THE SUPERNODE. C XPNT - XPNT(J+1) POINTS ONE LOCATION BEYOND THE END C OF THE J-TH COLUMN OF THE SUPERNODE. C X(*) - CONTAINS THE COLUMNS OF OF THE SUPERNODE TO C BE FACTORED. C C EXTERNAL ROUTINE: C SMXPY8 - MATRIX-VECTOR MULTIPLY WITH 8 LOOP UNROLLING. C C OUTPUT PARAMETERS - C X(*) - ON OUTPUT, CONTAINS THE FACTORED COLUMNS OF C THE SUPERNODE. C C*********************************************************************** C SUBROUTINE PCHOL ( M, N, XPNT, X, MXDIAG, NTINY ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C EXTERNAL SMXPY8 C INTEGER M, N C INTEGER XPNT(*) C CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC DOUBLE PRECISION X(*), MXDIAG INTEGER NTINY C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER JPNT , JCOL , MM C DOUBLE PRECISION DIAG C C*********************************************************************** C C ------------------------------------------ C FOR EVERY COLUMN JCOL IN THE SUPERNODE ... C ------------------------------------------ MM = M JPNT = XPNT(1) DO 100 JCOL = 1, N C C ---------------------------------- C UPDATE JCOL WITH PREVIOUS COLUMNS. C ---------------------------------- IF ( JCOL .GT. 1 ) THEN CALL SMXPY8 ( MM, JCOL-1, X(JPNT), XPNT, X ) ENDIF C C --------------------------- C COMPUTE THE DIAGONAL ENTRY. C --------------------------- DIAG = X(JPNT) CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC IF (DIAG .LE. 1.0D-30*MXDIAG) THEN DIAG = 1.0D+128 NTINY = NTINY+1 ENDIF CxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPCxPC DIAG = SQRT ( DIAG ) X(JPNT) = DIAG DIAG = 1.0D+00 / DIAG C C ---------------------------------------------------- C SCALE COLUMN JCOL WITH RECIPROCAL OF DIAGONAL ENTRY. C ---------------------------------------------------- MM = MM - 1 JPNT = JPNT + 1 CALL DSCAL1 ( MM, DIAG, X(JPNT) ) JPNT = JPNT + MM C 100 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: January 12, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************** SFINIT ..... SET UP FOR SYMB. FACT. ************ C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS SUBROUTINE COMPUTES THE STORAGE REQUIREMENTS AND SETS UP C PRELIMINARY DATA STRUCTURES FOR THE SYMBOLIC FACTORIZATION. C C NOTE: C THIS VERSION PRODUCES THE MAXIMAL SUPERNODE PARTITION (I.E., C THE ONE WITH THE FEWEST POSSIBLE SUPERNODES). C C INPUT PARAMETERS: C NEQNS - NUMBER OF EQUATIONS. C NNZA - LENGTH OF ADJACENCY STRUCTURE. C XADJ(*) - ARRAY OF LENGTH NEQNS+1, CONTAINING POINTERS C TO THE ADJACENCY STRUCTURE. C ADJNCY(*) - ARRAY OF LENGTH XADJ(NEQNS+1)-1, CONTAINING C THE ADJACENCY STRUCTURE. C PERM(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C POSTORDERING. C INVP(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE C INVERSE OF THE POSTORDERING. C IWSIZ - SIZE OF INTEGER WORKING STORAGE. C C OUTPUT PARAMETERS: C COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH COLUMN OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C NNZL - NUMBER OF NONZEROS IN THE FACTOR, INCLUDING C THE DIAGONAL ENTRIES. C NSUB - NUMBER OF SUBSCRIPTS. C NSUPER - NUMBER OF SUPERNODES (<= NEQNS). C SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C XSUPER(*) - ARRAY OF LENGTH NEQNS+1, CONTAINING THE C SUPERNODE PARTITIONING. C IFLAG(*) - ERROR FLAG. C 0: SUCCESSFUL SF INITIALIZATION. C -1: INSUFFICENT WORKING STORAGE C [IWORK(*)]. C C WORK PARAMETERS: C IWORK(*) - INTEGER WORK ARRAY OF LENGTH 7*NEQNS+3. C C FIRST CREATED ON NOVEMEBER 14, 1994. C LAST UPDATED ON January 12, 1995. C C*********************************************************************** C SUBROUTINE SFINIT ( NEQNS , NNZA , XADJ , ADJNCY, PERM , & INVP , COLCNT, NNZL , NSUB , NSUPER, & SNODE , XSUPER, IWSIZ , IWORK , IFLAG ) C C ----------- C PARAMETERS. C ----------- INTEGER IFLAG , IWSIZ , NNZA , NEQNS , NNZL , & NSUB , NSUPER INTEGER ADJNCY(NNZA) , COLCNT(NEQNS) , & INVP(NEQNS) , IWORK(7*NEQNS+3), & PERM(NEQNS) , SNODE(NEQNS) , & XADJ(NEQNS+1) , XSUPER(NEQNS+1) C C*********************************************************************** C C -------------------------------------------------------- C RETURN IF THERE IS INSUFFICIENT INTEGER WORKING STORAGE. C -------------------------------------------------------- IFLAG = 0 IF ( IWSIZ .LT. 7*NEQNS+3 ) THEN IFLAG = -1 RETURN ENDIF C C ------------------------------------------ C COMPUTE ELIMINATION TREE AND POSTORDERING. C ------------------------------------------ CALL ETORDR ( NEQNS , XADJ , ADJNCY, PERM , INVP , & IWORK(1) , & IWORK(NEQNS+1) , & IWORK(2*NEQNS+1) , & IWORK(3*NEQNS+1) ) C C --------------------------------------------- C COMPUTE ROW AND COLUMN FACTOR NONZERO COUNTS. C --------------------------------------------- CALL FCNTHN ( NEQNS , NNZA , XADJ , ADJNCY, PERM , & INVP , IWORK(1) , SNODE , COLCNT, & NNZL , & IWORK(NEQNS+1) , & IWORK(2*NEQNS+1) , & XSUPER , & IWORK(3*NEQNS+1) , & IWORK(4*NEQNS+2) , & IWORK(5*NEQNS+3) , & IWORK(6*NEQNS+4) ) C C --------------------------------------------------------- C REARRANGE CHILDREN SO THAT THE LAST CHILD HAS THE MAXIMUM C NUMBER OF NONZEROS IN ITS COLUMN OF L. C --------------------------------------------------------- CALL CHORDR ( NEQNS , PERM , INVP , & COLCNT, & IWORK(1) , & IWORK(NEQNS+1) , & IWORK(2*NEQNS+1) , & IWORK(3*NEQNS+1) ) C C ---------------- C FIND SUPERNODES. C ---------------- CALL FSUP1 ( NEQNS , IWORK(1) , COLCNT, NSUB , & NSUPER, SNODE ) CALL FSUP2 ( NEQNS , NSUPER, SNODE, XSUPER ) C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: December 27, 1994 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C****** SMXPY8 .... MATRIX-VECTOR MULTIPLY ************** C*********************************************************************** C*********************************************************************** C C PURPOSE - THIS ROUTINE PERFORMS A MATRIX-VECTOR MULTIPLY, C Y = Y + AX, ASSUMING DATA STRUCTURES USED IN C RECENTLY DEVELOPED SPARSE CHOLESKY CODES. THE C '8' SIGNIFIES LEVEL 8 LOOP UNROLLING. C C INPUT PARAMETERS - C M - NUMBER OF ROWS. C N - NUMBER OF COLUMNS. C Y - M-VECTOR TO WHICH AX WILL BE ADDED. C APNT - INDEX VECTOR FOR A. APNT(I) POINTS TO THE C FIRST NONZERO IN COLUMN I OF A. C Y - ON OUTPUT, CONTAINS Y = Y + AX. C C*********************************************************************** C SUBROUTINE SMXPY8 ( M, N, Y, APNT, A ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- C INTEGER M, N, LEVEL C INTEGER APNT(*) C DOUBLE PRECISION Y(*), A(*) C PARAMETER ( LEVEL = 8 ) C C ---------------- C LOCAL VARIABLES. C ---------------- C INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, & J, REMAIN C DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8 C C*********************************************************************** C REMAIN = MOD ( N, LEVEL ) C C GO TO ( 2000, 100, 200, 300, C & 400, 500, 600, 700 ), REMAIN+1 if (REMAIN .eq. 0) go to 2000 C if (REMAIN .eq. 1) go to 100 if (REMAIN .eq. 2) go to 200 if (REMAIN .eq. 3) go to 300 if (REMAIN .eq. 4) go to 400 if (REMAIN .eq. 5) go to 500 if (REMAIN .eq. 6) go to 600 if (REMAIN .eq. 7) go to 700 C C 100 CONTINUE I1 = APNT(1+1) - M A1 = - A(I1) DO 150 I = 1, M Y(I) = Y(I) + A1*A(I1) I1 = I1 + 1 150 CONTINUE GO TO 2000 C 200 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M A1 = - A(I1) A2 = - A(I2) DO 250 I = 1, M Y(I) = ( (Y(I)) & + A1*A(I1)) + A2*A(I2) I1 = I1 + 1 I2 = I2 + 1 250 CONTINUE GO TO 2000 C 300 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) DO 350 I = 1, M Y(I) = (( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 350 CONTINUE GO TO 2000 C 400 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) DO 450 I = 1, M Y(I) = ((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 450 CONTINUE GO TO 2000 C 500 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M I5 = APNT(1+5) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) DO 550 I = 1, M Y(I) = (((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 550 CONTINUE GO TO 2000 C 600 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M I5 = APNT(1+5) - M I6 = APNT(1+6) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) A6 = - A(I6) DO 650 I = 1, M Y(I) = ((((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5)) + A6*A(I6) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 650 CONTINUE GO TO 2000 C 700 CONTINUE I1 = APNT(1+1) - M I2 = APNT(1+2) - M I3 = APNT(1+3) - M I4 = APNT(1+4) - M I5 = APNT(1+5) - M I6 = APNT(1+6) - M I7 = APNT(1+7) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) A6 = - A(I6) A7 = - A(I7) DO 750 I = 1, M Y(I) = (((((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5)) + A6*A(I6)) & + A7*A(I7) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 I7 = I7 + 1 750 CONTINUE GO TO 2000 C 2000 CONTINUE DO 4000 J = REMAIN+1, N, LEVEL I1 = APNT(J+1) - M I2 = APNT(J+2) - M I3 = APNT(J+3) - M I4 = APNT(J+4) - M I5 = APNT(J+5) - M I6 = APNT(J+6) - M I7 = APNT(J+7) - M I8 = APNT(J+8) - M A1 = - A(I1) A2 = - A(I2) A3 = - A(I3) A4 = - A(I4) A5 = - A(I5) A6 = - A(I6) A7 = - A(I7) A8 = - A(I8) DO 3000 I = 1, M Y(I) = ((((((( (Y(I)) & + A1*A(I1)) + A2*A(I2)) & + A3*A(I3)) + A4*A(I4)) & + A5*A(I5)) + A6*A(I6)) & + A7*A(I7)) + A8*A(I8) I1 = I1 + 1 I2 = I2 + 1 I3 = I3 + 1 I4 = I4 + 1 I5 = I5 + 1 I6 = I6 + 1 I7 = I7 + 1 I8 = I8 + 1 3000 CONTINUE 4000 CONTINUE C RETURN END C*********************************************************************** C*********************************************************************** C C Version: 0.4 C Last modified: February 13, 1995 C Authors: Esmond G. Ng and Barry W. Peyton C C Mathematical Sciences Section, Oak Ridge National Laboratory C C*********************************************************************** C*********************************************************************** C************* SYMFC2 ..... SYMBOLIC FACTORIZATION ************** C*********************************************************************** C*********************************************************************** C C PURPOSE: C THIS ROUTINE PERFORMS SUPERNODAL SYMBOLIC FACTORIZATION ON A C REORDERED LINEAR SYSTEM. IT ASSUMES ACCESS TO THE COLUMNS C COUNTS, SUPERNODE PARTITION, AND SUPERNODAL ELIMINATION TREE C ASSOCIATED WITH THE FACTOR MATRIX L. C C INPUT PARAMETERS: C (I) NEQNS - NUMBER OF EQUATIONS C (I) ADJLEN - LENGTH OF THE ADJACENCY LIST. C (I) XADJ(*) - ARRAY OF LENGTH NEQNS+1 CONTAINING POINTERS C TO THE ADJACENCY STRUCTURE. C (I) ADJNCY(*) - ARRAY OF LENGTH XADJ(NEQNS+1)-1 CONTAINING C THE ADJACENCY STRUCTURE. C (I) PERM(*) - ARRAY OF LENGTH NEQNS CONTAINING THE C POSTORDERING. C (I) INVP(*) - ARRAY OF LENGTH NEQNS CONTAINING THE C INVERSE OF THE POSTORDERING. C (I) COLCNT(*) - ARRAY OF LENGTH NEQNS, CONTAINING THE NUMBER C OF NONZEROS IN EACH COLUMN OF THE FACTOR, C INCLUDING THE DIAGONAL ENTRY. C (I) NSUPER - NUMBER OF SUPERNODES. C (I) XSUPER(*) - ARRAY OF LENGTH NSUPER+1, CONTAINING THE C FIRST COLUMN OF EACH SUPERNODE. C (I) SNODE(*) - ARRAY OF LENGTH NEQNS FOR RECORDING C SUPERNODE MEMBERSHIP. C (I) NOFSUB - NUMBER OF SUBSCRIPTS TO BE STORED IN C LINDX(*). C C OUTPUT PARAMETERS: C (I) XLINDX - ARRAY OF LENGTH NEQNS+1, CONTAINING POINTERS C INTO THE SUBSCRIPT VECTOR. C (I) LINDX - ARRAY OF LENGTH MAXSUB, CONTAINING THE C COMPRESSED SUBSCRIPTS. C (I) XLNZ - COLUMN POINTERS FOR L. C (I) FLAG - ERROR FLAG: C 0 - NO ERROR. C 1 - INCONSISTANCY IN THE INPUT. C C WORKING PARAMETERS: C (I) MRGLNK - ARRAY OF LENGTH NSUPER, CONTAINING THE C CHILDREN OF EACH SUPERNODE AS A LINKED LIST. C (I) RCHLNK - ARRAY OF LENGTH NEQNS+1, CONTAINING THE C CURRENT LINKED LIST OF MERGED INDICES (THE C "REACH" SET). C (I) MARKER - ARRAY OF LENGTH NEQNS USED TO MARK INDICES C AS THEY ARE INTRODUCED INTO EACH SUPERNODE'S C INDEX SET. C C*********************************************************************** C SUBROUTINE SYMFC2 ( NEQNS , ADJLEN, XADJ , ADJNCY, PERM , & INVP , COLCNT, NSUPER, XSUPER, SNODE , & NOFSUB, XLINDX, LINDX , XLNZ , MRGLNK, & RCHLNK, MARKER, FLAG ) C C*********************************************************************** C C ----------- C PARAMETERS. C ----------- INTEGER ADJLEN, FLAG , NEQNS , NOFSUB, NSUPER INTEGER ADJNCY(ADJLEN), COLCNT(NEQNS) , & INVP(NEQNS) , MARKER(NEQNS) , & MRGLNK(NSUPER), LINDX(NOFSUB) , & PERM(NEQNS) , RCHLNK(0:NEQNS), & SNODE(NEQNS) , XSUPER(NSUPER+1) INTEGER XADJ(NEQNS+1) , XLINDX(NSUPER+1), & XLNZ(NEQNS+1) C C ---------------- C LOCAL VARIABLES. C ---------------- INTEGER FSTCOL, HEAD , I , JNZBEG, JNZEND, & JPTR , JSUP , JWIDTH, KNZ , KNZBEG, & KNZEND, KPTR , KSUP , LENGTH, LSTCOL, & NEWI , NEXTI , NODE , NZBEG , NZEND , & PCOL , PSUP , POINT , TAIL , WIDTH C C*********************************************************************** C FLAG = 0 IF ( NEQNS .LE. 0 ) RETURN C C --------------------------------------------------- C INITIALIZATIONS ... C NZEND : POINTS TO THE LAST USED SLOT IN LINDX. C TAIL : END OF LIST INDICATOR C (IN RCHLNK(*), NOT MRGLNK(*)). C MRGLNK : CREATE EMPTY LISTS. C MARKER : "UNMARK" THE INDICES. C --------------------------------------------------- NZEND = 0 HEAD = 0 TAIL = NEQNS + 1 POINT = 1 DO 50 I = 1, NEQNS MARKER(I) = 0 XLNZ(I) = POINT POINT = POINT + COLCNT(I) 50 CONTINUE XLNZ(NEQNS+1) = POINT POINT = 1 DO 100 KSUP = 1, NSUPER MRGLNK(KSUP) = 0 FSTCOL = XSUPER(KSUP) XLINDX(KSUP) = POINT POINT = POINT + COLCNT(FSTCOL) 100 CONTINUE XLINDX(NSUPER+1) = POINT C C --------------------------- C FOR EACH SUPERNODE KSUP ... C --------------------------- DO 1000 KSUP = 1, NSUPER C C --------------------------------------------------------- C INITIALIZATIONS ... C FSTCOL : FIRST COLUMN OF SUPERNODE KSUP. C LSTCOL : LAST COLUMN OF SUPERNODE KSUP. C KNZ : WILL COUNT THE NONZEROS OF L IN COLUMN KCOL. C RCHLNK : INITIALIZE EMPTY INDEX LIST FOR KCOL. C --------------------------------------------------------- FSTCOL = XSUPER(KSUP) LSTCOL = XSUPER(KSUP+1) - 1 WIDTH = LSTCOL - FSTCOL + 1 LENGTH = COLCNT(FSTCOL) KNZ = 0 RCHLNK(HEAD) = TAIL JSUP = MRGLNK(KSUP) C C ------------------------------------------------- C IF KSUP HAS CHILDREN IN THE SUPERNODAL E-TREE ... C ------------------------------------------------- IF ( JSUP .GT. 0 ) THEN C --------------------------------------------- C COPY THE INDICES OF THE FIRST CHILD JSUP INTO C THE LINKED LIST, AND MARK EACH WITH THE VALUE C KSUP. C --------------------------------------------- JWIDTH = XSUPER(JSUP+1) - XSUPER(JSUP) JNZBEG = XLINDX(JSUP) + JWIDTH JNZEND = XLINDX(JSUP+1) - 1 DO 200 JPTR = JNZEND, JNZBEG, -1 NEWI = LINDX(JPTR) KNZ = KNZ+1 MARKER(NEWI) = KSUP RCHLNK(NEWI) = RCHLNK(HEAD) RCHLNK(HEAD) = NEWI 200 CONTINUE C ------------------------------------------ C FOR EACH SUBSEQUENT CHILD JSUP OF KSUP ... C ------------------------------------------ JSUP = MRGLNK(JSUP) 300 CONTINUE IF ( JSUP .NE. 0 .AND. KNZ .LT. LENGTH ) THEN C ---------------------------------------- C MERGE THE INDICES OF JSUP INTO THE LIST, C AND MARK NEW INDICES WITH VALUE KSUP. C ---------------------------------------- JWIDTH = XSUPER(JSUP+1) - XSUPER(JSUP) JNZBEG = XLINDX(JSUP) + JWIDTH JNZEND = XLINDX(JSUP+1) - 1 NEXTI = HEAD DO 500 JPTR = JNZBEG, JNZEND NEWI = LINDX(JPTR) 400 CONTINUE I = NEXTI NEXTI = RCHLNK(I) IF ( NEWI .GT. NEXTI ) GO TO 400 IF ( NEWI .LT. NEXTI ) THEN KNZ = KNZ+1 RCHLNK(I) = NEWI RCHLNK(NEWI) = NEXTI MARKER(NEWI) = KSUP NEXTI = NEWI ENDIF 500 CONTINUE JSUP = MRGLNK(JSUP) GO TO 300 ENDIF ENDIF C --------------------------------------------------- C STRUCTURE OF A(*,FSTCOL) HAS NOT BEEN EXAMINED YET. C "SORT" ITS STRUCTURE INTO THE LINKED LIST, C INSERTING ONLY THOSE INDICES NOT ALREADY IN THE C LIST. C --------------------------------------------------- IF ( KNZ .LT. LENGTH ) THEN NODE = PERM(FSTCOL) KNZBEG = XADJ(NODE) KNZEND = XADJ(NODE+1) - 1 DO 700 KPTR = KNZBEG, KNZEND NEWI = ADJNCY(KPTR) NEWI = INVP(NEWI) IF ( NEWI .GT. FSTCOL .AND. & MARKER(NEWI) .NE. KSUP ) THEN C -------------------------------- C POSITION AND INSERT NEWI IN LIST C AND MARK IT WITH KCOL. C -------------------------------- NEXTI = HEAD 600 CONTINUE I = NEXTI NEXTI = RCHLNK(I) IF ( NEWI .GT. NEXTI ) GO TO 600 KNZ = KNZ + 1 RCHLNK(I) = NEWI RCHLNK(NEWI) = NEXTI MARKER(NEWI) = KSUP ENDIF 700 CONTINUE ENDIF C ------------------------------------------------------------ C IF KSUP HAS NO CHILDREN, INSERT FSTCOL INTO THE LINKED LIST. C ------------------------------------------------------------ IF ( RCHLNK(HEAD) .NE. FSTCOL ) THEN RCHLNK(FSTCOL) = RCHLNK(HEAD) RCHLNK(HEAD) = FSTCOL KNZ = KNZ + 1 ENDIF C C -------------------------------------------- C COPY INDICES FROM LINKED LIST INTO LINDX(*). C -------------------------------------------- NZBEG = NZEND + 1 NZEND = NZEND + KNZ IF ( NZEND+1 .NE. XLINDX(KSUP+1) ) GO TO 8000 I = HEAD DO 800 KPTR = NZBEG, NZEND I = RCHLNK(I) LINDX(KPTR) = I 800 CONTINUE C C --------------------------------------------------- C IF KSUP HAS A PARENT, INSERT KSUP INTO ITS PARENT'S C "MERGE" LIST. C --------------------------------------------------- IF ( LENGTH .GT. WIDTH ) THEN PCOL = LINDX ( XLINDX(KSUP) + WIDTH ) PSUP = SNODE(PCOL) MRGLNK(KSUP) = MRGLNK(PSUP) MRGLNK(PSUP) = KSUP ENDIF C 1000 CONTINUE C RETURN C C ----------------------------------------------- C INCONSISTENCY IN DATA STRUCTURE WAS DISCOVERED. C ----------------------------------------------- 8000 CONTINUE FLAG = -2 RETURN C END subroutine genrcm ( node_num, adj_num, adj_row, adj, perm ) !*****************************************************************************80 ! !! GENRCM finds the reverse Cuthill-Mckee ordering for a general graph. ! ! Discussion: ! ! For each connected component in the graph, the routine obtains ! an ordering by calling RCM. ! ! Modified: ! ! 04 January 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer NODE_NUM, the number of nodes. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Output, integer PERM(NODE_NUM), the RCM ordering. ! ! Local Parameters: ! ! Local, integer LEVEL_ROW(NODE_NUM+1), the index vector for a level ! structure. The level structure is stored in the currently unused ! spaces in the permutation vector PERM. ! ! Local, integer MASK(NODE_NUM), marks variables that have been numbered. ! implicit none integer adj_num,node_num integer adj(adj_num) integer adj_row(node_num+1) integer i integer iccsze integer mask(node_num) integer level_num integer level_row(node_num+1) integer num integer perm(node_num) integer root do i=1,node_num mask(i) = 1 enddo num = 1 do i = 1, node_num ! ! For each masked connected component... ! if ( mask(i).ne. 0 ) then root = i ! ! Find a pseudo-peripheral node ROOT. The level structure found by ! ROOT_FIND is stored starting at PERM(NUM). ! call root_find ( root, adj_num, adj_row, adj, mask, & level_num, level_row, perm(num), node_num ) ! ! RCM orders the component using ROOT as the starting node. ! call rcm ( root, adj_num, adj_row, adj, mask, perm(num), & iccsze, node_num ) num = num + iccsze ! ! We can stop once every node is in one of the connected components. ! if ( node_num .lt. num ) then return endif endif enddo return end subroutine rcm ( root, adj_num, adj_row, adj, mask, perm, iccsze, & node_num ) !*****************************************************************************80 ! !! RCM renumbers a connected component by the reverse Cuthill McKee algorithm. ! ! Discussion: ! ! The connected component is specified by a node ROOT and a mask. ! The numbering starts at the root node. ! ! An outline of the algorithm is as follows: ! ! X(1) = ROOT. ! ! for ( I = 1 to N-1) ! Find all unlabeled neighbors of X(I), ! assign them the next available labels, in order of increasing degree. ! ! When done, reverse the ordering. ! ! Modified: ! ! 02 January 2007 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer ROOT, the node that defines the connected component. ! It is used as the starting point for the RCM ordering. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input/output, integer MASK(NODE_NUM), a mask for the nodes. Only ! those nodes with nonzero input mask values are considered by the ! routine. The nodes numbered by RCM will have their mask values ! set to zero. ! ! Output, integer PERM(NODE_NUM), the RCM ordering. ! ! Output, integer ICCSZE, the size of the connected component ! that has been numbered. ! ! Input, integer NODE_NUM, the number of nodes. ! ! Local Parameters: ! ! Workspace, integer DEG(NODE_NUM), a temporary vector used to hold ! the degree of the nodes in the section graph specified by mask and root. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer deg(node_num) integer fnbr integer i integer iccsze integer j integer jstop integer jstrt integer k integer l integer lbegin integer lnbr integer lperm integer lvlend integer mask(node_num) integer nbr integer node integer perm(node_num) integer root ! ! Find the degrees of the nodes in the component specified by MASK and ROOT. ! call degree ( root, adj_num, adj_row, adj, mask, deg, iccsze, & perm, node_num ) mask(root) = 0 if ( iccsze .le. 1 ) then return end if lvlend = 0 lnbr = 1 ! ! LBEGIN and LVLEND point to the beginning and ! the end of the current level respectively. ! do while ( lvlend .lt. lnbr ) lbegin = lvlend + 1 lvlend = lnbr do i = lbegin, lvlend ! ! For each node in the current level... ! node = perm(i) jstrt = adj_row(node) jstop = adj_row(node+1) - 1 ! ! Find the unnumbered neighbors of NODE. ! ! FNBR and LNBR point to the first and last neighbors ! of the current node in PERM. ! fnbr = lnbr + 1 do j = jstrt, jstop nbr = adj(j) if ( mask(nbr) .ne. 0 ) then lnbr = lnbr + 1 mask(nbr) = 0 perm(lnbr) = nbr end if end do ! ! If no neighbors, skip to next node in this level. ! cc if ( lnbr .le. fnbr ) then cc cycle cc end if if ( lnbr .gt. fnbr ) then ! ! Sort the neighbors of NODE in increasing order by degree. ! Linear insertion is used. ! k = fnbr do while ( k .lt. lnbr ) l = k k = k + 1 nbr = perm(k) do while ( fnbr .lt. l ) lperm = perm(l) if ( deg(lperm) .le. deg(nbr) ) then exit end if perm(l+1) = lperm l = l - 1 end do perm(l+1) = nbr end do end if end do end do ! ! We now have the Cuthill-McKee ordering. Reverse it. ! k=iccsze/2 l=iccsze do i=1,k lperm=perm(l) perm(l)=perm(i) perm(i)=lperm l=l-1 enddo return end subroutine root_find ( root, adj_num, adj_row, adj, mask, & level_num, level_row, level, node_num ) !*****************************************************************************80 ! !! ROOT_FIND finds a pseudo-peripheral node. ! ! Discussion: ! ! The diameter of a graph is the maximum distance (number of edges) ! between any two nodes of the graph. ! ! The eccentricity of a node is the maximum distance between that ! node and any other node of the graph. ! ! A peripheral node is a node whose eccentricity equals the ! diameter of the graph. ! ! A pseudo-peripheral node is an approximation to a peripheral node; ! it may be a peripheral node, but all we know is that we tried our ! best. ! ! The routine is given a graph, and seeks pseudo-peripheral nodes, ! using a modified version of the scheme of Gibbs, Poole and ! Stockmeyer. It determines such a node for the section subgraph ! specified by MASK and ROOT. ! ! The routine also determines the level structure associated with ! the given pseudo-peripheral node; that is, how far each node ! is from the pseudo-peripheral node. The level structure is ! returned as a list of nodes LS, and pointers to the beginning ! of the list of nodes that are at a distance of 0, 1, 2, ..., ! NODE_NUM-1 from the pseudo-peripheral node. ! ! Modified: ! ! 28 October 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Norman Gibbs, William Poole, Paul Stockmeyer, ! An Algorithm for Reducing the Bandwidth and Profile of a Sparse Matrix, ! SIAM Journal on Numerical Analysis, ! Volume 13, pages 236-250, 1976. ! ! Norman Gibbs, ! Algorithm 509: A Hybrid Profile Reduction Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 2, pages 378-387, 1976. ! ! Parameters: ! ! Input/output, integer ROOT. On input, ROOT is a node in the ! the component of the graph for which a pseudo-peripheral node is ! sought. On output, ROOT is the pseudo-peripheral node obtained. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input, integer MASK(NODE_NUM), specifies a section subgraph. Nodes ! for which MASK is zero are ignored by FNROOT. ! ! Output, integer LEVEL_NUM, is the number of levels in the level structure ! rooted at the node ROOT. ! ! Output, integer LEVEL_ROW(NODE_NUM+1), LEVEL(NODE_NUM), the ! level structure array pair containing the level structure found. ! ! Input, integer NODE_NUM, the number of nodes. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer iccsze integer j integer jstrt integer k integer kstop integer kstrt integer level(node_num) integer level_num integer level_num2 integer level_row(node_num+1) integer mask(node_num) integer mindeg integer nabor integer ndeg integer node integer root ! ! Determine the level structure rooted at ROOT. ! call level_set ( root, adj_num, adj_row, adj, mask, level_num, & level_row, level, node_num ) ! ! Count the number of nodes in this level structure. ! iccsze = level_row(level_num+1) - 1 ! ! Extreme case: ! A complete graph has a level set of only a single level. ! Every node is equally good (or bad). ! if ( level_num .eq. 1 ) then return end if ! ! Extreme case: ! A "line graph" 0--0--0--0--0 has every node in its only level. ! By chance, we've stumbled on the ideal root. ! if ( level_num .eq. iccsze ) then return end if ! ! Pick any node from the last level that has minimum degree ! as the starting point to generate a new level set. ! do mindeg = iccsze jstrt = level_row(level_num) root = level(jstrt) if ( jstrt .lt. iccsze ) then do j = jstrt, iccsze node = level(j) ndeg = 0 kstrt = adj_row(node) kstop = adj_row(node+1) - 1 do k = kstrt, kstop nabor = adj(k) if ( 0 .lt. mask(nabor) ) then ndeg = ndeg + 1 end if end do if ( ndeg .lt. mindeg ) then root = node mindeg = ndeg end if end do end if ! ! Generate the rooted level structure associated with this node. ! call level_set ( root, adj_num, adj_row, adj, mask, & level_num2, level_row, level, node_num ) ! ! If the number of levels did not increase, accept the new ROOT. ! if ( level_num2 .le. level_num ) then exit end if level_num = level_num2 ! ! In the unlikely case that ROOT is one endpoint of a line graph, ! we can exit now. ! if ( iccsze .le. level_num ) then exit end if end do return end subroutine level_set ( root, adj_num, adj_row, adj, mask, & level_num, level_row, level, node_num ) !*****************************************************************************80 ! !! LEVEL_SET generates the connected level structure rooted at a given node. ! ! Discussion: ! ! Only nodes for which MASK is nonzero will be considered. ! ! The root node chosen by the user is assigned level 1, and masked. ! All (unmasked) nodes reachable from a node in level 1 are ! assigned level 2 and masked. The process continues until there ! are no unmasked nodes adjacent to any node in the current level. ! The number of levels may vary between 2 and NODE_NUM. ! ! Modified: ! ! 28 October 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer ROOT, the node at which the level structure ! is to be rooted. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input/output, integer MASK(NODE_NUM). On input, only nodes with nonzero ! MASK are to be processed. On output, those nodes which were included ! in the level set have MASK set to 1. ! ! Output, integer LEVEL_NUM, the number of levels in the level ! structure. ROOT is in level 1. The neighbors of ROOT ! are in level 2, and so on. ! ! Output, integer LEVEL_ROW(NODE_NUM+1), LEVEL(NODE_NUM), the rooted ! level structure. ! ! Input, integer NODE_NUM, the number of nodes. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer i integer iccsze integer j integer jstop integer jstrt integer lbegin integer level_num integer level_row(node_num+1) integer level(node_num) integer lvlend integer lvsize integer mask(node_num) integer nbr integer node integer root mask(root) = 0 level(1) = root level_num = 0 lvlend = 0 iccsze = 1 ! ! LBEGIN is the pointer to the beginning of the current level, and ! LVLEND points to the end of this level. ! do lbegin = lvlend + 1 lvlend = iccsze level_num = level_num + 1 level_row(level_num) = lbegin ! ! Generate the next level by finding all the masked neighbors of nodes ! in the current level. ! do i = lbegin, lvlend node = level(i) jstrt = adj_row(node) jstop = adj_row(node+1) - 1 do j = jstrt, jstop nbr = adj(j) if ( mask(nbr) .ne. 0 ) then iccsze = iccsze + 1 level(iccsze) = nbr mask(nbr) = 0 end if end do end do ! ! Compute the current level width (the number of nodes encountered.) ! If it is positive, generate the next level. ! lvsize = iccsze - lvlend if ( lvsize .le. 0 ) then exit end if end do level_row(level_num+1) = lvlend + 1 ! ! Reset MASK to 1 for the nodes in the level structure. ! do i =1 ,iccsze mask(level(i)) = 1 enddo return end subroutine degree ( root, adj_num, adj_row, adj, mask, deg, & iccsze, ls, node_num ) !*****************************************************************************80 ! !! DEGREE computes the degrees of the nodes in the connected component. ! ! Discussion: ! ! The connected component is specified by MASK and ROOT. ! Nodes for which MASK is zero are ignored. ! ! Modified: ! ! 05 January 2003 ! ! Author: ! ! Alan George, Joseph Liu ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Alan George, Joseph Liu, ! Computer Solution of Large Sparse Positive Definite Systems, ! Prentice Hall, 1981. ! ! Parameters: ! ! Input, integer ROOT, the node that defines the connected component. ! ! Input, integer ADJ_NUM, the number of adjacency entries. ! ! Input, integer ADJ_ROW(NODE_NUM+1). Information about row I is stored ! in entries ADJ_ROW(I) through ADJ_ROW(I+1)-1 of ADJ. ! ! Input, integer ADJ(ADJ_NUM), the adjacency structure. ! For each row, it contains the column indices of the nonzero entries. ! ! Input, integer MASK(NODE_NUM), is nonzero for those nodes which are ! to be considered. ! ! Output, integer DEG(NODE_NUM), contains, for each node in the connected ! component, its degree. ! ! Output, integer ICCSIZE, the number of nodes in the connected component. ! ! Output, integer LS(NODE_NUM), stores in entries 1 through ICCSIZE the nodes ! in the connected component, starting with ROOT, and proceeding ! by levels. ! ! Input, integer NODE_NUM, the number of nodes. ! implicit none integer adj_num integer node_num integer adj(adj_num) integer adj_row(node_num+1) integer deg(node_num) integer i integer iccsze integer ideg integer j integer jstop integer jstrt integer lbegin integer ls(node_num) integer lvlend integer lvsize integer mask(node_num) integer nbr integer node integer root ! ! The sign of ADJ_ROW(I) is used to indicate if node I has been considered. ls(1) = root adj_row(root) = -adj_row(root) lvlend = 0 iccsze = 1 ! ! LBEGIN is the pointer to the beginning of the current level, and ! LVLEND points to the end of this level. do lbegin = lvlend + 1 lvlend = iccsze ! ! Find the degrees of nodes in the current level, ! and at the same time, generate the next level. do i = lbegin, lvlend node = ls(i) jstrt = -adj_row(node) jstop = abs ( adj_row(node+1) ) - 1 ideg = 0 do j = jstrt, jstop nbr = adj(j) if ( mask(nbr) .ne. 0 ) then ideg = ideg + 1 if ( 0 .le. adj_row(nbr) ) then adj_row(nbr) = -adj_row(nbr) iccsze = iccsze + 1 ls(iccsze) = nbr end if end if end do deg(node) = ideg end do ! ! Compute the current level width. lvsize = iccsze - lvlend ! ! If the current level width is nonzero, generate another level. if ( lvsize .eq. 0 ) then exit end if end do ! ! Reset ADJ_ROW to its correct sign and return. do i = 1, iccsze node = ls(i) adj_row(node) = -adj_row(node) end do return end RandomFieldsUtils/src/brdomain.cc0000644000175100001440000000443113074063617016562 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Collection of system specific auxiliary functions Copyright (C) 2001 -- 2015 Martin Schlather, This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 PURSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ // #define SIMD_AVAIALBLE 1 #include #include #include "RandomFieldsUtils.h" #include "General_utils.h" // #ifdef SCHLATHERS_MACHINE //#include "kleinkram.h" SEXP brdomain(SEXP Srf, SEXP Ssigma2, SEXP Sinstances, SEXP Smaxn) { double *rf = REAL(Srf), *sigma2 = REAL(Ssigma2); int instances = INTEGER(Sinstances)[0], maxn = INTEGER(Smaxn)[0], nloc = nrows(Ssigma2), total = instances * nloc, N = ncols(Srf); SEXP Ans; PROTECT(Ans = allocVector(REALSXP, total)); double *ans = REAL(Ans); for (int i=0; i ans[j]) ans[j] = w; } } } PutRNGstate(); UNPROTECT(1); return Ans; } // #endif // SCHLATHERS_MACHINE RandomFieldsUtils/src/sort.cc0000644000175100001440000003266413074063617015767 0ustar hornikusers #include "RandomFieldsUtils.h" #include "General_utils.h" #include "init_RandomFieldsUtils.h" static int ORDERDIM; static double *ORDERD; static int *ORDERDINT; static int order_from, order_to; typedef bool (*vergleich)(int, int); vergleich SMALLER=NULL, GREATER=NULL; bool smaller(int i, int j) { double *x, *y; int d; x = ORDERD + i * ORDERDIM; y = ORDERD + j * ORDERDIM; for(d=0; d y[d]; return false; } bool smaller1(int i, int j) { return ORDERD[i] < ORDERD[j]; } bool greater1(int i, int j) { return ORDERD[i] > ORDERD[j]; } bool smallerInt(int i, int j) { int *x, *y; int d; x = ORDERDINT + i * ORDERDIM; y = ORDERDINT + j * ORDERDIM; for(d=0; d y[d]; return false; } bool smallerInt1(int i, int j) { return ORDERDINT[i] < ORDERDINT[j]; } bool greaterInt1(int i, int j) { return ORDERDINT[i] > ORDERDINT[j]; } void order(int *pos, int start, int end) { int randpos, pivot, left, right, pivotpos, swap; if( start < end ) { //Get RNGstate();randpos = start + (int) (UNIFORM_RANDOM * (end-start+1)); PutRNGstate(); // use Get/Put RNGstate with great care !! randpos = (int) (0.5 * (start + end)); pivot = pos[randpos]; pos[randpos] = pos[start]; pos[start] = pivot; pivotpos=start; left = start; right=end+1; while (left < right) { //printf("order > %ld start=%d %d left=%d %d %d pivot=%d\n", pos, start, end, left, right, pos[left], pivot); while (++left < right && SMALLER(pos[left], pivot)) pivotpos++; while (--right > left && GREATER(pos[right], pivot)); if (left < right) { swap=pos[left]; pos[left]=pos[right]; pos[right]=swap; pivotpos++; } } pos[start] = pos[pivotpos]; pos[pivotpos] = pivot; if (start <= order_to && pivotpos > order_from) order(pos, start, pivotpos-1); if (pivotpos < order_to && end >= order_from) order(pos, pivotpos + 1, end); } } void orderingFromTo(double *d, int len, int dim, int *pos, int from, int to, usr_bool NAlast) { int start, end; if (NAlast == Nan) { for (int i=0; i start=%d %d left=%d %d %f pivot=%f\n", start, end, left, right, ORDERD[left], pivot); while (++left < right && ORDERD[left] < pivot) pivotpos++; while (--right > left && ORDERD[right] > pivot); if (left < right) { double swap = ORDERD[left]; ORDERD[left]=ORDERD[right]; ORDERD[right]=swap; pivotpos++; } } ORDERD[start] = ORDERD[pivotpos]; ORDERD[pivotpos] = pivot; if (start <= order_to && pivotpos > order_from) quicksort(start, pivotpos-1); if (pivotpos < order_to && end >= order_from) quicksort(pivotpos + 1, end); } } void sortingFromTo(double *d, int len, int from, int to, usr_bool NAlast) { int start, end; if (NAlast == Nan) { end = len-1; start = 0; } if (NAlast == True) { start = end = 0; int NAend = len - 1; while (end < NAend) { while (NAend >= 0 && (ISNA(d[NAend]) || ISNAN(d[NAend]))) NAend--; while (end < NAend && !ISNA(d[end]) && !ISNAN(d[end])) end++; if (end < NAend) { double swap = d[end]; d[end] = d[NAend]; d[NAend--] = swap; } } assert(NAend == end && false); } else { // if (NAlast == False) { start = end = len - 1; int NAstart = 0; while (start > NAstart) { while(NAstart < len && (ISNA(d[NAstart]) || ISNAN(d[NAstart]))) NAstart++; while (start > NAstart && !ISNA(d[start]) && !ISNAN(d[start])) start--; // printf("s = %d\n", start); if (start > NAstart) { double swap = d[start]; d[start] = d[NAstart]; d[NAstart++] = swap; } } // print("Rstart %d %d %d\n", start, end, NAstart); assert(NAstart == start); } order_from = from - 1; order_to = to - 1; ORDERD = d; // print("Xstart %d %d\n", start, end); quicksort(start, end); // for (int i=0; i left && ORDERDINT[right] > pivot); if (left < right) { int swap = ORDERDINT[left]; ORDERDINT[left]=ORDERDINT[right]; ORDERDINT[right]=swap; pivotpos++; } } ORDERDINT[start] = ORDERDINT[pivotpos]; ORDERDINT[pivotpos] = pivot; if (start <= order_to && pivotpos > order_from) sortInt(start, pivotpos-1); if (pivotpos < order_to && end >= order_from) sortInt(pivotpos + 1, end); } } void sortingIntFromTo(int *d, int len, int from, int to, usr_bool NAlast) { /* quicksort algorithm, slightly modified: does not sort the data, but d[pos] will be ordered NOTE: pos must have the values 0,1,2,...,start-end ! (orderdouble is a kind of sorting pos according to the variable d) */ int start, end; if (NAlast == Nan) { end = len-1; start = 0; } if (NAlast == True) { start = end = 0; int NAend = len - 1; while (end < NAend) { while (NAend >= 0 && d[NAend] == NA_INTEGER) NAend--; while (end < NAend && d[end] != NA_INTEGER) end++; if (end < NAend) { int swap = d[end]; d[end] = d[NAend]; d[NAend--] = swap; } } assert(NAend == end && false); } else { // if (NAlast == False) { start = end = len - 1; int NAstart = 0; while (start > NAstart) { while(NAstart < len && d[NAstart] == NA_INTEGER) NAstart++; while (start > NAstart && d[start] != NA_INTEGER) start--; if (start > NAstart) { double swap = d[start]; d[start] = d[NAstart]; d[NAstart++] = swap; } } assert(NAstart == start); } order_from = from - 1; order_to = to - 1; ORDERDINT = d; sortInt(start, end); } void sortingInt(int *d, int len, usr_bool NAlast) { sortingIntFromTo(d, len, 1, len, NAlast); } SEXP sortX(SEXP Data, SEXP From, SEXP To, SEXP NAlast) { int err = NOERROR, len = length(Data), from = MAX(1, INTEGER(From)[0]), to = MIN(INTEGER(To)[0], len); if (from > to) return R_NilValue; usr_bool nalast = LOGICAL(NAlast)[0] == NA_LOGICAL ? Nan : LOGICAL(NAlast)[0] ? True : False; SEXP Ans; if (TYPEOF(Data) == REALSXP) { // printf("%d %d %d %d\n", from, to, INTEGER(To)[0], len); PROTECT(Ans=allocVector(REALSXP, to - from + 1)); int bytes = len * sizeof(double); double *data; if ((data = (double*) MALLOC(bytes)) == NULL) { err = ERRORMEMORYALLOCATION; goto ErrorHandling; } MEMCOPY(data, REAL(Data), bytes); sortingFromTo(data, len, from, to, nalast); from--; double *ans; ans = REAL(Ans); for (int i=from; i to) return R_NilValue; SEXP Ans; PROTECT(Ans=allocVector(INTSXP, to - from + 1)); usr_bool nalast = LOGICAL(NAlast)[0] == NA_LOGICAL ? Nan : LOGICAL(NAlast)[0] ? True : False; int bytes = len * sizeof(int), *pos = (int*) MALLOC(bytes); if (pos == NULL) {err = ERRORMEMORYALLOCATION; goto ErrorHandling;} if (TYPEOF(Data) == REALSXP) { // printf("%d %d %d %d\n", from, to, INTEGER(To)[0], len); orderingFromTo(REAL(Data), len, 1, pos, from, to, nalast); } else if (TYPEOF(Data) == INTSXP) { orderingIntFromTo(INTEGER(Data), len, 1, pos, from, to, nalast); } else { err = ERRORFAILED; goto ErrorHandling; } from--; int *ans; ans = INTEGER(Ans); for (int i=from; i to) return R_NilValue; int *pos = (int*) MALLOC(len * sizeof(int)); usr_bool nalast = LOGICAL(NAlast)[0] == NA_LOGICAL ? Nan : LOGICAL(NAlast)[0] ? True : False; SEXP Ans; if (TYPEOF(Data) == REALSXP) { // printf("%d %d %d %d\n", from, to, INTEGER(To)[0], len); PROTECT(Ans=allocVector(REALSXP, to - from + 1)); double *ans = REAL(Ans), *data = REAL(Data); ordering(data, len, dim, pos, from, to, nalast); from--; for (int i=from; i #include #include #include "Basic_utils.h" #ifdef __cplusplus extern "C" { #endif void R_init_RandomFieldsUtils(DllInfo *info); void R_unload_RandomFieldsUtils(DllInfo *info); SEXP struve(SEXP X, SEXP Nu, SEXP Factor_Sign, SEXP Expscaled); SEXP I0ML0(SEXP X); SEXP gaussr(SEXP X, SEXP Derivative); SEXP WMr(SEXP X, SEXP Nu, SEXP Derivative, SEXP Factor); SEXP logWMr(SEXP X, SEXP Nu1, SEXP Nu2, SEXP Factor); SEXP SolvePosDef(SEXP M, SEXP rhs, SEXP logdet); SEXP Chol(SEXP M); SEXP RFoptions(SEXP options); void RelaxUnknownRFoption(int *relax); SEXP attachRFoptionsUtils(); SEXP detachRFoptionsUtils(); SEXP sortX(SEXP Data, SEXP From, SEXP To, SEXP NAlast); SEXP orderX(SEXP Data, SEXP From, SEXP To, SEXP NAlast); void sleepMicro(int *micro); void sleepMilli(int *milli); void hostname(char **h, int *i); void pid(int *i); SEXP getChar(); void Ordering(double *d, int *len, int *dim, int *pos); #ifdef SCHLATHERS_MACHINE SEXP scalarX(SEXP x, SEXP y, SEXP mode); SEXP brdomain(SEXP Srf, SEXP Sgamma, SEXP Sinstances, SEXP Smaxn); SEXP Udiffusion(SEXP SUSc, SEXP SUCo, SEXP Snevertried, SEXP Sa, SEXP Sabar, SEXP tWeight, SEXP Sq, SEXP Sdt, SEXP rho, SEXP SrandSc, SEXP SrandCo, SEXP Sit, SEXP Sdummy, SEXP Sthreshold); #endif #ifdef __cplusplus } #endif #endif RandomFieldsUtils/src/win_linux_aux.h0000644000175100001440000000200413074063617017514 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef WIN_LINUX_AUX_H #define WIN_LINUX_AUX_H 1 extern "C" void sleepMilli(int *milli); extern "C" void sleepMicro(int *milli); extern "C" void pid(int *i); extern "C" void hostname(char **h, int *i); #endif /* WIN_LINUX_AUX_H */ RandomFieldsUtils/src/init_RandomFieldsUtils.h0000644000175100001440000002060013074063617021240 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_init_H #define rfutils_init_H 1 #include "Options_utils.h" #include "errors_messages.h" #ifdef HAVE_VISIBILITY_ATTRIBUTE # define attribute_hidden __attribute__ ((visibility ("hidden"))) #else # define attribute_hidden #endif #ifdef __cplusplus extern "C" { #endif #define RF_UTILS "RandomFieldsUtils" //#define FCT_PREFIX RU_ #define CALL0(V, N) \ V attribute_hidden RU_##N() { \ static V(*fun)(AV) = NULL; \ if (fun == NULL) fun = (V (*) ()) R_GetCCallable(RF_UTILS, #N); \ return fun(); } #define DECLARE0(V, N) \ typedef V (*N##_type)(); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(); \ V N(); #define CALL1(V, N, AV, AN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN); } #define DECLARE1(V, N, AV, AN) \ typedef V (*N##_type)(AV AN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN); \ V N(AV AN); #define CALL2(V, N, AV, AN, BV, BN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN); } #define DECLARE2(V, N, AV, AN, BV, BN) \ typedef V (*N##_type)(AV AN, BV BN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN); \ V N(AV AN, BV BN); #define CALL3(V, N, AV, AN, BV, BN, CV, CN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN, CN); } #define DECLARE3(V, N, AV, AN, BV, BN, CV, CN) \ typedef V (*N##_type)(AV AN, BV BN, CV CN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN); \ V N(AV AN, BV BN, CV CN); #define CALL4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN, CN, DN); } #define DECLARE4(V, N, AV, AN, BV, BN, CV, CN, DV, DN) \ typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN); \ V N(AV AN, BV BN, CV CN, DV DN); #define CALL5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN, CN, DN, EN); } #define DECLARE5(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN) \ typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN); \ V N(AV AN, BV BN, CV CN, DV DN, EV EN); #define CALL6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN, CN, DN, EN, FN); } #define DECLARE6(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN) \ typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); \ V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN); #define CALL7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN, CN, DN, EN, FN, GN); } #define DECLARE7(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN) \ typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); \ V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN); #define CALL8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \ /* N##_type Ext_##N = NULL; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN) { \ static N##_type fun = NULL; \ if (fun == NULL) fun = (N##_type) R_GetCCallable(RF_UTILS, #N); \ return fun(AN, BN, CN, DN, EN, FN, GN, HN); } #define DECLARE8(V, N, AV, AN, BV, BN, CV, CN, DV, DN, EV, EN, FV, FN, GV, GN, HV, HN) \ typedef V (*N##_type)(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \ /* extern N##_type Ext_##N; */ \ V attribute_hidden RU_##N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); \ V N(AV AN, BV BN, CV CN, DV DN, EV EN, FV FN, GV GN, HV HN); DECLARE1(void, solve_DELETE, solve_storage**, S) DECLARE1(void, solve_NULL, solve_storage*, x) DECLARE7(int, solvePosDef, double*, M, int, size, bool, posdef, double *, rhs, int, rhs_cols, double *, logdet, solve_storage *, PT) DECLARE8(int, solvePosDefResult, double*, M, int, size, bool, posdef, double *, rhs, int, rhs_cols, double *, result, double*, logdet, solve_storage*, PT) DECLARE3(int, sqrtPosDef, double *, M, int, size, solve_storage *, pt) DECLARE3(int, sqrtPosDefFree, double *, M, int, size, solve_storage *, pt) DECLARE3(int, sqrtRHS, solve_storage *, pt, double*, RHS, double *, res) DECLARE2(int, invertMatrix, double *, M, int, size) DECLARE2(double, StruveH, double, x, double, nu) DECLARE3(double, StruveL, double, x, double, nu, bool, expScaled) DECLARE1(double, I0mL0, double, x) DECLARE3(double, WM, double, x, double, nu, double, factor) DECLARE3(double, DWM, double, x, double, nu, double, factor) DECLARE3(double, DDWM, double, x, double, nu, double, factor) DECLARE3(double, D3WM, double, x, double, nu, double, factor) DECLARE3(double, D4WM, double, x, double, nu, double, factor) DECLARE4(double, logWM, double, x, double, nu1, double, nu2, double, factor) DECLARE1(double, Gauss, double, x) DECLARE1(double, DGauss, double, x) DECLARE1(double, DDGauss, double, x) DECLARE1(double, D3Gauss, double, x) DECLARE1(double, D4Gauss, double, x) DECLARE1(double, logGauss, double, x) DECLARE1(void, getErrorString, errorstring_type, errorstring) DECLARE1(void, setErrorLoc, errorloc_type, errorloc) DECLARE1(void, getUtilsParam, utilsparam **, up) DECLARE7(void, attachRFoptions, const char **, prefixlist, int, N, const char ***, all, int *, allN, setparameterfct, set, finalsetparameterfct, final, getparameterfct, get) DECLARE2(void, detachRFoptions, const char **, prefixlist, int, N) DECLARE1(void, relaxUnknownRFoption, bool, relax) DECLARE3(void, sorting, double*, data, int, len, usr_bool, NAlast) DECLARE3(void, sortingInt, int*, data, int, len, usr_bool, NAlast) DECLARE4(void, ordering, double*, data, int, len, int, dim, int *, pos) DECLARE4(void, orderingInt, int*, data, int, len, int, dim, int *, pos) /* See in R package RandomFields, /src/userinterfaces.cc CALL#(...) at the beginning for how to make the functions available in a calling package */ #ifdef __cplusplus } #endif #endif RandomFieldsUtils/src/General_utils.h0000644000175100001440000001065413074063617017432 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_H #define rfutils_H 1 #include #include #include #include #include "Basic_utils.h" #include "errors_messages.h" #include "kleinkram.h" #include "Solve.h" #define DOPRINTF if (DOPRINT) Rprintf #define PRINTF Rprintf #define print PRINTF /* // */ #ifdef HIDE_UNUSED_VARIABLE #define VARIABLE_IS_NOT_USED __attribute__ ((unused)) #else #ifdef __GNUC__ #define VARIABLE_IS_NOT_USED __attribute__ ((unused)) #else #define VARIABLE_IS_NOT_USED #endif #endif // not SCHLATHERS_MACHINE #ifndef SCHLATHERS_MACHINE #define INTERNAL SERR("Sorry. This functionality does not exist currently. There is work in progress at the moment by the maintainer.") #define assert(X) {} #define BUG { \ SPRINTF(BUG_MSG, "Severe error occured in function '%s' (file '%s', line %d). Please contact maintainer martin.schlather@math.uni-mannheim.de .", \ __FUNCTION__, __FILE__, __LINE__); \ RFERROR(BUG_MSG); \ } #define DO_TESTS false //#define MEMCOPY(A,B,C) {memcpy(A,B,C); printf("memcpy %s %d\n", __FILE__, __LINE__);} #define MEMCOPY(A,B,C) MEMCOPYX(A,B,C) #define MALLOC MALLOCX #define CALLOC CALLOCX #define FREE(X) if ((X) != NULL) {FREEX(X); (X)=NULL;} #define UNCONDFREE(X) {FREEX(X); (X)=NULL;} #endif // not SCHLATHERS_MACHINE // SCHLATHERS_MACHINE #ifdef SCHLATHERS_MACHINE #define MAXALLOC 1e9 // __extension__ unterdrueckt Fehlermeldung wegen geklammerter Argumente #define INTERNAL \ SPRINTF(BUG_MSG, \ "made to be an internal function '%s' ('%s', line %d).", /* // */ \ __FUNCTION__, __FILE__, __LINE__); \ /* warning(BUG_MSG) */ \ SERR(BUG_MSG) #define assert(X) if (!__extension__ (X)) { \ SPRINTF(BUG_MSG,"'assert(%s)' failed in function '%s'.",#X,__FUNCTION__); \ ERR(BUG_MSG); \ } #define SHOW_ADDRESSES 1 #define BUG { PRINTF("BUG in '%s'.", __FUNCTION__); ERR(BUG_MSG); } #define DO_TESTS true #define MEMCOPY(A,B,C) __extension__ ({ assert((A)!=NULL && (B)!=NULL); MEMCOPYX(A,B,C); }) //#define MEMCOPY(A,B,C) memory_copy(A, B, C) #define MALLOC(X) __extension__ ({assert((X)>0 && (X)<=MAXALLOC); MALLOCX(X);}) #define CALLOC(X, Y) __extension__({assert((X)>0 && (X)<=MAXALLOC && (Y)>0 && (Y)<=64); CALLOCX(X,Y);}) #define FREE(X) { if ((X) != NULL) {if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;}} #define UNCONDFREE(X) { if (showfree) DOPRINTF("(free in %s, line %d)\n", __FILE__, __LINE__); FREEX(X); (X)=NULL;} #endif // SCHLATHERS_MACHINE #ifdef RANDOMFIELDS_DEBUGGING #undef MALLOC #define MALLOC(X) __extension__({DOPRINTF("(MALL %s, line %d)\n", __FILE__, __LINE__);assert((X)>0 && (X)<=3e9); MALLOCX(X);}) // #undef CALLOC #define CALLOC(X, Y) __extension__({DOPRINTF("(CALL %s, line %d)\n",__FILE__, __LINE__);assert((X)>0 && (X)0 && (Y)<=64); CALLOCX(X,Y);}) //#define MALLOC malloc //#define CALLOC calloc #define DEBUGINFOERR { \ errorstring_type dummy_; strcpy(dummy_, ERRORSTRING); \ SPRINTF(ERRORSTRING, "%s (%s, line %d)\n", dummy_, __FILE__, __LINE__); \ } #define DEBUGINFO DOPRINTF("(currently at %s, line %d)\n", __FILE__, __LINE__) #else #define DEBUGINFO #define DEBUGINFOERR if (PL >= PL_ERRORS) PRINTF("error: %s\n", ERRORSTRING); #endif #define PL_IMPORTANT 1 #define PL_BRANCHING 2 #define PL_DETAILSUSER 3 #define PL_RECURSIVE 4 #define PL_STRUCTURE 5 // see also initNerror.ERROROUTOFMETHOD #define PL_ERRORS 6 // only those that are caught internally #define PL_FCTN_DETAILS 7 // R #define PL_FCTN_SUBDETAILS 8 #define PL_COV_STRUCTURE 7 // C #define PL_DIRECT_SEQU 8 #define PL_DETAILS 9 #define PL_SUBDETAILS 10 #define MATERN_NU_THRES 100 #endif RandomFieldsUtils/src/errors_messages.h0000644000175100001440000001366613074063617020046 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ // Datei wi #ifndef rfutils_error_H #define rfutils_error_H 1 #define NOERROR 0 #define ERRORMEMORYALLOCATION 1 #define ERRORFAILED 2 /* method didn't work for the specified parameters */ #define ERRORM 3 /* a single error message */ #define ERRORNOTPROGRAMMEDYET 4 #ifdef SCHLATHERS_MACHINE #define ERRLINE PRINTF("(ERROR in %s, line %d)\n", __FILE__, __LINE__); #else #define ERRLINE #endif #define LENMSG 250 #define MAXERRORSTRING 1000 #define nErrorLoc 1000 #define LENERRMSG 2000 typedef char errorstring_type[MAXERRORSTRING]; typedef char errorloc_type[nErrorLoc]; extern char ERRMSG[LENERRMSG], // used by Error_utils.h. Never use elsewhere MSG[LENERRMSG], // used by RandomFields in intermediate steps BUG_MSG[LENMSG],// not much used MSG2[LENERRMSG];// used at the same time with MSG and ERR() extern errorstring_type ERRORSTRING; // used by ERRORM in RandomFields extern errorloc_type ERROR_LOC; #define ERRMSG(X) if (PL>=PL_ERRORS){errorMSG(X,MSG); PRINTF("error: %s%s\n",ERROR_LOC,MSG);} #define RFERROR error #define ERR(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFERROR(ERRMSG);} #define ERR1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y); \ RFERROR(MSG2);} #define ERR2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\ SPRINTF(MSG2, ERRMSG, Y, Z); \ RFERROR(MSG2);} #define ERR3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A); \ RFERROR(MSG2);} #define ERR4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \ RFERROR(MSG2);} #define ERR5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \ RFERROR(MSG2);} #define ERR6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \ RFERROR(MSG2);} #define ERR7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \ RFERROR(MSG2);} #define ERR8(X,Y,Z,A,B,C,D,E,F) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E, F); \ RFERROR(MSG2);} #define FERR(X) strcpy(ERRORSTRING, X); DEBUGINFOERR #define SERR(X) { FERR(X); return ERRORM;} #define CERR(X) { FERR(X); err=ERRORM; continue;} #define FERR1(X,Y) SPRINTF(ERRORSTRING, X, Y); DEBUGINFOERR #define SERR1(X,Y) { FERR1(X, Y); return ERRORM;} #define CERR1(X,Y) { FERR1(X, Y); err=ERRORM; continue; } #define FERR2(X,Y,Z) SPRINTF(ERRORSTRING, X, Y, Z); DEBUGINFOERR #define SERR2(X, Y, Z) { FERR2(X, Y, Z); return ERRORM;} #define CERR2(X, Y, Z) { FERR2(X, Y, Z); err=ERRORM; continue;} #define FERR3(X,Y,Z,A) SPRINTF(ERRORSTRING, X, Y, Z, A); DEBUGINFOERR #define SERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); return ERRORM;} #define CERR3(X, Y, Z, A) { FERR3(X, Y, Z, A); err=ERRORM; continue;} #define FERR4(X,Y,Z,A,B) SPRINTF(ERRORSTRING, X, Y, Z, A, B); DEBUGINFOERR #define SERR4(X, Y, Z, A, B) { FERR4(X, Y, Z, A, B); return ERRORM;} #define FERR5(X,Y,Z,A,B,C) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C); DEBUGINFOERR #define SERR5(X, Y, Z, A, B, C) {FERR5(X, Y, Z, A, B, C); return ERRORM;} #define FERR6(X,Y,Z,A,B,C,D) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D); DEBUGINFOERR #define SERR6(X, Y, Z, A, B, C, D) {FERR6(X, Y, Z, A, B, C,D); return ERRORM;} #define FERR7(X,Y,Z,A,B,C,D,E) SPRINTF(ERRORSTRING,X,Y,Z,A,B,C,D,E);DEBUGINFOERR #define SERR7(X, Y, Z, A, B, C, D, E) {FERR7(X,Y,Z,A,B,C,D,E); return ERRORM;} #define GERR(X) {FERR(X); err = ERRORM; goto ErrorHandling;} #define GERR1(X,Y) {FERR1(X,Y);err = ERRORM; goto ErrorHandling;} #define GERR2(X,Y,Z) {FERR2(X,Y,Z); err = ERRORM; goto ErrorHandling;} #define GERR3(X,Y,Z,A) {FERR3(X,Y,Z,A); err = ERRORM; goto ErrorHandling;} #define GERR4(X,Y,Z,A,B) {FERR4(X,Y,Z,A,B); err = ERRORM; goto ErrorHandling;} #define GERR5(X,Y,Z,A,B,C) {FERR5(X,Y,Z,A,B,C); err=ERRORM; goto ErrorHandling;} #define GERR6(X,Y,Z,A,B,C,D) {FERR6(X,Y,Z,A,B,C,D); err=ERRORM; goto ErrorHandling;} #define RFWARNING warning #define warn(X) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); RFWARNING(ERRMSG);} #define WARN1(X, Y) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y); \ RFWARNING(MSG2);} #define WARN2(X, Y, Z) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X);\ SPRINTF(MSG2, ERRMSG, Y, Z); \ RFWARNING(MSG2);} #define WARN3(X, Y, Z, A) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A); \ RFWARNING(MSG2);} #define WARN4(X, Y, Z, A, B) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC, X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B); \ RFWARNING(MSG2);} #define WARN5(X, Y, Z, A, B, C) {ERRLINE;SPRINTF(ERRMSG, "%s %s", ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C); \ RFWARNING(MSG2);} #define WARN6(X, Y, Z, A, B,C,D) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D); \ RFWARNING(MSG2);} #define WARN7(X, Y, Z,A,B,C,D,E) {ERRLINE;SPRINTF(ERRMSG, "%s %s",ERROR_LOC,X); \ SPRINTF(MSG2, ERRMSG, Y, Z, A, B, C, D, E); \ RFWARNING(MSG2);} #endif RandomFieldsUtils/src/options.cc0000644000175100001440000001270013074063617016460 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2016 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "Basic_utils.h" // must be before anything else #ifdef DO_PARALLEL #include #endif #include "General_utils.h" #include "kleinkram.h" #include "init_RandomFieldsUtils.h" #include #define PLverbose 2 // IMPORTANT: all names of general must be at least 3 letters long !!! const char *basic[basicN] = { "printlevel", "skipchecks", "cPrintlevel", "seed", "asList", "cores", "verbose"}; const char * solve[solveN] = { "use_spam", "spam_tol", "spam_min_p", "svdtol", "solve_method", "spam_min_n", "spam_sample_n", "spam_factor", "spam_pivot", "max_chol", "max_svd", "eigen2zero" //, "tmp_delete" }; #define ownprefixN 2 const char * ownprefixlist[ownprefixN] = {"basic", "solve"}; const char **ownall[ownprefixN] = {basic, solve}; int ownallN[ownprefixN] = {basicN, solveN}; int PL=C_PRINTLEVEL; utilsparam GLOBAL = { basic_START, solve_START }; #if defined(unix) || defined(__unix__) || defined(__unix) int numCPU = sysconf(_SC_NPROCESSORS_ONLN); #else int numCPU = MAXINT; #endif void setparameterUtils(int i, int j, SEXP el, char name[LEN_OPTIONNAME], bool isList) { switch(i) { case 0: {// general basic_param *gp; gp = &(GLOBAL.basic); switch(j) { case 0: { // general options int threshold = 1000; //PL_ERRORS; gp->Rprintlevel = INT; PL = gp->Cprintlevel = gp->Rprintlevel <= threshold ? gp->Rprintlevel : threshold; } break; case 1: gp->skipchecks = LOG; break; case 2: PL = gp->Cprintlevel = INT; break; case 3: gp->seed = Integer(el, name, 0, true); break; case 4: gp->asList = LOG; break; case 5: gp->cores = POSINT; if (gp->cores > numCPU) { WARN1("number of 'cores' is set to %d", numCPU); gp->cores = numCPU; } #ifdef DO_PARALLEL omp_set_num_threads(gp->cores); #else if (gp->cores != 1) ERR("The system does not allow for OpenMP: the value 1 is kept for'cores'."); #endif break; case 6 : if (!isList) { PL = gp->Cprintlevel = gp->Rprintlevel = (LOG) * PLverbose; } break; default: BUG; }} break; case 1: { solve_param *so = &(GLOBAL.solve); switch(j) { case 0: { double sparse = NUM; so->sparse = !R_finite(sparse) ? Nan : sparse==0.0 ? False : True ; break; } case 1: so->spam_tol = POS0NUM; break; case 2: so->spam_min_p = POS0NUM; break; case SOLVE_SVD_TOL: so->svd_tol = POS0NUM; break; case 4: GetName(el, name, InversionNames, nr_user_InversionMethods, (int) NoInversionMethod, (int) NoFurtherInversionMethod, (int *)so->Methods, SOLVE_METHODS); break; case 5: so->spam_min_n = POSINT; break; case 6: so->spam_sample_n = POSINT; break; case 7: so->spam_factor = POSINT; break; case 8: so->pivot = POSINT; if (so->pivot > 2) so->pivot = PIVOT_NONE; break; case 9: so->max_chol = POSINT; break; case 10: so->max_svd = POSINT; break; // case 11: so->tmp_delete = LOG; break; case 11: so->eigen2zero = POS0NUM; break; default: BUG; }} break; default: BUG; } } void getparameterUtils(SEXP *sublist) { int i, k; //#define ADD(ELT) {printf(#ELT"\n");SET_VECTOR_ELT(sublist[i], k++, ELT);} i = 0; { // printf("OK %d\n", i); k = 0; basic_param *p = &(GLOBAL.basic); ADD(ScalarInteger(p->Rprintlevel)); ADD(ScalarLogical(p->skipchecks)); ADD(ScalarInteger(p->Cprintlevel)); ADD(ScalarInteger(p->seed)); ADD(ScalarLogical(p->asList)); ADD(ScalarInteger(p->cores)); ADD(ScalarLogical(p->Rprintlevel >= PLverbose)) } i++; { k = 0; solve_param *p = &(GLOBAL.solve); // printf("sparse user interface %d %d; %d %d\n", p->sparse, ExtendedBoolean(p->sparse), NA_LOGICAL, NA_INTEGER); ADD(ExtendedBooleanUsr(p->sparse)); ADD(ScalarReal(p->spam_tol)); ADD(ScalarReal(p->spam_min_p)); ADD(ScalarReal(p->svd_tol)); SET_VECTOR_ELT(sublist[i], k++, String((int*) p->Methods, InversionNames, SOLVE_METHODS, (int) NoFurtherInversionMethod)); ADD(ScalarInteger(p->spam_min_n)); ADD(ScalarInteger(p->spam_sample_n)); ADD(ScalarInteger(p->spam_factor)); ADD(ScalarInteger(p->pivot)); ADD(ScalarInteger(p->max_chol)); ADD(ScalarInteger(p->max_svd)); ADD(ScalarReal(p->eigen2zero)); // ADD(ScalarLogical(p->tmp_delete)); } assert (i == ownprefixN - 1); } void getErrorString(errorstring_type errorstring){ strcopyN(errorstring, ERRORSTRING, MAXERRORSTRING); } void setErrorLoc(errorloc_type errorloc){ strcopyN(ERROR_LOC, errorloc, nErrorLoc); } RandomFieldsUtils/src/own.cc0000644000175100001440000000332413074063617015572 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ //#include "Basic_utils.h" // must be before anything else #include "RandomFieldsUtils.h" // must be before anything else #ifdef DO_PARALLEL #include #endif #include #include #include "General_utils.h" #include "own.h" #include "init_RandomFieldsUtils.h" // local char ERRMSG[LENERRMSG], MSG[LENERRMSG], BUG_MSG[250], MSG2[LENERRMSG]; // globally needed errorloc_type ERROR_LOC=""; errorstring_type ERRORSTRING; SEXP attachRFoptionsUtils() { // NList = 0; // printf("UTx %ld\n", (long) getUtilsParam); attachRFoptions(ownprefixlist, ownprefixN, ownall, ownallN, setparameterUtils, NULL, getparameterUtils); #ifdef DO_PARALLEL basic_param *gp = &(GLOBAL.basic); omp_set_num_threads(gp->cores); #endif return R_NilValue; } SEXP detachRFoptionsUtils(){ #ifdef DO_PARALLEL omp_set_num_threads(1); #endif detachRFoptions(ownprefixlist, ownprefixN); return R_NilValue; } RandomFieldsUtils/src/spamown.f0000644000175100001440000015362713074063617016327 0ustar hornikusers subroutine amuxmat (n,m,p, x, y, a,ja,ia) implicit none integer n, m, p, ja(*), ia(*) double precision x(m,p), y(n,p), a(*) c----------------------------------------------------------------------- c Multiplies a sparse matrix by a full matrix using consecutive dot c products, cf. subroutine amux from sparse kit. c Matrix A is stored in compressed sparse row storage. c c on entry: c---------- c n = row dimension of A c p = column dimension of x c x = array of dimension mxp, m column dimension of A. c a, ja, c ia = input matrix in compressed sparse row format. c c on return: c----------- c y = array of dimension nxp, containing the product y=Ax c c Reinhard Furrer c----------------------------------------------------------------------- c local variables c double precision t integer j, i, k c----------------------------------------------------------------------- do j = 1,p do i = 1,n c c compute the inner product of row i with vector x c t = 0.0d0 do k=ia(i), ia(i+1)-1 t = t + a(k)*x(ja(k),j) enddo c y(i,j) = t enddo enddo c return c---------end-of-amuxmat------------------------------------------------ c----------------------------------------------------------------------- end c subroutine notzero (ja,ia,nrow,ncol,nnz,nz,jao,iao) c Return the structure of the zero entries in ra,ja,ia, in c compressed sparse row format via rao, jao, iao. c INPUT: c ja, ia -- sparse structure of the matrix A c nrow -- number of rows in `a' c ncol -- number of columns in `a' c nnz -- number of non-zero elements c nz -- number of zero elements c OUTPUT: c jao, iao -- sparse structure of the zero entries c WORK ARRAY: c colmn -- logical vector of length ncol implicit none integer nrow,ncol,nnz,nz,inz, & ja(nnz),ia(nrow+1),jao(nz),iao(nrow+1) logical colmn(ncol) integer i,j,k inz = 0 iao(1) = 1 do i = 1,nrow iao(i+1) = iao(i) do k = 1,ncol colmn(k) = .true. enddo do j = ia(i),ia(i+1)-1 colmn(ja(j)) = .false. enddo do k = 1,ncol if(colmn(k)) then inz = inz + 1 jao(inz) = k iao(i+1) = iao(i+1) + 1 endif enddo enddo return end subroutine setdiagmat (nrow, n, a, ja, ia, diag, iw) implicit none integer nrow, n double precision a(*), diag(n) integer ja(*), ia(nrow+1), iw(nrow) c----------------------------------------------------------------------- c Sets the diagonal entries of a sparse matrix c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c n = integer. Smallest dimension of A c c a, ja, ia = Matrix A in compressed sparse row format. Sorted. c diag = diagonal matrix stored as a vector diag(1:n) c iw = n vector of zeros. c c on return: c---------- c updated matrix A c iw = iw contains the positions of the diagonal entries in the c output matrix. (i.e., a(iw(k)), ja(iw(k)), k=1,...n, c are the values/column indices of the diagonal elements c of the output matrix. ). c c Reinhard Furrer c----------------------------------------------------------------- logical insert integer i,j, k, k1, k2, icount c c get positions of diagonal elements in data structure. c do 11 i=1,n do 21 j= ia(i),ia(i+1)-1 if (ja(j) .ge. i) then if (ja(j) .eq. i) then iw(i) = j endif goto 11 endif 21 continue 11 continue c c count number of holes in diagonal and add diag(*) elements to c valid diagonal entries. c icount = 0 do 31 i=1, n if (iw(i) .eq. 0) then icount = icount+1 else a(iw(i)) = diag(i) endif 31 continue c c if no diagonal elements to insert return c if (icount .eq. 0) return c c shift the nonzero elements if needed, to allow for created c diagonal elements. c c c copy rows backward c do 5 i=nrow, 1, -1 c c go through row ii c k1 = ia(i) k2 = ia(i+1)-1 ia(i+1) = ia(i+1)+icount if ((i .gt. n) .or. (iw(i) .gt. 0)) then c iw(ii) equal to 0, means no diagonal element in a, we need to insert it c test is thus true. c no fill-in, only copying do 4 k = k2,k1,-1 ja(k+icount)=ja(k) a(k+icount)=a(k) 4 continue iw(i)=-i else insert=.TRUE. if (k2.lt.k1) then ja(k2+icount)=i a(k2+icount)=diag(i) iw(i)=k2+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return else do 6 k = k2,k1,-1 if (ja(k).gt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) else if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif if (ja(k).lt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) endif 6 continue c in case there is only one element, larger than i, we still need to c add the diagonal element if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif endif endif 5 continue return c----------------------------------------------------------------------- c------------end-of-diagaddmat------------------------------------------ end subroutine diagaddmat (nrow, n, a, ja, ia, diag, iw) implicit none integer nrow, n double precision a(*), diag(n) integer ja(*), ia(nrow+1), iw(nrow) c----------------------------------------------------------------------- c Adds a diagonal matrix to a sparse matrix: A = Diag + A c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c n = integer. Smallest dimension of A c c a, ja, ia = Matrix A in compressed sparse row format. Sorted. c diag = diagonal matrix stored as a vector diag(1:n) c iw = n vector of zeros. c c on return: c---------- c updated matrix A c iw = iw contains the positions of the diagonal entries in the c output matrix. (i.e., a(iw(k)), ja(iw(k)), k=1,...n, c are the values/column indices of the diagonal elements c of the output matrix. ). c c Reinhard Furrer c----------------------------------------------------------------- logical insert integer i,j, k, k1, k2, icount c c get positions of diagonal elements in data structure. c do 11 i=1,n do 21 j= ia(i),ia(i+1)-1 if (ja(j) .ge. i) then if (ja(j) .eq. i) then iw(i) = j endif goto 11 endif 21 continue 11 continue c c count number of holes in diagonal and add diag(*) elements to c valid diagonal entries. c icount = 0 do 31 i=1, n if (iw(i) .eq. 0) then icount = icount+1 else a(iw(i)) = a(iw(i)) + diag(i) endif 31 continue c c if no diagonal elements to insert return c if (icount .eq. 0) return c c shift the nonzero elements if needed, to allow for created c diagonal elements. c c c copy rows backward c do 5 i=nrow, 1, -1 c c go through row ii c k1 = ia(i) k2 = ia(i+1)-1 ia(i+1) = ia(i+1)+icount if ((i .gt. n) .or. (iw(i) .gt. 0)) then c iw(ii) equal to 0, means no diagonal element in a, we need to insert it c test is thus true. c no fill-in, only copying do 4 k = k2,k1,-1 ja(k+icount)=ja(k) a(k+icount)=a(k) 4 continue iw(i)=-i else insert=.TRUE. if (k2.lt.k1) then ja(k2+icount)=i a(k2+icount)=diag(i) iw(i)=k2+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return else do 6 k = k2,k1,-1 if (ja(k).gt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) else if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif if (ja(k).lt. i) then ja(k+icount)=ja(k) a(k+icount)=a(k) endif 6 continue c in case there is only one element, larger than i, we still need to c add the diagonal element if (insert) then ja(k+icount)=i a(k+icount)=diag(i) iw(i)=k+icount icount=icount-1 insert = .FALSE. if (icount .eq. 0) return endif endif endif 5 continue return c----------------------------------------------------------------------- c------------end-of-setdiagmat------------------------------------------ end c----------------------------------------------------------------------- subroutine diagmua (nrow, a, ia, diag) implicit none integer nrow, ia(nrow+1) double precision a(*), diag(nrow), scal c----------------------------------------------------------------------- c performs the matrix by matrix product A = Diag * A (in place) c (diamua from sparsekit provides more functionality) c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A c a, ia = Matrix A in compressed sparse row format. c (ja is not needed) c c diag = diagonal matrix stored as a vector diag(1:n) c c on return: c---------- c a, = resulting matrix A in compressed sparse row sparse format. c c Notes: c------- c Reinhard Furrer 2007-06-21 c c----------------------------------------------------------------- c local variables integer ii, k, k1, k2 do 1 ii=1,nrow c c normalize each row c k1 = ia(ii) k2 = ia(ii+1)-1 scal = diag(ii) do 2 k=k1, k2 a(k) = a(k)*scal 2 continue 1 continue c return c----------end-of-diagmua------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine getdiag (a,ja,ia,len,diag) implicit none double precision diag(*),a(*) integer len, ia(*), ja(*) c----------------------------------------------------------------------- c This subroutine extracts the main diagonal. c (getdia from sparsekit provides more functionality) c----------------------------------------------------------------------- c c on entry: c---------- c c len= min(nrow, ncol) = min dimension of the matrix a. c a,ja,ia = matrix stored in sorted compressed sparse row a,ja,ia,format c diag = array of zeros. c c on return: c----------- c diag = array of length containing the wanted diagonal. c c Notes: c------- c Reinhard Furrer 2006-11-02 c----------------------------------------------------------------------c c local variables integer i, k c c extract diagonal elements c do 1 i=1, len do k= ia(i),ia(i+1) -1 if (ja(k) .ge. i) then c we are at or beyond the diagonal. if (ja(k) .eq. i) then diag(i)= a(k) endif goto 1 endif enddo 1 continue return c------------end-of-getdiag---------------------------------------------- c----------------------------------------------------------------------- end c Functions that are new or modified. subroutine subsparsefull(nrow,a,ja,ia,b) c c subtracts a sparse matrix from a full one c algorithm is in-place, i.e. b is changed c c c Notes: c------- c Reinhard Furrer 2006-09-21 c----------------------------------------------------------------------- implicit none integer nrow,ja(*),ia(nrow+1) double precision a(*), b(nrow,*) integer i,k do i=1,nrow do k=ia(i),ia(i+1)-1 b(i,ja(k)) = b(i,ja(k))-a(k) enddo enddo return end subroutine subfullsparse(nrow,ncol,a,ja,ia,b) c c subtracts a full matrix from a sparse one c algorithm is in-place, i.e. b is changed c c c Notes: c------- c Reinhard Furrer 2006-09-21 c----------------------------------------------------------------------- implicit none integer nrow,ncol,ja(*),ia(nrow+1) double precision a(*), b(nrow,*) integer i,j,k do i=1,nrow do j=1,ncol b(i,j) = -b(i,j) enddo do k=ia(i),ia(i+1)-1 b(i,ja(k)) = b(i,ja(k))+a(k) enddo enddo return end subroutine addsparsefull(nrow,a,ja,ia,b) c c adds a sparse matrix to a full one c algorithm is in-place, i.e. b is changed c c c Notes: c------- c Reinhard Furrer 2006-09-21 c----------------------------------------------------------------------- implicit none integer nrow,ja(*),ia(nrow+1) double precision a(*), b(nrow,*) integer i,k do i=1,nrow do k=ia(i),ia(i+1)-1 b(i,ja(k)) = b(i,ja(k))+a(k) enddo enddo return end subroutine constructia(nrow,nir,ia,ir) c c constructs from a regular row index vector a sparse ia vector. c note that a regular column index vector corresponds to the c sparse ja vector. for example: c A[ir,jc] => A@ja = jc, A@ia = constructia(nrow,nir,ia,ir)$ia c c nrow: row dimension of A c nir: length of ir c ir: array of length nir+1!!! c c Notes: c------- c _*Row indices have to be ordered!*_ c c Reinhard Furrer 2006-09-13 c----------------------------------------------------------------------- implicit none integer nrow,nir integer ia(nrow+1),ir(*) integer i,k k=1 ia(1)=1 do i=1,nrow 5 continue if (ir(k) .eq. i) then k=k+1 if (k .le. nir) goto 5 endif ia(i+1)=k enddo ia(nrow+1)=nir+1 return end subroutine disttospam(nrow,x,a,ja,ia,eps) implicit none integer nrow, ia(nrow+1), ja(*) double precision x(*), a(*), eps c c Convertion of an R dist object (removes zero entries as well). c c On entry: c---------- c nrow -- row dimension of the matrix c x -- elements of the dist object (is lower diagonal) c n*(i-1) - i*(i-1)/2 + j-i for i < j c c a,ja,ia -- input matrix in CSR format c c On return: c----------- c a,ja,ia -- cleaned matrix c c Notes: c------- c Reinhard Furrer 2008-08-13 c----------------------------------------------------------------------- c c Local integer i,j,k, tmp ia(1) = 1 k = 1 do i = 2, nrow ia(i) = k do j=1 , i-1 tmp = nrow*(j-1)-j*(j-1)/2+i-j if (.not.(dabs(x(tmp)) .le. eps)) then ja(k) = j a(k) = x(tmp) k = k + 1 endif enddo enddo ia(nrow+1) = k return c---- end of disttospam ------------------------------------------------- c----------------------------------------------------------------------- end subroutine setdiaold (nrow,ncol,a,ja,ia,c,jc,ic,cmax,diag,eps) implicit none double precision a(*),c(*),diag(*),eps integer nrow, ncol, ia(*), ja(*), ic(*), jc(*), cmax c c this routine sets the diagonal entries of a matix, provided they c are non-zero. c c On entry: c---------- c nrow,ncol -- dimensions of the matrix c a,ja,ia -- input matrix in CSR format c c,jc,ic -- input matrix in CSR format with enough space, see below c diag -- diagonal values to set c eps -- what is smaller than zero? c c On return: c----------- c c,jc,ic -- matrix with modified diag in CSR format c c Notes: c------- c Reinhard Furrer 2006-10-30 c----------------------------------------------------------------------- c c Local double precision b(nrow) integer i,k, len, ib(nrow+1), jb(nrow) c len=0 ib(1)=1 do i=1,nrow jb(i)=0 enddo do 10 i=1,nrow do 15 k= ia(i),ia(i+1) -1 if (ja(k) .eq. i) then a(k)=diag(i) c(k)=diag(i) ib(i+1)=ib(i) goto 10 endif if (ja(k) .gt. i) then if (diag(i).gt.eps) then len=len+1 jb(len)=i ib(i+1)=ib(i)+1 b(len)=diag(i) else ib(i+1)=ib(i) endif goto 10 endif 15 continue 10 continue if (len .eq. 0) return c c set nonexisiting elements. c call subass(nrow,ncol,a,ja,ia,b,jb,ib,c,jc,ic,cmax) return c------------end of setdia---------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c c----------------------------------------------------------------------- subroutine subass(nrow,ncol,a,ja,ia,b,jb,ib,c,jc,ic,nzmax) implicit none integer nrow,ncol,nzmax integer ja(*),jb(*),jc(*),ia(*),ib(*),ic(*) double precision a(*), b(*), c(*) c----------------------------------------------------------------------- c replaces the elements of A with those of B for matrices in sorted CSR c format. we assume that each row is sorted with increasing column c indices. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a,ja,ia, c b,jb,ib = Matrices A and B in compressed sparse row format with column c entries sorted ascendly in each row c c nzmax = integer. The max length of the arrays c and jc. c c on return: c---------- c c,jc,ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c Notes: c------- c Reinhard Furrer 2006-09-13, based on sparsekit2 subroutine aplb1 c----------------------------------------------------------------------- c local variables integer i,j1,j2,ka,kb,kc,kamax,kbmax kc = 1 ic(1) = kc c c looping over the rows: do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c If we have one or more entries then ka <= kamax c If we do not have any entries in both A and B c we will not enter the if clause. In which case c we repeatedly copy ic(i+1) <- ic(i). if (ka .le. kamax .or. kb .le. kbmax) then c j1 and j2 are left hand pointers of the first entry c of A and B. If no entry, they are set to ncol+1 if (ka .le. kamax) then j1 = ja(ka) else j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else j2 = ncol+1 endif c c Three cases: c j1=j2: copy element of b in c, incr. all three pointers c j1j2: copy element of b in c, incr. b and c pointers if (j1 .eq. j2) then c(kc) = b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then jc(kc) = j1 c(kc) = a(ka) ka = ka+1 kc = kc+1 else if (j1 .gt. j2) then jc(kc) = j2 c(kc) = b(kb) kb = kb+1 kc = kc+1 endif C the next four lines should not be required... if (kc .gt. nzmax+1) then c write (*,*) "exceeding array capacities...",i,nzmax, c & ka,kb,kc,j1,j2,kamax,kbmax,ncol,jb(kb) return endif goto 5 endif ic(i+1) = kc 6 continue return c------------end-of-subass---------------------------------------------- c----------------------------------------------------------------------- end subroutine spamcsrdns(nrow,a,ja,ia,dns) implicit none integer i,k integer nrow,ja(*),ia(*) double precision dns(nrow,*),a(*) c----------------------------------------------------------------------- c Compressed Sparse Row to Dense c----------------------------------------------------------------------- c c converts a row-stored sparse matrix into a densely stored one c c On entry: c---------- c c nrow = row-dimension of a c a, c ja, c ia = input matrix in compressed sparse row format. c (a=value array, ja=column array, ia=pointer array) c dns = array where to store dense matrix c c on return: c----------- c dns = the sparse matrix a, ja, ia has been stored in dns(nrow,*) c c changes: c--------- c eliminated the ierr c eliminated the filling of zeros: all done with c----------------------------------------------------------------------- do i=1,nrow do k=ia(i),ia(i+1)-1 dns(i,ja(k)) = a(k) enddo enddo return c---- end of csrdns ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine spamdnscsr(nrow,ncol,dns,ndns,a,ja,ia,eps) implicit none integer i,j,next integer nrow,ncol,ndns,ia(*),ja(*) double precision dns(ndns,*),a(*),eps c----------------------------------------------------------------------- c Converts a densely stored matrix into a CSR sparse matrix. c----------------------------------------------------------------------- c on entry: c--------- c c nrow = row-dimension of a c ncol = column dimension of a c nzmax = maximum number of nonzero elements allowed. This c should be set to be the lengths of the arrays a and ja. c dns = input nrow x ncol (dense) matrix. c ndns = first dimension of dns. c c on return: c---------- c c a, ja, ia = value, column, pointer arrays for output matrix c c changes: c--------- c eliminated the ierr c introduced epsilon c----------------------------------------------------------------------- next = 1 ia(1) = 1 do i=1,nrow do j=1, ncol if (.not.(dabs(dns(i,j)) .le. eps)) then ja(next) = j c write(*,*) next,dns(i,j), eps, i, j a(next) = dns(i,j) next = next+1 endif enddo ia(i+1) = next enddo return c---- end of dnscsr ---------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getmask(nrow,nnz,ir,jc,jao,iao) c----------------------------------------------------------------------- implicit none integer nrow,nnz,ir(*),jc(*),jao(*),iao(*) integer k,k0,j,i,iad c----------------------------------------------------------------------- c Gets Compressed Sparse Row indices from Coordinate ones c----------------------------------------------------------------------- c Loosely based on coocsr from Sparsekit. c c on entry: c--------- c nrow = dimension of the matrix c nnz = number of nonzero elements in matrix c ir, c jc = matrix in coordinate format. ir(k), jc(k) store the nnz c nonzero index. The order of the elements is arbitrary. c iao = vector of 0 of size nrow+1 c c on return: c----------- c ir is destroyed c c jao, iao = matrix index in general sparse matrix format with c jao containing the column indices, c and iao being the pointer to the beginning of the row c c------------------------------------------------------------------------ c determine row-lengths. do 2 k=1, nnz iao(ir(k)) = iao(ir(k))+1 2 continue c starting position of each row.. k = 1 do 3 j=1,nrow+1 k0 = iao(j) iao(j) = k k = k+k0 3 continue c go through the structure once more. Fill in output matrix. do 4 k=1, nnz i = ir(k) j = jc(k) iad = iao(i) jao(iad) = j iao(i) = iad+1 4 continue c shift back iao do 5 j=nrow,1,-1 iao(j+1) = iao(j) 5 continue iao(1) = 1 return c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getblock(a,ja,ia, nrw, rw, ncl, cl, bnz, b,jb,ib) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the elements a(rw,cl) of a matrix a, c for any index vector rw and cl. the matrix is assumed to be stored c in compressed sparse row (csr) format. c c c Reinhard Furrer 2006-09-12 c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c a,ja,ia = the matrix a in compressed sparse row format (input). c nrw,rw c ncl,cl = length of and the vector containing the rows and columns c to extract c c on return: c----------- c bnz = nonzero elements of b c b,jb,ib = the matrix a(rw,cl) in compressed sparse row format. c c note: c------ c no error testing is done. It is assumed that b has enough space c allocated. c----------------------------------------------------------------------- implicit none integer nrw,rw(*), ncl, cl(*) integer bnz, ia(*),ja(*), ib(*),jb(*) double precision a(*),b(*) c c local variables. c integer irw, jcl, jja c c write(*,*) cl(1),cl(2) bnz = 1 ib(1) = 1 do irw = 1,nrw do jcl = 1,ncl do jja = ia(rw(irw)),ia(rw(irw)+1)-1 if (cl(jcl) .eq. ja(jja)) then c we've found one... b(bnz) = a(jja) jb(bnz) = jcl bnz = bnz + 1 endif enddo enddo ib(irw+1) = bnz c end irw, we've cycled over all lines enddo bnz = bnz - 1 c write(*,*) cl(1),cl(2) return c--------end-of-getblock------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getlines(a,ja,ia, nrw, rw, bnz, b,jb,ib) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the lines rw of a matrix a. c the matrix is assumed to be stored c in compressed sparse row (csr) format. c c c Reinhard Furrer 2012-04-04 c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c a,ja,ia = the matrix a in compressed sparse row format (input). c nrw,rw = length of and the vector containing the rows and columns c to extract c c on return: c----------- c bnz = nonzero elements of b c b,jb,ib = the matrix a(rw,cl) in compressed sparse row format. c c note: c------ c no error testing is done. It is assumed that b has enough space c allocated. c----------------------------------------------------------------------- implicit none integer nrw,rw(*) integer bnz, ia(*),ja(*), ib(*),jb(*) double precision a(*),b(*) c c local variables. c integer irw, jja c bnz = 1 ib(1) = 1 do irw = 1,nrw do jja = ia(rw(irw)),ia(rw(irw)+1)-1 b(bnz) = a(jja) jb(bnz) = ja(jja) bnz = bnz + 1 enddo ib(irw+1) = bnz c end irw, we've cycled over all lines enddo bnz = bnz - 1 return c--------end-of-getlines------------------------------------------------ c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine getelem(i,j,a,ja,ia,iadd,elem) c----------------------------------------------------------------------- c purpose: c -------- c this function returns the element a(i,j) of a matrix a, c for any pair (i,j). the matrix is assumed to be stored c in compressed sparse row (csr) format. getelem performs a c binary search. c also returns (in iadd) the address of the element a(i,j) in c arrays a and ja when the search is successsful (zero if not). c----------------------------------------------------------------------- c parameters: c ----------- c on entry: c---------- c i = the row index of the element sought (input). c j = the column index of the element sought (input). c a = the matrix a in compressed sparse row format (input). c ja = the array of column indices (input). c ia = the array of pointers to the rows' data (input). c on return: c----------- c elem = value of a(i,j). c iadd = address of element a(i,j) in arrays a, ja if found, c zero if not found. (output) c c note: the inputs i and j are not checked for validity. c----------------------------------------------------------------------- c noel m. nachtigal october 28, 1990 -- youcef saad jan 20, 1991. c c Reinhard Furrer: converted to subroutine and eliminated sorted c many manipulations... last for 0.31; Sept 13 c----------------------------------------------------------------------- implicit none integer i, ia(*), iadd, j, ja(*) double precision a(*),elem c c local variables. c integer ibeg, iend, imid c c initialization c iadd = 0 ibeg = ia(i) iend = ia(i+1)-1 c empty line! test at beginning 10 if (iend .lt. ibeg) return c c begin binary search: c test of bounds if (ja(ibeg).gt.j) return if (ja(iend).lt.j) return if (ja(ibeg).eq.j) then iadd = ibeg goto 20 endif if (ja(iend).eq.j) then iadd = iend goto 20 endif c compute the middle index and test if found imid = ( ibeg + iend ) / 2 if (ja(imid).eq.j) then iadd = imid goto 20 endif c update the interval bounds. if (ja(imid).gt.j) then iend = imid -1 else ibeg = imid +1 endif goto 10 c c set iadd and elem before returning 20 elem = a(iadd) return c--------end-of-getelem------------------------------------------------- c----------------------------------------------------------------------- end subroutine getallelem(nir,ir,jr,a,ja,ia,alliadd,allelem) c----------------------------------------------------------------------- c purpose: c -------- c wrapper to getelem to retrieve several elements. c----------------------------------------------------------------------- c Reinhard Furrer 2006-09-12 c----------------------------------------------------------------------- implicit none integer nir,ir(nir),jr(nir),ja(*),ia(*),alliadd(nir) double precision a(*),allelem(nir) c local vars integer i do i = 1,nir call getelem(ir(i),jr(i),a,ja,ia,alliadd(i),allelem(i)) enddo return c--------end-of-allgetelem---------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------- c- c- Modified by P. T. Ng from sparsekit c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine aemub (nrow,ncol,a,ja,ia,amask,jmask,imask, * c,jc,ic,iw,aw,nzmax,ierr) c--------------------------------------------------------------------- real(8) a(*),c(*),amask(*),aw(ncol) integer ia(nrow+1),ja(*),jc(*),ic(nrow+1),jmask(*),imask(nrow+1) logical iw(ncol) c----------------------------------------------------------------------- c Modified from amask by Pin T. Ng on 2/27/03 to perform c element-wise multiplication c----------------------------------------------------------------------- c On entry: c--------- c nrow = integer. row dimension of input matrix c ncol = integer. Column dimension of input matrix. c c a, c ja, c ia = the A matrix in Compressed Sparse Row format c c amask, c jmask, c imask = matrix defining mask stored in compressed c sparse row format. (This is the B matrix) c c nzmax = length of arrays c and jc. see ierr. c c On return: c----------- c c a, ja, ia and amask, jmask, imask are unchanged. c c c c jc, c ic = the output matrix in Compressed Sparse Row format. c c ierr = integer. serving as error message.c c ierr = 1 means normal return c ierr .gt. 1 means that amask stopped when processing c row number ierr, because there was not enough space in c c, jc according to the value of nzmax. c c work arrays: c------------- c iw = logical work array of length ncol. c aw = real work array of length ncol. c c note: c------ the algorithm is in place: c, jc, ic can be the same as c a, ja, ia in which cas the code will overwrite the matrix c c on a, ja, ia c c----------------------------------------------------------------------- ierr = 0 len = 0 do 1 j=1, ncol iw(j) = .false. aw(j) = 0.0 1 continue c unpack the mask for row ii in iw do 100 ii=1, nrow c save pointer and value in order to be able to do things in place do 2 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .true. aw(jmask(k)) = amask(k) 2 continue c add umasked elemnts of row ii k1 = ia(ii) k2 = ia(ii+1)-1 ic(ii) = len+1 do 200 k=k1,k2 j = ja(k) if (iw(j)) then len = len+1 if (len .gt. nzmax) then ierr = ii return endif jc(len) = j c(len) = a(k)*aw(j) endif 200 continue c do 3 k=imask(ii), imask(ii+1)-1 iw(jmask(k)) = .false. aw(jmask(k)) = 0.0 3 continue 100 continue ic(nrow+1)=len+1 c return c-----end-of-aemub ----------------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aemub1 (nrow,ncol,a,ja,ia,b,jb,ib,c,jc,ic, * nzmax,ierr) real(8) a(*), b(*), c(*) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1) c----------------------------------------------------------------------- c A modification of aplsb by Pin Ng on 6/12/02 to c perform the element-wise operation C = A*B for matrices in c sorted CSR format. c the difference with aplsb is that the resulting matrix is such that c the elements of each row are sorted with increasing column indices in c each row, provided the original matrices are sorted in the same way. c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c c a, c ja, c ia = Matrix A in compressed sparse row format with entries sorted c c b, c jb, c ib = Matrix B in compressed sparse row format with entries sorted c ascendly in each row c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format c with entries sorted ascendly in each row. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c Notes: c------- c this will not work if any of the two input matrices is not sorted c----------------------------------------------------------------------- ierr = 0 kc = 1 ic(1) = kc c c the following loop does a merge of two sparse rows and c multiplies them. c do 6 i=1, nrow ka = ia(i) kb = ib(i) kamax = ia(i+1)-1 kbmax = ib(i+1)-1 5 continue c c this is a while -- do loop -- c if (ka .le. kamax .or. kb .le. kbmax) then c if (ka .le. kamax) then j1 = ja(ka) else c take j1 large enough that always j2 .lt. j1 j1 = ncol+1 endif if (kb .le. kbmax) then j2 = jb(kb) else c similarly take j2 large enough that always j1 .lt. j2 j2 = ncol+1 endif c c three cases c if (j1 .eq. j2) then c(kc) = a(ka)*b(kb) jc(kc) = j1 ka = ka+1 kb = kb+1 kc = kc+1 else if (j1 .lt. j2) then ka = ka+1 else if (j1 .gt. j2) then kb = kb+1 endif if (kc .gt. nzmax) goto 999 goto 5 c c end while loop c endif ic(i+1) = kc 6 continue return 999 ierr = i return c------------end-of-aemub1 --------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aedib (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,aw,ierr) real(8) a(*), b(*), c(*), aw(ncol) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1), * iw(ncol) c----------------------------------------------------------------------- c performs the element-wise matrix division C = A/B. c Modified from aplsb by Pin Ng on 2/27/03 c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c aw = real work array of length equal to the number of c columns in A. c c----------------------------------------------------------------------- logical values values = (job .ne. 0) ierr = 0 len = 0 ic(1) = 1 do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 len = len+1 jcol = ja(ka) if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = a(ka)/0.0 iw(jcol)= len aw(jcol) = a(ka) 200 continue c do 300 kb=ib(ii),ib(ii+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = 0.0 iw(jcol)= len else if (values) c(jpos) = aw(jcol)/b(kb) endif 300 continue do 301 k=ic(ii), len iw(jc(k)) = 0 301 continue ic(ii+1) = len+1 500 continue return 999 ierr = ii return c------------end of aedib ----------------------------------------------- c----------------------------------------------------------------------- end c----------------------------------------------------------------------- subroutine aeexpb (nrow,ncol,job,a,ja,ia,b,jb,ib, * c,jc,ic,nzmax,iw,aw,ierr) real(8) a(*), b(*), c(*), aw(ncol) integer ja(*),jb(*),jc(*),ia(nrow+1),ib(nrow+1),ic(nrow+1), * iw(ncol) c----------------------------------------------------------------------- c performs the element-wise matrix division C = A/B. c Modified from aplsb by Pin Ng on 2/27/03 c----------------------------------------------------------------------- c on entry: c --------- c nrow = integer. The row dimension of A and B c ncol = integer. The column dimension of A and B. c job = integer. Job indicator. When job = 0, only the structure c (i.e. the arrays jc, ic) is computed and the c real values are ignored. c c a, c ja, c ia = Matrix A in compressed sparse row format. c c b, c jb, c ib = Matrix B in compressed sparse row format. c c nzmax = integer. The length of the arrays c and jc. c amub will stop if the result matrix C has a number c of elements that exceeds exceeds nzmax. See ierr. c c on return: c---------- c c, c jc, c ic = resulting matrix C in compressed sparse row sparse format. c c ierr = integer. serving as error message. c ierr = 0 means normal return, c ierr .gt. 0 means that amub stopped while computing the c i-th row of C with i=ierr, because the number c of elements in C exceeds nzmax. c c work arrays: c------------ c iw = integer work array of length equal to the number of c columns in A. c aw = real work array of length equal to the number of c columns in A. c c----------------------------------------------------------------------- logical values values = (job .ne. 0) ierr = 0 len = 0 ic(1) = 1 do 1 j=1, ncol iw(j) = 0 1 continue c do 500 ii=1, nrow c row i do 200 ka=ia(ii), ia(ii+1)-1 len = len+1 jcol = ja(ka) if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = 1.0 iw(jcol)= len aw(jcol) = a(ka) 200 continue c do 300 kb=ib(ii),ib(ii+1)-1 jcol = jb(kb) jpos = iw(jcol) if (jpos .eq. 0) then len = len+1 if (len .gt. nzmax) goto 999 jc(len) = jcol if (values) c(len) = 0.0**b(kb) iw(jcol)= len else if (values) c(jpos) = aw(jcol)**b(kb) endif 300 continue do 301 k=ic(ii), len iw(jc(k)) = 0 301 continue ic(ii+1) = len+1 500 continue return 999 ierr = ii return c------------end of aeexpb ----------------------------------------------- c----------------------------------------------------------------------- end SUBROUTINE CALCJA(nrow,nsuper, % xsuper,lindx,xlindx,xlnz, % cholcja) c small function to calculate ja for the cholesky factor c as they use a condensed format. GRATULIERU LIT! c INPUT: c nrow (integer) number of rows c nsuper (integer) number of supernodes c xsuper (integer) supernode partition c xlindx,lindx (integer) row indices for each supernode c xlnz (integer) ia for cholesky factor c c OUTPUT: c cholcja (integer) ja for cholesky factor IMPLICIT NONE INTEGER nrow,nsuper INTEGER xsuper(nrow),lindx(*),xlindx(nrow+1),xlnz(nrow+1) INTEGER cholcja(*) INTEGER k, i, j, m, n k=1 m=1 DO i=1,nsuper DO j=1,( xsuper(i+1)-xsuper(i)) DO n=1,(xlnz(k+1)-xlnz(k)) cholcja(m)=lindx( xlindx(i)+j-2 + n) m=m+1 ENDDO k=k+1 ENDDO ENDDO RETURN END subroutine transpose(n,m,a,ja,ia,ao,jao,iao) implicit none integer n,m,ia(n+1),iao(m+1),ja(*),jao(*) double precision a(*),ao(*) integer i,j,k,next c----------------------------------------------------------------------- c Transposition c similar to csrcsc from sparsekit c----------------------------------------------------------------------- c on entry: c---------- c n = number of rows of CSR matrix. c m = number of columns of CSC matrix. c a = real array of length nnz (nnz=number of nonzero elements in input c matrix) containing the nonzero elements. c ja = integer array of length nnz containing the column positions c of the corresponding elements in a. c ia = integer of size n+1. ia(k) contains the position in a, ja of c the beginning of the k-th row. c c on return: c ---------- c ao = real array of size nzz containing the "a" part of the transpose c jao = integer array of size nnz containing the column indices. c iao = integer array of size n+1 containing the "ia" index array of c the transpose. c c----------------------------------------------------------------------- c----------------- compute lengths of rows of transp(A) ---------------- do i=1, n do k=ia(i), ia(i+1)-1 j = ja(k)+1 iao(j) = iao(j)+1 enddo enddo c---------- compute pointers from lengths ------------------------------ iao(1) = 1 do i=1,m iao(i+1) = iao(i) + iao(i+1) enddo c--------------- now do the actual copying ----------------------------- do i=1,n do k=ia(i),ia(i+1)-1 j = ja(k) next = iao(j) ao(next) = a(k) jao(next) = i iao(j) = next+1 enddo enddo c-------------------------- reshift iao and leave ---------------------- do i=m,1,-1 iao(i+1) = iao(i) enddo iao(1) = 1 c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------- subroutine reducedim(a,ja,ia,eps,bnrow,bncol,k,b,jb,ib) implicit none double precision a(*),b(*),eps integer bnrow, bncol,k integer ia(*),ja(*),ib(*),jb(*) integer i, j, jaj c----------------------------------------------------------------------- c Reduces the dimension of A to (,bnrow,bncol) by copying it to B. c (Hence not in place - for R purposes). c Only elements smaller than eps are copied. c----------------------------------------------------------------------- c on entry: c--------- c c------------------------------------------------------------------------ k=1 do i=1,bnrow ib(i)=k do j=ia(i), ia(i+1)-1 jaj=ja(j) if (jaj .le.bncol) then if (abs( a(j)) .gt. eps) then b(k)=a(j) jb(k)=jaj k=k+1 endif endif enddo enddo ib(bnrow+1)=k return c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c Currently not used... subroutine reducediminplace(eps,nrow,ncol,k,a,ja,ia) implicit none double precision a(*),eps integer nrow, ncol,k integer ia(*),ja(*) integer i, j, jj, itmp c----------------------------------------------------------------------- c Reduces the dimension of A to (nrow,ncol) _in place_ c Only elements smaller than eps are copied. c----------------------------------------------------------------------- c Reinhard Furrer, June 2008 c------------------------------------------------------------------------ k=1 do i=1,nrow itmp = ia(i) ia(i)=k do j=itmp, ia(i+1)-1 jj=ja(j) if (jj .le. ncol) then if (abs( a(jj)) .gt. eps) then a(k)=a(jj) ja(k)=jj k=k+1 endif endif enddo enddo ia(nrow+1)=k return c----------------------------------------------------------------------- end c----------------------------------------------------------------------- c----------------------------------------------------------------------c c T R I A N G U L A R S Y S T E M S O L U T I O N S c c c c spamforward and spamback c c----------------------------------------------------------------------c subroutine spamforward (n,p,x,b,l,jl,il) implicit none integer n, p, jl(*),il(n+1) double precision x(n,p), b(n,p), l(*) integer i, k, j double precision t c----------------------------------------------------------------------- c solves L x = y ; L = lower triang. / CSR format c sequential forward elimination c----------------------------------------------------------------------- c c On entry: c---------- c n,p = integer. dimensions of problem. c b = real array containg the right side. c c l, jl, il, = Lower triangular matrix stored in CSR format. c c On return: c----------- c x = The solution of L x = b. c-------------------------------------------------------------------- c Reinhard Furrer June 2008, April 2012 c if first diagonal element is zero, break if (l(1) .eq. 0.0 ) goto 5 c cycle over all columns of b do i=1,p c first row has one element then cycle over all rows x(1,i) = b(1,i) / l(1) do 3 k = 2, n t = b(k,i) do 1 j = il(k), il(k+1)-1 if (jl(j) .lt. k) then t = t-l(j)*x(jl(j),i) else if (jl(j) .eq. k) then if (l(j) .eq. 0.0) goto 5 c diagonal element is not zero, hence we divide and leave the loop x(k,i) = t / l(j) goto 3 endif endif 1 continue 3 continue enddo return 5 n = -k return end c----------------------------------------------------------------------- subroutine spamback (n,p,x,b,r,jr,ir) implicit none integer n, p, jr(*),ir(n+1) double precision x(n,p), b(n,p), r(*) integer l, k, j double precision t c----------------------------------------------------------------------- c Solves R x = b R = upper triangular. c----------------------------------------------------------------------- c c On entry: c---------- c n,p = integers. dimension of problem. c b = real array containg the right side. c c r, jr, ir, = Upper triangular matrix stored in CSR format. c c On return: c----------- c x = The solution of R x = b . c-------------------------------------------------------------------- c Reinhard Furrer June 2008, April 2012 if (r(ir(n+1)-1) .eq. 0.0 ) goto 5 do l=1,p x(n,l) = b(n,l) / r(ir(n+1)-1) do 3 k = n-1,1,-1 t = b(k,l) do 1 j = ir(k+1)-1,ir(k),-1 if (jr(j) .gt. k) then t = t - r(j)*x(jr(j),l) else if (jr(j) .eq. k) then if (r(j) .eq. 0.0) goto 5 c diagonal element is not zero, hence we divide and leave the loop x(k,l) = t / r(j) goto 3 endif endif 1 continue 3 continue enddo return 5 n = -k return end c----------------------------------------------------------------------- RandomFieldsUtils/src/Options_utils.h0000644000175100001440000000502513074063617017504 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef rfutils_options_H #define rfutils_options_H 1 #include #include #include "Basic_utils.h" #include "Solve.h" #define R_PRINTLEVEL 1 #define C_PRINTLEVEL 1 extern int PL; #define LEN_OPTIONNAME 201 #define basicN 7 // IMPORTANT: all names of basic must be at least 3 letters long !!! extern const char *basic[basicN]; typedef struct basic_param { bool skipchecks, asList; int Rprintlevel, Cprintlevel, seed, cores; } basic_param; #define basic_START \ { false, true, \ R_PRINTLEVEL, C_PRINTLEVEL, NA_INTEGER, 1 \ } #define nr_InversionMethods ((int) Diagonal + 1) #define nr_user_InversionMethods ((int) NoInversionMethod + 1) extern const char * InversionNames[nr_InversionMethods]; #define PIVOT_NONE 0 #define PIVOT_MMD 1 #define PIVOT_RCM 2 #define SOLVE_SVD_TOL 3 #define solveN 12 typedef struct solve_param { usr_bool sparse; double spam_tol, spam_min_p, svd_tol, eigen2zero; InversionMethod Methods[SOLVE_METHODS]; int spam_min_n, spam_sample_n, spam_factor, pivot, max_chol, max_svd; // bool tmp_delete; } solve_param; #ifdef SCHLATHERS_MACHINE #define svd_tol_start 1e-08 #else #define svd_tol_start 0 #endif #define solve_START \ { Nan, DBL_EPSILON, 0.8, svd_tol_start, 1e-12, \ {NoInversionMethod, NoInversionMethod}, \ 400, 500, 4294967, PIVOT_MMD, 16384, 10000} extern const char * solve[solveN]; typedef struct utilsparam{ basic_param basic; solve_param solve; } utilsparam; typedef void (*setparameterfct) (int, int, SEXP, char[200], bool); typedef void (*getparameterfct) (SEXP*); typedef void (*finalsetparameterfct) (); #define ADD(ELT) SET_VECTOR_ELT(sublist[i], k++, ELT); #define ADDCHAR(ELT) x[0] = ELT; ADD(ScalarString(mkChar(x))); #endif RandomFieldsUtils/src/Basic_utils.h0000644000175100001440000001051113074063617017066 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 Martin Schlather This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #ifndef basic_rfutils_h #define basic_rfutils_h 1 #ifndef __cplusplus #include #endif #include #include #ifdef _OPENMP #define DO_PARALLEL 1 #else #ifdef DO_PARALLEL #undef DO_PARALLEL #endif #endif #define MULTIMINSIZE(S) ((S) > 20) // #define MULTIMINSIZE(S) false // #define MULTIMINSIZE(S) true #ifndef showfree #define showfree !true #endif #define DOPRINT true // // 1 // // 1 // // 1 #ifdef __cplusplus extern "C" { #endif // Fortran Code by Reinhard Furrer void spamcsrdns_(int*, double *, int *, int*, double*); void spamdnscsr_(int*, int*, double *, int*, double*, int*, int*, double*); void cholstepwise_(int*, int*, double*, int*, int*, int*, int*, int*, int*, int*, int*, int*, int*, int*, double*, int*, int*, int*, int*, int*); void backsolves_(int*, int*, int*, int*, int*, double*, int*, int*, int*, int*, double*, double*); void calcja_(int*, int*, int*, int*, int*, int*, int*); void amuxmat_(int*, int*, int*, double*, double*, double*, int*, int*); // void transpose_(int *, int *, double *, int * int *, double*, int*, int*); // void spamback_(); // void spamforward(); #ifdef __cplusplus } #endif typedef enum usr_bool { // NOTE: if more options are included, change ExtendedBoolean in // userinterface.cc of RandomFields False=false, True=true, //Exception=2, // for internal use only Nan=INT_MIN } usr_bool; #define RF_NA NA_REAL #define RF_NAN R_NaN #define RF_NEGINF R_NegInf #define RF_INF R_PosInf #define T_PI M_2_PI #define MAXUNITS 4 #define MAXCHAR 18 // max number of characters for (covariance) names #define OBSOLETENAME "obsolete" #define RFOPTIONS "RFoptions" #define MAXINT 2147483647 #define INFDIM MAXINT #define INFTY INFDIM #define LENGTH length // safety, in order not to use LENGTH defined by R #define complex Rcomplex #define DOT "." #define GAUSS_RANDOM(SIGMA) rnorm(0.0, SIGMA) #define UNIFORM_RANDOM unif_rand() #define POISSON_RANDOM(x) rpois(x) #define SQRT2 M_SQRT2 #define SQRTPI M_SQRT_PI #define INVPI M_1_PI #define PIHALF M_PI_2 #define ONETHIRD 0.333333333333333333333333 #define TWOTHIRD 0.6666666666666666666666667 #define TWOPI 6.283185307179586476925286766559 #define INVLOG2 1.442695040888963 #define INVSQRTTWO 0.70710678118654752440084436210 #define INVSQRTTWOPI 0.39894228040143270286 #define SQRTTWOPI 2.5066282746310002416 #define SQRTINVLOG005 0.5777613700268771079749 //#define LOG05 -0.69314718055994528623 #define LOG3 1.0986122886681096913952452369225257046474905578227 #define LOG2 M_LN2 #define EPSILON 0.00000000001 #define EPSILON1000 0.000000001 #define MIN(A,B) ((A) < (B) ? (A) : (B)) #define MAX(A,B) ((A) > (B) ? (A) : (B)) #define ACOS(X) std::acos(X) #define ASIN(X) std::asin(X) #define ATAN(X) std::atan(X) #define CEIL(X) std::ceil((double) X) // keine Klammern um X! #define COS(X) std::cos(X) #define EXP(X) std::exp(X) #define FABS(X) std::fabs((double) X) // keine Klammern um X! #define FLOOR(X) std::floor(X) #define Log(X) std::log(X) #define POW(X, Y) R_pow((double) X, (double) Y) // keine Klammern um X! #define SIN(X) std::sin(X) #define SQRT(X) std::sqrt((double) X) #define STRCMP(A, B) std::strcmp(A, B) #define STRCPY(A, B) std::strcpy(A, B) #define STRLEN(X) std::strlen(X) #define STRNCMP(A, B, C) std::strncmp(A, B, C) #define TAN(X) std::tan(X) #define MEMCOPYX std::memcpy #define CALLOCX std::calloc #define MALLOCX std::malloc #define FREEX std::free #define SPRINTF std::sprintf // #define ROUND(X) std::round(X) #define TRUNC(X) ftrunc((double) X) // keine Klammern um X! #define QSORT std::qsort #endif RandomFieldsUtils/src/init_RandomFieldsUtils.c0000644000175100001440000000712413074063617021241 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 -- 2017 Martin Schlather, Reinhard Furrer This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ //#include "Basic_utils.h" // must be before anything else #include "RandomFieldsUtils.h" #include "init_RandomFieldsUtils.h" static R_NativePrimitiveArgType Relax_t[] = { LGLSXP }, int_arg[] = { INTSXP }, host_arg[] = { STRSXP, INTSXP}; // static R_NativeArgStyle argin[] = {R_ARG_IN}, // argout[] = {R_ARG_OUT}, // hostarg[] = {R_ARG_OUT, R_ARG_OUT}; static const R_CMethodDef cMethods[] = { {"RelaxUnknownRFoption", (DL_FUNC) &RelaxUnknownRFoption, 1, Relax_t}, {"sleepMilli", (DL_FUNC) &sleepMilli, 1, int_arg}, {"sleepMicro", (DL_FUNC) &sleepMicro, 1, int_arg}, {"pid", (DL_FUNC) &pid, 1, int_arg}, {"hostname", (DL_FUNC) &hostname, 2, host_arg}, // {"attachRFoptionsUtils", (DL_FUNC) &attachRFoptionsUtils, 0, NULL, NULL}, // {"detachRFoptionsUtils", (DL_FUNC) &detachRFoptionsUtils, 0, NULL, NULL}, {NULL, NULL, 0, NULL} }; #define CALLDEF_DO(name, n) {#name, (DL_FUNC) &name, n} static R_CallMethodDef callMethods[] = { // in die respectiven C-Dateien muss RandomFieldsUtils.h eingebunden sein CALLDEF_DO(Chol, 1), CALLDEF_DO(SolvePosDef, 3), CALLDEF_DO(struve, 4), CALLDEF_DO(I0ML0, 1), CALLDEF_DO(gaussr, 2), CALLDEF_DO(WMr, 4), CALLDEF_DO(logWMr, 4), CALLDEF_DO(attachRFoptionsUtils, 0), CALLDEF_DO(detachRFoptionsUtils, 0), CALLDEF_DO(sortX, 4), CALLDEF_DO(orderX, 4), CALLDEF_DO(getChar, 0), #ifdef SCHLATHERS_MACHINE CALLDEF_DO(scalarX, 3), CALLDEF_DO(brdomain, 4), CALLDEF_DO(Udiffusion, 14), #endif // CALLDEF_DO(), {NULL, NULL, 0} }; #define EXTDEF_DO(name, n) {#name, (DL_FUNC) &name, n} static const R_ExternalMethodDef extMethods[] = { // in die respectiven C-Dateien muss RandomFieldsUtils.h eingebunden sein EXTDEF_DO(RFoptions, -1), {NULL, NULL, 0} }; #define CALLABLE(FCTN) R_RegisterCCallable("RandomFieldsUtils", #FCTN, (DL_FUNC) FCTN) void R_init_RandomFieldsUtils(DllInfo *dll) { CALLABLE(solve_DELETE); CALLABLE(solve_NULL); CALLABLE(solvePosDef); CALLABLE(invertMatrix); CALLABLE(sqrtPosDef); CALLABLE(sqrtPosDefFree); CALLABLE(sqrtRHS); CALLABLE(StruveH); CALLABLE(StruveL); CALLABLE(I0mL0); CALLABLE(WM); CALLABLE(DWM); CALLABLE(DDWM); CALLABLE(D3WM); CALLABLE(D4WM); CALLABLE(logWM); CALLABLE(Gauss); CALLABLE(DGauss); CALLABLE(DDGauss); CALLABLE(D3Gauss); CALLABLE(D4Gauss); CALLABLE(logGauss); CALLABLE(getErrorString); CALLABLE(setErrorLoc); CALLABLE(getUtilsParam); CALLABLE(attachRFoptions); CALLABLE(detachRFoptions); CALLABLE(relaxUnknownRFoption); CALLABLE(ordering); CALLABLE(orderingInt); CALLABLE(sorting); CALLABLE(sortingInt); R_registerRoutines(dll, cMethods, callMethods, NULL, // .Fortran extMethods); R_useDynamicSymbols(dll, FALSE); } void R_unload_RandomFieldsUtils(DllInfo *info) { /* Release resources. */ } RandomFieldsUtils/src/utils.cc0000644000175100001440000000405213074063617016126 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Collection of system specific auxiliary functions Copyright (C) 2001 -- 2015 Martin Schlather, This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 PURSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include #include #include "RandomFieldsUtils.h" #include "win_linux_aux.h" #include "General_utils.h" SEXP getChar() { ERR("does not work"); #ifdef WIN32 ERR("input limitations on windows"); #endif #define maxGetChar 255 //typedef char intchar[sizeof(int) / sizeof(char)]; //typedef char intchar[sizeof(int) / sizeof(char)]; SEXP str; int //g, i = -1; char // c, *t = NULL, *s = NULL ; s = (char*) MALLOC(sizeof(char) * maxGetChar); // initscr(); // fflush(stdin); // nocbreak(); while (++i < maxGetChar) { // g = getchar(); //s[i] = ((intchar*) &g)[0][0]; // g = scanf("%c\n", s); s[1] = '\0'; break; //t = fgets(s, 2, stdin); break; // s[i] = getch(); //fflush(stdin); if (false) { s[i+1] = '\0'; // printf("%d i=%d '%c' '%c' '%c' '%c' '%c'\n", g, i, s[i], // ((intchar*) &g)[0][0], // ((intchar*) &g)[0][1], // ((intchar*) &g)[0][2], // ((intchar*) &g)[0][3] // ); } if (s[i] == '\n') { s[i] = '\0'; break; } } //endwin(); //printf(">%s<\n", s); PROTECT(str=allocVector(STRSXP, 1)); SET_STRING_ELT(str, 0, mkChar(s)); UNPROTECT(1); FREE(s); return str; } RandomFieldsUtils/src/scalar.cc0000644000175100001440000002266313074063617016243 0ustar hornikusers /* Authors Martin Schlather, schlather@math.uni-mannheim.de Collection of system specific auxiliary functions Copyright (C) 2001 -- 2015 Martin Schlather, This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 PURSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ /* Makefile must be: PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) -march=native -mssse3 PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -march=native -mssse3 */ #define SIMD_AVAILABLE 1 #include "RandomFieldsUtils.h" #include "General_utils.h" #ifdef XXXSCHLATHERS_MACHINE #ifdef SIMD_AVAILABLE #include #endif #include "kleinkram.h" #define Nmodi 9 name_type modi = { "1x1", "2x2", "4x4", "8x8", "near", "simple", "precise", "kahan", "1x1p"}; typedef unsigned int uint32; #define size 8 #define vectorlen (256 / (size * 8)) #define repet 8 #define VECTOR _mm256_loadu_pd #define SET_0(NR) sum##NR = _mm256_setzero_pd() #define P_0(NR) prod##NR = _mm256_setzero_pd() #define SUMUP(NR, nr) sum##NR = _mm256_add_pd(sum##NR, sum##nr) #define ADDF(NR) \ sum##NR = _mm256_fmadd_pd(VECTOR(x + i + NR * vectorlen),\ VECTOR(y + i + NR * vectorlen), sum##NR) #define ADDN(NR) \ prod##NR = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \ VECTOR(y + i + NR * vectorlen)); \ sum##NR = _mm256_add_pd(sum##NR, prod##NR) #ifdef SIMD_AVAILABLE #ifdef FMA_AVAILABLE double avx_scalarproductDfma(double * x, double * y, int len) { int i = 0, lenM = len - (repet * vectorlen - 1); __m256d SET_0(0); double *D = (double *) &sum0; if ( len >= vectorlen * repet) { __m256d SET_0(1), SET_0(2), SET_0(3), SET_0(4), SET_0(5), SET_0(6),SET_0(7); #if (7 != repet - 1) wrong repet length #endif for (; i < lenM; i += repet * vectorlen) { ADDF(0); ADDF(1); ADDF(2); ADDF(3); ADDF(4); ADDF(5); ADDF(6); ADDF(7); #if (7 != repet - 1) wrong repet length #endif } SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7); SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4); #if (7 != repet - 1) wrong repet length #endif } lenM = len - vectorlen + 1; for (; i < lenM; i += vectorlen) { // could unroll further ADDF(0); } double sum = D[0] + D[1] + D[2] + D[3]; #if (3 != vectorlen - 1) wrong vector length #endif for (; i < len; ++i) sum += x[i] * y[i]; return sum; } #endif double avx_scalarproductDnearfma(double * x, double * y, int len) { // deutlich genauer zum 0 tarif int i = 0, lenM = len - (repet * vectorlen - 1); __m256d SET_0(0), SET_0(1), SET_0(2), SET_0(3), SET_0(4), SET_0(5), SET_0(6),SET_0(7), P_0(0), P_0(1), P_0(2), P_0(3), P_0(4), P_0(5), P_0(6),P_0(7); double *D = (double *) &sum0; if ( len >= vectorlen * repet) { for (; i < lenM; i += repet*vectorlen) { // ADDN(0); ADDN(1); ADDN(2); ADDN(3); ADDN(4); ADDN(5); ADDN(6); ADDN(7); #if (7 != repet - 1) wrong repet length #endif } SUMUP(0, 1); SUMUP(2, 3); SUMUP(4, 5); SUMUP(6, 7); SUMUP(0, 2); SUMUP(4, 6); SUMUP(0, 4); // SUMUP(0, 1); SUMUP(0, 2); SUMUP(0, 3); SUMUP(0, 4); SUMUP(0, 5); SUMUP(0, 6); SUMUP(0, 7); #if (7 != repet - 1) wrong repet length #endif } lenM = len - vectorlen + 1; for (; i < lenM; i += vectorlen) { // could unroll further ADDN(0); } double sum = D[0] + D[1] + D[2] + D[3]; #if (3 != vectorlen - 1) wrong vector length #endif for (; i < len; ++i) sum += x[i] * y[i]; return sum; } #define ADD(NR) \ prod0 = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \ VECTOR(y + i + NR * vectorlen)); \ sum0 = _mm256_add_pd(sum0, prod0) double avx_scalarproductD(double * x, double * y, int len) { int i = 0, lenM = len - (repet * vectorlen - 1); __m256d SET_0(0), P_0(0); double *D = (double *) &sum0; if ( len >= vectorlen * repet) { for (; i < lenM; i += repet*vectorlen) { // ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7); #if (7 != repet - 1) wrong repet length #endif } } lenM = len - vectorlen + 1; for (; i < lenM; i += vectorlen) { // could unroll further ADD(0); } double sum = D[0] + D[1] + D[2] + D[3]; #if (3 != vectorlen - 1) wrong vector length #endif for (; i < len; ++i) sum += x[i] * y[i]; return sum; } double avx_scalarproductDP(double * x, double * y, int len) { int i = 0, lenM = len - (repet * vectorlen - 1); __m256d SET_0(0), SET_0(1), P_0(0); double *D = (double *) &sum1; if ( len >= vectorlen * repet) { for (; i < lenM; ) { int lenMM = i + vectorlen * (repet * 10 + 1); if (lenMM > lenM) lenMM = lenM; sum0 = _mm256_mul_pd(VECTOR(x + i), VECTOR(y + i)); i += vectorlen; for (; i < lenMM; i += repet*vectorlen) { ADD(0); ADD(1); ADD(2); ADD(3); ADD(4); ADD(5); ADD(6); ADD(7); #if (7 != repet - 1) wrong repet length #endif } sum1 = _mm256_add_pd(sum0, sum1); } } lenM = len - vectorlen + 1; for (; i < lenM; i += vectorlen) { // could unroll further prod0 = _mm256_mul_pd(VECTOR(x + i), VECTOR(y + i)); sum1 = _mm256_add_pd(sum1, prod0); } double sum = D[0] + D[1] + D[2] + D[3]; #if (3 != vectorlen - 1) wrong vector length #endif for (; i < len; ++i) { // printf("final %d\n", i); sum += x[i] * y[i]; } return sum; } #define ADDK(NR) \ prod0 = _mm256_mul_pd(VECTOR(x + i + NR * vectorlen), \ VECTOR(y + i + NR * vectorlen)); \ sum2 = _mm256_sub_pd(prod0, sum1);\ sum3 = _mm256_add_pd(sum0, sum2); \ sum1 = _mm256_sub_pd(sum3, sum0); \ sum0 = sum3; \ sum1 = _mm256_sub_pd(sum1, sum2); double avx_scalarproductDK(double * x, double * y, int len) { // Kahan enhanced int i = 0, lenM = len - (repet * vectorlen - 1); __m256d SET_0(0), // sum SET_0(1), // c SET_0(2), // y SET_0(3), // t P_0(0), P_0(1); double *D = (double *) &sum0; if ( len >= vectorlen * repet) { for (; i < lenM; i += repet*vectorlen) { // ADDK(0); ADDK(1); ADDK(2); ADDK(3); ADDK(4); ADDK(5); ADDK(6); ADDK(7); #if (7 != repet - 1) wrong repet length #endif } } lenM = len - vectorlen + 1; for (; i < lenM; i += vectorlen) { // could unroll further ADDK(0); } sum0 = _mm256_add_pd(sum0, prod1); double sum = D[0] + D[1] + D[2] + D[3]; #if (3 != vectorlen - 1) wrong vector length #endif for (; i < len; ++i) sum += x[i] * y[i]; return sum; } // end if simd #endif double scalarproductf64( double * v1, double * v2, int N){ double *endv1 = v1 + N, sum = 0; for(; v1!= endv1; v1++, v2++) sum+= v2[0] * v1[0]; return sum; } double scalarproductf64P( double * v1, double * v2, int N){ double //*endv1 = v1 + N, sum = 0; #ifdef DO_PARALLEL #pragma omp parallel for reduction(+:sum) #else ERR("parallel not allowed"); #endif for(int i=0; i<=N; i++) sum += v2[i] * v1[i]; return sum; } double scalarproduct2by2f64( double * v1, double * v2, int N){ double *endv1 = v1 + N, sum = 0; for(; v1!= endv1; v1+=2, v2+=2) { sum+= v2[0] * v1[0] + v2[1] * v1[1]; } return sum; } double scalarproduct4by4f64( double * v1, double * v2, int N){ double*endv1 = v1 + N, sum = 0; for(; v1 < endv1; v1+=4, v2+=4) { sum+= v2[0] * v1[0] + v2[1] * v1[1] + v2[2] * v1[2]+ v2[3] * v1[3]; } return sum; } double scalarproduct8by8f64( double * v1, double * v2, int N){ double *endv1 = v1 + N, sum = 0; for(; v1!= endv1; v1+=8, v2+=8) { sum+= v2[0] * v1[0] + v2[1] * v1[1]+ v2[2] * v1[2] + v2[3] * v1[3] + v2[4] * v1[4] + v2[5] * v1[5]+ v2[6] * v1[6]+ v2[7] * v1[7]; } return sum; } SEXP scalarX(SEXP x, SEXP y, SEXP mode) { int len = length(x); if (length(y) != len) ERR("x and y differ in length"); int n = Match((char*) CHAR(STRING_ELT(mode, 0)), modi, Nmodi); if (n < 0) ERR("unknown modus"); SEXP Ans; PROTECT(Ans = allocVector(REALSXP, 1)); double *ans = REAL(Ans); switch(n) { case 0 : *ans = scalarproductf64(REAL(x), REAL(y), len); break; case 1 : *ans = scalarproduct2by2f64(REAL(x), REAL(y), len); break; case 2 : *ans = scalarproduct4by4f64(REAL(x), REAL(y), len); break; case 3 : *ans = scalarproduct8by8f64(REAL(x), REAL(y), len); break; case 4 : #ifdef SIMD_AVAILABLE *ans = avx_scalarproductDnearfma(REAL(x), REAL(y), len); break; #else BUG; #endif case 5 : #ifdef SIMD_AVAILABLE *ans = avx_scalarproductD(REAL(x), REAL(y), len); break; #else BUG; #endif case 6 : #ifdef SIMD_AVAILABLE *ans = avx_scalarproductDP(REAL(x), REAL(y), len); break; #else BUG; #endif case 7 : #ifdef SIMD_AVAILABLE *ans = avx_scalarproductDK(REAL(x), REAL(y), len); break; #else BUG; #endif case 8 : *ans = scalarproductf64P(REAL(x), REAL(y), len); break; default : BUG; } UNPROTECT(1); return Ans; } #else SEXP scalarX(SEXP VARIABLE_IS_NOT_USED x, SEXP VARIABLE_IS_NOT_USED y, SEXP VARIABLE_IS_NOT_USED mode) { BUG; } #endif // SCHLATHERS_MACHINE RandomFieldsUtils/src/diffusion.cc0000644000175100001440000000520613074063617016756 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer, Martin Kroll This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "Basic_utils.h" // must be before anything else #ifdef DO_PARALLEL #include #endif #include #include #include "RandomFieldsUtils.h" #include "own.h" #include "init_RandomFieldsUtils.h" #include "kleinkram.h" SEXP Udiffusion(SEXP SUSc, SEXP SUCo, SEXP Snevertried, SEXP Sa, SEXP Sabar, SEXP StWeight, SEXP Sq, SEXP Sdt, SEXP Srho, SEXP SrandSc, SEXP SrandCo, SEXP Sit, SEXP Sdummy, SEXP Sthreshold) { #define r_per_step 2 int *nevertried = INTEGER(Snevertried), repN = length(SUSc), N = nrows(Snevertried), rep = ncols(Snevertried), it = INTEGER(Sit)[0] ; double *USc = REAL(SUSc), *UCo = REAL(SUCo), *a = REAL(Sa), *abar = REAL(Sabar), *tWeight = REAL(StWeight), *q = REAL(Sq), dt = REAL(Sdt)[0], *randSc = REAL(SrandSc) + it * repN, *randCo = REAL(SrandCo) + it * repN, *dummy = REAL(Sdummy), rho = REAL(Srho)[0], threshold = REAL(Sthreshold)[0] ; SEXP Ans; PROTECT(Ans = allocVector(INTSXP, rep)); int *dN = INTEGER(Ans); GetRNGstate(); #ifdef DO_PARALLEL #pragma omp parallel for #endif for (int r=0; r= threshold) { never[i] = false; deltaN++; } } dN[r] = deltaN; } PutRNGstate(); UNPROTECT(1); return(Ans); } RandomFieldsUtils/src/solve.cc0000644000175100001440000012334513074063617016125 0ustar hornikusers/* Authors Martin Schlather, schlather@math.uni-mannheim.de Copyright (C) 2015 -- Martin Schlather, Reinhard Furrer, Martin Kroll This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "Basic_utils.h" // must be before anything else #ifdef DO_PARALLEL #include #endif #include #include "RandomFieldsUtils.h" #include "own.h" #include "init_RandomFieldsUtils.h" #include "General_utils.h" const char * InversionNames[nr_InversionMethods] = { "cholesky", "svd", "eigen", "sparse", "method undefined", "qr", "lu", "no method left", "direct formula", "diagonal"}; // double *A_= A, *B_= B; // i_ = N, #define CMALLOC(WHICH, N, TYPE) { \ int _N_ = N; \ if (pt->WHICH##_n < _N_) { \ if (pt->WHICH##_n < 0) BUG; \ FREE(pt->WHICH); \ pt->WHICH##_n = _N_; \ if ((pt->WHICH = (TYPE *) CALLOC(_N_, sizeof(TYPE))) == NULL) \ return ERRORMEMORYALLOCATION; \ } else { \ assert( (_N_ > 0 && pt->WHICH != NULL) || _N_ == 0); \ for (int iii=0; iii<_N_; pt->WHICH[iii++] = 0); \ } \ } \ TYPE VARIABLE_IS_NOT_USED *WHICH = pt->WHICH // sqrtPosDef nutzt pt->U fuer das Ergebnis #define FREEING(WHICH) \ assert(int VARIABLE_IS_UNUSED *_i = WHICH); \ if (pt->WHICH != NULL && pt->WHICH != result) { \ UNCONDFREE(pt->WHICH); \ pt->WHICH##_n = 0; \ } #define FREEING_INT(WHICH) \ assert(int VARIABLE_IS_UNUSED *_i = WHICH); \ if (pt->WHICH != NULL) { \ UNCONDFREE(pt->WHICH); \ pt->WHICH##_n = 0; \ } void solve_DELETE0(solve_storage *x) { FREE(x->iwork); FREE(x->ipiv); FREE(x->pivot); FREE(x->xlnz); FREE(x->snode); FREE(x->xsuper); FREE(x->xlindx); FREE(x->invp); FREE(x->cols); FREE(x->rows); FREE(x->lindx); FREE(x->xja); // FREE(x->); // double * FREE(x->SICH); FREE(x->MM); FREE(x->workspaceD); FREE(x->workspaceU); FREE(x->VT); FREE(x->work); FREE(x->w2); FREE(x->U); FREE(x->D); FREE(x->workLU); FREE(x->lnz); FREE(x->DD); FREE(x->w3); FREE(x->result); FREE(x->to_be_deleted); } void solve_DELETE(solve_storage **S) { solve_storage *x = *S; if (x!=NULL) { solve_DELETE0(*S); UNCONDFREE(*S); } } void solve_NULL(solve_storage* x) { if (x == NULL) return; x->iwork_n = x->ipiv_n = x->pivot_n = x->xlnz_n = x->snode_n = x->xsuper_n = x->xlindx_n = x->invp_n = x->cols_n = x->rows_n =x->lindx_n = x->xja_n = // x->SICH_n = x->MM_n = x->workspaceD_n = x->workspaceU_n = x->VT_n = x->work_n = x->w2_n = x->U_n = x->D_n = x->workLU_n = x->lnz_n = x->DD_n = x->w3_n = x->result_n = 0; x->nsuper = x->nnzlindx = x->size = -1; x->method = NoInversionMethod; for (int i=0; inewMethods[i++] = NoInversionMethod); x->iwork = x->ipiv = x->pivot = x->xlnz = x->snode = x->xsuper = x->xlindx = x->invp = x->cols = x->rows = x->lindx = x->xja = NULL; x->SICH = x->MM = x->workspaceD = x->workspaceU = x->VT = x->work = x->w2 = x->U = x->D = x->workLU = x->lnz = x->DD = x->w3 = x->result = x->to_be_deleted = NULL; } int solve3(double *M, int size, bool posdef, double *rhs, int rhs_cols, double *result, double *logdet ){ assert(size <= 3); if (size <= 0) SERR("matrix in 'solvePosDef' of non-positive size."); double det; switch(size){ // Abfrage nach Groesse der Matrix M + Berechnung der Determinante per Hand case 1: det = M[0]; break; case 2: det = M[0] * M[3] - M[1] * M[2]; break; case 3: det = M[0] * (M[4] * M[8] - M[5] * M[7]) - M[1] * (M[3] * M[8] - M[5] * M[6]) + M[2] * (M[3] * M[7] - M[4] * M[6]); // Entwicklung nach 1. Spalte break; default : BUG; break; } if (det == 0 || (posdef && det < 0)) return ERRORFAILED; if (logdet != NULL) *logdet = Log(det); double detinv = 1.0 / det; // determinant of inverse of M switch(size){ case 1 : {// size of matrix == 1 if (rhs_cols == 0) result[0] = detinv; else for (int i=0; i 0 ? rhs : M; //printf("%ld %ld %ld\ %ldn", RESULT, result, rhs, M); BUG; if (size <= 3) { if (Pt != NULL) { Pt->method = direct_formula; Pt->size = size; } return sqrtOnly ? chol3(M, size, RESULT) : solve3(M, size, posdef, rhs, rhs_cols, RESULT, logdet); } assert(SOLVE_METHODS >= 2); solve_param *sp = Sp == NULL ? &(GLOBAL.solve) : Sp; solve_storage *pt; if (Pt != NULL) { pt = Pt; } else { pt = (solve_storage*) MALLOC(sizeof(solve_storage)); solve_NULL(pt); } int err = NOERROR, spam_zaehler = 0, nnzA = 0, sizeSq = size * size, sizeP1 = size + 1; usr_bool sparse = sp->sparse; double spam_tol = sp->spam_tol; bool diag = false; pt->method = NoFurtherInversionMethod; pt->size = size; if (sparse == Nan && (sparse = (usr_bool) (size > sp->spam_min_n))) { double mean_diag = 0.0; for (int i=0; i= sp->spam_sample_n * 3; if (random_sample) { double thr = sp->spam_sample_n * (1.0 - sp->spam_min_p); int threshold = (int) (thr + SQRT(thr) * 3), notZero = 0; for (int i=0; ispam_sample_n; i++) { if ((notZero += FABS(M[(i * sp->spam_factor) % sizeSq]) > spam_tol) >= threshold){ sparse = False; break; } } if (PL >= PL_FCTN_DETAILS) PRINTF("random sampling: sparse=%d\n", sparse == Nan ? NA_INTEGER : (int) sparse); } if (!random_sample || sparse == True) { int diag_nnzA = 0; //#ifdef DO_PARALLEL //#pragma omp parallel for schedule(dynamic) reduction(+:nnzA,diag_nnzA) //#endif for (int i=0; i= spam_tol); diag_nnzA += FABS(M[j++]) > spam_tol; end = (i+1) * size; if (!posdef) for (; j= spam_tol; } diag = (nnzA == 0); if (posdef) nnzA *= 2; nnzA += diag_nnzA; sparse = (usr_bool) (nnzA <= sizeSq * (1.0 - sp->spam_min_p)); spam_zaehler = nnzA + 1; if (PL >= PL_DETAILSUSER) { if (diag) PRINTF("diagonal matrix detected\n"); else if (sparse == True) PRINTF("sparse matrix detected (%3.2f%% zeros)\n", 100.0 * (1.0 - nnzA / (double) sizeSq)); else PRINTF("full matrix detected (%3.2f%% nonzeros)\n", 100.0 * nnzA / (double) sizeSq); } } } else { diag = true; for (int i=0; i spam_tol) { diag = false; break; } } if (!diag) break; j++; end = (i+1) * size; if (!posdef) { for (; jmethod = Diagonal; if (PL>=PL_STRUCTURE) PRINTF("dealing with diagonal matrix\n"); if (logdet != NULL) { double tmp = 0.0; for (int i=0; i 0.0 ? SQRT(M[i]) : 0.0; } } else for (int i=0; iMethods[0] == NoFurtherInversionMethod || sp->Methods[0] == NoInversionMethod) { Meth = pt->newMethods; if (sparse == True) { Meth[0] = Sparse; bool given0 = sp->Methods[0] != NoFurtherInversionMethod && sp->Methods[0] != NoInversionMethod; Meth[1] = given0 && sp->Methods[0] != Sparse ? sp->Methods[0] : posdef ? Cholesky : LU; if (SOLVE_METHODS > 2) { bool given1 = sp->Methods[1] != NoFurtherInversionMethod && sp->Methods[1] != NoInversionMethod; Meth[2] = given0 && sp->Methods[0] != Sparse && given1 && sp->Methods[1] != Sparse ? sp->Methods[1] : posdef ? Eigen : LU; } // pt->newMethods[1] = Sparse; } else { Meth[0] = posdef ? Cholesky : LU; Meth[1] = posdef ? Eigen : LU; if (SOLVE_METHODS > 2) Meth[2] = Eigen; } for (int i=3; iMethods; if (!posdef && Meth[0] != Eigen && Meth[0] != Eigen) { err = ERRORNOTPROGRAMMEDYET; goto ErrorHandling; } // cholesky, QR, SVD, Eigen, LU always destroy original matrix M bool gesichert; if ((gesichert = rhs_cols==0 && result == NULL)) { if ((gesichert = (SOLVE_METHODS > sparse + 1 && Meth[sparse + 1] != Meth[sparse] && Meth[sparse + 1] != NoFurtherInversionMethod) || (Meth[sparse] == SVD && sp->svd_tol > 0.0 && sqrtOnly) )) { // at least two different Methods in the list CMALLOC(SICH, sizeSq, double); MEMCOPY(SICH, M, sizeSq * sizeof(double)); } } double *SICH, *MPT; SICH = pt->SICH; MPT = M; // also for sparse result if (rhs_cols > 0) { CMALLOC(MM, sizeSq, double); MPT = MM; } else if (result != NULL) MPT = result; // printf("gesichert %d\n", gesichert); // int size4; size4 = MIN(5, size);printf("MPT\n"); for (int ii=0; iimethod = Meth[m]; if (pt->method<0) break; if (sqrtOnly) { if (pt->method == NoInversionMethod && m<=sparse) BUG; if (pt->method == NoFurtherInversionMethod) break; if (PL>=PL_STRUCTURE) { PRINTF("method to calculate the square root : %s\n", InversionNames[pt->method]); } } else { if (PL>=PL_STRUCTURE) { PRINTF("method to calculate the inverse : %s\n", InversionNames[pt->method]); } } if (rhs_cols == 0 && result == NULL) { if (m > sparse) { MEMCOPY(MPT, SICH, sizeSq * sizeof(double)); } } else if (pt->method != Sparse && MPT != M) { MEMCOPY(MPT, M, sizeSq * sizeof(double)); } switch(pt->method) { case Cholesky : // cholesky if (!posdef) CERR("Cholesky needs positive definite matrix"); if (size > sp->max_chol) CERR("matrix too large for Cholesky decomposition."); // cmp for instance http://stackoverflow.com/questions/22479258/cholesky-decomposition-with-openmp //printf("multicore = %d cores=%d\n", GLOBAL.basic.cores); err = NOERROR; { double *A = MPT; for (int i=0; i 0.0) A[i] = SQRT(sum); else { err = ERRORFAILED; break;} } } if (false) { //braucht 100 % mehr zeit als aufruf von dpotrf // laesst sich nicht ohne weiteres err = NOERROR; // o mp_set_num_threads(Sp->cores); int isize=0; for (int i=0; i 0.0) A[j] = SQRT(sum); else { err = ERRORFAILED; } } } } if (false) { //https://courses.engr.illinois.edu/cs554/fa2013/notes/07_cholesky.pdf // saying that no pivoting necessary. needs 150 % more time err = NOERROR; for (int k =0; k= PL_DETAILSUSER) PRINTF("Cholesky decomposition successful\n"); break; case QR : {// QR returns transposed of the inverse !! if (rhs_cols > 0 || logdet != NULL || !sqrtOnly) { err = ERRORFAILED; continue; } err = ERRORNOTPROGRAMMEDYET; /// to do: clarify transposed ! continue; CMALLOC(workspaceD, size, double); CMALLOC(workspaceU, size, double); F77_CALL(dgeqrf)(&size, &size, MPT, &size, // aijmax, &irank, inc, workspaceD, workspaceU, workspaceD, &size, &err); //if (GLOBAL.solve.tmp_delete) {FREEING(workspaceD); FREEING(workspaceU);} if (err != NOERROR) { CERR1("'dgeqrf' failed with err=%d\n", err); } if (PL >= PL_DETAILSUSER) PRINTF("QR successful\n"); break; } case Eigen : { // M = U D UT int max_eigen = sp->max_svd; double eigen2zero = sp->eigen2zero; if (size > max_eigen) CERR("matrix too large for eigen value decomposition."); double optimal_work, *pt_work = &optimal_work; int k=0, optimal_intwork, *pt_iwork = &optimal_intwork, lwork = -1, lintwork = -1; CMALLOC(U, sizeSq, double); CMALLOC(D, size, double); CMALLOC(xja, 2 * size, int); for (int i=0; i<=1; i++) { double dummy = 0.0, abstol = 0.0; int dummy_nr; // printf("i = %d\n", i); F77_CALL(dsyevr)("V", "A", "U", &size, MPT, &size, &dummy, &dummy, &k, &k, &abstol,// or DLAMCH &dummy_nr, D, U, &size, xja, // 2 * size * sizeof(integer); nonzeros_idx pt_work, &lwork, pt_iwork, &lintwork, &err ); // printf("i=%d, %d %d size=%d err=%d\n", i, lwork, lintwork, size, err); if (i==1 || err != NOERROR || ISNAN(D[0])) break; lwork = (int) optimal_work; lintwork = (int) optimal_intwork; CMALLOC(work, lwork, double); CMALLOC(iwork, lintwork, int); pt_iwork = iwork; pt_work = work; } // if (!false) { // int end = MIN(5, size); // for(int ii=0; iiPL_ERRORS) PRINTF("Error code F77_CALL(dsyevr) = %d\n", err); CERR1("'dsyevr' failed with err=%d\n", err); break; } for (int i=0; i -eigen2zero * 100]); } //else print("%f ", D[i]); if (sqrtOnly) { for (int j=0; j 0) { int tot = size * rhs_cols; CMALLOC(w2, tot, double); matmulttransposed(U, rhs, w2, size, size, rhs_cols); for (k=0; k= PL_DETAILSUSER) PRINTF("eigen value decomposition successful\n"); break; } case SVD : {// SVD : M = U D VT if (size > sp->max_svd) CERR("matrix too large for SVD decomposition."); int k = 0, lwork = -1, size8 = size * 8; double optim_lwork, eigen2zero = sp->eigen2zero, *pt_work = &optim_lwork; CMALLOC(VT, sizeSq, double); CMALLOC(U, sizeSq, double); CMALLOC(D, size, double); CMALLOC(iwork, size8, int); for (int i=0; i<=1; i++) { F77_CALL(dgesdd)("A", &size, &size, MPT, &size, D, U, &size, VT, &size, pt_work, &lwork, iwork, &err); if (i==1 || err != NOERROR || ISNAN(D[0])) break; lwork = (int) optim_lwork; CMALLOC(work, lwork, double); pt_work = work; } if (err != NOERROR) { if (PL>PL_ERRORS) PRINTF("Error code F77_CALL(dgesdd) = %d\n", err); CERR1("'dgesdd' failed with err=%d\n", err); break; } if (sqrtOnly) { double svdtol = sp->svd_tol; /* calculate SQRT of covariance matrix */ for (int j=0; j 0.0) { double *Morig = gesichert ? SICH : M; for (int i=0; i svdtol) { if (PL > PL_ERRORS) { PRINTF("difference %e at (%d,%d) between the value (%e) of the covariance matrix and the square of its root (%e).\n", Morig[i * size +k] - sum, i, k, Morig[i*size+k], sum); } FERR3("required precision not attained (%e > %e): probably invalid model. See also '%s'\n", FABS(Morig[i * size + k] - sum), svdtol, solve[SOLVE_SVD_TOL]); err=ERRORM; break; } //else printf("ok (%d,%d) %f %f\n", i, k, Morig[i*size+k],sum); } if (err != NOERROR) break; } if (err != NOERROR) break; } // end if svdtol > 0 } else { // calculate determinant if (logdet != NULL) { double dummy = 0.0; for (int i = 0; i < size; dummy += Log(D[i++])); *logdet = dummy; } for (int j=0; j 0) { int tot = size * rhs_cols; CMALLOC(w2, tot, double); matmulttransposed(U, rhs, w2, size, size, rhs_cols); for (k=0; k= PL_DETAILSUSER) PRINTF("svd successful\n"); // if (GLOBAL.solve.tmp_delete) {FREEING(VT);FREEING(U);FREEING(D); //FREEING_INT(iwork);FREEING(work);FREEING(w2);} break; } case LU : {// LU if (!sqrtOnly) { err = ERRORFAILED; continue; } CMALLOC(ipiv, size, int); F77_CALL(dgetrf)(&size, &size, MPT, &size, ipiv, &err); if (err != NOERROR) { CERR1("'dgetrf' (LU) failed with err=%d\n", err); } if (logdet != NULL) { CERR("logdet cannot be determined for 'LU'"); int i; for (*logdet=0.0, i = 0; i < sizeSq; i += sizeP1) *logdet +=Log(MPT[i]); } if (rhs_cols > 0) { int totalRHS = size * rhs_cols; if (result != NULL) MEMCOPY(RESULT, rhs, sizeof(double) * totalRHS); F77_CALL(dgetrs)("N", &size, &rhs_cols, MPT, &size, ipiv, RESULT, &size, &err); if (err != NOERROR) { CERR1("'dgetrs' (LU) failed with err=%d\n", err); } } else { int lwork = -1; double dummy, *p = &dummy; for (int i=0; i<=1; i++) { F77_CALL(dgetri)(&size, MPT, &size, ipiv, p, &lwork, &err); if (err != NOERROR) break; lwork = (int) dummy; CMALLOC(workLU, lwork, double); p = workLU; } } if (PL >= PL_DETAILSUSER) PRINTF("LU decomposition successful\n"); //if (GLOBAL.solve.tmp_delete) {FREEING_INT(ipiv);FREEING(workLU);} break; } case Sparse : {// sparse matrix int nnzlindx, doperm = sp->pivot, halfsq = size * (size + 1) / 2, nnzcolindices = 0, nnzR = 0, cache = 512, // to do: CPU cache size nnzcfact[3] = { 5, 1, 5 }, nnzRfact[3] = { 5, 1, 2 }; double cholincrease_nnzcol = 1.25, cholincrease_nnzR = 1.25; if (!posdef) CERR("'spam' needs a positive definite matrix"); CMALLOC(pivot, size, int); if (!doperm) for (int i=0; i= spam_tol; spam_zaehler = nnzA + 1; // falls nur aus Nullen bestehend } CMALLOC(xlnz, sizeP1, int); CMALLOC(snode, size, int); CMALLOC(xsuper, sizeP1, int); CMALLOC(xlindx, sizeP1, int); CMALLOC(invp, size, int); CMALLOC(w3, size, double); CMALLOC(cols, spam_zaehler, int); CMALLOC(rows, sizeP1, int); int nDD = spam_zaehler; if (nDD < size) nDD = size; CMALLOC(DD, nDD, double); // prepare spam F77_CALL(spamdnscsr)(&size, &size, M, &size, DD, cols, // ja rows, // ia &spam_tol); // create spam object pt->nsuper = 0; // calculate spam_cholesky err = 4; // to get into the while loop while (err == 4 || err == 5) { if (nnzcolindices == 0) { double rel = nnzA / (double) size; if (rel < 5) { nnzcolindices = (int) CEIL(nnzA * (1.05 * rel - 3.8)); if (nnzcolindices < 1000) nnzcolindices = 1000; } else { nnzcolindices = nnzA; } nnzcolindices *= nnzcfact[doperm]; if (nnzcolindices < nnzA) nnzcolindices = nnzA; } else if (err == 5) { int tmp = (int) CEIL(nnzcolindices * cholincrease_nnzcol); if (PL > PL_RECURSIVE) PRINTF("Increased 'nnzcolindices' with 'NgPeyton' method\n(currently set to %d from %d)", tmp, nnzR); nnzcolindices = tmp; } if (nnzcolindices < pt->lindx_n) nnzcolindices = pt->lindx_n; if (nnzR == 0) { double u = FLOOR(.4 * POW(nnzA, 1.2)); u = u < 4 * nnzA ? 4 * nnzA : CEIL(u); nnzR = (int) u * nnzRfact[doperm]; } else if (err == 4) { int tmp = (int) CEIL(nnzR * cholincrease_nnzR); if (PL > PL_RECURSIVE) PRINTF("Increased 'nnzR' with 'NgPeyton' method\n(currently set to %d from %d)", tmp, nnzR); nnzR = tmp; } if (nnzR < pt->lnz_n) nnzR = pt->lnz_n; else if (nnzR > halfsq) nnzR = halfsq; CMALLOC(lindx, nnzcolindices, int); CMALLOC(lnz, nnzR, double); F77_CALL(cholstepwise)(&size, &nnzA, DD, cols, rows, &doperm, invp, pivot, &nnzlindx, &nnzcolindices, lindx, // xlindx,// &(pt->nsuper), // length of lindx &nnzR, // physical length of lindx lnz, // output:result xlnz, // cols of lnz "ja" snode, // supernode membership ?? xsuper, // supernode partioning &cache, // cache size of the CPU &err ); if (err != NOERROR) { CERR1("'cholstepwise' failed with err=%d\n", err); break; } } // while if (err != NOERROR) CERR("'spam' failed"); if (PL >= PL_DETAILSUSER) PRINTF("'spam' successful\n"); // spam solve if (sqrtOnly) { //BUG; // unexpected behaviour in spam nnzR = xlnz[size] - 1; CMALLOC(xja, nnzR, int); F77_CALL(calcja)(&size, &(pt->nsuper), pt->xsuper, pt->lindx, pt->xlindx, pt->xlnz, xja); for (int i=0; ilnz, xja, pt->xlnz, RESULT); for (int i=0; ilnz; int RHS_COLS, *lindx = pt->lindx; // spam determinant if (logdet != NULL) { double tmp = 0.0; for (int i=0; insuper); // for (int ii=0; iinsuper, sizeP1, xsuper[ii], // w3[ii]); // if (false) // for (int jsub=0; jsub<=pt->nsuper; jsub++) { // int fj = xsuper[1 - 1], // Lj = xsuper[jsub + 1 - 1] -1; // printf("%d %d %d\n", jsub, fj, Lj); // for (int jcol=fj; jcol <= Lj; jcol++) { // printf("%d,%f ", jcol, w3[jcol - 1]); // } // } // for (int jcol=1; jcol <= 600; jcol++) { // w3[jcol - 1] = jcol; // printf("%d,%f ", jcol, w3[jcol - 1]); // } // printf("%ld %ld %d\n", RESULT, rhs, rhs_cols); // for (int ii=0; iinsuper), &RHS_COLS, lindx, // colindices xlindx, //colpointers lnz, xlnz, // rowpointers invp, pivot, xsuper, // supernodes w3, RESULT); if (PL >= PL_DETAILSUSER) PRINTF("'spam' successful\n"); //if (GLOBAL.solve.tmp_delete) {FREEING_INT(pivot);FREEING_INT(xlnz); //FREEING_INT(snode);FREEING_INT(xsuper);FREEING_INT(xlindx); //FREEING_INT(invp);FREEING(w3);FREEING_INT(cols);FREEING_INT(rows); //FREEING(DD);FREEING_INT(lindx);FREEING(lnz);FREEING_INT(xja);} } break; } // Sparse default : BUG; GERR("unknown method in 'RandomFieldsUtils'"); } // switch if (err==NOERROR) break; } // for m ErrorHandling: if (Pt == NULL) solve_DELETE(&pt); //else if (GLOBAL.solve.tmp_delete) {FREEING(SICH); FREEING(MM);} return err; // -method; } SEXP doPosDef(SEXP M, SEXP rhs, SEXP logdet, bool sqrtOnly, solve_param *Sp){ int rhs_rows, rhs_cols, err = NOERROR, size = ncols(M), rows = nrows(M); bool deleteMM = false, deleteRHS = false; SEXP res; if (rhs == R_NilValue) { rhs_rows = rhs_cols = 0; } else if (isMatrix(rhs)) { rhs_rows = nrows(rhs); rhs_cols = ncols(rhs); } else if ((rhs_rows = length(rhs)) == 0) { rhs_cols = 0; } else { rhs_cols = 1; } if (rows != size) ERR("not a square matrix"); if (rhs_rows > 0 && rhs_rows != size) ERR("vector size does not match the matrix size"); int new_cols = rhs_cols == 0 ? size : rhs_cols, total = size * new_cols; // res = PROTECT(isReal(M) ? duplicate(M): coerceVector(M, REALSXP)); UNPROTECT(1); return res; if (rhs_cols==0 || isMatrix(rhs)) { res = PROTECT(allocMatrix(REALSXP, size, new_cols)); } else { res = PROTECT(allocVector(REALSXP, total)); } double *MM=NULL, *RHS = NULL; if (TYPEOF(M) != REALSXP) { if (TYPEOF(M) != INTSXP && TYPEOF(M) != LGLSXP) GERR("numerical matrix expected"); if ((deleteMM = rhs_cols != 0)) MM = (double*) MALLOC(total * sizeof(double)); else MM = REAL(res); if (TYPEOF(M) == INTSXP) { for (int i=0; i 0) { if ((deleteRHS = TYPEOF(rhs) != REALSXP)) { if (TYPEOF(res) != INTSXP && TYPEOF(rhs) != LGLSXP) GERR("numerical matrix expected"); int totalRHS = rhs_cols * rhs_rows; RHS = (double*) MALLOC(totalRHS * sizeof(double)); if (TYPEOF(rhs) == INTSXP) { for (int i=0; i 0 && TYPEOF(rhs) == REALSXP) ? REAL(res) : NULL, length(logdet) == 0 ? NULL : REAL(logdet), sqrtOnly, NULL, Sp); ErrorHandling: if (deleteMM) FREE(MM); if (deleteRHS) FREE(RHS); UNPROTECT(1); if (err != NOERROR) { const char *methname[] = {"solvePosDef", "cholesky"}; if (err != ERRORM) strcpy(ERRORSTRING, ""); ERR2("'%s' failed: %s\n", methname[sqrtOnly], ERRORSTRING); } return res; } SEXP SolvePosDef(SEXP M, SEXP rhs, SEXP logdet){ return doPosDef(M, rhs, logdet, false, &(GLOBAL.solve)); } int solvePosDefResult(double *M, int size, bool posdef, double *rhs, int rhs_cols, double *result, double *logdet, solve_storage *PT) { return doPosDef(M, size, posdef, rhs, rhs_cols, result, logdet, false, PT, &(GLOBAL.solve)); } int solvePosDef(double *M, int size, bool posdef, double *rhs, int rhs_cols, double *logdet, solve_storage *PT) { return doPosDef(M, size, posdef, rhs, rhs_cols, NULL, logdet, false, PT, &(GLOBAL.solve)); } int invertMatrix(double *M, int size) { solve_storage *pt = (solve_storage*) MALLOC(sizeof(solve_storage)); int err; // to do err = doPosDef(M, size, false, NULL, 0, NULL, NULL, false, pt, &(GLOBAL.solve)); solve_DELETE(&pt); return err; } /* ## extrem wichter check -- folgendes funktioniert bislang bei spam nicht: library(RandomFields, lib="~/TMP") RFoptions(printlevel = 3, pch="", seed=999, use_spam = TRUE) z = RFsimulate(RMspheric(), x, max_variab=10000, n=10000, spC=FALSE) C = cov(t(z)) c = RFcovmatrix(RMspheric(), x) print(summary(as.double(c - C))) ##// stopifnot(max(a b s(c-C)) < 0.05) */ int sqrtPosDef(double *M, int size, // in out solve_storage *pt // in out ){ int err, sizeSq = size * size; // InversionMethod Methods[SOLVE_METHODS] = { GLOBAL.solve.Methods[0], // GLOBAL.solve.Methods[1] }; // GLOBAL.solve.Methods[0] = GLOBAL.solve.Methods[1] = if (GLOBAL.solve.sparse == True) warning("package 'spam' is currently not used for simulation"); usr_bool sparse = GLOBAL.solve.sparse; GLOBAL.solve.sparse = False; assert(pt != NULL); CMALLOC(result, sizeSq, double); err = doPosDef(M, size, true, NULL, 0, result, NULL, true, pt, &(GLOBAL.solve)); GLOBAL.solve.sparse = sparse; return err; } int sqrtPosDefFree(double *M, int size, // in out solve_storage *pt // in out ){ int err, sizeSq = size * size; solve_param *sp = &(GLOBAL.solve); InversionMethod *Meth = sp->Methods; if (Meth[0] == NoInversionMethod || Meth[0] == NoFurtherInversionMethod || (Meth[1] != NoInversionMethod && Meth[1] != NoFurtherInversionMethod && Meth[1] != Meth[0]) || (Meth[0] != Cholesky && Meth[0] != Eigen && Meth[0] != SVD) ) { err = sqrtPosDef(M, size, pt); #ifdef WIN32 pt->to_be_deleted = M; #else Free(M); #endif return(err); } if (GLOBAL.solve.sparse == True) warning("package 'spam' is currently not used for simulation"); usr_bool sparse = GLOBAL.solve.sparse; GLOBAL.solve.sparse = False; assert(pt != NULL); FREE(pt->result); pt->result = M; pt->result_n = sizeSq; err = doPosDef(M, size, true, NULL, 0, NULL, NULL, true, pt, sp); //int doPosDef(double *M, int size, bool posdef, // double *rhs, int rhs_cols, double *result, double *logdet, // bool sqrtOnly, solve_storage *Pt, solve_param *Sp GLOBAL.solve.sparse = sparse; return err; } SEXP Chol(SEXP M) { solve_param chol_param = GLOBAL.solve; chol_param.Methods[0] = chol_param.Methods[1] = Cholesky; chol_param.sparse = False; // currently does not work, waiting for Reinhard chol_param.pivot = PIVOT_NONE; return doPosDef(M, R_NilValue, R_NilValue, true, &chol_param); } int sqrtRHS(solve_storage *pt, double* RHS, double *result){ assert(pt != NULL); int size = pt->size; switch (pt->method) { case direct_formula : case Cholesky : { double *U = pt->result; assert(U != NULL); #ifdef DO_PARALLEL #pragma omp parallel for schedule(dynamic) if (MULTIMINSIZE(size)) #endif for (int i=0; iresult; assert(U != NULL); #ifdef DO_PARALLEL #pragma omp parallel for if (MULTIMINSIZE(size)) #endif for (int i=0; iDD != NULL); F77_CALL(amuxmat)(&size, &size, &one, RHS, pt->DD, pt->lnz, pt->xja, pt->xlnz); for (int i=0; iDD[pt->invp[i]]; } break; case Diagonal : { int i, j, sizeP1 = size + 1; double *D = pt->result; assert(D != NULL); for (i=j=0; j #include "RandomFieldsUtils.h" #include "init_RandomFieldsUtils.h" #include "General_utils.h" double struve_intern(double x, double nu, double factor_Sign, bool expscaled) { if ((x == 0.0) && (nu>-1.0)) return 0.0; if (x <= 0.0) return RF_NA; // not programmed yet double exp_dummy, dummy = 0.0, logx = 2.0 * Log(0.5 * x), x1 = 1.5, x2 = nu + 1.5, value = 1.0, fsign = factor_Sign, epsilon=1e-20; do { dummy += logx - Log(x1) - Log(FABS(x2)); exp_dummy = EXP(dummy); value += (1 - 2 * (x2 < 0)) * fsign * exp_dummy; // printf("%f %f %f %f\n", value, fsign, x1, x2); x1 += 1.0; x2 += 1.0; fsign = factor_Sign * fsign; } while (exp_dummy > FABS(value) * epsilon); x1 = 1.5; x2 = nu + 1.5; if (x2 > 0.0) { dummy = (nu + 1.0) * 0.5 * logx - lgammafn(x1) - lgammafn(x2); if (expscaled) dummy -= x; value *= EXP(dummy); } else { //if ( (double) ((int) (x1-0.5)) != x1-0.5 ) return RF_NA; value *= POW(0.5 * x, nu + 1.0) / (gammafn(x1) * gammafn(x2)); if (expscaled) value *= EXP(-x); } return value; } //void StruveH(double *x, double *nu) {*x=struve(*x, *nu, -1.0, false);} //void StruveL(double *x, double *nu, int * expScaled) { // *x=struve(*x, *nu, 1.0, (bool) *expScaled); //} double StruveH(double x, double nu) {return struve_intern(x, nu, -1.0, false);} double StruveL(double x, double nu, bool expScaled) { return struve_intern(x, nu, 1.0, expScaled); } SEXP struve(SEXP X, SEXP Nu, SEXP Factor_Sign, SEXP Expscaled) { int i, lenx = length(X), lennu = length(Nu), len = lenx; if (len < lennu) len = lennu; SEXP Result; PROTECT(Result = allocVector(REALSXP, len)); double *x = REAL(X), *nu = REAL(Nu), factor_sign = REAL(Factor_Sign)[0], *result = REAL(Result); bool expscaled = LOGICAL(Expscaled)[0]; for (i=0; i MATERN_NU_THRES; if (x > LOW_MATERN) { if (simple) { if (nuThres != nuOld) { nuOld = nuThres; loggamma_old = lgammafn(nuThres); } loggamma = loggamma_old; } else { if (nu1 != nu1old) { nu1old = nu1; loggamma1old = lgammafn(nu1); } if (nu2 != nu2old) { nu2old = nu2; loggamma2old = lgammafn(nu2); } loggamma = 0.5 * (loggamma1old + loggamma2old); } y = x * scale; v = LOG2 + nuThres * Log(0.5 * y) - loggamma + Log(bessel_k(y, nuThres, 2.0)) - y; } else v = 0.0; if (nu > MATERN_NU_THRES) { // factor!=0.0 && double w, g = MATERN_NU_THRES / nu; y = x * factor / 2; w = logGauss(y); //if (nu>100) printf("nu=%f %e %e %e\n", nu, v, g, w); v = v * g + (1.0 - g) * w; if (nu1 != nu2) { // consistenz zw. nu1, nu2 und nuThres wiederherstellen v += lgammafn(nu)- 0.5 * (lgammafn(nu1) + lgammafn(nu2)); // !nuThres } // if (!R_FINITE(v)) ERR("non-finite value in the whittle-matern model -- value of 'nu' is much too large"); //if (nu>100) printf("v=%f \n", v); } return v; } double WM(double x, double nu, double factor) { // check calling functions, like hyperbolic and gneiting if any changings !! return EXP(logWM(x, nu, nu, factor)); } double DWM(double x, double nu, double factor) { static double nuOld=RF_INF; static double loggamma; double y, v, nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES, scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0; if (x > LOW_MATERN) { if (nuThres!=nuOld) { nuOld = nuThres; loggamma = lgammafn(nuThres); } y = x * scale; v = - 2.0 * EXP(nuThres * Log(0.5 * y) - loggamma + Log(bessel_k(y, nuThres - 1.0, 2.0)) - y); } else { v = (nuThres > 0.5) ? 0.0 : (nuThres < 0.5) ? INFTY : 1.253314137; } v *= scale; if (nu > MATERN_NU_THRES) { double w, g = MATERN_NU_THRES / nu; scale = factor / 2.0; y = x * scale; w = DGauss(y) * scale; v = v * g + (1.0 - g) * w; } return v; } double DDWM(double x, double nu, double factor) { static double nuOld=RF_INF; static double gamma; double y, v, nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES, scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0, scaleSq = scale * scale; if (x > LOW_MATERN) { if (nuThres!=nuOld) { nuOld = nuThres; gamma = gammafn(nuThres); } y = x * scale; v = POW(0.5 * y , nuThres - 1.0) / gamma * (- bessel_k(y, nuThres - 1.0, 1.0) + y * bessel_k(y, nuThres - 2.0, 1.0)); } else { v = (nu > 1.0) ? -0.5 / (nu - 1.0) : INFTY; } v *= scaleSq; if (nu > MATERN_NU_THRES) { double w, g = MATERN_NU_THRES / nu; scale = factor / 2.0; scaleSq = scale * scale; y = x * scale; w = DDGauss(y) * scaleSq; v = v * g + (1.0 - g) * w; } return v; } double D3WM(double x, double nu, double factor) { static double nuOld=RF_INF; static double gamma; double y, v, nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES, scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0, scaleSq = scale * scale; if (x > LOW_MATERN) { if (nuThres!=nuOld) { nuOld = nuThres; gamma = gammafn(nuThres); } y = x * scale; v = POW(0.5 * y , nuThres - 1.0) / gamma * ( 3.0 * bessel_k(y, nuThres - 2.0, 1.0) -y * bessel_k(y, nuThres - 3.0, 1.0)); } else { v = 0.0; } v *= scaleSq * scale; if (nu > MATERN_NU_THRES) { double w, g = MATERN_NU_THRES / nu; scale = factor / 2.0; scaleSq = scale * scale; y = x * scale; w = D3Gauss(y) * scaleSq * scale; v = v * g + (1.0 - g) * w; } return v; } double D4WM(double x, double nu, double factor) { static double nuOld=RF_INF; static double gamma; double y, v, nuThres = nu < MATERN_NU_THRES ? nu : MATERN_NU_THRES, scale = (factor != 0.0) ? factor * SQRT(nuThres) : 1.0, scaleSq = scale * scale; // printf("x=%f nu=%f\n", x, nuThres); if (x > LOW_MATERN) { if (nuThres!=nuOld) { nuOld = nuThres; gamma = gammafn(nuThres); } y = x * scale; v = 0.25 * POW(0.5 * y , nuThres - 3.0) / gamma * (+ 6.0 * (nuThres - 3.0 - y * y) * bessel_k(y, nuThres - 3.0, 1.0) + y * (3.0 + y * y) * bessel_k(y, nuThres - 4.0, 1.0)); } else { v = (nuThres > 2.0) ? 0.75 / ((nuThres - 1.0) * (nuThres - 2.0)) : INFTY; } v *= scaleSq * scaleSq; if (nu > MATERN_NU_THRES) { double w, g = MATERN_NU_THRES / nu; scale = factor / 2.0; scaleSq = scale * scale; y = x * scale; w = D4Gauss(y) * scaleSq * scaleSq; v = v * g + (1.0 - g) * w; } // printf("v=%f\n", v); return v; } typedef double (*primfct1)(double); typedef double (*primfct3)(double, double, double); #define CALCULATE(PRIMFCTN) \ double *x = REAL(X); \ int n = length(X), \ deriv = INTEGER(Derivative)[0]; \ if (deriv < 0 || deriv > 4) ERR("value of 'derivative' out of range"); \ PRIMFCTN F = fctns[deriv]; \ \ SEXP Ans; \ PROTECT(Ans=allocVector(REALSXP, n)); \ double *ans = REAL(Ans); \ for (int i=0; i=PL_ERRORS ) cat("'",file,"' is locked.\n"); return(2); } PID <- pid(); write(file=LockFile,c(PID,hostname()),ncolumns=2,append=TRUE); #3.a. Pid <- matrix(scan(LockFile,what=character(0), quiet=TRUE),nrow=2) if ((sum(Pid[1,]==PID)!=1) || (sum(Pid[1,]>PID)>0)){ #3.b. if (printlevel>PL_ERRORS ) cat("Lock file of '", file, "' is knocked out.\n"); return(3); } return(0); } FileExists <- function(file, printlevel=RFoptions()$basic$printlevel) { ## for parallel simulation studies: the same data output file should not ## be created twice. So: ## 1. if file exists then assume another process has done the work already ## 2. if file.lock existss then assume another process is doing the work ## 3.a. otherwise create file.lock to show other processes that the process ## will do the work ## 3.b. check if another process has started with the same work at the same ## time it may happen that in case of simulatenous creation of file.lock ## no process will do the work...(then the lock file will rest.) PL_ERRORS <- 6 if (file.exists(file)) { #1. if (printlevel>=PL_ERRORS ) cat("'", file, "' already exists.\n"); return(1) } else { return(LockFile(file, printlevel=printlevel)) } } LockRemove <- function(file) { ## removes auxiliary files created by FileExists lock.ext <- ".lock"; file.remove(paste(file, lock.ext, sep="")) } Print <- function(..., digits=6, empty.lines=2) { # ## ?"..1" # print(..1) # print(substitute(..1)) # print(missing(..100)) max.elements <- 99 l <- list(...) n <- as.character(match.call())[-1] cat(paste(rep("\n", empty.lines), collapse="")) # for (i in 1:length(l)) { cat(n[i]) # if (!is.list(l[[i]]) && is.vector(l[[i]])) { L <- length(l[[i]]) if (L==0) cat(" = ")# else { cat(" [", L, "] = ", sep="") cat(if (is.numeric(l[[i]])) round(l[[i]][1:min(L , max.elements)], digits=digits)# else l[[i]][1:min(L , max.elements)]) # if (max.elements < L) cat(" ...") } } else { if (is.list(l[[i]])) { cat(" = ") # str(l[[i]], digits.d=digits) # } else { cat(" =") if (length(l[[i]]) <= 100 && FALSE) { print(if (is.numeric(l[[i]])) round(l[[i]], digits=digits)# else l[[i]]) } else { if (length(l[[i]]) > 1 && !is.vector(l[[i]]) && !is.matrix(l[[i]]) && !is.array(l[[i]])) cat("\n") str(l[[i]]) # } } } cat("\n") } } cholx <- function(a) { # return(.Call("Cholesky", a, PACKAGE="RandomFieldsUtils")) .Call(C_Chol, a) } cholPosDef <- function() stop("please use 'cholx' instead of 'cholPosDef'.") solvePosDef <- function(a, b=NULL, logdeterminant=FALSE) { stop("please use 'solvex' instead of 'solvePosDef'.") } solvex <- function(a, b=NULL, logdeterminant=FALSE) { if (logdeterminant) { logdet <- double(1) res <- .Call(C_SolvePosDef, a, b, logdet) return(list(inv=res, logdet=logdet)) } else { .Call(C_SolvePosDef, a, b, double(0)) } } sortx <- function(x, from=1, to=length(x), decreasing=FALSE, na.last = NA) { n <- length(x) if (n <= 4000 || (to - from) < (0.35 + is.double(x) * 0.15) * n) { if (decreasing) { x <- -x if (!is.na(na.last)) na.last <- !na.last } ans <- .Call(C_sortX, x, as.integer(from), as.integer(to), as.logical(na.last)) return(if (decreasing) -ans else ans) } else { return(if (from==1 && to==n) sort(x, decreasing=decreasing, na.last=na.last) else sort(x, decreasing=decreasing, na.last=na.last)[from:to]) } } orderx <- function(x, from=1, to=length(x), decreasing=FALSE, na.last = NA) { # cat((to - from) * (0.35 + 0.14 * log(length(x)))^2, "", length(x), "\n") if ((to - from) * (0.35 + 0.14 * log(length(x)))^2 > length(x)) { #10^2:1, 10^3:1.5, 10^4:3 10^5:5 10^6:5, 10^7: 8, 10^8:10, # cat("old", from, to ,"\n"); ans <- order(x, decreasing=decreasing, na.last=na.last) return(if (from==1 && to==length(x)) ans else ans[from:to]) } if (decreasing) { x <- -x if (!is.na(na.last)) na.last <- !na.last } .Call(C_orderX, x, as.integer(from), as.integer(to), as.logical(na.last)) } # scalar <- function(x, y, mode="1x1") .Call(C_scalarX, x, y, mode) RandomFieldsUtils/R/maths.R0000644000175100001440000000470513074063617015335 0ustar hornikusers ## Authors ## Martin Schlather, schlather@math.uni-mannheim.de ## ## ## Copyright (C) 2015 Martin Schlather ## ## This program is free software; you can redistribute it and/or ## modify it under the terms of the GNU General Public License ## as published by the Free Software Foundation; either version 3 ## of the License, or (at your option) any later version. ## ## This program 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 General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. I0L0 <- function(x) { storage.mode(x) <- "double" # res <- double(length(x)) .Call(C_I0ML0, x) } .struve <- function(x, nu, sign, expon.scaled) { storage.mode(x) <- "double" storage.mode(nu) <- "double" storage.mode(expon.scaled) <- "logical" storage.mode(sign) <- "double" # res <- double(max(length(x), length(nu))) .Call(C_struve, x, nu, sign, expon.scaled) } struveH <- function(x, nu) .struve(x, nu, -1, FALSE) struveL <- function(x, nu, expon.scaled=FALSE) .struve(x, nu, 1, expon.scaled) wmscale <- function(scaling) { switch(scaling, whittle = 0.0, matern = sqrt(2), handcockwallis = 2.0 ) } whittle <- function(x, nu, derivative=0, scaling=c("whittle", "matern", "handcockwallis")) { .Call(C_WMr, as.double(x), as.double(nu), as.integer(derivative), if (is.character(scaling)) wmscale(match.arg(scaling)) else as.double(scaling)) } matern <- function(x, nu, derivative=0, scaling=c("matern", "whittle", "handcockwallis")) { whittle(x, nu, derivative, if (is.character(scaling)) wmscale(match.arg(scaling)) else scaling) } nonstwm <- function(x, y, nu, log=FALSE, scaling=c("whittle", "matern", "handcockwallis")) { if (is.function(nu)) { nu1 <- nu(x) nu2 <- nu(y) } else nu1 <- nu2 <- nu L <- .Call(C_logWMr, sqrt(sum((x - y)^2)), as.double(nu1), as.double(nu2), if (is.character(scaling)) wmscale(match.arg(scaling)) else as.double(scaling)) if (log) L else exp(L) } gauss <- function(x, derivative=0) { .Call(C_gaussr, as.double(x), as.integer(derivative)) } RandomFieldsUtils/R/RFoptions.R0000644000175100001440000000240113074063617016133 0ustar hornikusers summary.RFopt <- function(object, ...) { object <- lapply(object, function(z) z[order(names(z))]) object <- object[c(1, 1 + order(names(object[-1])))] class(object) <- "summary.RFopt" object } print.summary.RFopt <- function(x, ...) { str(x, give.attr=FALSE, ...) # invisible(x) } print.RFopt <- function(x, ...) { print.summary.RFopt(summary.RFopt(x, ...)) # invisible(x) } summary.RFoptElmnt <- function(object, ...) { object <- object[order(names(object))] class(object) <- "summary.RFoptElmt" object } print.summary.RFoptElmnt <- function(x, ...) { str(x, give.attr=FALSE, ...) # invisible(x) } print.RFoptElmnt <- function(x, ...) { print.summary.RFoptElmnt(summary.RFoptElmnt(x, ...)) # invisible(x) } RFoptions <- function(..., no.readonly=TRUE) { ## on.exit(.C("RelaxUnknownRFoption", FALSE)) ## .C("RelaxUnknownRFoption", TRUE) opt <- lapply(.External(C_RFoptions, ...), function(x) { class(x) <- "RFoptElmnt" x }) if (length(opt)!=0) { class(opt) <- "RFopt" if (!no.readonly) { opt$readonly <- list() } } if (length(opt)==0) { # O <- opt # names(O) <- NULL # opt <- c(opt, unlist(O)) invisible(opt) } else opt } RandomFieldsUtils/R/zzz.R0000644000175100001440000000046513074063617015055 0ustar hornikusers .onLoad <- function(lib, pkg) { .Call("attachRFoptionsUtils") } .onAttach <- function (lib, pkg) { # packageStartupMessage("This is RandomFieldsUtils Version: 0.3.25"); } .onDetach <- function(lib) { # .Call("detachRFoptionsUtils") } .onUnload <- function(lib, pkg){ .Call("detachRFoptionsUtils") } RandomFieldsUtils/MD50000644000175100001440000000543013074162660014177 0ustar hornikusers23e06b94ac0894fb894b8330a144436a *DESCRIPTION 08e4bcd6eff029d24db78dcf53f79894 *NAMESPACE acabf021c425958b8b2b7bebf4034be2 *R/RFoptions.R 3324a6ddfcf33c60b75eb11793125fbd *R/maths.R feaa9602b2d967cc42f36b0f911787cf *R/utils.R 06a4e00616dc945cdad05519f53e8582 *R/zzz.R a021bfabf5361d383820398d4473bfe7 *inst/CITATION 87386da75db85d7fc88ab1c46261c94f *inst/include/Basic_utils.h 39598aef7112741a19221ed37181d83d *inst/include/General_utils.h 83ff926b36e383a5b4fd19bafc65d424 *inst/include/Options_utils.h 5c2fa3fdbde3b9e587dd4f5a7216a6cc *inst/include/Solve.h f3970e74b496a033cea94b92c9603de7 *inst/include/errors_messages.h 3b920f7dab7aa23f847475163ec7d649 *inst/include/init_RandomFieldsUtils.h 994e648ba036ca9d2a62784c35fec0c4 *inst/include/kleinkram.h a74b10a955ed930d76095b58caf5e3ce *inst/include/win_linux_aux.h 29fbe043cf6de23fc0d1e599a85a7054 *man/Print.Rd 416de51881b2e7a02ece5da10846ac61 *man/RFoptions.Rd 81981c0e2e019bf5ccbe8246806893c9 *man/Struve.Rd 352d6bd7d4e4aeb10feb59981afef3c1 *man/cholPosDef.Rd 9165996fd1830acfad9faa304e5190eb *man/fileexists.Rd eda605d6cc8e92d2c2f6a0bb9efa7b94 *man/gauss.Rd dc6965440125ce839f4d116f277fe336 *man/hostname.Rd b91cc9fd0c3d30d3e6c3c993f7e67b15 *man/matern.Rd c9954677c5143d1293a7ff7c6403358b *man/nonstwm.Rd 4415cc547bd340f4bca460df660fa55a *man/orderx.Rd 30f323fb4473b0ddada1160cb5af1e01 *man/sleep.Rd a556c1215acedb06c7d095f2566672cd *man/solvePosDef.Rd 7034e7a90104522c8da4f95a536472de *man/sortx.Rd f31accc274159145eed7d13ed2b58870 *src/Basic_utils.h 39598aef7112741a19221ed37181d83d *src/General_utils.h d70143e9b9f31bbac4a3350515dfd9ee *src/Makevars 83ff926b36e383a5b4fd19bafc65d424 *src/Options_utils.h 2b7aa9d7586d84964d5f213f06208b50 *src/RFoptions.cc de7ed03b4683a1c5192f8ecf60e951eb *src/RandomFieldsUtils.h 5c2fa3fdbde3b9e587dd4f5a7216a6cc *src/Solve.h 7ec47b2ed2f99f629a6f1f2329abc866 *src/bckslvmodified.f bbf650f3e54ed72cc0f3ac61941ea2d3 *src/brdomain.cc 08a9f6c9da48a188df6c8c32fcdfa3d9 *src/cholmodified.f e12b5af8ef95913d3e7f54c8ea94c448 *src/diffusion.cc f3970e74b496a033cea94b92c9603de7 *src/errors_messages.h 9fce0515bfb67f6836cec2f3aaae3ff8 *src/init_RandomFieldsUtils.c 3b920f7dab7aa23f847475163ec7d649 *src/init_RandomFieldsUtils.h 40b298fc7899caf5be61fe393d2a308b *src/kleinkram.cc 994e648ba036ca9d2a62784c35fec0c4 *src/kleinkram.h bc23d55d45e15fa7b799da55f5536853 *src/maths.cc ac5ac679aeeb10e1ed1084b79566764d *src/options.cc ddaa979904d3af73ee7e08bf309340a4 *src/own.cc 3bb97c6dfbe1c924dede5acbc7fdf202 *src/own.h cbf60fdbd617f7586274b9e569cb6aaa *src/scalar.cc 0149871235c9b909f680ca9a34133a99 *src/solve.cc 893ac8d1d2990a623200bfcffc50b9f3 *src/sort.cc 3865607d016169fc2b8d7155f6e8fad4 *src/spamown.f f7dc30f705872a48f0d6f5160d83b04a *src/utils.cc 0731d68aab70567cdd4b83337eaa6191 *src/win_linux_aux.cc a74b10a955ed930d76095b58caf5e3ce *src/win_linux_aux.h RandomFieldsUtils/DESCRIPTION0000644000175100001440000000136613074162660015401 0ustar hornikusersPackage: RandomFieldsUtils Version: 0.3.25 Title: Utilities for the Simulation and Analysis of Random Fields Author: Martin Schlather [aut, cre], Reinhard Furrer [ctb], Martin Kroll [ctb] Maintainer: Martin Schlather Depends: R (>= 3.3) Imports: utils Description: Various utilities are provided that might be used in spatial statistics and elsewhere. It delivers a method for solving linear equations that checks the sparsity of the matrix before any algorithm is used. Furthermore, it includes the Struve functions. License: GPL (>= 3) URL: http://ms.math.uni-mannheim.de/de/publications/software Packaged: 2017-04-14 06:09:19 UTC; schlather NeedsCompilation: yes Repository: CRAN Date/Publication: 2017-04-14 15:07:28 UTC RandomFieldsUtils/man/0000755000175100001440000000000013074063617014442 5ustar hornikusersRandomFieldsUtils/man/matern.Rd0000644000175100001440000000607713074063617016231 0ustar hornikusers\name{matern} \alias{whittle} \alias{matern} \alias{sobolev} \alias{whittle-matern} \title{Whittle-Matern Model} \description{ \command{matern} calculates the Whittle-Matern covariance function (Soboloev kernel). The Whittle model is given by \deqn{C(r)=W_{\nu}(r)=2^{1- \nu} \Gamma(\nu)^{-1}r^{\nu}K_{\nu}(r)}{C(r)=W_{\nu}(r)=2^{1- \nu} \Gamma(\nu)^{-1}r^{\nu}K_{\nu}(r)} where \eqn{\nu > 0}{\nu > 0} and \eqn{K_\nu}{K_\nu} is the modified Bessel function of second kind. The Matern model is given by \deqn{C(r) = \frac{2^{1-\nu}}{\Gamma(\nu)} (\sqrt{2\nu}r)^\nu K_\nu(\sqrt{2\nu}r)}{C(r) = 2^{1- \nu} \Gamma(\nu)^{-1} (\sqrt{2\nu} r)^\nu K_\nu(\sqrt{2\nu} r)} The Handcock-Wallis parametrisation equals \deqn{C(r) = \frac{2^{1-\nu}}{\Gamma(\nu)} (2\sqrt{\nu}r)^\nu K_\nu(2\sqrt{\nu}r)}{C(r) = 2^{1- \nu} \Gamma(\nu)^{-1} (2\sqrt{\nu} r)^\nu K_\nu(2\sqrt{\nu} r)} } \usage{ whittle(x, nu, derivative=0, scaling=c("whittle", "matern", "handcockwallis")) matern(x, nu, derivative=0, scaling=c("matern", "whittle", "handcockwallis")) } \arguments{ \item{x}{numerical vector; for negative values the modulus is used} \item{nu}{numerical vector with positive entries} \item{derivative}{value in \code{0:4}. } \item{scaling}{numerical vector of positive values or character; see Details.} } \value{ If \code{derivative=0}, the function value is returned, otherwise the \code{derivative}th derivative. A vector of \code{length(x)} is returned; \code{nu} is recycled; \code{scaling} is recycled if numerical. If \code{scaling} has a numerical values \eqn{s}, the covariance model equals \deqn{C(r) = \frac{2^{1-\nu}}{\Gamma(\nu)} (s\sqrt{\nu}r)^\nu K_\nu(s\sqrt{\nu}r)}{C(r) = 2^{1- \nu} \Gamma(\nu)^{-1} (s\sqrt{\nu} r)^\nu K_\nu(s\sqrt{\nu} r)} The function values are rather precise even for large values of \code{nu}. } \references{ Covariance function \itemize{ \item Chiles, J.-P. and Delfiner, P. (1999) \emph{Geostatistics. Modeling Spatial Uncertainty.} New York: Wiley. \item Gelfand, A. E., Diggle, P., Fuentes, M. and Guttorp, P. (eds.) (2010) \emph{Handbook of Spatial Statistics.} Boca Raton: Chapman & Hall/CRL. \item Guttorp, P. and Gneiting, T. (2006) Studies in the history of probability and statistics. XLIX. On the Matern correlation family. \emph{Biometrika} \bold{93}, 989--995. \item Handcock, M. S. and Wallis, J. R. (1994) An approach to statistical spatio-temporal modeling of meteorological fields. \emph{JASA} \bold{89}, 368--378. \item Stein, M. L. (1999) \emph{Interpolation of Spatial Data -- Some Theory for Kriging.} New York: Springer. } } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \seealso{ \command{\link{nonstwm}} For more details see also \command{\link[RandomFields]{RMmatern}}. } \keyword{spatial} \keyword{models} \keyword{math} \examples{ confirm <- function(x, y) stopifnot(all.equal(x, y)) x <- 3 confirm(matern(x, 0.5), exp(-x)) confirm(matern(x, Inf), gauss(x/sqrt(2))) confirm(matern(1:2, c(0.5, Inf)), exp(-(1:2))) } RandomFieldsUtils/man/hostname.Rd0000644000175100001440000000132213074063617016545 0ustar hornikusers\name{host} \alias{hostname} \alias{pid} \title{System calls} \description{ The functions \code{hostname} and \code{pid} return the host name and the PID, respectively. } \usage{ hostname() pid() } \details{ If R runs on a unix platform the host name and the PID are returned, otherwise the empty string and naught, respectively. } \value{ \item{hostname}{returns a string} \item{pid}{returns an unsigned integer} } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \examples{ cat("The name of your computer is '", hostname(), "'. Your R program has current pid ", pid(), ".\n", sep="") } \keyword{sysdata} \keyword{utilities} % LocalWords: pid unix Schlather url RandomFieldsUtils/man/Struve.Rd0000644000175100001440000000307313074063617016224 0ustar hornikusers\name{Struve} \alias{struve} \alias{Struve} \alias{struveH} \alias{struveL} \alias{bessel} \alias{I0L0} \alias{I0ML0} \title{Modified Struve functions and related functions} \description{ These functions return the values of the modified Struve functions and related functions } \usage{ struveH(x, nu) struveL(x, nu, expon.scaled=FALSE) I0L0(x) } \arguments{ \item{x}{non-negative numeric vector} \item{nu}{numeric vector} \item{expon.scaled}{logical; if \code{TRUE}, the results are exponentially scaled in order to avoid overflow or underflow respectively. } } \value{ Numeric vector with the (scaled, if \code{expon.scaled = TRUE}) values of the corresponding function. The length of the result is the maximum of the lengths of the arguments \code{x} and \code{nu}. The two arguments are recycled to that length. } \details{ \code{I0L0} returns \code{\link[base]{besselI}(nu=0)} minus \code{struveL(nu=0)}. } \references{ \itemize{ \item MacLeod, A.J. (1993) Chebyshev expansions for modified Struve and related functions, \emph{Mathematics of Computation}, \bold{60}, 735-747 \item Abramowitz, M., and Stegun, I.A. (1984) \emph{Pocketbook of Mathematical Functions}, Verlag Harry Deutsch } } \seealso{ \link[base]{besselI} } \examples{ if (FALSE) { x <- seq(1, 2, 0.1) struveH(x, 0) struveH(x, 1) I0L0(x) - (besselI(x, nu=0) - struveL(x, 0)) besselI(x, nu=1) - struveL(x, 1) ## cf. Abramovitz & Stegun, table 12.1 } } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \keyword{math} RandomFieldsUtils/man/solvePosDef.Rd0000644000175100001440000000540313074063617017164 0ustar hornikusers\name{solve} \alias{solvePosDef} \alias{solvex} \alias{solve} \title{Solve a System of Equations for Positive Definite Matrices} \description{ This function solves the equality \eqn{a x = b} for \eqn{x} where \eqn{a} is a \bold{positive definite} matrix and \eqn{b} is a vector or a matrix. It is slightly faster than the inversion by the \code{\link[base]{chol}}esky decomposition and clearly faster than \code{\link[base]{solve}}. It also returns the logarithm of the determinant at no additional computational costs. } \usage{ solvex(a, b=NULL, logdeterminant=FALSE) %, sparse=NA, method=-1) } \arguments{ \item{a}{a square real-valued matrix containing the coefficients of the linear system. Logical matrices are coerced to numeric. } \item{b}{ a numeric or complex vector or matrix giving the right-hand side(s) of the linear system. If missing, \code{b} is taken to be an identity matrix and \code{solvex} will return the inverse of \code{a}. } \item{logdeterminant}{logical. whether the logarithm of the determinant should also be returned } % \item{sparse}{logical or \code{NA}. % If \code{NA} the function determines whether a sparse % matrix algorithm of the package \pkg{spam} should be used. % } % \item{method}{integer vector. % If the sparse matrix algorithm is not used, \code{method} % determines the alternative algorithm. See Details. % } } \value{ If \code{logdeterminant=FALSE} the function returns a vector or a matrix, depending on \code{b} which is the solution to the linear equation. Else the function returns a list containing both the solution to the linear equation and the logarithm of the determinant of \code{a}. } \details{ % The values of \code{method} could be: % \itemize{ % \item \code{<0} : If the matrix is diagonal direct calculations are performed. Else if the matrix is sparse the package \pkg{spam} is used. Else the Cholesky decomposition is tried. If it fails, the eigen value decomposition is tried. } \references{ See \link[spam]{chol.spam} of the package \pkg{spam} } \seealso{ \link[spam]{chol.spam} in the package \pkg{spam} } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \keyword{math} \examples{ if (FALSE) { ## This examples shows that 'solvex' can be much faster than 'solve' ## creating a covariance matrix for a temporal process covmatrix <- function(model, x) { x <- as.matrix(dist(x)) return(eval(substitute(model))) } size <- 600 x <- runif(size, 0, size / 10) M <- covmatrix((1 - x) * (x < 1) , x) ## Askey's model of covariance b <- seq(0, 1, len=size) system.time(inv2 <- solve(M, b)) system.time(inv1 <- solvex(M, b)) ## much faster in this case range(inv2 - inv1) stopifnot(all(abs(inv2 - inv1) < 10^{-9})) } } RandomFieldsUtils/man/fileexists.Rd0000644000175100001440000000366413074063617017121 0ustar hornikusers\name{FileExists} \alias{FileExists} \alias{LockRemove} \alias{LockFile} \title{Files} \description{ The function \code{FileExists} checks whether a file or a lock-file exists The function \code{LockRemove} removes a lock-file } \usage{ FileExists(file, printlevel=RFoptions()$basic$printlevel) LockFile(file, printlevel=RFoptions()$basic$printlevel) LockRemove(file) } \arguments{ \item{file}{name of the data file} \item{printlevel}{if \code{PrintLevel<=1} no messages are displayed} } \details{ \code{FileExists} checks whether file or file.lock exists. If none of them exists \code{file}.lock is created and hostname and PID are written into \code{file}.lock. This is useful if several processes use the same directory. Further, it is checked whether another process has tried to create the same file in the same instance. In this case \code{FileExists} returns for at least one of the processes that \code{file}.lock has already been created. \code{LockFile} is the same as \code{FileExists} except that it does not check whether \code{file} already exists. } \value{ \code{FileExists} returns \item{1}{if \code{file} already exists} \item{2}{if \code{file}.lock already exists} \item{3}{if \code{file}.lock was tried to be created, but another process inferred and got priority} \item{0}{otherwise, \code{file} and \code{file}.lock did not exist and \code{file}.lock has been created} } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \examples{ \dontrun{ ## the next command checks whether the file 'data.rda' ## or the file 'data.rda.lock' exists. If so, a positive ## value is returned. If not, the file 'data.rda.lock' ## is created and the value 0 returned. FileExists("data.rda") ## the next command deletes the file 'data.rda.lock' LockRemove("data.rda") } } \keyword{file} \keyword{utilities} % LocalWords: FileExists LockRemove PrintLevel RFoptions PID Schlather url RandomFieldsUtils/man/orderx.Rd0000644000175100001440000000277413074063617016246 0ustar hornikusers\name{orderx} \alias{orderx} \title{Ordering Permutation} \description{ \command{orderx} has the same functionality as \command{\link[base]{order}}, except that \code{orderx(..., from=from, to=to)} is the same as \code{order[from:to]} } \usage{ orderx(x, from=1, to=length(x), decreasing=FALSE, na.last = NA) } \arguments{ \item{x}{an atomic vector} \item{from,to}{\code{order(..., from=from, to=to)} equals \code{order(...)[from:to]}} \item{decreasing}{ logical. Should the sort order be increasing or decreasing? } \item{na.last}{for controlling the treatment of \code{NA}s. If \code{TRUE}, missing values in the data are put last; if \code{FALSE}, they are put first; if \code{NA}, they are removed (see the Notes in \command{\link[base]{order}}) } } \value{ integer vector of length \code{to}-\code{from}+1. } \details{ The smaller the difference \code{to}-\code{from} is compared to the length of \code{x}, the faster is \command{orderx} compared to \link[base]{order}. Particularly, \code{orderx(..., from=k, to=k)} is much faster than \code{order(...)[k]}. \command{orderx} is never really slower than \command{order}. For further details see \link[base]{order}. } \seealso{ \link{sortx} } \examples{ x <- runif(10^6) k <- 10 system.time(y<-order(x)[1:k]) system.time(z<-orderx(x, from=1, to=k)) ## much faster stopifnot(all(x[y ]== x[z])) ## same result } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \keyword{univar} \keyword{manip} RandomFieldsUtils/man/RFoptions.Rd0000644000175100001440000002042613074063617016660 0ustar hornikusers\name{RFoptions} \alias{RFoptions} \title{Setting control arguments} \description{ \command{\link{RFoptions}} sets and returns control arguments for the analysis and the simulation of random fields } \usage{ RFoptions(..., no.readonly = TRUE) } \arguments{ \item{...}{arguments in \code{tag = value} form, or a list of tagged values.} \item{no.readonly}{If \command{\link{RFoptions}} is called without argument then all arguments are returned in a list. If \code{no.readonly=TRUE} then only rewritable arguments are returned. Currenlty all arguments are rewritable. So the list is empty. } } \details{ The subsections below comment on\cr \bold{1. \code{basic}: Basic options}\cr \bold{2. \code{solve}: Options for solving linear systems}\cr %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % \bold{16. Options for RFloglikelihood}\cr % % "auto", "full", "composite", "selection" %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \bold{1. Basic options} \describe{ \item{asList}{logical. Lists of arguments are treated slightly different from non-lists. If \code{asList=FALSE} they are treated the same way as non-lists. This options being set to \code{FALSE} after calling \command{RFoptions} it should be set as first element of a list. Default: \code{TRUE} } \item{\code{cores}}{ Number of cores for multicore algorithms; currently only used for the Cholesky decomposition. Default : 1 } \item{\code{cPrintlevel}}{ \code{cPrintlevel} is automatically set to \code{printlevel} when \code{printlevel} is changed. Standard users will never use a value higher than 3. 0 : no messages\cr 1 : messages and warnings when the user's input looks odd\cr 2 : messages (and internal errors) documenting the choice of the simulation method\cr 3 : further user relevant informations\cr 4 : information on recursive function calls\cr 5 : function flow information of central functions \cr 6 : errors that are internally treated\cr 7 : details on building up the covariance structure\cr 8 : details on taking the square root of the covariance matrix\cr 9 : details on intermediate calculations\cr 10 : further details on intermediate calculations\cr Note that \code{printlevel} works on the R level whereas \code{cPrintlevel} works on the C level. Default: 1 \cr % [also do].\cr } \item{\code{printlevel}}{If \code{printlevel}\eqn{\le0}{<=0} there is not any output on the screen. The higher the number the more tracing information is given. Standard users will never use a value higher than 3. 0 : no messages\cr 1 : important (error) messages and warnings\cr 2 : less important messages\cr 3 : details, but still for the user\cr 4 : recursive call tracing\cr 5 : function flow information of large functions\cr 6 : errors that are internally treated\cr 7 : details on intermediate calculations\cr 8 : further details on intermediate calculations\cr Default: 1 %[also do].\cr } \item{seed}{integer (currently only used by the package RandomFields). If \code{NULL} or \code{NA} \command{\link[base]{set.seed}} is \bold{not} called. Otherwise, \code{\link[base]{set.seed}(seed)} is set before any simulations are performed. If the argument is set locally, i.e., within a function, it has the usual local effect. If it is set globally, i.e. by \command{RFoptions} the \code{seed} is fixed for \bold{all subsequent} calls. If the number of simulations \code{n} is greater than one and if \code{RFoptions(seed=seed)} is set, the \eqn{i}th simulation is started with the seed \sQuote{\code{seed}\eqn{+i-1}}. % The function \code{set.seed} should not be used in case \code{n} % is greater than 1. % %Vgle! %set.seed(5) %RFsimulate(RPschlather(RMmatern(nu=2), xi=1, mu=1, s=1), x, grid=F, n=5)@data %set.seed(5) %RFsimulate(RPschlather(RMmatern(nu=2.01), xi=1, mu=1, s=1), x,grid=F,n=5)@data %RFoptions(cPr=3, seed=5) %RFsimulate(RPschlather(RMmatern(nu=2), xi=1, mu=1, s=1), x, grid=F, n=5)@data %RFsimulate(RPschlather(RMmatern(nu=2.01), xi=1, mu=1, s=1), x, grid=F,n=5)@data } \item{\code{skipchecks}}{logical. If \code{TRUE}, several checks whether the given parameter values and the dimension are within the allowed range is skipped. Do not change the value of this variable except you really know what you do. Default: \code{FALSE} $ %[also do]. } \item{\code{verbose}}{logical. If \code{FALSE} it identical to \code{printlevel = 1} else to \code{printlevel = 2}. } } %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \bold{2. \code{solve}: Options for solving linear systems} \describe{ % to do \item{\code{max_chol}}{integer. Maximum number of rows of a matrix in a Cholesky decomposition Default: \eqn{8192} } \item{\code{max_svn}}{integer. Maximum number of rows of a matrix in a svd decomposition Default: \eqn{6555} } \item{\code{solve_method}}{ vector of at most 3 integers that gives the sequence of methods in order to inverse a matrix or to calculate its square root: \code{"cholesky"}, \code{"svd"}, \code{"eigen"} \code{"sparse"}, \code{"method undefined"}. In the latter case, the algorithm decides which method might suit best. Note that if \code{use_spam} is not \code{false} the algorithm checks whether a sparse matrix algorithm should be used and which is then tried first. Default: \code{"method undefined"}. } \item{\code{spam_factor}}{ integer. See argument \code{spam_sample_n}. Default: 4294967 } \item{\code{spam_min_n}}{ integer. Has the matrix Default: 400 } \item{\code{spam_min_p}}{ number in \eqn{(0,1)} giving the proportion of zero about which an sparse matrix algorithm is used. Default: \code{0.8} } \item{\code{spam_pivot}}{ integer. Pivoting algorithm for sparse matrices: 0:none; 1:MMD, 2:RCM See package \code{spam} for details. Default: 1 } \item{\code{spam_sample_n}}{ Whether a matrix is sparse or not is tested by a \sQuote{random} sample of size \code{spam_sample_n}; The selection of the sample is iteratively obtained by multiplying the index by \code{spam_factor} modulo the size of the matrix. Default: 500. } \item{\code{spam_tol}}{ largest absolute value being considered as zero. Default: \code{DBL_EPSILON} } \item{\code{svdtol}}{Internal. When the svd decomposition is used for calculating the square root of a matrix then the absolute componentwise difference between this matrix and the square of the square root must be less than \code{svdtol}. No check is performed if \code{svdtol} is not positive. Default: \code{0} } \item{\code{eigen2zero}}{ When the svd or eigen decomposition is calculated, all values with modulus less than or equal to \code{eigen2zero} are set to zero. Default: \code{1e-12} } \item{\code{use_spam}}{ Should the package \code{spam} (sparse matrices) be used for matrix calculations? If \code{TRUE} \pkg{spam} is always used. If \code{FALSE}, it is never used. If \code{NA} its use is determined by the size and the sparsity of the matrix. Default: \code{NA}. } } } \value{ \code{NULL} if any argument is given, and the full list of arguments, otherwise. } %\references{} \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} \url{http://ms.math.uni-mannheim.de/de/publications/software}} \examples{ if (FALSE) { n <- 500 M <- matrix(rnorm(n * n), nc=n) M <- M \%*\% t(M) system.time(chol(M)) system.time(cholesky(M)) RFoptions(cores = 2) system.time(cholesky(M)) } } \keyword{spatial} RandomFieldsUtils/man/cholPosDef.Rd0000644000175100001440000000316313074063617016762 0ustar hornikusers\name{Cholesky} \alias{cholesky} \alias{chol} \alias{cholx} \alias{cholPosDef} \title{Cholesky Decomposition of Positive Definite Matrices} \description{ This function calculates the Choleskey decomposition of a matrix. } \usage{ cholx(a) %, sparse=NA, method=-1) } \arguments{ \item{a}{a square real-valued positive definite matrix } % \item{sparse}{logical or \code{NA}. % If \code{NA} the function determines whether a sparse % matrix algorithm of the package \pkg{spam} should be used. % } % \item{method}{integer vector. % If the sparse matrix algorithm is not used, \code{method} % determines the alternative algorithm. See Details. % } } \value{ a matrix containing the Choleskey decomposition (in its upper part) } \details{ If the matrix is diagonal direct calculations are performed. %Else if the matrix is sparse the package \pkg{spam} is used. Else the Cholesky decomposition is tried. } % \references{ See \link[spam]{chol.spam} of the package \pkg{spam} } \seealso{ \link[spam]{chol.spam} in the package \pkg{spam} } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \keyword{math} \examples{ if (FALSE) { ## This examples shows that 'cholesky' can be much faster ## than 'chol' ## creating a covariance matrix for a temporal process covmatrix <- function(model, x) { x <- as.matrix(dist(x)) return(eval(substitute(model))) } size <- 600 x <- runif(size, 0, size / 10) M <- covmatrix((1 - x) * (x < 1) , x) ## Askey's model of covariance b <- seq(0, 1, len=size) system.time(C2 <- chol(M)) system.time(C1 <- cholx(M)) range(C2 - C1) stopifnot(all(abs(C2 - C1) < 10^{-9})) } } RandomFieldsUtils/man/Print.Rd0000644000175100001440000000131313074063617016023 0ustar hornikusers\name{Print} \alias{Print} \title{Print method returning also the names automatically} \description{ prints variable names and the values } \usage{ Print(..., digits = 6, empty.lines = 2) } \arguments{ \item{...}{any object that can be \command{print}-ed} \item{digits}{see \code{\link{print}}} \item{empty.lines}{number of leading empty lines} } \value{ prints the names and the values; for vectors \command{cat} is used and for lists \command{str} } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} \url{http://ms.math.uni-mannheim.de/de/publications/software}} \keyword{print} \examples{ if (FALSE) { a <- 4 b <- list(c=5, g=7) m <- matrix(1:4, nc=2) Print(a, b, m) } }RandomFieldsUtils/man/sleep.Rd0000644000175100001440000000071713074063617016046 0ustar hornikusers\name{sleep.milli} \alias{sleep.milli} \alias{sleep.micro} \alias{sleep} \title{Sleep} \description{ Process sleeps for a given amount of time } \usage{ sleep.milli(n) sleep.micro(n) } \arguments{ \item{n}{integer. sleeping time units} } \value{ No value is returned. } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \examples{ ## next command waits half a second before returning sleep.milli(500) } \keyword{utilities} \keyword{misc} RandomFieldsUtils/man/sortx.Rd0000644000175100001440000000273413074063617016116 0ustar hornikusers\name{sortx} \alias{sortx} \title{Sorting Vectors} \description{ \command{sortx} has the same functionality as \command{\link[base]{sort}}, except that \code{sortx(..., from=from, to=to)} is the same as \code{sort[from:to]} Sort a vector or factor into ascending or descending order. } \usage{ sortx(x, from=1, to=length(x), decreasing=FALSE, na.last = NA) } \arguments{ \item{x}{an atomic vector} \item{from,to}{\code{sort(..., from=from, to=to)} equals \code{sort(...)[from:to]}} \item{decreasing}{ logical. Should the sort sort be increasing or decreasing? } \item{na.last}{for controlling the treatment of \code{NA}s. If \code{TRUE}, missing values in the data are put last; if \code{FALSE}, they are put first; if \code{NA}, they are removed (see the Notes in \command{\link[base]{sort}}) } } \value{ vector of length \code{to}-\code{from}+1. } \details{ The smaller the difference \code{to}-\code{from} is compared to the length of \code{x}, the faster is \command{sortx} compared to \link[base]{sort}. Particularly, \code{sortx(..., from=k, to=k)} is much faster than \code{sort(...)[k]}. For further details see \link[base]{sort}. } \seealso{ \link{orderx} } \examples{ x <- runif(10^6) k <- 10 system.time(y<-sort(x)[1:k]) system.time(z<-sortx(x, from=1, to=k)) ## much faster stopifnot(all(y == z)) ## same result } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \keyword{univar} \keyword{manip} RandomFieldsUtils/man/nonstwm.Rd0000644000175100001440000000312313074063617016435 0ustar hornikusers\name{nonstwm} \alias{nonstwm} \title{nonstwm} \description{ The non-stationary Whittle-Matern model \eqn{C} is given by \deqn{C(x, y)=\Gamma(\mu) \Gamma(\nu(x))^{-1/2} \Gamma(\nu(y))^{-1/2} W_{\mu} (f(\mu) |x-y|)}{C(x, y)=\Gamma(\mu) \Gamma(\nu(x))^{-1/2} \Gamma(\nu(y))^{-1/2} W_{\mu} (f(\mu) |x-y|)} where \eqn{\mu = [\nu(x) + \nu(y)]/2}, and \eqn{\nu} must a positive function. \eqn{W_{\mu}} is the covariance function \command{\link{whittle}}. The function \eqn{f} takes the following values \describe{ \item{\code{scaling = "whittle"} :}{\eqn{f(\mu) = 1}} \item{\code{scaling = "matern"} :}{\eqn{f(\mu) = \sqrt{2\nu}}} \item{\code{scaling = "handcockwallis"} :}{\eqn{f(\mu) = 2\sqrt{\nu}}} \item{\code{scaling} = s, numerical :}{\eqn{f(\mu) = s * \sqrt{nu}}} } } \usage{ nonstwm(x, y, nu, log=FALSE, scaling=c("whittle", "matern", "handcockwallis")) } \arguments{ \item{x, y}{numerical vectors of the same length} \item{nu}{positive value or a function with positive values and \code{x} as argument} \item{log}{logical. If \code{TRUE} the logirithm of the covariance function is returned.} \item{scaling}{positive value or character; see Details.} } \value{ A single value is returned. } \references{ \itemize{ \item Stein, M. (2005) Nonstationary Spatial Covariance Functions. Tech. Rep., 2005 } } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \seealso{ \command{\link{matern}}. For more details see \command{\link[RandomFields]{RMnonstwm}}. } \examples{ nonstwm(2, 1, sin) } \keyword{spatial} \keyword{models} RandomFieldsUtils/man/gauss.Rd0000644000175100001440000000224113074063617016052 0ustar hornikusers\name{gauss} \alias{gauss} \title{Gaussian Covariance Model} \description{ \command{gauss} is a stationary isotropic covariance model. The corresponding covariance function only depends on the distance \eqn{r \ge 0}{r \ge 0} between two points and is given by \deqn{C(r) = e^{-r^2}}{C(r)=e^{-r^2}.} } \usage{ gauss(x, derivative=0) } \arguments{ \item{x}{numerical vector; for negative values the modulus is used} \item{derivative}{value in \code{0:4}. } } \value{ If \code{derivative=0}, the function value is returned, otherwise the \code{derivative}th derivative. A vector of \code{length(x)} is returned; \code{nu} is recycled; \code{scaling} is recycled if numerical. } \references{ Gelfand, A. E., Diggle, P., Fuentes, M. and Guttorp, P. (eds.) (2010) \emph{Handbook of Spatial Statistics.} Boca Raton: Chapman & Hall/CRL. Stein, M. L. (1999) \emph{Interpolation of Spatial Data.} New York: Springer-Verlag } \author{Martin Schlather, \email{schlather@math.uni-mannheim.de} } \seealso{ For more details see \command{\link[RandomFields]{RMgauss}}. } \keyword{spatial} \keyword{models} \keyword{math} \examples{ x <- 3 stopifnot(gauss(x) == exp(-x^2)) }