meschach-1.2b/ 40755 764 764 0 6552221126 12552 5ustar lapeyrelapeyremeschach-1.2b/copy.c100644 764 764 12632 5515157016 14015 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ static char rcsid[] = "$Id: copy.c,v 1.2 1994/01/13 05:37:14 des Exp $"; #include #include "matrix.h" /* _m_copy -- copies matrix into new area */ MAT *_m_copy(in,out,i0,j0) MAT *in,*out; u_int i0,j0; { u_int i /* ,j */; if ( in==MNULL ) error(E_NULL,"_m_copy"); if ( in==out ) return (out); if ( out==MNULL || out->m < in->m || out->n < in->n ) out = m_resize(out,in->m,in->n); for ( i=i0; i < in->m; i++ ) MEM_COPY(&(in->me[i][j0]),&(out->me[i][j0]), (in->n - j0)*sizeof(Real)); /* for ( j=j0; j < in->n; j++ ) out->me[i][j] = in->me[i][j]; */ return (out); } /* _v_copy -- copies vector into new area */ VEC *_v_copy(in,out,i0) VEC *in,*out; u_int i0; { /* u_int i,j; */ if ( in==VNULL ) error(E_NULL,"_v_copy"); if ( in==out ) return (out); if ( out==VNULL || out->dim < in->dim ) out = v_resize(out,in->dim); MEM_COPY(&(in->ve[i0]),&(out->ve[i0]),(in->dim - i0)*sizeof(Real)); /* for ( i=i0; i < in->dim; i++ ) out->ve[i] = in->ve[i]; */ return (out); } /* px_copy -- copies permutation 'in' to 'out' */ PERM *px_copy(in,out) PERM *in,*out; { /* int i; */ if ( in == PNULL ) error(E_NULL,"px_copy"); if ( in == out ) return out; if ( out == PNULL || out->size != in->size ) out = px_resize(out,in->size); MEM_COPY(in->pe,out->pe,in->size*sizeof(u_int)); /* for ( i = 0; i < in->size; i++ ) out->pe[i] = in->pe[i]; */ return out; } /* The .._move() routines are for moving blocks of memory around within Meschach data structures and for re-arranging matrices, vectors etc. */ /* m_move -- copies selected pieces of a matrix -- moves the m0 x n0 submatrix with top-left cor-ordinates (i0,j0) to the corresponding submatrix of out with top-left co-ordinates (i1,j1) -- out is resized (& created) if necessary */ MAT *m_move(in,i0,j0,m0,n0,out,i1,j1) MAT *in, *out; int i0, j0, m0, n0, i1, j1; { int i; if ( ! in ) error(E_NULL,"m_move"); if ( i0 < 0 || j0 < 0 || i1 < 0 || j1 < 0 || m0 < 0 || n0 < 0 || i0+m0 > in->m || j0+n0 > in->n ) error(E_BOUNDS,"m_move"); if ( ! out ) out = m_resize(out,i1+m0,j1+n0); else if ( i1+m0 > out->m || j1+n0 > out->n ) out = m_resize(out,max(out->m,i1+m0),max(out->n,j1+n0)); for ( i = 0; i < m0; i++ ) MEM_COPY(&(in->me[i0+i][j0]),&(out->me[i1+i][j1]), n0*sizeof(Real)); return out; } /* v_move -- copies selected pieces of a vector -- moves the length dim0 subvector with initial index i0 to the corresponding subvector of out with initial index i1 -- out is resized if necessary */ VEC *v_move(in,i0,dim0,out,i1) VEC *in, *out; int i0, dim0, i1; { if ( ! in ) error(E_NULL,"v_move"); if ( i0 < 0 || dim0 < 0 || i1 < 0 || i0+dim0 > in->dim ) error(E_BOUNDS,"v_move"); if ( (! out) || i1+dim0 > out->dim ) out = v_resize(out,i1+dim0); MEM_COPY(&(in->ve[i0]),&(out->ve[i1]),dim0*sizeof(Real)); return out; } /* mv_move -- copies selected piece of matrix to a vector -- moves the m0 x n0 submatrix with top-left co-ordinate (i0,j0) to the subvector with initial index i1 (and length m0*n0) -- rows are copied contiguously -- out is resized if necessary */ VEC *mv_move(in,i0,j0,m0,n0,out,i1) MAT *in; VEC *out; int i0, j0, m0, n0, i1; { int dim1, i; if ( ! in ) error(E_NULL,"mv_move"); if ( i0 < 0 || j0 < 0 || m0 < 0 || n0 < 0 || i1 < 0 || i0+m0 > in->m || j0+n0 > in->n ) error(E_BOUNDS,"mv_move"); dim1 = m0*n0; if ( (! out) || i1+dim1 > out->dim ) out = v_resize(out,i1+dim1); for ( i = 0; i < m0; i++ ) MEM_COPY(&(in->me[i0+i][j0]),&(out->ve[i1+i*n0]),n0*sizeof(Real)); return out; } /* vm_move -- copies selected piece of vector to a matrix -- moves the subvector with initial index i0 and length m1*n1 to the m1 x n1 submatrix with top-left co-ordinate (i1,j1) -- copying is done by rows -- out is resized if necessary */ MAT *vm_move(in,i0,out,i1,j1,m1,n1) VEC *in; MAT *out; int i0, i1, j1, m1, n1; { int dim0, i; if ( ! in ) error(E_NULL,"vm_move"); if ( i0 < 0 || i1 < 0 || j1 < 0 || m1 < 0 || n1 < 0 || i0+m1*n1 > in->dim ) error(E_BOUNDS,"vm_move"); if ( ! out ) out = m_resize(out,i1+m1,j1+n1); else out = m_resize(out,max(i1+m1,out->m),max(j1+n1,out->n)); dim0 = m1*n1; for ( i = 0; i < m1; i++ ) MEM_COPY(&(in->ve[i0+i*n1]),&(out->me[i1+i][j1]),n1*sizeof(Real)); return out; } meschach-1.2b/err.c100644 764 764 23250 5713176174 13637 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File with basic error-handling operations Based on previous version on Zilog System 8000 setret() etc. Ported to Pyramid 9810 late 1987 */ static char rcsid[] = "$Id: err.c,v 1.6 1995/01/30 14:49:14 des Exp $"; #include #include #include #include "err.h" #ifdef SYSV /* AT&T System V */ #include #else /* something else -- assume BSD or ANSI C */ #include #endif #define FALSE 0 #define TRUE 1 #define EF_EXIT 0 #define EF_ABORT 1 #define EF_JUMP 2 #define EF_SILENT 3 /* The only error caught in this file! */ #define E_SIGNAL 16 static char *err_mesg[] = { "unknown error", /* 0 */ "sizes of objects don't match", /* 1 */ "index out of bounds", /* 2 */ "can't allocate memory", /* 3 */ "singular matrix", /* 4 */ "matrix not positive definite", /* 5 */ "incorrect format input", /* 6 */ "bad input file/device", /* 7 */ "NULL objects passed", /* 8 */ "matrix not square", /* 9 */ "object out of range", /* 10 */ "can't do operation in situ for non-square matrix", /* 11 */ "can't do operation in situ", /* 12 */ "excessive number of iterations", /* 13 */ "convergence criterion failed", /* 14 */ "bad starting value", /* 15 */ "floating exception", /* 16 */ "internal inconsistency (data structure)",/* 17 */ "unexpected end-of-file", /* 18 */ "shared vectors (cannot release them)", /* 19 */ "negative argument", /* 20 */ "cannot overwrite object", /* 21 */ "breakdown in iterative method" /* 22 */ }; #define MAXERR (sizeof(err_mesg)/sizeof(char *)) static char *warn_mesg[] = { "unknown warning", /* 0 */ "wrong type number (use macro TYPE_*)", /* 1 */ "no corresponding mem_stat_mark", /* 2 */ "computed norm of a residual is less than 0", /* 3 */ "resizing a shared vector" /* 4 */ }; #define MAXWARN (sizeof(warn_mesg)/sizeof(char *)) #define MAX_ERRS 100 jmp_buf restart; /* array of pointers to lists of errors */ typedef struct { char **listp; /* pointer to a list of errors */ unsigned len; /* length of the list */ unsigned warn; /* =FALSE - errors, =TRUE - warnings */ } Err_list; static Err_list err_list[ERR_LIST_MAX_LEN] = { {err_mesg,MAXERR,FALSE}, /* basic errors list */ {warn_mesg,MAXWARN,TRUE} /* basic warnings list */ }; static int err_list_end = 2; /* number of elements in err_list */ /* attach a new list of errors pointed by err_ptr or change a previous one; list_len is the number of elements in the list; list_num is the list number; warn == FALSE - errors (stop the program), warn == TRUE - warnings (continue the program); Note: lists numbered 0 and 1 are attached automatically, you do not need to do it */ int err_list_attach(list_num, list_len,err_ptr,warn) int list_num, list_len, warn; char **err_ptr; { if (list_num < 0 || list_len <= 0 || err_ptr == (char **)NULL) return -1; if (list_num >= ERR_LIST_MAX_LEN) { fprintf(stderr,"\n file \"%s\": %s %s\n", "err.c","increase the value of ERR_LIST_MAX_LEN", "in matrix.h and zmatdef.h"); if ( ! isatty(fileno(stdout)) ) fprintf(stderr,"\n file \"%s\": %s %s\n", "err.c","increase the value of ERR_LIST_MAX_LEN", "in matrix.h and zmatdef.h"); printf("Exiting program\n"); exit(0); } if (err_list[list_num].listp != (char **)NULL && err_list[list_num].listp != err_ptr) free((char *)err_list[list_num].listp); err_list[list_num].listp = err_ptr; err_list[list_num].len = list_len; err_list[list_num].warn = warn; err_list_end = list_num+1; return list_num; } /* release the error list numbered list_num */ int err_list_free(list_num) int list_num; { if (list_num < 0 || list_num >= err_list_end) return -1; if (err_list[list_num].listp != (char **)NULL) { err_list[list_num].listp = (char **)NULL; err_list[list_num].len = 0; err_list[list_num].warn = 0; } return 0; } /* check if list_num is attached; return FALSE if not; return TRUE if yes */ int err_is_list_attached(list_num) int list_num; { if (list_num < 0 || list_num >= err_list_end) return FALSE; if (err_list[list_num].listp != (char **)NULL) return TRUE; return FALSE; } /* other local variables */ static int err_flag = EF_EXIT, num_errs = 0, cnt_errs = 1; /* set_err_flag -- sets err_flag -- returns old err_flag */ int set_err_flag(flag) int flag; { int tmp; tmp = err_flag; err_flag = flag; return tmp; } /* count_errs -- sets cnt_errs (TRUE/FALSE) & returns old value */ int count_errs(flag) int flag; { int tmp; tmp = cnt_errs; cnt_errs = flag; return tmp; } /* ev_err -- reports error (err_num) in file "file" at line "line_num" and returns to user error handler; list_num is an error list number (0 is the basic list pointed by err_mesg, 1 is the basic list of warnings) */ int ev_err(file,err_num,line_num,fn_name,list_num) char *file, *fn_name; int err_num, line_num,list_num; { int num; if ( err_num < 0 ) err_num = 0; if (list_num < 0 || list_num >= err_list_end || err_list[list_num].listp == (char **)NULL) { fprintf(stderr, "\n Not (properly) attached list of errors: list_num = %d\n", list_num); fprintf(stderr," Call \"err_list_attach\" in your program\n"); if ( ! isatty(fileno(stdout)) ) { fprintf(stderr, "\n Not (properly) attached list of errors: list_num = %d\n", list_num); fprintf(stderr," Call \"err_list_attach\" in your program\n"); } printf("\nExiting program\n"); exit(0); } num = err_num; if ( num >= err_list[list_num].len ) num = 0; if ( cnt_errs && ++num_errs >= MAX_ERRS ) /* too many errors */ { fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); printf("Sorry, too many errors: %d\n",num_errs); printf("Exiting program\n"); exit(0); } if ( err_list[list_num].warn ) switch ( err_flag ) { case EF_SILENT: break; default: fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); break; } else switch ( err_flag ) { case EF_SILENT: longjmp(restart,(err_num==0)? -1 : err_num); break; case EF_ABORT: fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); abort(); break; case EF_JUMP: fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); longjmp(restart,(err_num==0)? -1 : err_num); break; default: fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); break; } /* ensure exit if fall through */ if ( ! err_list[list_num].warn ) exit(0); return 0; } /* float_error -- catches floating arithmetic signals */ static void float_error(num) int num; { signal(SIGFPE,float_error); /* fprintf(stderr,"SIGFPE: signal #%d\n",num); */ /* fprintf(stderr,"errno = %d\n",errno); */ ev_err("???.c",E_SIGNAL,0,"???",0); } /* catch_signal -- sets up float_error() to catch SIGFPE's */ void catch_FPE() { signal(SIGFPE,float_error); } meschach-1.2b/matrixio.c100644 764 764 32141 5515156245 14677 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* 1.6 matrixio.c 11/25/87 */ #include #include #include "matrix.h" static char rcsid[] = "$Id: matrixio.c,v 1.4 1994/01/13 05:31:10 des Exp $"; /* local variables */ static char line[MAXLINE]; /************************************************************************** Input routines **************************************************************************/ /* skipjunk -- skips white spaces and strings of the form #....\n Here .... is a comment string */ int skipjunk(fp) FILE *fp; { int c; for ( ; ; ) /* forever do... */ { /* skip blanks */ do c = getc(fp); while ( isspace(c) ); /* skip comments (if any) */ if ( c == '#' ) /* yes it is a comment (line) */ while ( (c=getc(fp)) != '\n' ) ; else { ungetc(c,fp); break; } } return 0; } MAT *m_finput(fp,a) FILE *fp; MAT *a; { MAT *im_finput(),*bm_finput(); if ( isatty(fileno(fp)) ) return im_finput(fp,a); else return bm_finput(fp,a); } /* im_finput -- interactive input of matrix */ MAT *im_finput(fp,mat) FILE *fp; MAT *mat; { char c; u_int i, j, m, n, dynamic; /* dynamic set to TRUE if memory allocated here */ /* get matrix size */ if ( mat != (MAT *)NULL && mat->mnm; n = mat->n; dynamic = FALSE; } else { dynamic = TRUE; do { fprintf(stderr,"Matrix: rows cols:"); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"im_finput"); } while ( sscanf(line,"%u%u",&m,&n)<2 || m>MAXDIM || n>MAXDIM ); mat = m_get(m,n); } /* input elements */ for ( i=0; ime[i][j]); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"im_finput"); if ( (*line == 'b' || *line == 'B') && j > 0 ) { j--; dynamic = FALSE; goto redo2; } if ( (*line == 'f' || *line == 'F') && j < n-1 ) { j++; dynamic = FALSE; goto redo2; } #if REAL == DOUBLE } while ( *line=='\0' || sscanf(line,"%lf",&mat->me[i][j])<1 ); #elif REAL == FLOAT } while ( *line=='\0' || sscanf(line,"%f",&mat->me[i][j])<1 ); #endif fprintf(stderr,"Continue: "); fscanf(fp,"%c",&c); if ( c == 'n' || c == 'N' ) { dynamic = FALSE; goto redo; } if ( (c == 'b' || c == 'B') /* && i > 0 */ ) { if ( i > 0 ) i--; dynamic = FALSE; goto redo; } } return (mat); } /* bm_finput -- batch-file input of matrix */ MAT *bm_finput(fp,mat) FILE *fp; MAT *mat; { u_int i,j,m,n,dummy; int io_code; /* get dimension */ skipjunk(fp); if ((io_code=fscanf(fp," Matrix: %u by %u",&m,&n)) < 2 || m>MAXDIM || n>MAXDIM ) error(io_code==EOF ? E_EOF : E_FORMAT,"bm_finput"); /* allocate memory if necessary */ if ( mat==(MAT *)NULL ) mat = m_resize(mat,m,n); /* get entries */ for ( i=0; ime[i][j])) < 1 ) #elif REAL == FLOAT if ((io_code=fscanf(fp,"%f",&mat->me[i][j])) < 1 ) #endif error(io_code==EOF ? 7 : 6,"bm_finput"); } return (mat); } PERM *px_finput(fp,px) FILE *fp; PERM *px; { PERM *ipx_finput(),*bpx_finput(); if ( isatty(fileno(fp)) ) return ipx_finput(fp,px); else return bpx_finput(fp,px); } /* ipx_finput -- interactive input of permutation */ PERM *ipx_finput(fp,px) FILE *fp; PERM *px; { u_int i,j,size,dynamic; /* dynamic set if memory allocated here */ u_int entry,ok; /* get permutation size */ if ( px!=(PERM *)NULL && px->sizesize; dynamic = FALSE; } else { dynamic = TRUE; do { fprintf(stderr,"Permutation: size: "); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"ipx_finput"); } while ( sscanf(line,"%u",&size)<1 || size>MAXDIM ); px = px_get(size); } /* get entries */ i = 0; while ( i%u new: ", i,px->pe[i]); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"ipx_finput"); if ( (*line == 'b' || *line == 'B') && i > 0 ) { i--; dynamic = FALSE; goto redo; } } while ( *line=='\0' || sscanf(line,"%u",&entry) < 1 ); /* check entry */ ok = (entry < size); for ( j=0; jpe[j]); if ( ok ) { px->pe[i] = entry; i++; } } return (px); } /* bpx_finput -- batch-file input of permutation */ PERM *bpx_finput(fp,px) FILE *fp; PERM *px; { u_int i,j,size,entry,ok; int io_code; /* get size of permutation */ skipjunk(fp); if ((io_code=fscanf(fp," Permutation: size:%u",&size)) < 1 || size>MAXDIM ) error(io_code==EOF ? 7 : 6,"bpx_finput"); /* allocate memory if necessary */ if ( px==(PERM *)NULL || px->size %u",&entry)) < 1 ) error(io_code==EOF ? 7 : 6,"bpx_finput"); /* check entry */ ok = (entry < size); for ( j=0; jpe[j]); if ( ok ) { px->pe[i] = entry; i++; } else error(E_BOUNDS,"bpx_finput"); } return (px); } VEC *v_finput(fp,x) FILE *fp; VEC *x; { VEC *ifin_vec(),*bfin_vec(); if ( isatty(fileno(fp)) ) return ifin_vec(fp,x); else return bfin_vec(fp,x); } /* ifin_vec -- interactive input of vector */ VEC *ifin_vec(fp,vec) FILE *fp; VEC *vec; { u_int i,dim,dynamic; /* dynamic set if memory allocated here */ /* get vector dimension */ if ( vec != (VEC *)NULL && vec->dimdim; dynamic = FALSE; } else { dynamic = TRUE; do { fprintf(stderr,"Vector: dim: "); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"ifin_vec"); } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); vec = v_get(dim); } /* input elements */ for ( i=0; ive[i]); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"ifin_vec"); if ( (*line == 'b' || *line == 'B') && i > 0 ) { i--; dynamic = FALSE; goto redo; } if ( (*line == 'f' || *line == 'F') && i < dim-1 ) { i++; dynamic = FALSE; goto redo; } #if REAL == DOUBLE } while ( *line=='\0' || sscanf(line,"%lf",&vec->ve[i]) < 1 ); #elif REAL == FLOAT } while ( *line=='\0' || sscanf(line,"%f",&vec->ve[i]) < 1 ); #endif return (vec); } /* bfin_vec -- batch-file input of vector */ VEC *bfin_vec(fp,vec) FILE *fp; VEC *vec; { u_int i,dim; int io_code; /* get dimension */ skipjunk(fp); if ((io_code=fscanf(fp," Vector: dim:%u",&dim)) < 1 || dim>MAXDIM ) error(io_code==EOF ? 7 : 6,"bfin_vec"); /* allocate memory if necessary */ if ( vec==(VEC *)NULL ) vec = v_resize(vec,dim); /* get entries */ skipjunk(fp); for ( i=0; ive[i])) < 1 ) #elif REAL == FLOAT if ((io_code=fscanf(fp,"%f",&vec->ve[i])) < 1 ) #endif error(io_code==EOF ? 7 : 6,"bfin_vec"); return (vec); } /************************************************************************** Output routines **************************************************************************/ static char *format = "%14.9g "; char *setformat(f_string) char *f_string; { char *old_f_string; old_f_string = format; if ( f_string != (char *)NULL && *f_string != '\0' ) format = f_string; return old_f_string; } void m_foutput(fp,a) FILE *fp; MAT *a; { u_int i, j, tmp; if ( a == (MAT *)NULL ) { fprintf(fp,"Matrix: NULL\n"); return; } fprintf(fp,"Matrix: %d by %d\n",a->m,a->n); if ( a->me == (Real **)NULL ) { fprintf(fp,"NULL\n"); return; } for ( i=0; im; i++ ) /* for each row... */ { fprintf(fp,"row %u: ",i); for ( j=0, tmp=2; jn; j++, tmp++ ) { /* for each col in row... */ fprintf(fp,format,a->me[i][j]); if ( ! (tmp % 5) ) putc('\n',fp); } if ( tmp % 5 != 1 ) putc('\n',fp); } } void px_foutput(fp,px) FILE *fp; PERM *px; { u_int i; if ( px == (PERM *)NULL ) { fprintf(fp,"Permutation: NULL\n"); return; } fprintf(fp,"Permutation: size: %u\n",px->size); if ( px->pe == (u_int *)NULL ) { fprintf(fp,"NULL\n"); return; } for ( i=0; isize; i++ ) if ( ! (i % 8) && i != 0 ) fprintf(fp,"\n %u->%u ",i,px->pe[i]); else fprintf(fp,"%u->%u ",i,px->pe[i]); fprintf(fp,"\n"); } void v_foutput(fp,x) FILE *fp; VEC *x; { u_int i, tmp; if ( x == (VEC *)NULL ) { fprintf(fp,"Vector: NULL\n"); return; } fprintf(fp,"Vector: dim: %d\n",x->dim); if ( x->ve == (Real *)NULL ) { fprintf(fp,"NULL\n"); return; } for ( i=0, tmp=0; idim; i++, tmp++ ) { fprintf(fp,format,x->ve[i]); if ( tmp % 5 == 4 ) putc('\n',fp); } if ( tmp % 5 != 0 ) putc('\n',fp); } void m_dump(fp,a) FILE *fp; MAT *a; { u_int i, j, tmp; if ( a == (MAT *)NULL ) { fprintf(fp,"Matrix: NULL\n"); return; } fprintf(fp,"Matrix: %d by %d @ 0x%lx\n",a->m,a->n,(long)a); fprintf(fp,"\tmax_m = %d, max_n = %d, max_size = %d\n", a->max_m, a->max_n, a->max_size); if ( a->me == (Real **)NULL ) { fprintf(fp,"NULL\n"); return; } fprintf(fp,"a->me @ 0x%lx\n",(long)(a->me)); fprintf(fp,"a->base @ 0x%lx\n",(long)(a->base)); for ( i=0; im; i++ ) /* for each row... */ { fprintf(fp,"row %u: @ 0x%lx ",i,(long)(a->me[i])); for ( j=0, tmp=2; jn; j++, tmp++ ) { /* for each col in row... */ fprintf(fp,format,a->me[i][j]); if ( ! (tmp % 5) ) putc('\n',fp); } if ( tmp % 5 != 1 ) putc('\n',fp); } } void px_dump(fp,px) FILE *fp; PERM *px; { u_int i; if ( ! px ) { fprintf(fp,"Permutation: NULL\n"); return; } fprintf(fp,"Permutation: size: %u @ 0x%lx\n",px->size,(long)(px)); if ( ! px->pe ) { fprintf(fp,"NULL\n"); return; } fprintf(fp,"px->pe @ 0x%lx\n",(long)(px->pe)); for ( i=0; isize; i++ ) fprintf(fp,"%u->%u ",i,px->pe[i]); fprintf(fp,"\n"); } void v_dump(fp,x) FILE *fp; VEC *x; { u_int i, tmp; if ( ! x ) { fprintf(fp,"Vector: NULL\n"); return; } fprintf(fp,"Vector: dim: %d @ 0x%lx\n",x->dim,(long)(x)); if ( ! x->ve ) { fprintf(fp,"NULL\n"); return; } fprintf(fp,"x->ve @ 0x%lx\n",(long)(x->ve)); for ( i=0, tmp=0; idim; i++, tmp++ ) { fprintf(fp,format,x->ve[i]); if ( tmp % 5 == 4 ) putc('\n',fp); } if ( tmp % 5 != 0 ) putc('\n',fp); } meschach-1.2b/memory.c100644 764 764 46716 5550144454 14366 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* memory.c 1.3 11/25/87 */ #include "matrix.h" static char rcsid[] = "$Id: memory.c,v 1.13 1994/04/05 02:10:37 des Exp $"; /* m_get -- gets an mxn matrix (in MAT form) by dynamic memory allocation */ MAT *m_get(m,n) int m,n; { MAT *matrix; int i; if (m < 0 || n < 0) error(E_NEG,"m_get"); if ((matrix=NEW(MAT)) == (MAT *)NULL ) error(E_MEM,"m_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,sizeof(MAT)); mem_numvar(TYPE_MAT,1); } matrix->m = m; matrix->n = matrix->max_n = n; matrix->max_m = m; matrix->max_size = m*n; #ifndef SEGMENTED if ((matrix->base = NEW_A(m*n,Real)) == (Real *)NULL ) { free(matrix); error(E_MEM,"m_get"); } else if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,m*n*sizeof(Real)); } #else matrix->base = (Real *)NULL; #endif if ((matrix->me = (Real **)calloc(m,sizeof(Real *))) == (Real **)NULL ) { free(matrix->base); free(matrix); error(E_MEM,"m_get"); } else if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,m*sizeof(Real *)); } #ifndef SEGMENTED /* set up pointers */ for ( i=0; ime[i] = &(matrix->base[i*n]); #else for ( i = 0; i < m; i++ ) if ( (matrix->me[i]=NEW_A(n,Real)) == (Real *)NULL ) error(E_MEM,"m_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,n*sizeof(Real)); } #endif return (matrix); } /* px_get -- gets a PERM of given 'size' by dynamic memory allocation -- Note: initialized to the identity permutation */ PERM *px_get(size) int size; { PERM *permute; int i; if (size < 0) error(E_NEG,"px_get"); if ((permute=NEW(PERM)) == (PERM *)NULL ) error(E_MEM,"px_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_PERM,0,sizeof(PERM)); mem_numvar(TYPE_PERM,1); } permute->size = permute->max_size = size; if ((permute->pe = NEW_A(size,u_int)) == (u_int *)NULL ) error(E_MEM,"px_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_PERM,0,size*sizeof(u_int)); } for ( i=0; ipe[i] = i; return (permute); } /* v_get -- gets a VEC of dimension 'dim' -- Note: initialized to zero */ VEC *v_get(size) int size; { VEC *vector; if (size < 0) error(E_NEG,"v_get"); if ((vector=NEW(VEC)) == (VEC *)NULL ) error(E_MEM,"v_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_VEC,0,sizeof(VEC)); mem_numvar(TYPE_VEC,1); } vector->dim = vector->max_dim = size; if ((vector->ve=NEW_A(size,Real)) == (Real *)NULL ) { free(vector); error(E_MEM,"v_get"); } else if (mem_info_is_on()) { mem_bytes(TYPE_VEC,0,size*sizeof(Real)); } return (vector); } /* m_free -- returns MAT & asoociated memory back to memory heap */ int m_free(mat) MAT *mat; { #ifdef SEGMENTED int i; #endif if ( mat==(MAT *)NULL || (int)(mat->m) < 0 || (int)(mat->n) < 0 ) /* don't trust it */ return (-1); #ifndef SEGMENTED if ( mat->base != (Real *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_MAT,mat->max_m*mat->max_n*sizeof(Real),0); } free((char *)(mat->base)); } #else for ( i = 0; i < mat->max_m; i++ ) if ( mat->me[i] != (Real *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_MAT,mat->max_n*sizeof(Real),0); } free((char *)(mat->me[i])); } #endif if ( mat->me != (Real **)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_MAT,mat->max_m*sizeof(Real *),0); } free((char *)(mat->me)); } if (mem_info_is_on()) { mem_bytes(TYPE_MAT,sizeof(MAT),0); mem_numvar(TYPE_MAT,-1); } free((char *)mat); return (0); } /* px_free -- returns PERM & asoociated memory back to memory heap */ int px_free(px) PERM *px; { if ( px==(PERM *)NULL || (int)(px->size) < 0 ) /* don't trust it */ return (-1); if ( px->pe == (u_int *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_PERM,sizeof(PERM),0); mem_numvar(TYPE_PERM,-1); } free((char *)px); } else { if (mem_info_is_on()) { mem_bytes(TYPE_PERM,sizeof(PERM)+px->max_size*sizeof(u_int),0); mem_numvar(TYPE_PERM,-1); } free((char *)px->pe); free((char *)px); } return (0); } /* v_free -- returns VEC & asoociated memory back to memory heap */ int v_free(vec) VEC *vec; { if ( vec==(VEC *)NULL || (int)(vec->dim) < 0 ) /* don't trust it */ return (-1); if ( vec->ve == (Real *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_VEC,sizeof(VEC),0); mem_numvar(TYPE_VEC,-1); } free((char *)vec); } else { if (mem_info_is_on()) { mem_bytes(TYPE_VEC,sizeof(VEC)+vec->max_dim*sizeof(Real),0); mem_numvar(TYPE_VEC,-1); } free((char *)vec->ve); free((char *)vec); } return (0); } /* m_resize -- returns the matrix A of size new_m x new_n; A is zeroed -- if A == NULL on entry then the effect is equivalent to m_get() */ MAT *m_resize(A,new_m,new_n) MAT *A; int new_m, new_n; { int i; int new_max_m, new_max_n, new_size, old_m, old_n; if (new_m < 0 || new_n < 0) error(E_NEG,"m_resize"); if ( ! A ) return m_get(new_m,new_n); /* nothing was changed */ if (new_m == A->m && new_n == A->n) return A; old_m = A->m; old_n = A->n; if ( new_m > A->max_m ) { /* re-allocate A->me */ if (mem_info_is_on()) { mem_bytes(TYPE_MAT,A->max_m*sizeof(Real *), new_m*sizeof(Real *)); } A->me = RENEW(A->me,new_m,Real *); if ( ! A->me ) error(E_MEM,"m_resize"); } new_max_m = max(new_m,A->max_m); new_max_n = max(new_n,A->max_n); #ifndef SEGMENTED new_size = new_max_m*new_max_n; if ( new_size > A->max_size ) { /* re-allocate A->base */ if (mem_info_is_on()) { mem_bytes(TYPE_MAT,A->max_m*A->max_n*sizeof(Real), new_size*sizeof(Real)); } A->base = RENEW(A->base,new_size,Real); if ( ! A->base ) error(E_MEM,"m_resize"); A->max_size = new_size; } /* now set up A->me[i] */ for ( i = 0; i < new_m; i++ ) A->me[i] = &(A->base[i*new_n]); /* now shift data in matrix */ if ( old_n > new_n ) { for ( i = 1; i < min(old_m,new_m); i++ ) MEM_COPY((char *)&(A->base[i*old_n]), (char *)&(A->base[i*new_n]), sizeof(Real)*new_n); } else if ( old_n < new_n ) { for ( i = (int)(min(old_m,new_m))-1; i > 0; i-- ) { /* copy & then zero extra space */ MEM_COPY((char *)&(A->base[i*old_n]), (char *)&(A->base[i*new_n]), sizeof(Real)*old_n); __zero__(&(A->base[i*new_n+old_n]),(new_n-old_n)); } __zero__(&(A->base[old_n]),(new_n-old_n)); A->max_n = new_n; } /* zero out the new rows.. */ for ( i = old_m; i < new_m; i++ ) __zero__(&(A->base[i*new_n]),new_n); #else if ( A->max_n < new_n ) { Real *tmp; for ( i = 0; i < A->max_m; i++ ) { if (mem_info_is_on()) { mem_bytes(TYPE_MAT,A->max_n*sizeof(Real), new_max_n*sizeof(Real)); } if ( (tmp = RENEW(A->me[i],new_max_n,Real)) == NULL ) error(E_MEM,"m_resize"); else { A->me[i] = tmp; } } for ( i = A->max_m; i < new_max_m; i++ ) { if ( (tmp = NEW_A(new_max_n,Real)) == NULL ) error(E_MEM,"m_resize"); else { A->me[i] = tmp; if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,new_max_n*sizeof(Real)); } } } } else if ( A->max_m < new_m ) { for ( i = A->max_m; i < new_m; i++ ) if ( (A->me[i] = NEW_A(new_max_n,Real)) == NULL ) error(E_MEM,"m_resize"); else if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,new_max_n*sizeof(Real)); } } if ( old_n < new_n ) { for ( i = 0; i < old_m; i++ ) __zero__(&(A->me[i][old_n]),new_n-old_n); } /* zero out the new rows.. */ for ( i = old_m; i < new_m; i++ ) __zero__(A->me[i],new_n); #endif A->max_m = new_max_m; A->max_n = new_max_n; A->max_size = A->max_m*A->max_n; A->m = new_m; A->n = new_n; return A; } /* px_resize -- returns the permutation px with size new_size -- px is set to the identity permutation */ PERM *px_resize(px,new_size) PERM *px; int new_size; { int i; if (new_size < 0) error(E_NEG,"px_resize"); if ( ! px ) return px_get(new_size); /* nothing is changed */ if (new_size == px->size) return px; if ( new_size > px->max_size ) { if (mem_info_is_on()) { mem_bytes(TYPE_PERM,px->max_size*sizeof(u_int), new_size*sizeof(u_int)); } px->pe = RENEW(px->pe,new_size,u_int); if ( ! px->pe ) error(E_MEM,"px_resize"); px->max_size = new_size; } if ( px->size <= new_size ) /* extend permutation */ for ( i = px->size; i < new_size; i++ ) px->pe[i] = i; else for ( i = 0; i < new_size; i++ ) px->pe[i] = i; px->size = new_size; return px; } /* v_resize -- returns the vector x with dim new_dim -- x is set to the zero vector */ VEC *v_resize(x,new_dim) VEC *x; int new_dim; { if (new_dim < 0) error(E_NEG,"v_resize"); if ( ! x ) return v_get(new_dim); /* nothing is changed */ if (new_dim == x->dim) return x; if ( x->max_dim == 0 ) /* assume that it's from sub_vec */ return v_get(new_dim); if ( new_dim > x->max_dim ) { if (mem_info_is_on()) { mem_bytes(TYPE_VEC,x->max_dim*sizeof(Real), new_dim*sizeof(Real)); } x->ve = RENEW(x->ve,new_dim,Real); if ( ! x->ve ) error(E_MEM,"v_resize"); x->max_dim = new_dim; } if ( new_dim > x->dim ) __zero__(&(x->ve[x->dim]),new_dim - x->dim); x->dim = new_dim; return x; } /* Varying number of arguments */ /* other functions of this type are in sparse.c and zmemory.c */ #ifdef ANSI_C /* To allocate memory to many arguments. The function should be called: v_get_vars(dim,&x,&y,&z,...,NULL); where int dim; VEC *x, *y, *z,...; The last argument should be NULL ! dim is the length of vectors x,y,z,... returned value is equal to the number of allocated variables Other gec_... functions are similar. */ int v_get_vars(int dim,...) { va_list ap; int i=0; VEC **par; va_start(ap, dim); while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ *par = v_get(dim); i++; } va_end(ap); return i; } int iv_get_vars(int dim,...) { va_list ap; int i=0; IVEC **par; va_start(ap, dim); while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ *par = iv_get(dim); i++; } va_end(ap); return i; } int m_get_vars(int m,int n,...) { va_list ap; int i=0; MAT **par; va_start(ap, n); while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ *par = m_get(m,n); i++; } va_end(ap); return i; } int px_get_vars(int dim,...) { va_list ap; int i=0; PERM **par; va_start(ap, dim); while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ *par = px_get(dim); i++; } va_end(ap); return i; } /* To resize memory for many arguments. The function should be called: v_resize_vars(new_dim,&x,&y,&z,...,NULL); where int new_dim; VEC *x, *y, *z,...; The last argument should be NULL ! rdim is the resized length of vectors x,y,z,... returned value is equal to the number of allocated variables. If one of x,y,z,.. arguments is NULL then memory is allocated to this argument. Other *_resize_list() functions are similar. */ int v_resize_vars(int new_dim,...) { va_list ap; int i=0; VEC **par; va_start(ap, new_dim); while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ *par = v_resize(*par,new_dim); i++; } va_end(ap); return i; } int iv_resize_vars(int new_dim,...) { va_list ap; int i=0; IVEC **par; va_start(ap, new_dim); while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ *par = iv_resize(*par,new_dim); i++; } va_end(ap); return i; } int m_resize_vars(int m,int n,...) { va_list ap; int i=0; MAT **par; va_start(ap, n); while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ *par = m_resize(*par,m,n); i++; } va_end(ap); return i; } int px_resize_vars(int new_dim,...) { va_list ap; int i=0; PERM **par; va_start(ap, new_dim); while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ *par = px_resize(*par,new_dim); i++; } va_end(ap); return i; } /* To deallocate memory for many arguments. The function should be called: v_free_vars(&x,&y,&z,...,NULL); where VEC *x, *y, *z,...; The last argument should be NULL ! There must be at least one not NULL argument. returned value is equal to the number of allocated variables. Returned value of x,y,z,.. is VNULL. Other *_free_list() functions are similar. */ int v_free_vars(VEC **pv,...) { va_list ap; int i=1; VEC **par; v_free(*pv); *pv = VNULL; va_start(ap, pv); while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ v_free(*par); *par = VNULL; i++; } va_end(ap); return i; } int iv_free_vars(IVEC **ipv,...) { va_list ap; int i=1; IVEC **par; iv_free(*ipv); *ipv = IVNULL; va_start(ap, ipv); while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ iv_free(*par); *par = IVNULL; i++; } va_end(ap); return i; } int px_free_vars(PERM **vpx,...) { va_list ap; int i=1; PERM **par; px_free(*vpx); *vpx = PNULL; va_start(ap, vpx); while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ px_free(*par); *par = PNULL; i++; } va_end(ap); return i; } int m_free_vars(MAT **va,...) { va_list ap; int i=1; MAT **par; m_free(*va); *va = MNULL; va_start(ap, va); while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ m_free(*par); *par = MNULL; i++; } va_end(ap); return i; } #elif VARARGS /* old varargs is used */ /* To allocate memory to many arguments. The function should be called: v_get_vars(dim,&x,&y,&z,...,VNULL); where int dim; VEC *x, *y, *z,...; The last argument should be VNULL ! dim is the length of vectors x,y,z,... */ int v_get_vars(va_alist) va_dcl { va_list ap; int dim,i=0; VEC **par; va_start(ap); dim = va_arg(ap,int); while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ *par = v_get(dim); i++; } va_end(ap); return i; } int iv_get_vars(va_alist) va_dcl { va_list ap; int i=0, dim; IVEC **par; va_start(ap); dim = va_arg(ap,int); while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ *par = iv_get(dim); i++; } va_end(ap); return i; } int m_get_vars(va_alist) va_dcl { va_list ap; int i=0, n, m; MAT **par; va_start(ap); m = va_arg(ap,int); n = va_arg(ap,int); while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ *par = m_get(m,n); i++; } va_end(ap); return i; } int px_get_vars(va_alist) va_dcl { va_list ap; int i=0, dim; PERM **par; va_start(ap); dim = va_arg(ap,int); while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ *par = px_get(dim); i++; } va_end(ap); return i; } /* To resize memory for many arguments. The function should be called: v_resize_vars(new_dim,&x,&y,&z,...,NULL); where int new_dim; VEC *x, *y, *z,...; The last argument should be NULL ! rdim is the resized length of vectors x,y,z,... returned value is equal to the number of allocated variables. If one of x,y,z,.. arguments is NULL then memory is allocated to this argument. Other *_resize_list() functions are similar. */ int v_resize_vars(va_alist) va_dcl { va_list ap; int i=0, new_dim; VEC **par; va_start(ap); new_dim = va_arg(ap,int); while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ *par = v_resize(*par,new_dim); i++; } va_end(ap); return i; } int iv_resize_vars(va_alist) va_dcl { va_list ap; int i=0, new_dim; IVEC **par; va_start(ap); new_dim = va_arg(ap,int); while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ *par = iv_resize(*par,new_dim); i++; } va_end(ap); return i; } int m_resize_vars(va_alist) va_dcl { va_list ap; int i=0, m, n; MAT **par; va_start(ap); m = va_arg(ap,int); n = va_arg(ap,int); while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ *par = m_resize(*par,m,n); i++; } va_end(ap); return i; } int px_resize_vars(va_alist) va_dcl { va_list ap; int i=0, new_dim; PERM **par; va_start(ap); new_dim = va_arg(ap,int); while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ *par = px_resize(*par,new_dim); i++; } va_end(ap); return i; } /* To deallocate memory for many arguments. The function should be called: v_free_vars(&x,&y,&z,...,NULL); where VEC *x, *y, *z,...; The last argument should be NULL ! returned value is equal to the number of allocated variables. Returned value of x,y,z,.. is VNULL. Other *_free_list() functions are similar. */ int v_free_vars(va_alist) va_dcl { va_list ap; int i=0; VEC **par; va_start(ap); while (par = va_arg(ap,VEC **)) { /* NULL ends the list*/ v_free(*par); *par = VNULL; i++; } va_end(ap); return i; } int iv_free_vars(va_alist) va_dcl { va_list ap; int i=0; IVEC **par; va_start(ap); while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/ iv_free(*par); *par = IVNULL; i++; } va_end(ap); return i; } int px_free_vars(va_alist) va_dcl { va_list ap; int i=0; PERM **par; va_start(ap); while (par = va_arg(ap,PERM **)) { /* NULL ends the list*/ px_free(*par); *par = PNULL; i++; } va_end(ap); return i; } int m_free_vars(va_alist) va_dcl { va_list ap; int i=0; MAT **par; va_start(ap); while (par = va_arg(ap,MAT **)) { /* NULL ends the list*/ m_free(*par); *par = MNULL; i++; } va_end(ap); return i; } #endif /* VARARGS */ meschach-1.2b/vecop.c100644 764 764 32166 5537011100 14146 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* vecop.c 1.3 8/18/87 */ #include #include "matrix.h" static char rcsid[] = "$Id: vecop.c,v 1.4 1994/03/08 05:50:39 des Exp $"; /* _in_prod -- inner product of two vectors from i0 downwards */ double _in_prod(a,b,i0) VEC *a,*b; u_int i0; { u_int limit; /* Real *a_v, *b_v; */ /* register Real sum; */ if ( a==(VEC *)NULL || b==(VEC *)NULL ) error(E_NULL,"_in_prod"); limit = min(a->dim,b->dim); if ( i0 > limit ) error(E_BOUNDS,"_in_prod"); return __ip__(&(a->ve[i0]),&(b->ve[i0]),(int)(limit-i0)); /***************************************** a_v = &(a->ve[i0]); b_v = &(b->ve[i0]); for ( i=i0; idim != vector->dim ) out = v_resize(out,vector->dim); if ( scalar == 0.0 ) return v_zero(out); if ( scalar == 1.0 ) return v_copy(vector,out); __smlt__(vector->ve,(double)scalar,out->ve,(int)(vector->dim)); /************************************************** dim = vector->dim; out_ve = out->ve; vec_ve = vector->ve; for ( i=0; ive[i] = scalar*vector->ve[i]; (*out_ve++) = scalar*(*vec_ve++); **************************************************/ return (out); } /* v_add -- vector addition -- may be in-situ */ VEC *v_add(vec1,vec2,out) VEC *vec1,*vec2,*out; { u_int dim; /* Real *out_ve, *vec1_ve, *vec2_ve; */ if ( vec1==(VEC *)NULL || vec2==(VEC *)NULL ) error(E_NULL,"v_add"); if ( vec1->dim != vec2->dim ) error(E_SIZES,"v_add"); if ( out==(VEC *)NULL || out->dim != vec1->dim ) out = v_resize(out,vec1->dim); dim = vec1->dim; __add__(vec1->ve,vec2->ve,out->ve,(int)dim); /************************************************************ out_ve = out->ve; vec1_ve = vec1->ve; vec2_ve = vec2->ve; for ( i=0; ive[i] = vec1->ve[i]+vec2->ve[i]; (*out_ve++) = (*vec1_ve++) + (*vec2_ve++); ************************************************************/ return (out); } /* v_mltadd -- scalar/vector multiplication and addition -- out = v1 + scale.v2 */ VEC *v_mltadd(v1,v2,scale,out) VEC *v1,*v2,*out; double scale; { /* register u_int dim, i; */ /* Real *out_ve, *v1_ve, *v2_ve; */ if ( v1==(VEC *)NULL || v2==(VEC *)NULL ) error(E_NULL,"v_mltadd"); if ( v1->dim != v2->dim ) error(E_SIZES,"v_mltadd"); if ( scale == 0.0 ) return v_copy(v1,out); if ( scale == 1.0 ) return v_add(v1,v2,out); if ( v2 != out ) { tracecatch(out = v_copy(v1,out),"v_mltadd"); /* dim = v1->dim; */ __mltadd__(out->ve,v2->ve,scale,(int)(v1->dim)); } else { tracecatch(out = sv_mlt(scale,v2,out),"v_mltadd"); out = v_add(v1,out,out); } /************************************************************ out_ve = out->ve; v1_ve = v1->ve; v2_ve = v2->ve; for ( i=0; i < dim ; i++ ) out->ve[i] = v1->ve[i] + scale*v2->ve[i]; (*out_ve++) = (*v1_ve++) + scale*(*v2_ve++); ************************************************************/ return (out); } /* v_sub -- vector subtraction -- may be in-situ */ VEC *v_sub(vec1,vec2,out) VEC *vec1,*vec2,*out; { /* u_int i, dim; */ /* Real *out_ve, *vec1_ve, *vec2_ve; */ if ( vec1==(VEC *)NULL || vec2==(VEC *)NULL ) error(E_NULL,"v_sub"); if ( vec1->dim != vec2->dim ) error(E_SIZES,"v_sub"); if ( out==(VEC *)NULL || out->dim != vec1->dim ) out = v_resize(out,vec1->dim); __sub__(vec1->ve,vec2->ve,out->ve,(int)(vec1->dim)); /************************************************************ dim = vec1->dim; out_ve = out->ve; vec1_ve = vec1->ve; vec2_ve = vec2->ve; for ( i=0; ive[i] = vec1->ve[i]-vec2->ve[i]; (*out_ve++) = (*vec1_ve++) - (*vec2_ve++); ************************************************************/ return (out); } /* v_map -- maps function f over components of x: out[i] = f(x[i]) -- _v_map sets out[i] = f(params,x[i]) */ VEC *v_map(f,x,out) #ifdef PROTOTYPES_IN_STRUCT double (*f)(double); #else double (*f)(); #endif VEC *x, *out; { Real *x_ve, *out_ve; int i, dim; if ( ! x || ! f ) error(E_NULL,"v_map"); if ( ! out || out->dim != x->dim ) out = v_resize(out,x->dim); dim = x->dim; x_ve = x->ve; out_ve = out->ve; for ( i = 0; i < dim; i++ ) *out_ve++ = (*f)(*x_ve++); return out; } VEC *_v_map(f,params,x,out) #ifdef PROTOTYPES_IN_STRUCT double (*f)(void *,double); #else double (*f)(); #endif VEC *x, *out; void *params; { Real *x_ve, *out_ve; int i, dim; if ( ! x || ! f ) error(E_NULL,"_v_map"); if ( ! out || out->dim != x->dim ) out = v_resize(out,x->dim); dim = x->dim; x_ve = x->ve; out_ve = out->ve; for ( i = 0; i < dim; i++ ) *out_ve++ = (*f)(params,*x_ve++); return out; } /* v_lincomb -- returns sum_i a[i].v[i], a[i] real, v[i] vectors */ VEC *v_lincomb(n,v,a,out) int n; /* number of a's and v's */ Real a[]; VEC *v[], *out; { int i; if ( ! a || ! v ) error(E_NULL,"v_lincomb"); if ( n <= 0 ) return VNULL; for ( i = 1; i < n; i++ ) if ( out == v[i] ) error(E_INSITU,"v_lincomb"); out = sv_mlt(a[0],v[0],out); for ( i = 1; i < n; i++ ) { if ( ! v[i] ) error(E_NULL,"v_lincomb"); if ( v[i]->dim != out->dim ) error(E_SIZES,"v_lincomb"); out = v_mltadd(out,v[i],a[i],out); } return out; } #ifdef ANSI_C /* v_linlist -- linear combinations taken from a list of arguments; calling: v_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); where vi are vectors (VEC *) and ai are numbers (double) */ VEC *v_linlist(VEC *out,VEC *v1,double a1,...) { va_list ap; VEC *par; double a_par; if ( ! v1 ) return VNULL; va_start(ap, a1); out = sv_mlt(a1,v1,out); while (par = va_arg(ap,VEC *)) { /* NULL ends the list*/ a_par = va_arg(ap,double); if (a_par == 0.0) continue; if ( out == par ) error(E_INSITU,"v_linlist"); if ( out->dim != par->dim ) error(E_SIZES,"v_linlist"); if (a_par == 1.0) out = v_add(out,par,out); else if (a_par == -1.0) out = v_sub(out,par,out); else out = v_mltadd(out,par,a_par,out); } va_end(ap); return out; } #elif VARARGS /* v_linlist -- linear combinations taken from a list of arguments; calling: v_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); where vi are vectors (VEC *) and ai are numbers (double) */ VEC *v_linlist(va_alist) va_dcl { va_list ap; VEC *par, *out; double a_par; va_start(ap); out = va_arg(ap,VEC *); par = va_arg(ap,VEC *); if ( ! par ) { va_end(ap); return VNULL; } a_par = va_arg(ap,double); out = sv_mlt(a_par,par,out); while (par = va_arg(ap,VEC *)) { /* NULL ends the list*/ a_par = va_arg(ap,double); if (a_par == 0.0) continue; if ( out == par ) error(E_INSITU,"v_linlist"); if ( out->dim != par->dim ) error(E_SIZES,"v_linlist"); if (a_par == 1.0) out = v_add(out,par,out); else if (a_par == -1.0) out = v_sub(out,par,out); else out = v_mltadd(out,par,a_par,out); } va_end(ap); return out; } #endif /* v_star -- computes componentwise (Hadamard) product of x1 and x2 -- result out is returned */ VEC *v_star(x1, x2, out) VEC *x1, *x2, *out; { int i; if ( ! x1 || ! x2 ) error(E_NULL,"v_star"); if ( x1->dim != x2->dim ) error(E_SIZES,"v_star"); out = v_resize(out,x1->dim); for ( i = 0; i < x1->dim; i++ ) out->ve[i] = x1->ve[i] * x2->ve[i]; return out; } /* v_slash -- computes componentwise ratio of x2 and x1 -- out[i] = x2[i] / x1[i] -- if x1[i] == 0 for some i, then raise E_SING error -- result out is returned */ VEC *v_slash(x1, x2, out) VEC *x1, *x2, *out; { int i; Real tmp; if ( ! x1 || ! x2 ) error(E_NULL,"v_slash"); if ( x1->dim != x2->dim ) error(E_SIZES,"v_slash"); out = v_resize(out,x1->dim); for ( i = 0; i < x1->dim; i++ ) { tmp = x1->ve[i]; if ( tmp == 0.0 ) error(E_SING,"v_slash"); out->ve[i] = x2->ve[i] / tmp; } return out; } /* v_min -- computes minimum component of x, which is returned -- also sets min_idx to the index of this minimum */ double v_min(x, min_idx) VEC *x; int *min_idx; { int i, i_min; Real min_val, tmp; if ( ! x ) error(E_NULL,"v_min"); if ( x->dim <= 0 ) error(E_SIZES,"v_min"); i_min = 0; min_val = x->ve[0]; for ( i = 1; i < x->dim; i++ ) { tmp = x->ve[i]; if ( tmp < min_val ) { min_val = tmp; i_min = i; } } if ( min_idx != NULL ) *min_idx = i_min; return min_val; } /* v_max -- computes maximum component of x, which is returned -- also sets max_idx to the index of this maximum */ double v_max(x, max_idx) VEC *x; int *max_idx; { int i, i_max; Real max_val, tmp; if ( ! x ) error(E_NULL,"v_max"); if ( x->dim <= 0 ) error(E_SIZES,"v_max"); i_max = 0; max_val = x->ve[0]; for ( i = 1; i < x->dim; i++ ) { tmp = x->ve[i]; if ( tmp > max_val ) { max_val = tmp; i_max = i; } } if ( max_idx != NULL ) *max_idx = i_max; return max_val; } #define MAX_STACK 60 /* v_sort -- sorts vector x, and generates permutation that gives the order of the components; x = [1.3, 3.7, 0.5] -> [0.5, 1.3, 3.7] and the permutation is order = [2, 0, 1]. -- if order is NULL on entry then it is ignored -- the sorted vector x is returned */ VEC *v_sort(x, order) VEC *x; PERM *order; { Real *x_ve, tmp, v; /* int *order_pe; */ int dim, i, j, l, r, tmp_i; int stack[MAX_STACK], sp; if ( ! x ) error(E_NULL,"v_sort"); if ( order != PNULL && order->size != x->dim ) order = px_resize(order, x->dim); x_ve = x->ve; dim = x->dim; if ( order != PNULL ) px_ident(order); if ( dim <= 1 ) return x; /* using quicksort algorithm in Sedgewick, "Algorithms in C", Ch. 9, pp. 118--122 (1990) */ sp = 0; l = 0; r = dim-1; v = x_ve[0]; for ( ; ; ) { while ( r > l ) { /* "i = partition(x_ve,l,r);" */ v = x_ve[r]; i = l-1; j = r; for ( ; ; ) { while ( x_ve[++i] < v ) ; while ( x_ve[--j] > v ) ; if ( i >= j ) break; tmp = x_ve[i]; x_ve[i] = x_ve[j]; x_ve[j] = tmp; if ( order != PNULL ) { tmp_i = order->pe[i]; order->pe[i] = order->pe[j]; order->pe[j] = tmp_i; } } tmp = x_ve[i]; x_ve[i] = x_ve[r]; x_ve[r] = tmp; if ( order != PNULL ) { tmp_i = order->pe[i]; order->pe[i] = order->pe[r]; order->pe[r] = tmp_i; } if ( i-l > r-i ) { stack[sp++] = l; stack[sp++] = i-1; l = i+1; } else { stack[sp++] = i+1; stack[sp++] = r; r = i-1; } } /* recursion elimination */ if ( sp == 0 ) break; r = stack[--sp]; l = stack[--sp]; } return x; } /* v_sum -- returns sum of entries of a vector */ double v_sum(x) VEC *x; { int i; Real sum; if ( ! x ) error(E_NULL,"v_sum"); sum = 0.0; for ( i = 0; i < x->dim; i++ ) sum += x->ve[i]; return sum; } /* v_conv -- computes convolution product of two vectors */ VEC *v_conv(x1, x2, out) VEC *x1, *x2, *out; { int i; if ( ! x1 || ! x2 ) error(E_NULL,"v_conv"); if ( x1 == out || x2 == out ) error(E_INSITU,"v_conv"); if ( x1->dim == 0 || x2->dim == 0 ) return out = v_resize(out,0); out = v_resize(out,x1->dim + x2->dim - 1); v_zero(out); for ( i = 0; i < x1->dim; i++ ) __mltadd__(&(out->ve[i]),x2->ve,x1->ve[i],x2->dim); return out; } /* v_pconv -- computes a periodic convolution product -- the period is the dimension of x2 */ VEC *v_pconv(x1, x2, out) VEC *x1, *x2, *out; { int i; if ( ! x1 || ! x2 ) error(E_NULL,"v_pconv"); if ( x1 == out || x2 == out ) error(E_INSITU,"v_pconv"); out = v_resize(out,x2->dim); if ( x2->dim == 0 ) return out; v_zero(out); for ( i = 0; i < x1->dim; i++ ) { __mltadd__(&(out->ve[i]),x2->ve,x1->ve[i],x2->dim - i); if ( i > 0 ) __mltadd__(out->ve,&(x2->ve[x2->dim - i]),x1->ve[i],i); } return out; } meschach-1.2b/matop.c100644 764 764 27460 5735556553 14205 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* matop.c 1.3 11/25/87 */ #include #include "matrix.h" static char rcsid[] = "$Id: matop.c,v 1.4 1995/03/27 15:43:57 des Exp $"; /* m_add -- matrix addition -- may be in-situ */ MAT *m_add(mat1,mat2,out) MAT *mat1,*mat2,*out; { u_int m,n,i; if ( mat1==(MAT *)NULL || mat2==(MAT *)NULL ) error(E_NULL,"m_add"); if ( mat1->m != mat2->m || mat1->n != mat2->n ) error(E_SIZES,"m_add"); if ( out==(MAT *)NULL || out->m != mat1->m || out->n != mat1->n ) out = m_resize(out,mat1->m,mat1->n); m = mat1->m; n = mat1->n; for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); /************************************************** for ( j=0; jme[i][j] = mat1->me[i][j]+mat2->me[i][j]; **************************************************/ } return (out); } /* m_sub -- matrix subtraction -- may be in-situ */ MAT *m_sub(mat1,mat2,out) MAT *mat1,*mat2,*out; { u_int m,n,i; if ( mat1==(MAT *)NULL || mat2==(MAT *)NULL ) error(E_NULL,"m_sub"); if ( mat1->m != mat2->m || mat1->n != mat2->n ) error(E_SIZES,"m_sub"); if ( out==(MAT *)NULL || out->m != mat1->m || out->n != mat1->n ) out = m_resize(out,mat1->m,mat1->n); m = mat1->m; n = mat1->n; for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); /************************************************** for ( j=0; jme[i][j] = mat1->me[i][j]-mat2->me[i][j]; **************************************************/ } return (out); } /* m_mlt -- matrix-matrix multiplication */ MAT *m_mlt(A,B,OUT) MAT *A,*B,*OUT; { u_int i, /* j, */ k, m, n, p; Real **A_v, **B_v /*, *B_row, *OUT_row, sum, tmp */; if ( A==(MAT *)NULL || B==(MAT *)NULL ) error(E_NULL,"m_mlt"); if ( A->n != B->m ) error(E_SIZES,"m_mlt"); if ( A == OUT || B == OUT ) error(E_INSITU,"m_mlt"); m = A->m; n = A->n; p = B->n; A_v = A->me; B_v = B->me; if ( OUT==(MAT *)NULL || OUT->m != A->m || OUT->n != B->n ) OUT = m_resize(OUT,A->m,B->n); /**************************************************************** for ( i=0; ime[i][j] = sum; } ****************************************************************/ m_zero(OUT); for ( i=0; ime[i],B_v[k],A_v[i][k],(int)p); /************************************************** B_row = B_v[k]; OUT_row = OUT->me[i]; for ( j=0; jn != B->n ) error(E_SIZES,"mmtr_mlt"); if ( ! OUT || OUT->m != A->m || OUT->n != B->m ) OUT = m_resize(OUT,A->m,B->m); limit = A->n; for ( i = 0; i < A->m; i++ ) for ( j = 0; j < B->m; j++ ) { OUT->me[i][j] = __ip__(A->me[i],B->me[j],(int)limit); /************************************************** sum = 0.0; A_row = A->me[i]; B_row = B->me[j]; for ( k = 0; k < limit; k++ ) sum += (*A_row++)*(*B_row++); OUT->me[i][j] = sum; **************************************************/ } return OUT; } /* mtrm_mlt -- matrix transposed-matrix multiplication -- A^T.B is returned, result stored in OUT */ MAT *mtrm_mlt(A,B,OUT) MAT *A, *B, *OUT; { int i, k, limit; /* Real *B_row, *OUT_row, multiplier; */ if ( ! A || ! B ) error(E_NULL,"mmtr_mlt"); if ( A == OUT || B == OUT ) error(E_INSITU,"mtrm_mlt"); if ( A->m != B->m ) error(E_SIZES,"mmtr_mlt"); if ( ! OUT || OUT->m != A->n || OUT->n != B->n ) OUT = m_resize(OUT,A->n,B->n); limit = B->n; m_zero(OUT); for ( k = 0; k < A->m; k++ ) for ( i = 0; i < A->n; i++ ) { if ( A->me[k][i] != 0.0 ) __mltadd__(OUT->me[i],B->me[k],A->me[k][i],(int)limit); /************************************************** multiplier = A->me[k][i]; OUT_row = OUT->me[i]; B_row = B->me[k]; for ( j = 0; j < limit; j++ ) *(OUT_row++) += multiplier*(*B_row++); **************************************************/ } return OUT; } /* mv_mlt -- matrix-vector multiplication -- Note: b is treated as a column vector */ VEC *mv_mlt(A,b,out) MAT *A; VEC *b,*out; { u_int i, m, n; Real **A_v, *b_v /*, *A_row */; /* register Real sum; */ if ( A==(MAT *)NULL || b==(VEC *)NULL ) error(E_NULL,"mv_mlt"); if ( A->n != b->dim ) error(E_SIZES,"mv_mlt"); if ( b == out ) error(E_INSITU,"mv_mlt"); if ( out == (VEC *)NULL || out->dim != A->m ) out = v_resize(out,A->m); m = A->m; n = A->n; A_v = A->me; b_v = b->ve; for ( i=0; ive[i] = __ip__(A_v[i],b_v,(int)n); /************************************************** A_row = A_v[i]; b_v = b->ve; for ( j=0; jve[i] = sum; **************************************************/ } return out; } /* sm_mlt -- scalar-matrix multiply -- may be in-situ */ MAT *sm_mlt(scalar,matrix,out) double scalar; MAT *matrix,*out; { u_int m,n,i; if ( matrix==(MAT *)NULL ) error(E_NULL,"sm_mlt"); if ( out==(MAT *)NULL || out->m != matrix->m || out->n != matrix->n ) out = m_resize(out,matrix->m,matrix->n); m = matrix->m; n = matrix->n; for ( i=0; ime[i],(double)scalar,out->me[i],(int)n); /************************************************** for ( j=0; jme[i][j] = scalar*matrix->me[i][j]; **************************************************/ return (out); } /* vm_mlt -- vector-matrix multiplication -- Note: b is treated as a row vector */ VEC *vm_mlt(A,b,out) MAT *A; VEC *b,*out; { u_int j,m,n; /* Real sum,**A_v,*b_v; */ if ( A==(MAT *)NULL || b==(VEC *)NULL ) error(E_NULL,"vm_mlt"); if ( A->m != b->dim ) error(E_SIZES,"vm_mlt"); if ( b == out ) error(E_INSITU,"vm_mlt"); if ( out == (VEC *)NULL || out->dim != A->n ) out = v_resize(out,A->n); m = A->m; n = A->n; v_zero(out); for ( j = 0; j < m; j++ ) if ( b->ve[j] != 0.0 ) __mltadd__(out->ve,A->me[j],b->ve[j],(int)n); /************************************************** A_v = A->me; b_v = b->ve; for ( j=0; jve[j] = sum; } **************************************************/ return out; } /* m_transp -- transpose matrix */ MAT *m_transp(in,out) MAT *in, *out; { int i, j; int in_situ; Real tmp; if ( in == (MAT *)NULL ) error(E_NULL,"m_transp"); if ( in == out && in->n != in->m ) error(E_INSITU2,"m_transp"); in_situ = ( in == out ); if ( out == (MAT *)NULL || out->m != in->n || out->n != in->m ) out = m_resize(out,in->n,in->m); if ( ! in_situ ) for ( i = 0; i < in->m; i++ ) for ( j = 0; j < in->n; j++ ) out->me[j][i] = in->me[i][j]; else for ( i = 1; i < in->m; i++ ) for ( j = 0; j < i; j++ ) { tmp = in->me[i][j]; in->me[i][j] = in->me[j][i]; in->me[j][i] = tmp; } return out; } /* swap_rows -- swaps rows i and j of matrix A upto column lim */ MAT *swap_rows(A,i,j,lo,hi) MAT *A; int i, j, lo, hi; { int k; Real **A_me, tmp; if ( ! A ) error(E_NULL,"swap_rows"); if ( i < 0 || j < 0 || i >= A->m || j >= A->m ) error(E_SIZES,"swap_rows"); lo = max(0,lo); hi = min(hi,A->n-1); A_me = A->me; for ( k = lo; k <= hi; k++ ) { tmp = A_me[k][i]; A_me[k][i] = A_me[k][j]; A_me[k][j] = tmp; } return A; } /* swap_cols -- swap columns i and j of matrix A upto row lim */ MAT *swap_cols(A,i,j,lo,hi) MAT *A; int i, j, lo, hi; { int k; Real **A_me, tmp; if ( ! A ) error(E_NULL,"swap_cols"); if ( i < 0 || j < 0 || i >= A->n || j >= A->n ) error(E_SIZES,"swap_cols"); lo = max(0,lo); hi = min(hi,A->m-1); A_me = A->me; for ( k = lo; k <= hi; k++ ) { tmp = A_me[i][k]; A_me[i][k] = A_me[j][k]; A_me[j][k] = tmp; } return A; } /* ms_mltadd -- matrix-scalar multiply and add -- may be in situ -- returns out == A1 + s*A2 */ MAT *ms_mltadd(A1,A2,s,out) MAT *A1, *A2, *out; double s; { /* register Real *A1_e, *A2_e, *out_e; */ /* register int j; */ int i, m, n; if ( ! A1 || ! A2 ) error(E_NULL,"ms_mltadd"); if ( A1->m != A2->m || A1->n != A2->n ) error(E_SIZES,"ms_mltadd"); if ( out != A1 && out != A2 ) out = m_resize(out,A1->m,A1->n); if ( s == 0.0 ) return m_copy(A1,out); if ( s == 1.0 ) return m_add(A1,A2,out); tracecatch(out = m_copy(A1,out),"ms_mltadd"); m = A1->m; n = A1->n; for ( i = 0; i < m; i++ ) { __mltadd__(out->me[i],A2->me[i],s,(int)n); /************************************************** A1_e = A1->me[i]; A2_e = A2->me[i]; out_e = out->me[i]; for ( j = 0; j < n; j++ ) out_e[j] = A1_e[j] + s*A2_e[j]; **************************************************/ } return out; } /* mv_mltadd -- matrix-vector multiply and add -- may not be in situ -- returns out == v1 + alpha*A*v2 */ VEC *mv_mltadd(v1,v2,A,alpha,out) VEC *v1, *v2, *out; MAT *A; double alpha; { /* register int j; */ int i, m, n; Real *v2_ve, *out_ve; if ( ! v1 || ! v2 || ! A ) error(E_NULL,"mv_mltadd"); if ( out == v2 ) error(E_INSITU,"mv_mltadd"); if ( v1->dim != A->m || v2->dim != A->n ) error(E_SIZES,"mv_mltadd"); tracecatch(out = v_copy(v1,out),"mv_mltadd"); v2_ve = v2->ve; out_ve = out->ve; m = A->m; n = A->n; if ( alpha == 0.0 ) return out; for ( i = 0; i < m; i++ ) { out_ve[i] += alpha*__ip__(A->me[i],v2_ve,(int)n); /************************************************** A_e = A->me[i]; sum = 0.0; for ( j = 0; j < n; j++ ) sum += A_e[j]*v2_ve[j]; out_ve[i] = v1->ve[i] + alpha*sum; **************************************************/ } return out; } /* vm_mltadd -- vector-matrix multiply and add -- may not be in situ -- returns out' == v1' + v2'*A */ VEC *vm_mltadd(v1,v2,A,alpha,out) VEC *v1, *v2, *out; MAT *A; double alpha; { int /* i, */ j, m, n; Real tmp, /* *A_e, */ *out_ve; if ( ! v1 || ! v2 || ! A ) error(E_NULL,"vm_mltadd"); if ( v2 == out ) error(E_INSITU,"vm_mltadd"); if ( v1->dim != A->n || A->m != v2->dim ) error(E_SIZES,"vm_mltadd"); tracecatch(out = v_copy(v1,out),"vm_mltadd"); out_ve = out->ve; m = A->m; n = A->n; for ( j = 0; j < m; j++ ) { tmp = v2->ve[j]*alpha; if ( tmp != 0.0 ) __mltadd__(out_ve,A->me[j],tmp,(int)n); /************************************************** A_e = A->me[j]; for ( i = 0; i < n; i++ ) out_ve[i] += A_e[i]*tmp; **************************************************/ } return out; } meschach-1.2b/pxop.c100644 764 764 16511 5544153770 14036 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* pxop.c 1.5 12/03/87 */ #include #include "matrix.h" static char rcsid[] = "$Id: pxop.c,v 1.5 1994/03/23 23:58:50 des Exp $"; /********************************************************************** Note: A permutation is often interpreted as a matrix (i.e. a permutation matrix). A permutation px represents a permutation matrix P where P[i][j] == 1 if and only if px->pe[i] == j **********************************************************************/ /* px_inv -- invert permutation -- in situ -- taken from ACM Collected Algorithms #250 */ PERM *px_inv(px,out) PERM *px, *out; { int i, j, k, n, *p; out = px_copy(px, out); n = out->size; p = (int *)(out->pe); for ( n--; n>=0; n-- ) { i = p[n]; if ( i < 0 ) p[n] = -1 - i; else if ( i != n ) { k = n; while (TRUE) { if ( i < 0 || i >= out->size ) error(E_BOUNDS,"px_inv"); j = p[i]; p[i] = -1 - k; if ( j == n ) { p[n] = i; break; } k = i; i = j; } } } return out; } /* px_mlt -- permutation multiplication (composition) */ PERM *px_mlt(px1,px2,out) PERM *px1,*px2,*out; { u_int i,size; if ( px1==(PERM *)NULL || px2==(PERM *)NULL ) error(E_NULL,"px_mlt"); if ( px1->size != px2->size ) error(E_SIZES,"px_mlt"); if ( px1 == out || px2 == out ) error(E_INSITU,"px_mlt"); if ( out==(PERM *)NULL || out->size < px1->size ) out = px_resize(out,px1->size); size = px1->size; for ( i=0; ipe[i] >= size ) error(E_BOUNDS,"px_mlt"); else out->pe[i] = px1->pe[px2->pe[i]]; return out; } /* px_vec -- permute vector */ VEC *px_vec(px,vector,out) PERM *px; VEC *vector,*out; { u_int old_i, i, size, start; Real tmp; if ( px==(PERM *)NULL || vector==(VEC *)NULL ) error(E_NULL,"px_vec"); if ( px->size > vector->dim ) error(E_SIZES,"px_vec"); if ( out==(VEC *)NULL || out->dim < vector->dim ) out = v_resize(out,vector->dim); size = px->size; if ( size == 0 ) return v_copy(vector,out); if ( out != vector ) { for ( i=0; ipe[i] >= size ) error(E_BOUNDS,"px_vec"); else out->ve[i] = vector->ve[px->pe[i]]; } else { /* in situ algorithm */ start = 0; while ( start < size ) { old_i = start; i = px->pe[old_i]; if ( i >= size ) { start++; continue; } tmp = vector->ve[start]; while ( TRUE ) { vector->ve[old_i] = vector->ve[i]; px->pe[old_i] = i+size; old_i = i; i = px->pe[old_i]; if ( i >= size ) break; if ( i == start ) { vector->ve[old_i] = tmp; px->pe[old_i] = i+size; break; } } start++; } for ( i = 0; i < size; i++ ) if ( px->pe[i] < size ) error(E_BOUNDS,"px_vec"); else px->pe[i] = px->pe[i]-size; } return out; } /* pxinv_vec -- apply the inverse of px to x, returning the result in out */ VEC *pxinv_vec(px,x,out) PERM *px; VEC *x, *out; { u_int i, size; if ( ! px || ! x ) error(E_NULL,"pxinv_vec"); if ( px->size > x->dim ) error(E_SIZES,"pxinv_vec"); /* if ( x == out ) error(E_INSITU,"pxinv_vec"); */ if ( ! out || out->dim < x->dim ) out = v_resize(out,x->dim); size = px->size; if ( size == 0 ) return v_copy(x,out); if ( out != x ) { for ( i=0; ipe[i] >= size ) error(E_BOUNDS,"pxinv_vec"); else out->ve[px->pe[i]] = x->ve[i]; } else { /* in situ algorithm --- cheat's way out */ px_inv(px,px); px_vec(px,x,out); px_inv(px,px); } return out; } /* px_transp -- transpose elements of permutation -- Really multiplying a permutation by a transposition */ PERM *px_transp(px,i1,i2) PERM *px; /* permutation to transpose */ u_int i1,i2; /* elements to transpose */ { u_int temp; if ( px==(PERM *)NULL ) error(E_NULL,"px_transp"); if ( i1 < px->size && i2 < px->size ) { temp = px->pe[i1]; px->pe[i1] = px->pe[i2]; px->pe[i2] = temp; } return px; } /* myqsort -- a cheap implementation of Quicksort on integers -- returns number of swaps */ static int myqsort(a,num) int *a, num; { int i, j, tmp, v; int numswaps; numswaps = 0; if ( num <= 1 ) return 0; i = 0; j = num; v = a[0]; for ( ; ; ) { while ( a[++i] < v ) ; while ( a[--j] > v ) ; if ( i >= j ) break; tmp = a[i]; a[i] = a[j]; a[j] = tmp; numswaps++; } tmp = a[0]; a[0] = a[j]; a[j] = tmp; if ( j != 0 ) numswaps++; numswaps += myqsort(&a[0],j); numswaps += myqsort(&a[j+1],num-(j+1)); return numswaps; } /* px_sign -- compute the ``sign'' of a permutation = +/-1 where px is the product of an even/odd # transpositions */ int px_sign(px) PERM *px; { int numtransp; PERM *px2; if ( px==(PERM *)NULL ) error(E_NULL,"px_sign"); px2 = px_copy(px,PNULL); numtransp = myqsort(px2->pe,px2->size); px_free(px2); return ( numtransp % 2 ) ? -1 : 1; } /* px_cols -- permute columns of matrix A; out = A.px' -- May NOT be in situ */ MAT *px_cols(px,A,out) PERM *px; MAT *A, *out; { int i, j, m, n, px_j; Real **A_me, **out_me; #ifdef ANSI_C MAT *m_get(int, int); #else extern MAT *m_get(); #endif if ( ! A || ! px ) error(E_NULL,"px_cols"); if ( px->size != A->n ) error(E_SIZES,"px_cols"); if ( A == out ) error(E_INSITU,"px_cols"); m = A->m; n = A->n; if ( ! out || out->m != m || out->n != n ) out = m_get(m,n); A_me = A->me; out_me = out->me; for ( j = 0; j < n; j++ ) { px_j = px->pe[j]; if ( px_j >= n ) error(E_BOUNDS,"px_cols"); for ( i = 0; i < m; i++ ) out_me[i][px_j] = A_me[i][j]; } return out; } /* px_rows -- permute columns of matrix A; out = px.A -- May NOT be in situ */ MAT *px_rows(px,A,out) PERM *px; MAT *A, *out; { int i, j, m, n, px_i; Real **A_me, **out_me; #ifdef ANSI_C MAT *m_get(int, int); #else extern MAT *m_get(); #endif if ( ! A || ! px ) error(E_NULL,"px_rows"); if ( px->size != A->m ) error(E_SIZES,"px_rows"); if ( A == out ) error(E_INSITU,"px_rows"); m = A->m; n = A->n; if ( ! out || out->m != m || out->n != n ) out = m_get(m,n); A_me = A->me; out_me = out->me; for ( i = 0; i < m; i++ ) { px_i = px->pe[i]; if ( px_i >= m ) error(E_BOUNDS,"px_rows"); for ( j = 0; j < n; j++ ) out_me[i][j] = A_me[px_i][j]; } return out; } meschach-1.2b/submat.c100644 764 764 10665 5515155770 14347 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* 1.2 submat.c 11/25/87 */ #include #include "matrix.h" static char rcsid[] = "$Id: submat.c,v 1.2 1994/01/13 05:28:12 des Exp $"; /* get_col -- gets a specified column of a matrix and retruns it as a vector */ VEC *get_col(mat,col,vec) u_int col; MAT *mat; VEC *vec; { u_int i; if ( mat==(MAT *)NULL ) error(E_NULL,"get_col"); if ( col >= mat->n ) error(E_RANGE,"get_col"); if ( vec==(VEC *)NULL || vec->dimm ) vec = v_resize(vec,mat->m); for ( i=0; im; i++ ) vec->ve[i] = mat->me[i][col]; return (vec); } /* get_row -- gets a specified row of a matrix and retruns it as a vector */ VEC *get_row(mat,row,vec) u_int row; MAT *mat; VEC *vec; { u_int i; if ( mat==(MAT *)NULL ) error(E_NULL,"get_row"); if ( row >= mat->m ) error(E_RANGE,"get_row"); if ( vec==(VEC *)NULL || vec->dimn ) vec = v_resize(vec,mat->n); for ( i=0; in; i++ ) vec->ve[i] = mat->me[row][i]; return (vec); } /* _set_col -- sets column of matrix to values given in vec (in situ) */ MAT *_set_col(mat,col,vec,i0) MAT *mat; VEC *vec; u_int col,i0; { u_int i,lim; if ( mat==(MAT *)NULL || vec==(VEC *)NULL ) error(E_NULL,"_set_col"); if ( col >= mat->n ) error(E_RANGE,"_set_col"); lim = min(mat->m,vec->dim); for ( i=i0; ime[i][col] = vec->ve[i]; return (mat); } /* _set_row -- sets row of matrix to values given in vec (in situ) */ MAT *_set_row(mat,row,vec,j0) MAT *mat; VEC *vec; u_int row,j0; { u_int j,lim; if ( mat==(MAT *)NULL || vec==(VEC *)NULL ) error(E_NULL,"_set_row"); if ( row >= mat->m ) error(E_RANGE,"_set_row"); lim = min(mat->n,vec->dim); for ( j=j0; jme[row][j] = vec->ve[j]; return (mat); } /* sub_mat -- returns sub-matrix of old which is formed by the rectangle from (row1,col1) to (row2,col2) -- Note: storage is shared so that altering the "new" matrix will alter the "old" matrix */ MAT *sub_mat(old,row1,col1,row2,col2,new) MAT *old,*new; u_int row1,col1,row2,col2; { u_int i; if ( old==(MAT *)NULL ) error(E_NULL,"sub_mat"); if ( row1 > row2 || col1 > col2 || row2 >= old->m || col2 >= old->n ) error(E_RANGE,"sub_mat"); if ( new==(MAT *)NULL || new->m < row2-row1+1 ) { new = NEW(MAT); new->me = NEW_A(row2-row1+1,Real *); if ( new==(MAT *)NULL || new->me==(Real **)NULL ) error(E_MEM,"sub_mat"); else if (mem_info_is_on()) { mem_bytes(TYPE_MAT,0,sizeof(MAT)+ (row2-row1+1)*sizeof(Real *)); } } new->m = row2-row1+1; new->n = col2-col1+1; new->base = (Real *)NULL; for ( i=0; i < new->m; i++ ) new->me[i] = (old->me[i+row1]) + col1; return (new); } /* sub_vec -- returns sub-vector which is formed by the elements i1 to i2 -- as for sub_mat, storage is shared */ VEC *sub_vec(old,i1,i2,new) VEC *old, *new; int i1, i2; { if ( old == (VEC *)NULL ) error(E_NULL,"sub_vec"); if ( i1 > i2 || old->dim < i2 ) error(E_RANGE,"sub_vec"); if ( new == (VEC *)NULL ) new = NEW(VEC); if ( new == (VEC *)NULL ) error(E_MEM,"sub_vec"); else if (mem_info_is_on()) { mem_bytes(TYPE_VEC,0,sizeof(VEC)); } new->dim = i2 - i1 + 1; new->ve = &(old->ve[i1]); return new; } meschach-1.2b/init.c100644 764 764 13401 5515157012 13775 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This is a file of routines for zero-ing, and initialising vectors, matrices and permutations. This is to be included in the matrix.a library */ static char rcsid[] = "$Id: init.c,v 1.6 1994/01/13 05:36:58 des Exp $"; #include #include "matrix.h" /* v_zero -- zero the vector x */ VEC *v_zero(x) VEC *x; { if ( x == VNULL ) error(E_NULL,"v_zero"); __zero__(x->ve,x->dim); /* for ( i = 0; i < x->dim; i++ ) x->ve[i] = 0.0; */ return x; } /* iv_zero -- zero the vector ix */ IVEC *iv_zero(ix) IVEC *ix; { int i; if ( ix == IVNULL ) error(E_NULL,"iv_zero"); for ( i = 0; i < ix->dim; i++ ) ix->ive[i] = 0; return ix; } /* m_zero -- zero the matrix A */ MAT *m_zero(A) MAT *A; { int i, A_m, A_n; Real **A_me; if ( A == MNULL ) error(E_NULL,"m_zero"); A_m = A->m; A_n = A->n; A_me = A->me; for ( i = 0; i < A_m; i++ ) __zero__(A_me[i],A_n); /* for ( j = 0; j < A_n; j++ ) A_me[i][j] = 0.0; */ return A; } /* mat_id -- set A to being closest to identity matrix as possible -- i.e. A[i][j] == 1 if i == j and 0 otherwise */ MAT *m_ident(A) MAT *A; { int i, size; if ( A == MNULL ) error(E_NULL,"m_ident"); m_zero(A); size = min(A->m,A->n); for ( i = 0; i < size; i++ ) A->me[i][i] = 1.0; return A; } /* px_ident -- set px to identity permutation */ PERM *px_ident(px) PERM *px; { int i, px_size; u_int *px_pe; if ( px == PNULL ) error(E_NULL,"px_ident"); px_size = px->size; px_pe = px->pe; for ( i = 0; i < px_size; i++ ) px_pe[i] = i; return px; } /* Pseudo random number generator data structures */ /* Knuth's lagged Fibonacci-based generator: See "Seminumerical Algorithms: The Art of Computer Programming" sections 3.2-3.3 */ #ifdef ANSI_C #ifndef LONG_MAX #include #endif #endif #ifdef LONG_MAX #define MODULUS LONG_MAX #else #define MODULUS 1000000000L /* assuming long's at least 32 bits long */ #endif #define MZ 0L static long mrand_list[56]; static int started = FALSE; static int inext = 0, inextp = 31; /* mrand -- pseudo-random number generator */ #ifdef ANSI_C double mrand(void) #else double mrand() #endif { long lval; static Real factor = 1.0/((Real)MODULUS); if ( ! started ) smrand(3127); inext = (inext >= 54) ? 0 : inext+1; inextp = (inextp >= 54) ? 0 : inextp+1; lval = mrand_list[inext]-mrand_list[inextp]; if ( lval < 0L ) lval += MODULUS; mrand_list[inext] = lval; return (double)lval*factor; } /* mrandlist -- fills the array a[] with len random numbers */ void mrandlist(a, len) Real a[]; int len; { int i; long lval; static Real factor = 1.0/((Real)MODULUS); if ( ! started ) smrand(3127); for ( i = 0; i < len; i++ ) { inext = (inext >= 54) ? 0 : inext+1; inextp = (inextp >= 54) ? 0 : inextp+1; lval = mrand_list[inext]-mrand_list[inextp]; if ( lval < 0L ) lval += MODULUS; mrand_list[inext] = lval; a[i] = (Real)lval*factor; } } /* smrand -- set seed for mrand() */ void smrand(seed) int seed; { int i; mrand_list[0] = (123413*seed) % MODULUS; for ( i = 1; i < 55; i++ ) mrand_list[i] = (123413*mrand_list[i-1]) % MODULUS; started = TRUE; /* run mrand() through the list sufficient times to thoroughly randomise the array */ for ( i = 0; i < 55*55; i++ ) mrand(); } #undef MODULUS #undef MZ #undef FAC /* v_rand -- initialises x to be a random vector, components independently & uniformly ditributed between 0 and 1 */ VEC *v_rand(x) VEC *x; { /* int i; */ if ( ! x ) error(E_NULL,"v_rand"); /* for ( i = 0; i < x->dim; i++ ) */ /* x->ve[i] = rand()/((Real)MAX_RAND); */ /* x->ve[i] = mrand(); */ mrandlist(x->ve,x->dim); return x; } /* m_rand -- initialises A to be a random vector, components independently & uniformly distributed between 0 and 1 */ MAT *m_rand(A) MAT *A; { int i /* , j */; if ( ! A ) error(E_NULL,"m_rand"); for ( i = 0; i < A->m; i++ ) /* for ( j = 0; j < A->n; j++ ) */ /* A->me[i][j] = rand()/((Real)MAX_RAND); */ /* A->me[i][j] = mrand(); */ mrandlist(A->me[i],A->n); return A; } /* v_ones -- fills x with one's */ VEC *v_ones(x) VEC *x; { int i; if ( ! x ) error(E_NULL,"v_ones"); for ( i = 0; i < x->dim; i++ ) x->ve[i] = 1.0; return x; } /* m_ones -- fills matrix with one's */ MAT *m_ones(A) MAT *A; { int i, j; if ( ! A ) error(E_NULL,"m_ones"); for ( i = 0; i < A->m; i++ ) for ( j = 0; j < A->n; j++ ) A->me[i][j] = 1.0; return A; } /* v_count -- initialises x so that x->ve[i] == i */ VEC *v_count(x) VEC *x; { int i; if ( ! x ) error(E_NULL,"v_count"); for ( i = 0; i < x->dim; i++ ) x->ve[i] = (Real)i; return x; } meschach-1.2b/otherio.c100644 764 764 10202 5515156604 14505 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File for doing assorted I/O operations not invlolving MAT/VEC/PERM objects */ static char rcsid[] = "$Id: otherio.c,v 1.2 1994/01/13 05:34:52 des Exp $"; #include #include #include "matrix.h" /* scratch area -- enough for a single line */ static char scratch[MAXLINE+1]; /* default value for fy_or_n */ static int y_n_dflt = TRUE; /* fy_or_n -- yes-or-no to question is string s -- question written to stderr, input from fp -- if fp is NOT a tty then return y_n_dflt */ int fy_or_n(fp,s) FILE *fp; char *s; { char *cp; if ( ! isatty(fileno(fp)) ) return y_n_dflt; for ( ; ; ) { fprintf(stderr,"%s (y/n) ? ",s); if ( fgets(scratch,MAXLINE,fp)==NULL ) error(E_INPUT,"fy_or_n"); cp = scratch; while ( isspace(*cp) ) cp++; if ( *cp == 'y' || *cp == 'Y' ) return TRUE; if ( *cp == 'n' || *cp == 'N' ) return FALSE; fprintf(stderr,"Please reply with 'y' or 'Y' for yes "); fprintf(stderr,"and 'n' or 'N' for no.\n"); } } /* yn_dflt -- sets the value of y_n_dflt to val */ int yn_dflt(val) int val; { return y_n_dflt = val; } /* fin_int -- return integer read from file/stream fp -- prompt s on stderr if fp is a tty -- check that x lies between low and high: re-prompt if fp is a tty, error exit otherwise -- ignore check if low > high */ int fin_int(fp,s,low,high) FILE *fp; char *s; int low, high; { int retcode, x; if ( ! isatty(fileno(fp)) ) { skipjunk(fp); if ( (retcode=fscanf(fp,"%d",&x)) == EOF ) error(E_INPUT,"fin_int"); if ( retcode <= 0 ) error(E_FORMAT,"fin_int"); if ( low <= high && ( x < low || x > high ) ) error(E_BOUNDS,"fin_int"); return x; } for ( ; ; ) { fprintf(stderr,"%s: ",s); if ( fgets(scratch,MAXLINE,stdin)==NULL ) error(E_INPUT,"fin_int"); retcode = sscanf(scratch,"%d",&x); if ( ( retcode==1 && low > high ) || ( x >= low && x <= high ) ) return x; fprintf(stderr,"Please type an integer in range [%d,%d].\n", low,high); } } /* fin_double -- return double read from file/stream fp -- prompt s on stderr if fp is a tty -- check that x lies between low and high: re-prompt if fp is a tty, error exit otherwise -- ignore check if low > high */ double fin_double(fp,s,low,high) FILE *fp; char *s; double low, high; { Real retcode, x; if ( ! isatty(fileno(fp)) ) { skipjunk(fp); #if REAL == DOUBLE if ( (retcode=fscanf(fp,"%lf",&x)) == EOF ) #elif REAL == FLOAT if ( (retcode=fscanf(fp,"%f",&x)) == EOF ) #endif error(E_INPUT,"fin_double"); if ( retcode <= 0 ) error(E_FORMAT,"fin_double"); if ( low <= high && ( x < low || x > high ) ) error(E_BOUNDS,"fin_double"); return (double)x; } for ( ; ; ) { fprintf(stderr,"%s: ",s); if ( fgets(scratch,MAXLINE,stdin)==NULL ) error(E_INPUT,"fin_double"); #if REAL == DOUBLE retcode = sscanf(scratch,"%lf",&x); #elif REAL == FLOAT retcode = sscanf(scratch,"%f",&x); #endif if ( ( retcode==1 && low > high ) || ( x >= low && x <= high ) ) return (double)x; fprintf(stderr,"Please type an double in range [%g,%g].\n", low,high); } } meschach-1.2b/machine.c100644 764 764 7125 5521047074 14427 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains basic routines which are used by the functions in meschach.a etc. These are the routines that should be modified in order to take full advantage of specialised architectures (pipelining, vector processors etc). */ static char *rcsid = "$Id: machine.c,v 1.4 1994/01/13 05:28:56 des Exp $"; #include "machine.h" /* __ip__ -- inner product */ double __ip__(dp1,dp2,len) register Real *dp1, *dp2; int len; { #ifdef VUNROLL register int len4; register Real sum1, sum2, sum3; #endif register int i; register Real sum; sum = 0.0; #ifdef VUNROLL sum1 = sum2 = sum3 = 0.0; len4 = len / 4; len = len % 4; for ( i = 0; i < len4; i++ ) { sum += dp1[4*i]*dp2[4*i]; sum1 += dp1[4*i+1]*dp2[4*i+1]; sum2 += dp1[4*i+2]*dp2[4*i+2]; sum3 += dp1[4*i+3]*dp2[4*i+3]; } sum += sum1 + sum2 + sum3; dp1 += 4*len4; dp2 += 4*len4; #endif for ( i = 0; i < len; i++ ) sum += dp1[i]*dp2[i]; return sum; } /* __mltadd__ -- scalar multiply and add c.f. v_mltadd() */ void __mltadd__(dp1,dp2,s,len) register Real *dp1, *dp2; register double s; register int len; { register int i; #ifdef VUNROLL register int len4; len4 = len / 4; len = len % 4; for ( i = 0; i < len4; i++ ) { dp1[4*i] += s*dp2[4*i]; dp1[4*i+1] += s*dp2[4*i+1]; dp1[4*i+2] += s*dp2[4*i+2]; dp1[4*i+3] += s*dp2[4*i+3]; } dp1 += 4*len4; dp2 += 4*len4; #endif for ( i = 0; i < len; i++ ) dp1[i] += s*dp2[i]; } /* __smlt__ scalar multiply array c.f. sv_mlt() */ void __smlt__(dp,s,out,len) register Real *dp, *out; register double s; register int len; { register int i; for ( i = 0; i < len; i++ ) out[i] = s*dp[i]; } /* __add__ -- add arrays c.f. v_add() */ void __add__(dp1,dp2,out,len) register Real *dp1, *dp2, *out; register int len; { register int i; for ( i = 0; i < len; i++ ) out[i] = dp1[i] + dp2[i]; } /* __sub__ -- subtract arrays c.f. v_sub() */ void __sub__(dp1,dp2,out,len) register Real *dp1, *dp2, *out; register int len; { register int i; for ( i = 0; i < len; i++ ) out[i] = dp1[i] - dp2[i]; } /* __zero__ -- zeros an array of floating point numbers */ void __zero__(dp,len) register Real *dp; register int len; { #ifdef CHAR0ISDBL0 /* if a floating point zero is equivalent to a string of nulls */ MEM_ZERO((char *)dp,len*sizeof(Real)); #else /* else, need to zero the array entry by entry */ int i; for ( i = 0; i < len; i++ ) dp[i] = 0.0; #endif } meschach-1.2b/matlab.c100644 764 764 12205 5720207330 14270 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains routines for import/exporting data to/from MATLAB. The main routines are: MAT *m_save(FILE *fp,MAT *A,char *name) VEC *v_save(FILE *fp,VEC *x,char *name) MAT *m_load(FILE *fp,char **name) */ #include #include "matrix.h" #include "matlab.h" static char rcsid[] = "$Id: matlab.c,v 1.8 1995/02/14 20:12:36 des Exp $"; /* m_save -- save matrix in ".mat" file for MATLAB -- returns matrix to be saved */ MAT *m_save(fp,A,name) FILE *fp; MAT *A; char *name; { int i; matlab mat; if ( ! A ) error(E_NULL,"m_save"); mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; mat.m = A->m; mat.n = A->n; mat.imag = FALSE; mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; /* write header */ fwrite(&mat,sizeof(matlab),1,fp); /* write name */ if ( name == (char *)NULL ) fwrite("",sizeof(char),1,fp); else fwrite(name,sizeof(char),(int)(mat.namlen),fp); /* write actual data */ #if ORDER == ROW_ORDER for ( i = 0; i < A->m; i++ ) fwrite(A->me[i],sizeof(Real),(int)(A->n),fp); #else /* column major order: ORDER == COL_ORDER */ for ( j = 0; j < A->n; j++ ) for ( i = 0; i < A->m; i++ ) fwrite(&(A->me[i][j]),sizeof(Real),1,fp); #endif return A; } /* v_save -- save vector in ".mat" file for MATLAB -- saves it as a row vector -- returns vector to be saved */ VEC *v_save(fp,x,name) FILE *fp; VEC *x; char *name; { matlab mat; if ( ! x ) error(E_NULL,"v_save"); mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; mat.m = x->dim; mat.n = 1; mat.imag = FALSE; mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; /* write header */ fwrite(&mat,sizeof(matlab),1,fp); /* write name */ if ( name == (char *)NULL ) fwrite("",sizeof(char),1,fp); else fwrite(name,sizeof(char),(int)(mat.namlen),fp); /* write actual data */ fwrite(x->ve,sizeof(Real),(int)(x->dim),fp); return x; } /* d_save -- save double in ".mat" file for MATLAB -- saves it as a row vector -- returns vector to be saved */ double d_save(fp,x,name) FILE *fp; double x; char *name; { matlab mat; Real x1 = x; mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; mat.m = 1; mat.n = 1; mat.imag = FALSE; mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; /* write header */ fwrite(&mat,sizeof(matlab),1,fp); /* write name */ if ( name == (char *)NULL ) fwrite("",sizeof(char),1,fp); else fwrite(name,sizeof(char),(int)(mat.namlen),fp); /* write actual data */ fwrite(&x1,sizeof(Real),1,fp); return x; } /* m_load -- loads in a ".mat" file variable as produced by MATLAB -- matrix returned; imaginary parts ignored */ MAT *m_load(fp,name) FILE *fp; char **name; { MAT *A; int i; int m_flag, o_flag, p_flag, t_flag; float f_temp; Real d_temp; matlab mat; if ( fread(&mat,sizeof(matlab),1,fp) != 1 ) error(E_FORMAT,"m_load"); if ( mat.type >= 10000 ) /* don't load a sparse matrix! */ error(E_FORMAT,"m_load"); m_flag = (mat.type/1000) % 10; o_flag = (mat.type/100) % 10; p_flag = (mat.type/10) % 10; t_flag = (mat.type) % 10; if ( m_flag != MACH_ID ) error(E_FORMAT,"m_load"); if ( t_flag != 0 ) error(E_FORMAT,"m_load"); if ( p_flag != DOUBLE_PREC && p_flag != SINGLE_PREC ) error(E_FORMAT,"m_load"); *name = (char *)malloc((unsigned)(mat.namlen)+1); if ( fread(*name,sizeof(char),(unsigned)(mat.namlen),fp) == 0 ) error(E_FORMAT,"m_load"); A = m_get((unsigned)(mat.m),(unsigned)(mat.n)); for ( i = 0; i < A->m*A->n; i++ ) { if ( p_flag == DOUBLE_PREC ) fread(&d_temp,sizeof(double),1,fp); else { fread(&f_temp,sizeof(float),1,fp); d_temp = f_temp; } if ( o_flag == ROW_ORDER ) A->me[i / A->n][i % A->n] = d_temp; else if ( o_flag == COL_ORDER ) A->me[i % A->m][i / A->m] = d_temp; else error(E_FORMAT,"m_load"); } if ( mat.imag ) /* skip imaginary part */ for ( i = 0; i < A->m*A->n; i++ ) { if ( p_flag == DOUBLE_PREC ) fread(&d_temp,sizeof(double),1,fp); else fread(&f_temp,sizeof(float),1,fp); } return A; } meschach-1.2b/ivecop.c100644 764 764 23110 5515157775 14335 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* ivecop.c */ #include #include "matrix.h" static char rcsid[] = "$Id: ivecop.c,v 1.5 1994/01/13 05:45:30 des Exp $"; static char line[MAXLINE]; /* iv_get -- get integer vector -- see also memory.c */ IVEC *iv_get(dim) int dim; { IVEC *iv; /* u_int i; */ if (dim < 0) error(E_NEG,"iv_get"); if ((iv=NEW(IVEC)) == IVNULL ) error(E_MEM,"iv_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_IVEC,0,sizeof(IVEC)); mem_numvar(TYPE_IVEC,1); } iv->dim = iv->max_dim = dim; if ((iv->ive = NEW_A(dim,int)) == (int *)NULL ) error(E_MEM,"iv_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_IVEC,0,dim*sizeof(int)); } return (iv); } /* iv_free -- returns iv & asoociated memory back to memory heap */ int iv_free(iv) IVEC *iv; { if ( iv==IVNULL || iv->dim > MAXDIM ) /* don't trust it */ return (-1); if ( iv->ive == (int *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_IVEC,sizeof(IVEC),0); mem_numvar(TYPE_IVEC,-1); } free((char *)iv); } else { if (mem_info_is_on()) { mem_bytes(TYPE_IVEC,sizeof(IVEC)+iv->max_dim*sizeof(int),0); mem_numvar(TYPE_IVEC,-1); } free((char *)iv->ive); free((char *)iv); } return (0); } /* iv_resize -- returns the IVEC with dimension new_dim -- iv is set to the zero vector */ IVEC *iv_resize(iv,new_dim) IVEC *iv; int new_dim; { int i; if (new_dim < 0) error(E_NEG,"iv_resize"); if ( ! iv ) return iv_get(new_dim); if (new_dim == iv->dim) return iv; if ( new_dim > iv->max_dim ) { if (mem_info_is_on()) { mem_bytes(TYPE_IVEC,iv->max_dim*sizeof(int), new_dim*sizeof(int)); } iv->ive = RENEW(iv->ive,new_dim,int); if ( ! iv->ive ) error(E_MEM,"iv_resize"); iv->max_dim = new_dim; } if ( iv->dim <= new_dim ) for ( i = iv->dim; i < new_dim; i++ ) iv->ive[i] = 0; iv->dim = new_dim; return iv; } /* iv_copy -- copy integer vector in to out -- out created/resized if necessary */ IVEC *iv_copy(in,out) IVEC *in, *out; { int i; if ( ! in ) error(E_NULL,"iv_copy"); out = iv_resize(out,in->dim); for ( i = 0; i < in->dim; i++ ) out->ive[i] = in->ive[i]; return out; } /* iv_move -- move selected pieces of an IVEC -- moves the length dim0 subvector with initial index i0 to the corresponding subvector of out with initial index i1 -- out is resized if necessary */ IVEC *iv_move(in,i0,dim0,out,i1) IVEC *in, *out; int i0, dim0, i1; { if ( ! in ) error(E_NULL,"iv_move"); if ( i0 < 0 || dim0 < 0 || i1 < 0 || i0+dim0 > in->dim ) error(E_BOUNDS,"iv_move"); if ( (! out) || i1+dim0 > out->dim ) out = iv_resize(out,i1+dim0); MEM_COPY(&(in->ive[i0]),&(out->ive[i1]),dim0*sizeof(int)); return out; } /* iv_add -- integer vector addition -- may be in-situ */ IVEC *iv_add(iv1,iv2,out) IVEC *iv1,*iv2,*out; { u_int i; int *out_ive, *iv1_ive, *iv2_ive; if ( iv1==IVNULL || iv2==IVNULL ) error(E_NULL,"iv_add"); if ( iv1->dim != iv2->dim ) error(E_SIZES,"iv_add"); if ( out==IVNULL || out->dim != iv1->dim ) out = iv_resize(out,iv1->dim); out_ive = out->ive; iv1_ive = iv1->ive; iv2_ive = iv2->ive; for ( i = 0; i < iv1->dim; i++ ) out_ive[i] = iv1_ive[i] + iv2_ive[i]; return (out); } /* iv_sub -- integer vector addition -- may be in-situ */ IVEC *iv_sub(iv1,iv2,out) IVEC *iv1,*iv2,*out; { u_int i; int *out_ive, *iv1_ive, *iv2_ive; if ( iv1==IVNULL || iv2==IVNULL ) error(E_NULL,"iv_sub"); if ( iv1->dim != iv2->dim ) error(E_SIZES,"iv_sub"); if ( out==IVNULL || out->dim != iv1->dim ) out = iv_resize(out,iv1->dim); out_ive = out->ive; iv1_ive = iv1->ive; iv2_ive = iv2->ive; for ( i = 0; i < iv1->dim; i++ ) out_ive[i] = iv1_ive[i] - iv2_ive[i]; return (out); } /* iv_foutput -- print a representation of iv on stream fp */ void iv_foutput(fp,iv) FILE *fp; IVEC *iv; { int i; fprintf(fp,"IntVector: "); if ( iv == IVNULL ) { fprintf(fp,"**** NULL ****\n"); return; } fprintf(fp,"dim: %d\n",iv->dim); for ( i = 0; i < iv->dim; i++ ) { if ( (i+1) % 8 ) fprintf(fp,"%8d ",iv->ive[i]); else fprintf(fp,"%8d\n",iv->ive[i]); } if ( i % 8 ) fprintf(fp,"\n"); } /* iv_finput -- input integer vector from stream fp */ IVEC *iv_finput(fp,x) FILE *fp; IVEC *x; { IVEC *iiv_finput(),*biv_finput(); if ( isatty(fileno(fp)) ) return iiv_finput(fp,x); else return biv_finput(fp,x); } /* iiv_finput -- interactive input of IVEC iv */ IVEC *iiv_finput(fp,iv) FILE *fp; IVEC *iv; { u_int i,dim,dynamic; /* dynamic set if memory allocated here */ /* get dimension */ if ( iv != (IVEC *)NULL && iv->dimdim; dynamic = FALSE; } else { dynamic = TRUE; do { fprintf(stderr,"IntVector: dim: "); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"iiv_finput"); } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); iv = iv_get(dim); } /* input elements */ for ( i=0; iive[i]); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"iiv_finput"); if ( (*line == 'b' || *line == 'B') && i > 0 ) { i--; dynamic = FALSE; goto redo; } if ( (*line == 'f' || *line == 'F') && i < dim-1 ) { i++; dynamic = FALSE; goto redo; } } while ( *line=='\0' || sscanf(line,"%d",&iv->ive[i]) < 1 ); return (iv); } /* biv_finput -- batch-file input of IVEC iv */ IVEC *biv_finput(fp,iv) FILE *fp; IVEC *iv; { u_int i,dim; int io_code; /* get dimension */ skipjunk(fp); if ((io_code=fscanf(fp," IntVector: dim:%u",&dim)) < 1 || dim>MAXDIM ) error(io_code==EOF ? 7 : 6,"biv_finput"); /* allocate memory if necessary */ if ( iv==(IVEC *)NULL || iv->dimive[i])) < 1 ) error(io_code==EOF ? 7 : 6,"biv_finput"); return (iv); } /* iv_dump -- dumps all the contents of IVEC iv onto stream fp */ void iv_dump(fp,iv) FILE*fp; IVEC*iv; { int i; fprintf(fp,"IntVector: "); if ( ! iv ) { fprintf(fp,"**** NULL ****\n"); return; } fprintf(fp,"dim: %d, max_dim: %d\n",iv->dim,iv->max_dim); fprintf(fp,"ive @ 0x%lx\n",(long)(iv->ive)); for ( i = 0; i < iv->max_dim; i++ ) { if ( (i+1) % 8 ) fprintf(fp,"%8d ",iv->ive[i]); else fprintf(fp,"%8d\n",iv->ive[i]); } if ( i % 8 ) fprintf(fp,"\n"); } #define MAX_STACK 60 /* iv_sort -- sorts vector x, and generates permutation that gives the order of the components; x = [1.3, 3.7, 0.5] -> [0.5, 1.3, 3.7] and the permutation is order = [2, 0, 1]. -- if order is NULL on entry then it is ignored -- the sorted vector x is returned */ IVEC *iv_sort(x, order) IVEC *x; PERM *order; { int *x_ive, tmp, v; /* int *order_pe; */ int dim, i, j, l, r, tmp_i; int stack[MAX_STACK], sp; if ( ! x ) error(E_NULL,"v_sort"); if ( order != PNULL && order->size != x->dim ) order = px_resize(order, x->dim); x_ive = x->ive; dim = x->dim; if ( order != PNULL ) px_ident(order); if ( dim <= 1 ) return x; /* using quicksort algorithm in Sedgewick, "Algorithms in C", Ch. 9, pp. 118--122 (1990) */ sp = 0; l = 0; r = dim-1; v = x_ive[0]; for ( ; ; ) { while ( r > l ) { /* "i = partition(x_ive,l,r);" */ v = x_ive[r]; i = l-1; j = r; for ( ; ; ) { while ( x_ive[++i] < v ) ; while ( x_ive[--j] > v ) ; if ( i >= j ) break; tmp = x_ive[i]; x_ive[i] = x_ive[j]; x_ive[j] = tmp; if ( order != PNULL ) { tmp_i = order->pe[i]; order->pe[i] = order->pe[j]; order->pe[j] = tmp_i; } } tmp = x_ive[i]; x_ive[i] = x_ive[r]; x_ive[r] = tmp; if ( order != PNULL ) { tmp_i = order->pe[i]; order->pe[i] = order->pe[r]; order->pe[r] = tmp_i; } if ( i-l > r-i ) { stack[sp++] = l; stack[sp++] = i-1; l = i+1; } else { stack[sp++] = i+1; stack[sp++] = r; r = i-1; } } /* recursion elimination */ if ( sp == 0 ) break; r = stack[--sp]; l = stack[--sp]; } return x; } meschach-1.2b/version.c100644 764 764 5002 5544154703 14503 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Version routine */ /* This routine must be modified whenever modifications are made to Meschach by persons other than the original authors (David E. Stewart & Zbigniew Leyk); when new releases of Meschach are made the version number will also be updated */ #include void m_version() { static char rcsid[] = "$Id: version.c,v 1.9 1994/03/24 00:04:05 des Exp $"; printf("Meshach matrix library version 1.2b\n"); printf("RCS id: %s\n",rcsid); printf("Changes since 1.2a:\n"); printf("\t Fixed bug in schur() for 2x2 blocks with real e-vals\n"); printf("\t Fixed bug in schur() reading beyond end of array\n"); printf("\t Fixed some installation bugs\n"); printf("\t Fixed bugs & improved efficiency in spILUfactor()\n"); printf("\t px_inv() doesn't crash inverting non-permutations\n"); /**** List of modifications ****/ /* Example below is for illustration only */ /* printf("Modified by %s, routine(s) %s, file %s on date %s\n", "Joe Bloggs", "m_version", "version.c", "Fri Apr 5 16:00:38 EST 1994"); */ /* printf("Purpose: %s\n", "To update the version number"); */ } /* $Log: version.c,v $ * Revision 1.9 1994/03/24 00:04:05 des * Added notes on changes to spILUfactor() and px_inv(). * * Revision 1.8 1994/02/21 04:32:25 des * Set version to 1.2b with bug fixes in schur() and installation. * * Revision 1.7 1994/01/13 05:43:57 des * Version 1.2 update * * */ meschach-1.2b/meminfo.c100644 764 764 21703 5515156350 14474 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* meminfo.c revised 22/11/93 */ /* contains basic functions, types and arrays to keep track of memory allocation/deallocation */ #include #include "matrix.h" #include "meminfo.h" #ifdef COMPLEX #include "zmatrix.h" #endif #ifdef SPARSE #include "sparse.h" #include "iter.h" #endif static char rcsid[] = "$Id: meminfo.c,v 1.1 1994/01/13 05:31:39 des Exp $"; /* this array is defined further in this file */ extern MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS]; /* names of types */ static char *mem_type_names[] = { "MAT", "BAND", "PERM", "VEC", "IVEC" #ifdef SPARSE ,"ITER", "SPROW", "SPMAT" #endif #ifdef COMPLEX ,"ZVEC", "ZMAT" #endif }; #define MEM_NUM_STD_TYPES (sizeof(mem_type_names)/sizeof(mem_type_names[0])) /* local array for keeping track of memory */ static MEM_ARRAY mem_info_sum[MEM_NUM_STD_TYPES]; /* for freeing various types */ static int (*mem_free_funcs[MEM_NUM_STD_TYPES])() = { m_free, bd_free, px_free, v_free, iv_free #ifdef SPARSE ,iter_free, sprow_free, sp_free #endif #ifdef COMPLEX ,zv_free, zm_free #endif }; /* it is a global variable for passing pointers to local arrays defined here */ MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS] = { { mem_type_names, mem_free_funcs, MEM_NUM_STD_TYPES, mem_info_sum } }; /* attach a new list of types */ int mem_attach_list(list, ntypes, type_names, free_funcs, info_sum) int list,ntypes; /* number of a list and number of types there */ char *type_names[]; /* list of names of types */ int (*free_funcs[])(); /* list of releasing functions */ MEM_ARRAY info_sum[]; /* local table */ { if (list < 0 || list >= MEM_CONNECT_MAX_LISTS) return -1; if (type_names == NULL || free_funcs == NULL || info_sum == NULL || ntypes < 0) return -1; /* if a list exists do not overwrite */ if ( mem_connect[list].ntypes != 0 ) error(E_OVERWRITE,"mem_attach_list"); mem_connect[list].ntypes = ntypes; mem_connect[list].type_names = type_names; mem_connect[list].free_funcs = free_funcs; mem_connect[list].info_sum = info_sum; return 0; } /* release a list of types */ int mem_free_vars(list) int list; { if (list < 0 || list >= MEM_CONNECT_MAX_LISTS) return -1; mem_connect[list].ntypes = 0; mem_connect[list].type_names = NULL; mem_connect[list].free_funcs = NULL; mem_connect[list].info_sum = NULL; return 0; } /* check if list is attached */ int mem_is_list_attached(list) int list; { if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return FALSE; if ( mem_connect[list].type_names != NULL && mem_connect[list].free_funcs != NULL && mem_connect[list].info_sum != NULL) return TRUE; else return FALSE; } /* to print out the contents of mem_connect[list] */ void mem_dump_list(fp,list) FILE *fp; int list; { int i; MEM_CONNECT *mlist; if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return; mlist = &mem_connect[list]; fprintf(fp," %15s[%d]:\n","CONTENTS OF mem_connect",list); fprintf(fp," %-7s %-12s %-9s %s\n", "name of", "alloc.", "# alloc.", "address" ); fprintf(fp," %-7s %-12s %-9s %s\n", " type", "bytes", "variables", "of *_free()" ); for (i=0; i < mlist->ntypes; i++) fprintf(fp," %-7s %-12ld %-9d %p\n", mlist->type_names[i], mlist->info_sum[i].bytes, mlist->info_sum[i].numvar, mlist->free_funcs[i] ); fprintf(fp,"\n"); } /*=============================================================*/ /* local variables */ static int mem_switched_on = MEM_SWITCH_ON_DEF; /* on/off */ /* switch on/off memory info */ int mem_info_on(sw) int sw; { int old = mem_switched_on; mem_switched_on = sw; return old; } #ifdef ANSI_C int mem_info_is_on(void) #else int mem_info_is_on() #endif { return mem_switched_on; } /* information about allocated memory */ /* return the number of allocated bytes for type 'type' */ long mem_info_bytes(type,list) int type,list; { if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return 0l; if ( !mem_switched_on || type < 0 || type >= mem_connect[list].ntypes || mem_connect[list].free_funcs[type] == NULL ) return 0l; return mem_connect[list].info_sum[type].bytes; } /* return the number of allocated variables for type 'type' */ int mem_info_numvar(type,list) int type,list; { if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return 0l; if ( !mem_switched_on || type < 0 || type >= mem_connect[list].ntypes || mem_connect[list].free_funcs[type] == NULL ) return 0l; return mem_connect[list].info_sum[type].numvar; } /* print out memory info to the file fp */ void mem_info_file(fp,list) FILE *fp; int list; { unsigned int type; long t = 0l, d; int n = 0, nt = 0; MEM_CONNECT *mlist; if (!mem_switched_on) return; if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return; if (list == 0) fprintf(fp," MEMORY INFORMATION (standard types):\n"); else fprintf(fp," MEMORY INFORMATION (list no. %d):\n",list); mlist = &mem_connect[list]; for (type=0; type < mlist->ntypes; type++) { if (mlist->type_names[type] == NULL ) continue; d = mlist->info_sum[type].bytes; t += d; n = mlist->info_sum[type].numvar; nt += n; fprintf(fp," type %-7s %10ld alloc. byte%c %6d alloc. variable%c\n", mlist->type_names[type], d, (d!=1 ? 's' : ' '), n, (n!=1 ? 's' : ' ')); } fprintf(fp," %-12s %10ld alloc. byte%c %6d alloc. variable%c\n\n", "total:",t, (t!=1 ? 's' : ' '), nt, (nt!=1 ? 's' : ' ')); } /* function for memory information */ /* mem_bytes_list Arguments: type - the number of type; old_size - old size of allocated memory (in bytes); new_size - new size of allocated memory (in bytes); list - list of types */ void mem_bytes_list(type,old_size,new_size,list) int type,list; int old_size,new_size; { MEM_CONNECT *mlist; if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return; mlist = &mem_connect[list]; if ( type < 0 || type >= mlist->ntypes || mlist->free_funcs[type] == NULL ) return; if ( old_size < 0 || new_size < 0 ) error(E_NEG,"mem_bytes_list"); mlist->info_sum[type].bytes += new_size - old_size; /* check if the number of bytes is non-negative */ if ( old_size > 0 ) { if (mlist->info_sum[type].bytes < 0) { fprintf(stderr, "\n WARNING !! memory info: allocated memory is less than 0\n"); fprintf(stderr,"\t TYPE %s \n\n", mlist->type_names[type]); if ( !isatty(fileno(stdout)) ) { fprintf(stdout, "\n WARNING !! memory info: allocated memory is less than 0\n"); fprintf(stdout,"\t TYPE %s \n\n", mlist->type_names[type]); } } } } /* mem_numvar_list Arguments: type - the number of type; num - # of variables allocated (> 0) or deallocated ( < 0) list - list of types */ void mem_numvar_list(type,num,list) int type,list,num; { MEM_CONNECT *mlist; if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return; mlist = &mem_connect[list]; if ( type < 0 || type >= mlist->ntypes || mlist->free_funcs[type] == NULL ) return; mlist->info_sum[type].numvar += num; /* check if the number of variables is non-negative */ if ( num < 0 ) { if (mlist->info_sum[type].numvar < 0) { fprintf(stderr, "\n WARNING !! memory info: allocated # of variables is less than 0\n"); fprintf(stderr,"\t TYPE %s \n\n", mlist->type_names[type]); if ( !isatty(fileno(stdout)) ) { fprintf(stdout, "\n WARNING !! memory info: allocated # of variables is less than 0\n"); fprintf(stdout,"\t TYPE %s \n\n", mlist->type_names[type]); } } } } meschach-1.2b/memstat.c100644 764 764 20704 5515156435 14520 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* mem_stat.c 6/09/93 */ /* Deallocation of static arrays */ #include #include "matrix.h" #include "meminfo.h" #ifdef COMPLEX #include "zmatrix.h" #endif #ifdef SPARSE #include "sparse.h" #include "iter.h" #endif static char rcsid[] = "$Id: memstat.c,v 1.1 1994/01/13 05:32:44 des Exp $"; /* global variable */ extern MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS]; /* local type */ typedef struct { void **var; /* for &A, where A is a pointer */ int type; /* type of A */ int mark; /* what mark is chosen */ } MEM_STAT_STRUCT; /* local variables */ /* how many marks are used */ static int mem_stat_mark_many = 0; /* current mark */ static int mem_stat_mark_curr = 0; static MEM_STAT_STRUCT mem_stat_var[MEM_HASHSIZE]; /* array of indices (+1) to mem_stat_var */ static unsigned int mem_hash_idx[MEM_HASHSIZE]; /* points to the first unused element in mem_hash_idx */ static unsigned int mem_hash_idx_end = 0; /* hashing function */ static unsigned int mem_hash(ptr) void **ptr; { unsigned long lp = (unsigned long)ptr; return (lp % MEM_HASHSIZE); } /* look for a place in mem_stat_var */ static int mem_lookup(var) void **var; { int k, j; k = mem_hash(var); if (mem_stat_var[k].var == var) { return -1; } else if (mem_stat_var[k].var == NULL) { return k; } else { /* look for an empty place */ j = k; while (mem_stat_var[j].var != var && j < MEM_HASHSIZE && mem_stat_var[j].var != NULL) j++; if (mem_stat_var[j].var == NULL) return j; else if (mem_stat_var[j].var == var) return -1; else { /* if (j == MEM_HASHSIZE) */ j = 0; while (mem_stat_var[j].var != var && j < k && mem_stat_var[j].var != NULL) j++; if (mem_stat_var[j].var == NULL) return j; else if (mem_stat_var[j].var == var) return -1; else { /* if (j == k) */ fprintf(stderr, "\n WARNING !!! static memory: mem_stat_var is too small\n"); fprintf(stderr, " Increase MEM_HASHSIZE in file: %s (currently = %d)\n\n", MEM_HASHSIZE_FILE, MEM_HASHSIZE); if ( !isatty(fileno(stdout)) ) { fprintf(stdout, "\n WARNING !!! static memory: mem_stat_var is too small\n"); fprintf(stdout, " Increase MEM_HASHSIZE in file: %s (currently = %d)\n\n", MEM_HASHSIZE_FILE, MEM_HASHSIZE); } error(E_MEM,"mem_lookup"); } } } return -1; } /* register static variables; Input arguments: var - variable to be registered, type - type of this variable; list - list of types returned value < 0 --> error, returned value == 0 --> not registered, returned value >= 0 --> registered with this mark; */ int mem_stat_reg_list(var,type,list) void **var; int type,list; { int n; if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS ) return -1; if (mem_stat_mark_curr == 0) return 0; /* not registered */ if (var == NULL) return -1; /* error */ if ( type < 0 || type >= mem_connect[list].ntypes || mem_connect[list].free_funcs[type] == NULL ) { warning(WARN_WRONG_TYPE,"mem_stat_reg_list"); return -1; } if ((n = mem_lookup(var)) >= 0) { mem_stat_var[n].var = var; mem_stat_var[n].mark = mem_stat_mark_curr; mem_stat_var[n].type = type; /* save n+1, not n */ mem_hash_idx[mem_hash_idx_end++] = n+1; } return mem_stat_mark_curr; } /* set a mark; Input argument: mark - positive number denoting a mark; returned: mark if mark > 0, 0 if mark == 0, -1 if mark is negative. */ int mem_stat_mark(mark) int mark; { if (mark < 0) { mem_stat_mark_curr = 0; return -1; /* error */ } else if (mark == 0) { mem_stat_mark_curr = 0; return 0; } mem_stat_mark_curr = mark; mem_stat_mark_many++; return mark; } /* deallocate static variables; Input argument: mark - a positive number denoting the mark; Returned: -1 if mark < 0 (error); 0 if mark == 0; */ int mem_stat_free_list(mark,list) int mark,list; { u_int i,j; int (*free_fn)(); if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS || mem_connect[list].free_funcs == NULL ) return -1; if (mark < 0) { mem_stat_mark_curr = 0; return -1; } else if (mark == 0) { mem_stat_mark_curr = 0; return 0; } if (mem_stat_mark_many <= 0) { warning(WARN_NO_MARK,"mem_stat_free"); return -1; } /* deallocate the marked variables */ for (i=0; i < mem_hash_idx_end; i++) { j = mem_hash_idx[i]; if (j == 0) continue; else { j--; if (mem_stat_var[j].mark == mark) { free_fn = mem_connect[list].free_funcs[mem_stat_var[j].type]; if ( free_fn != NULL ) (*free_fn)(*mem_stat_var[j].var); else warning(WARN_WRONG_TYPE,"mem_stat_free"); *(mem_stat_var[j].var) = NULL; mem_stat_var[j].var = NULL; mem_stat_var[j].mark = 0; mem_hash_idx[i] = 0; } } } while (mem_hash_idx_end > 0 && mem_hash_idx[mem_hash_idx_end-1] == 0) mem_hash_idx_end--; mem_stat_mark_curr = 0; mem_stat_mark_many--; return 0; } /* only for diagnostic purposes */ void mem_stat_dump(fp,list) FILE *fp; int list; { u_int i,j,k=1; if ( list < 0 || list >= MEM_CONNECT_MAX_LISTS || mem_connect[list].free_funcs == NULL ) return; fprintf(fp," Array mem_stat_var (list no. %d):\n",list); for (i=0; i < mem_hash_idx_end; i++) { j = mem_hash_idx[i]; if (j == 0) continue; else { j--; fprintf(fp," %d. var = 0x%p, type = %s, mark = %d\n", k,mem_stat_var[j].var, mem_stat_var[j].type < mem_connect[list].ntypes && mem_connect[list].free_funcs[mem_stat_var[j].type] != NULL ? mem_connect[list].type_names[(int)mem_stat_var[j].type] : "???", mem_stat_var[j].mark); k++; } } fprintf(fp,"\n"); } /* query function about the current mark */ #ifdef ANSI_C int mem_stat_show_mark(void) #else int mem_stat_show_mark() #endif { return mem_stat_mark_curr; } /* Varying number of arguments */ #ifdef ANSI_C /* To allocate memory to many arguments. The function should be called: mem_stat_vars(list,type,&v1,&v2,&v3,...,VNULL); where int list,type; void **v1, **v2, **v3,...; The last argument should be VNULL ! type is the type of variables v1,v2,v3,... (of course they must be of the same type) */ int mem_stat_reg_vars(int list,int type,...) { va_list ap; int i=0; void **par; va_start(ap, type); while (par = va_arg(ap,void **)) { /* NULL ends the list*/ mem_stat_reg_list(par,type,list); i++; } va_end(ap); return i; } #elif VARARGS /* old varargs is used */ /* To allocate memory to many arguments. The function should be called: mem_stat_vars(list,type,&v1,&v2,&v3,...,VNULL); where int list,type; void **v1, **v2, **v3,...; The last argument should be VNULL ! type is the type of variables v1,v2,v3,... (of course they must be of the same type) */ int mem_stat_reg_vars(va_alist) va_dcl { va_list ap; int type,list,i=0; void **par; va_start(ap); list = va_arg(ap,int); type = va_arg(ap,int); while (par = va_arg(ap,void **)) { /* NULL ends the list*/ mem_stat_reg_list(par,type,list); i++; } va_end(ap); return i; } #endif meschach-1.2b/lufactor.c100644 764 764 15344 5745532340 14667 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. */ /* LUfactor.c 1.5 11/25/87 */ static char rcsid[] = "$Id: lufactor.c,v 1.9 1995/04/20 19:21:54 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include /* Most matrix factorisation routines are in-situ unless otherwise specified */ /* LUfactor -- gaussian elimination with scaled partial pivoting -- Note: returns LU matrix which is A */ MAT *LUfactor(A,pivot) MAT *A; PERM *pivot; { u_int i, j, k, k_max, m, n; int i_max; Real **A_v, *A_piv, *A_row; Real max1, temp, tiny; static VEC *scale = VNULL; if ( A==(MAT *)NULL || pivot==(PERM *)NULL ) error(E_NULL,"LUfactor"); if ( pivot->size != A->m ) error(E_SIZES,"LUfactor"); m = A->m; n = A->n; scale = v_resize(scale,A->m); MEM_STAT_REG(scale,TYPE_VEC); A_v = A->me; tiny = 10.0/HUGE_VAL; /* initialise pivot with identity permutation */ for ( i=0; ipe[i] = i; /* set scale parameters */ for ( i=0; ive[i] = max1; } /* main loop */ k_max = min(m,n)-1; for ( k=0; kve[i]) >= tiny*fabs(A_v[i][k]) ) { temp = fabs(A_v[i][k])/scale->ve[i]; if ( temp > max1 ) { max1 = temp; i_max = i; } } /* if no pivot then ignore column k... */ if ( i_max == -1 ) { /* set pivot entry A[k][k] exactly to zero, rather than just "small" */ A_v[k][k] = 0.0; continue; } /* do we pivot ? */ if ( i_max != k ) /* yes we do... */ { px_transp(pivot,i_max,k); for ( j=0; jm != A->n || A->n != b->dim ) error(E_SIZES,"LUsolve"); x = v_resize(x,b->dim); px_vec(pivot,b,x); /* x := P.b */ Lsolve(A,x,x,1.0); /* implicit diagonal = 1 */ Usolve(A,x,x,0.0); /* explicit diagonal */ return (x); } /* LUTsolve -- given an LU factorisation in A, solve A^T.x=b */ VEC *LUTsolve(LU,pivot,b,x) MAT *LU; PERM *pivot; VEC *b,*x; { if ( ! LU || ! b || ! pivot ) error(E_NULL,"LUTsolve"); if ( LU->m != LU->n || LU->n != b->dim ) error(E_SIZES,"LUTsolve"); x = v_copy(b,x); UTsolve(LU,x,x,0.0); /* explicit diagonal */ LTsolve(LU,x,x,1.0); /* implicit diagonal = 1 */ pxinv_vec(pivot,x,x); /* x := P^T.tmp */ return (x); } /* m_inverse -- returns inverse of A, provided A is not too rank deficient -- uses LU factorisation */ MAT *m_inverse(A,out) MAT *A, *out; { int i; static VEC *tmp = VNULL, *tmp2 = VNULL; static MAT *A_cp = MNULL; static PERM *pivot = PNULL; if ( ! A ) error(E_NULL,"m_inverse"); if ( A->m != A->n ) error(E_SQUARE,"m_inverse"); if ( ! out || out->m < A->m || out->n < A->n ) out = m_resize(out,A->m,A->n); A_cp = m_resize(A_cp,A->m,A->n); A_cp = m_copy(A,A_cp); tmp = v_resize(tmp,A->m); tmp2 = v_resize(tmp2,A->m); pivot = px_resize(pivot,A->m); MEM_STAT_REG(A_cp,TYPE_MAT); MEM_STAT_REG(tmp, TYPE_VEC); MEM_STAT_REG(tmp2,TYPE_VEC); MEM_STAT_REG(pivot,TYPE_PERM); tracecatch(LUfactor(A_cp,pivot),"m_inverse"); for ( i = 0; i < A->n; i++ ) { v_zero(tmp); tmp->ve[i] = 1.0; tracecatch(LUsolve(A_cp,pivot,tmp,tmp2),"m_inverse"); set_col(out,i,tmp2); } return out; } /* LUcondest -- returns an estimate of the condition number of LU given the LU factorisation in compact form */ double LUcondest(LU,pivot) MAT *LU; PERM *pivot; { static VEC *y = VNULL, *z = VNULL; Real cond_est, L_norm, U_norm, sum, tiny; int i, j, n; if ( ! LU || ! pivot ) error(E_NULL,"LUcondest"); if ( LU->m != LU->n ) error(E_SQUARE,"LUcondest"); if ( LU->n != pivot->size ) error(E_SIZES,"LUcondest"); tiny = 10.0/HUGE_VAL; n = LU->n; y = v_resize(y,n); z = v_resize(z,n); MEM_STAT_REG(y,TYPE_VEC); MEM_STAT_REG(z,TYPE_VEC); for ( i = 0; i < n; i++ ) { sum = 0.0; for ( j = 0; j < i; j++ ) sum -= LU->me[j][i]*y->ve[j]; sum -= (sum < 0.0) ? 1.0 : -1.0; if ( fabs(LU->me[i][i]) <= tiny*fabs(sum) ) return HUGE_VAL; y->ve[i] = sum / LU->me[i][i]; } catch(E_SING, LTsolve(LU,y,y,1.0); LUsolve(LU,pivot,y,z); , return HUGE_VAL); /* now estimate norm of A (even though it is not directly available) */ /* actually computes ||L||_inf.||U||_inf */ U_norm = 0.0; for ( i = 0; i < n; i++ ) { sum = 0.0; for ( j = i; j < n; j++ ) sum += fabs(LU->me[i][j]); if ( sum > U_norm ) U_norm = sum; } L_norm = 0.0; for ( i = 0; i < n; i++ ) { sum = 1.0; for ( j = 0; j < i; j++ ) sum += fabs(LU->me[i][j]); if ( sum > L_norm ) L_norm = sum; } tracecatch(cond_est = U_norm*L_norm*v_norm_inf(z)/v_norm_inf(y), "LUcondest"); return cond_est; } meschach-1.2b/bkpfacto.c100644 764 764 20402 5673124071 14626 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. */ static char rcsid[] = "$Id: bkpfacto.c,v 1.7 1994/01/13 05:45:50 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include #define btos(x) ((x) ? "TRUE" : "FALSE") /* Most matrix factorisation routines are in-situ unless otherwise specified */ #define alpha 0.6403882032022076 /* = (1+sqrt(17))/8 */ /* sqr -- returns square of x -- utility function */ double sqr(x) double x; { return x*x; } /* interchange -- a row/column swap routine */ static void interchange(A,i,j) MAT *A; /* assumed != NULL & also SQUARE */ int i, j; /* assumed in range */ { Real **A_me, tmp; int k, n; A_me = A->me; n = A->n; if ( i == j ) return; if ( i > j ) { k = i; i = j; j = k; } for ( k = 0; k < i; k++ ) { /* tmp = A_me[k][i]; */ tmp = m_entry(A,k,i); /* A_me[k][i] = A_me[k][j]; */ m_set_val(A,k,i,m_entry(A,k,j)); /* A_me[k][j] = tmp; */ m_set_val(A,k,j,tmp); } for ( k = j+1; k < n; k++ ) { /* tmp = A_me[j][k]; */ tmp = m_entry(A,j,k); /* A_me[j][k] = A_me[i][k]; */ m_set_val(A,j,k,m_entry(A,i,k)); /* A_me[i][k] = tmp; */ m_set_val(A,i,k,tmp); } for ( k = i+1; k < j; k++ ) { /* tmp = A_me[k][j]; */ tmp = m_entry(A,k,j); /* A_me[k][j] = A_me[i][k]; */ m_set_val(A,k,j,m_entry(A,i,k)); /* A_me[i][k] = tmp; */ m_set_val(A,i,k,tmp); } /* tmp = A_me[i][i]; */ tmp = m_entry(A,i,i); /* A_me[i][i] = A_me[j][j]; */ m_set_val(A,i,i,m_entry(A,j,j)); /* A_me[j][j] = tmp; */ m_set_val(A,j,j,tmp); } /* BKPfactor -- Bunch-Kaufman-Parlett factorisation of A in-situ -- A is factored into the form P'AP = MDM' where P is a permutation matrix, M lower triangular and D is block diagonal with blocks of size 1 or 2 -- P is stored in pivot; blocks[i]==i iff D[i][i] is a block */ MAT *BKPfactor(A,pivot,blocks) MAT *A; PERM *pivot, *blocks; { int i, j, k, n, onebyone, r; Real **A_me, aii, aip1, aip1i, lambda, sigma, tmp; Real det, s, t; if ( ! A || ! pivot || ! blocks ) error(E_NULL,"BKPfactor"); if ( A->m != A->n ) error(E_SQUARE,"BKPfactor"); if ( A->m != pivot->size || pivot->size != blocks->size ) error(E_SIZES,"BKPfactor"); n = A->n; A_me = A->me; px_ident(pivot); px_ident(blocks); for ( i = 0; i < n; i = onebyone ? i+1 : i+2 ) { /* printf("# Stage: %d\n",i); */ aii = fabs(m_entry(A,i,i)); lambda = 0.0; r = (i+1 < n) ? i+1 : i; for ( k = i+1; k < n; k++ ) { tmp = fabs(m_entry(A,i,k)); if ( tmp >= lambda ) { lambda = tmp; r = k; } } /* printf("# lambda = %g, r = %d\n", lambda, r); */ /* printf("# |A[%d][%d]| = %g\n",r,r,fabs(m_entry(A,r,r))); */ /* determine if 1x1 or 2x2 block, and do pivoting if needed */ if ( aii >= alpha*lambda ) { onebyone = TRUE; goto dopivot; } /* compute sigma */ sigma = 0.0; for ( k = i; k < n; k++ ) { if ( k == r ) continue; tmp = ( k > r ) ? fabs(m_entry(A,r,k)) : fabs(m_entry(A,k,r)); if ( tmp > sigma ) sigma = tmp; } if ( aii*sigma >= alpha*sqr(lambda) ) onebyone = TRUE; else if ( fabs(m_entry(A,r,r)) >= alpha*sigma ) { /* printf("# Swapping rows/cols %d and %d\n",i,r); */ interchange(A,i,r); px_transp(pivot,i,r); onebyone = TRUE; } else { /* printf("# Swapping rows/cols %d and %d\n",i+1,r); */ interchange(A,i+1,r); px_transp(pivot,i+1,r); px_transp(blocks,i,i+1); onebyone = FALSE; } /* printf("onebyone = %s\n",btos(onebyone)); */ /* printf("# Matrix so far (@checkpoint A) =\n"); */ /* m_output(A); */ /* printf("# pivot =\n"); px_output(pivot); */ /* printf("# blocks =\n"); px_output(blocks); */ dopivot: if ( onebyone ) { /* do one by one block */ if ( m_entry(A,i,i) != 0.0 ) { aii = m_entry(A,i,i); for ( j = i+1; j < n; j++ ) { tmp = m_entry(A,i,j)/aii; for ( k = j; k < n; k++ ) m_sub_val(A,j,k,tmp*m_entry(A,i,k)); m_set_val(A,i,j,tmp); } } } else /* onebyone == FALSE */ { /* do two by two block */ det = m_entry(A,i,i)*m_entry(A,i+1,i+1)-sqr(m_entry(A,i,i+1)); /* Must have det < 0 */ /* printf("# det = %g\n",det); */ aip1i = m_entry(A,i,i+1)/det; aii = m_entry(A,i,i)/det; aip1 = m_entry(A,i+1,i+1)/det; for ( j = i+2; j < n; j++ ) { s = - aip1i*m_entry(A,i+1,j) + aip1*m_entry(A,i,j); t = - aip1i*m_entry(A,i,j) + aii*m_entry(A,i+1,j); for ( k = j; k < n; k++ ) m_sub_val(A,j,k,m_entry(A,i,k)*s + m_entry(A,i+1,k)*t); m_set_val(A,i,j,s); m_set_val(A,i+1,j,t); } } /* printf("# Matrix so far (@checkpoint B) =\n"); */ /* m_output(A); */ /* printf("# pivot =\n"); px_output(pivot); */ /* printf("# blocks =\n"); px_output(blocks); */ } /* set lower triangular half */ for ( i = 0; i < A->m; i++ ) for ( j = 0; j < i; j++ ) m_set_val(A,i,j,m_entry(A,j,i)); return A; } /* BKPsolve -- solves A.x = b where A has been factored a la BKPfactor() -- returns x, which is created if NULL */ VEC *BKPsolve(A,pivot,block,b,x) MAT *A; PERM *pivot, *block; VEC *b, *x; { static VEC *tmp=VNULL; /* dummy storage needed */ int i, j, n, onebyone; Real **A_me, a11, a12, a22, b1, b2, det, sum, *tmp_ve, tmp_diag; if ( ! A || ! pivot || ! block || ! b ) error(E_NULL,"BKPsolve"); if ( A->m != A->n ) error(E_SQUARE,"BKPsolve"); n = A->n; if ( b->dim != n || pivot->size != n || block->size != n ) error(E_SIZES,"BKPsolve"); x = v_resize(x,n); tmp = v_resize(tmp,n); MEM_STAT_REG(tmp,TYPE_VEC); A_me = A->me; tmp_ve = tmp->ve; px_vec(pivot,b,tmp); /* solve for lower triangular part */ for ( i = 0; i < n; i++ ) { sum = v_entry(tmp,i); if ( block->pe[i] < i ) for ( j = 0; j < i-1; j++ ) sum -= m_entry(A,i,j)*v_entry(tmp,j); else for ( j = 0; j < i; j++ ) sum -= m_entry(A,i,j)*v_entry(tmp,j); v_set_val(tmp,i,sum); } /* printf("# BKPsolve: solving L part: tmp =\n"); v_output(tmp); */ /* solve for diagonal part */ for ( i = 0; i < n; i = onebyone ? i+1 : i+2 ) { onebyone = ( block->pe[i] == i ); if ( onebyone ) { tmp_diag = m_entry(A,i,i); if ( tmp_diag == 0.0 ) error(E_SING,"BKPsolve"); /* tmp_ve[i] /= tmp_diag; */ v_set_val(tmp,i,v_entry(tmp,i) / tmp_diag); } else { a11 = m_entry(A,i,i); a22 = m_entry(A,i+1,i+1); a12 = m_entry(A,i+1,i); b1 = v_entry(tmp,i); b2 = v_entry(tmp,i+1); det = a11*a22-a12*a12; /* < 0 : see BKPfactor() */ if ( det == 0.0 ) error(E_SING,"BKPsolve"); det = 1/det; v_set_val(tmp,i,det*(a22*b1-a12*b2)); v_set_val(tmp,i+1,det*(a11*b2-a12*b1)); } } /* printf("# BKPsolve: solving D part: tmp =\n"); v_output(tmp); */ /* solve for transpose of lower traingular part */ for ( i = n-1; i >= 0; i-- ) { /* use symmetry of factored form to get stride 1 */ sum = v_entry(tmp,i); if ( block->pe[i] > i ) for ( j = i+2; j < n; j++ ) sum -= m_entry(A,i,j)*v_entry(tmp,j); else for ( j = i+1; j < n; j++ ) sum -= m_entry(A,i,j)*v_entry(tmp,j); v_set_val(tmp,i,sum); } /* printf("# BKPsolve: solving L^T part: tmp =\n");v_output(tmp); */ /* and do final permutation */ x = pxinv_vec(pivot,tmp,x); return x; } meschach-1.2b/chfactor.c100644 764 764 11636 5673124113 14634 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. */ /* CHfactor.c 1.2 11/25/87 */ static char rcsid[] = "$Id: chfactor.c,v 1.2 1994/01/13 05:36:36 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include /* Most matrix factorisation routines are in-situ unless otherwise specified */ /* CHfactor -- Cholesky L.L' factorisation of A in-situ */ MAT *CHfactor(A) MAT *A; { u_int i, j, k, n; Real **A_ent, *A_piv, *A_row, sum, tmp; if ( A==(MAT *)NULL ) error(E_NULL,"CHfactor"); if ( A->m != A->n ) error(E_SQUARE,"CHfactor"); n = A->n; A_ent = A->me; for ( k=0; km != A->n || A->n != b->dim ) error(E_SIZES,"CHsolve"); x = v_resize(x,b->dim); Lsolve(A,b,x,0.0); Usolve(A,x,x,0.0); return (x); } /* LDLfactor -- L.D.L' factorisation of A in-situ */ MAT *LDLfactor(A) MAT *A; { u_int i, k, n, p; Real **A_ent; Real d, sum; static VEC *r = VNULL; if ( ! A ) error(E_NULL,"LDLfactor"); if ( A->m != A->n ) error(E_SQUARE,"LDLfactor"); n = A->n; A_ent = A->me; r = v_resize(r,n); MEM_STAT_REG(r,TYPE_VEC); for ( k = 0; k < n; k++ ) { sum = 0.0; for ( p = 0; p < k; p++ ) { r->ve[p] = A_ent[p][p]*A_ent[k][p]; sum += r->ve[p]*A_ent[k][p]; } d = A_ent[k][k] -= sum; if ( d == 0.0 ) error(E_SING,"LDLfactor"); for ( i = k+1; i < n; i++ ) { sum = __ip__(A_ent[i],r->ve,(int)k); /**************************************** sum = 0.0; for ( p = 0; p < k; p++ ) sum += A_ent[i][p]*r->ve[p]; ****************************************/ A_ent[i][k] = (A_ent[i][k] - sum)/d; } } return A; } VEC *LDLsolve(LDL,b,x) MAT *LDL; VEC *b, *x; { if ( ! LDL || ! b ) error(E_NULL,"LDLsolve"); if ( LDL->m != LDL->n ) error(E_SQUARE,"LDLsolve"); if ( LDL->m != b->dim ) error(E_SIZES,"LDLsolve"); x = v_resize(x,b->dim); Lsolve(LDL,b,x,1.0); Dsolve(LDL,x,x); LTsolve(LDL,x,x,1.0); return x; } /* MCHfactor -- Modified Cholesky L.L' factorisation of A in-situ */ MAT *MCHfactor(A,tol) MAT *A; double tol; { u_int i, j, k, n; Real **A_ent, *A_piv, *A_row, sum, tmp; if ( A==(MAT *)NULL ) error(E_NULL,"MCHfactor"); if ( A->m != A->n ) error(E_SQUARE,"MCHfactor"); if ( tol <= 0.0 ) error(E_RANGE,"MCHfactor"); n = A->n; A_ent = A->me; for ( k=0; k #include "matrix2.h" #include #define sign(x) ((x) > 0.0 ? 1 : ((x) < 0.0 ? -1 : 0 )) extern VEC *Usolve(); /* See matrix2.h */ /* Note: The usual representation of a Householder transformation is taken to be: P = I - beta.u.uT where beta = 2/(uT.u) and u is called the Householder vector */ /* QRfactor -- forms the QR factorisation of A -- factorisation stored in compact form as described above ( not quite standard format ) */ /* MAT *QRfactor(A,diag,beta) */ MAT *QRfactor(A,diag) MAT *A; VEC *diag /* ,*beta */; { u_int k,limit; Real beta; static VEC *tmp1=VNULL; if ( ! A || ! diag ) error(E_NULL,"QRfactor"); limit = min(A->m,A->n); if ( diag->dim < limit ) error(E_SIZES,"QRfactor"); tmp1 = v_resize(tmp1,A->m); MEM_STAT_REG(tmp1,TYPE_VEC); for ( k=0; kve[k],tmp1,&A->me[k][k]); */ hhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); diag->ve[k] = tmp1->ve[k]; /* apply H/holder vector to remaining columns */ /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ hhtrcols(A,k,k+1,tmp1,beta); } return (A); } /* QRCPfactor -- forms the QR factorisation of A with column pivoting -- factorisation stored in compact form as described above ( not quite standard format ) */ /* MAT *QRCPfactor(A,diag,beta,px) */ MAT *QRCPfactor(A,diag,px) MAT *A; VEC *diag /* , *beta */; PERM *px; { u_int i, i_max, j, k, limit; static VEC *gamma=VNULL, *tmp1=VNULL, *tmp2=VNULL; Real beta, maxgamma, sum, tmp; if ( ! A || ! diag || ! px ) error(E_NULL,"QRCPfactor"); limit = min(A->m,A->n); if ( diag->dim < limit || px->size != A->n ) error(E_SIZES,"QRCPfactor"); tmp1 = v_resize(tmp1,A->m); tmp2 = v_resize(tmp2,A->m); gamma = v_resize(gamma,A->n); MEM_STAT_REG(tmp1,TYPE_VEC); MEM_STAT_REG(tmp2,TYPE_VEC); MEM_STAT_REG(gamma,TYPE_VEC); /* initialise gamma and px */ for ( j=0; jn; j++ ) { px->pe[j] = j; sum = 0.0; for ( i=0; im; i++ ) sum += square(A->me[i][j]); gamma->ve[j] = sum; } for ( k=0; kve[k]; for ( i=k+1; in; i++ ) /* Loop invariant:maxgamma=gamma[i_max] >=gamma[l];l=k,...,i-1 */ if ( gamma->ve[i] > maxgamma ) { maxgamma = gamma->ve[i]; i_max = i; } /* swap columns if necessary */ if ( i_max != k ) { /* swap gamma values */ tmp = gamma->ve[k]; gamma->ve[k] = gamma->ve[i_max]; gamma->ve[i_max] = tmp; /* update column permutation */ px_transp(px,k,i_max); /* swap columns of A */ for ( i=0; im; i++ ) { tmp = A->me[i][k]; A->me[i][k] = A->me[i][i_max]; A->me[i][i_max] = tmp; } } /* get H/holder vector for the k-th column */ get_col(A,k,tmp1); /* hhvec(tmp1,k,&beta->ve[k],tmp1,&A->me[k][k]); */ hhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); diag->ve[k] = tmp1->ve[k]; /* apply H/holder vector to remaining columns */ /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ hhtrcols(A,k,k+1,tmp1,beta); /* update gamma values */ for ( j=k+1; jn; j++ ) gamma->ve[j] -= square(A->me[k][j]); } return (A); } /* Qsolve -- solves Qx = b, Q is an orthogonal matrix stored in compact form a la QRfactor() -- may be in-situ */ /* VEC *_Qsolve(QR,diag,beta,b,x,tmp) */ VEC *_Qsolve(QR,diag,b,x,tmp) MAT *QR; VEC *diag /* ,*beta */ , *b, *x, *tmp; { u_int dynamic; int k, limit; Real beta, r_ii, tmp_val; limit = min(QR->m,QR->n); dynamic = FALSE; if ( ! QR || ! diag || ! b ) error(E_NULL,"_Qsolve"); if ( diag->dim < limit || b->dim != QR->m ) error(E_SIZES,"_Qsolve"); x = v_resize(x,QR->m); if ( tmp == VNULL ) dynamic = TRUE; tmp = v_resize(tmp,QR->m); /* apply H/holder transforms in normal order */ x = v_copy(b,x); for ( k = 0 ; k < limit ; k++ ) { get_col(QR,k,tmp); r_ii = fabs(tmp->ve[k]); tmp->ve[k] = diag->ve[k]; tmp_val = (r_ii*fabs(diag->ve[k])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; /* hhtrvec(tmp,beta->ve[k],k,x,x); */ hhtrvec(tmp,beta,k,x,x); } if ( dynamic ) V_FREE(tmp); return (x); } /* makeQ -- constructs orthogonal matrix from Householder vectors stored in compact QR form */ /* MAT *makeQ(QR,diag,beta,Qout) */ MAT *makeQ(QR,diag,Qout) MAT *QR,*Qout; VEC *diag /* , *beta */; { static VEC *tmp1=VNULL,*tmp2=VNULL; u_int i, limit; Real beta, r_ii, tmp_val; int j; limit = min(QR->m,QR->n); if ( ! QR || ! diag ) error(E_NULL,"makeQ"); if ( diag->dim < limit ) error(E_SIZES,"makeQ"); if ( Qout==(MAT *)NULL || Qout->m < QR->m || Qout->n < QR->m ) Qout = m_get(QR->m,QR->m); tmp1 = v_resize(tmp1,QR->m); /* contains basis vec & columns of Q */ tmp2 = v_resize(tmp2,QR->m); /* contains H/holder vectors */ MEM_STAT_REG(tmp1,TYPE_VEC); MEM_STAT_REG(tmp2,TYPE_VEC); for ( i=0; im ; i++ ) { /* get i-th column of Q */ /* set up tmp1 as i-th basis vector */ for ( j=0; jm ; j++ ) tmp1->ve[j] = 0.0; tmp1->ve[i] = 1.0; /* apply H/h transforms in reverse order */ for ( j=limit-1; j>=0; j-- ) { get_col(QR,j,tmp2); r_ii = fabs(tmp2->ve[j]); tmp2->ve[j] = diag->ve[j]; tmp_val = (r_ii*fabs(diag->ve[j])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; /* hhtrvec(tmp2,beta->ve[j],j,tmp1,tmp1); */ hhtrvec(tmp2,beta,j,tmp1,tmp1); } /* insert into Q */ set_col(Qout,i,tmp1); } return (Qout); } /* makeR -- constructs upper triangular matrix from QR (compact form) -- may be in-situ (all it does is zero the lower 1/2) */ MAT *makeR(QR,Rout) MAT *QR,*Rout; { u_int i,j; if ( QR==(MAT *)NULL ) error(E_NULL,"makeR"); Rout = m_copy(QR,Rout); for ( i=1; im; i++ ) for ( j=0; jn && jme[i][j] = 0.0; return (Rout); } /* QRsolve -- solves the system Q.R.x=b where Q & R are stored in compact form -- returns x, which is created if necessary */ /* VEC *QRsolve(QR,diag,beta,b,x) */ VEC *QRsolve(QR,diag,b,x) MAT *QR; VEC *diag /* , *beta */ , *b, *x; { int limit; static VEC *tmp = VNULL; if ( ! QR || ! diag || ! b ) error(E_NULL,"QRsolve"); limit = min(QR->m,QR->n); if ( diag->dim < limit || b->dim != QR->m ) error(E_SIZES,"QRsolve"); tmp = v_resize(tmp,limit); MEM_STAT_REG(tmp,TYPE_VEC); x = v_resize(x,QR->n); _Qsolve(QR,diag,b,x,tmp); x = Usolve(QR,x,x,0.0); v_resize(x,QR->n); return x; } /* QRCPsolve -- solves A.x = b where A is factored by QRCPfactor() -- assumes that A is in the compact factored form */ /* VEC *QRCPsolve(QR,diag,beta,pivot,b,x) */ VEC *QRCPsolve(QR,diag,pivot,b,x) MAT *QR; VEC *diag /* , *beta */; PERM *pivot; VEC *b, *x; { static VEC *tmp=VNULL; if ( ! QR || ! diag || ! pivot || ! b ) error(E_NULL,"QRCPsolve"); if ( (QR->m > diag->dim &&QR->n > diag->dim) || QR->n != pivot->size ) error(E_SIZES,"QRCPsolve"); tmp = QRsolve(QR,diag /* , beta */ ,b,tmp); MEM_STAT_REG(tmp,TYPE_VEC); x = pxinv_vec(pivot,tmp,x); return x; } /* Umlt -- compute out = upper_triang(U).x -- may be in situ */ static VEC *Umlt(U,x,out) MAT *U; VEC *x, *out; { int i, limit; if ( U == MNULL || x == VNULL ) error(E_NULL,"Umlt"); limit = min(U->m,U->n); if ( limit != x->dim ) error(E_SIZES,"Umlt"); if ( out == VNULL || out->dim < limit ) out = v_resize(out,limit); for ( i = 0; i < limit; i++ ) out->ve[i] = __ip__(&(x->ve[i]),&(U->me[i][i]),limit - i); return out; } /* UTmlt -- returns out = upper_triang(U)^T.x */ static VEC *UTmlt(U,x,out) MAT *U; VEC *x, *out; { Real sum; int i, j, limit; if ( U == MNULL || x == VNULL ) error(E_NULL,"UTmlt"); limit = min(U->m,U->n); if ( out == VNULL || out->dim < limit ) out = v_resize(out,limit); for ( i = limit-1; i >= 0; i-- ) { sum = 0.0; for ( j = 0; j <= i; j++ ) sum += U->me[j][i]*x->ve[j]; out->ve[i] = sum; } return out; } /* QRTsolve -- solve A^T.sc = c where the QR factors of A are stored in compact form -- returns sc -- original due to Mike Osborne modified Wed 09th Dec 1992 */ VEC *QRTsolve(A,diag,c,sc) MAT *A; VEC *diag, *c, *sc; { int i, j, k, n, p; Real beta, r_ii, s, tmp_val; if ( ! A || ! diag || ! c ) error(E_NULL,"QRTsolve"); if ( diag->dim < min(A->m,A->n) ) error(E_SIZES,"QRTsolve"); sc = v_resize(sc,A->m); n = sc->dim; p = c->dim; if ( n == p ) k = p-2; else k = p-1; v_zero(sc); sc->ve[0] = c->ve[0]/A->me[0][0]; if ( n == 1) return sc; if ( p > 1) { for ( i = 1; i < p; i++ ) { s = 0.0; for ( j = 0; j < i; j++ ) s += A->me[j][i]*sc->ve[j]; if ( A->me[i][i] == 0.0 ) error(E_SING,"QRTsolve"); sc->ve[i]=(c->ve[i]-s)/A->me[i][i]; } } for (i = k; i >= 0; i--) { s = diag->ve[i]*sc->ve[i]; for ( j = i+1; j < n; j++ ) s += A->me[j][i]*sc->ve[j]; r_ii = fabs(A->me[i][i]); tmp_val = (r_ii*fabs(diag->ve[i])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; tmp_val = beta*s; sc->ve[i] -= tmp_val*diag->ve[i]; for ( j = i+1; j < n; j++ ) sc->ve[j] -= tmp_val*A->me[j][i]; } return sc; } /* QRcondest -- returns an estimate of the 2-norm condition number of the matrix factorised by QRfactor() or QRCPfactor() -- note that as Q does not affect the 2-norm condition number, it is not necessary to pass the diag, beta (or pivot) vectors -- generates a lower bound on the true condition number -- if the matrix is exactly singular, HUGE is returned -- note that QRcondest() is likely to be more reliable for matrices factored using QRCPfactor() */ double QRcondest(QR) MAT *QR; { static VEC *y=VNULL; Real norm1, norm2, sum, tmp1, tmp2; int i, j, limit; if ( QR == MNULL ) error(E_NULL,"QRcondest"); limit = min(QR->m,QR->n); for ( i = 0; i < limit; i++ ) if ( QR->me[i][i] == 0.0 ) return HUGE; y = v_resize(y,limit); MEM_STAT_REG(y,TYPE_VEC); /* use the trick for getting a unit vector y with ||R.y||_inf small from the LU condition estimator */ for ( i = 0; i < limit; i++ ) { sum = 0.0; for ( j = 0; j < i; j++ ) sum -= QR->me[j][i]*y->ve[j]; sum -= (sum < 0.0) ? 1.0 : -1.0; y->ve[i] = sum / QR->me[i][i]; } UTmlt(QR,y,y); /* now apply inverse power method to R^T.R */ for ( i = 0; i < 3; i++ ) { tmp1 = v_norm2(y); sv_mlt(1/tmp1,y,y); UTsolve(QR,y,y,0.0); tmp2 = v_norm2(y); sv_mlt(1/v_norm2(y),y,y); Usolve(QR,y,y,0.0); } /* now compute approximation for ||R^{-1}||_2 */ norm1 = sqrt(tmp1)*sqrt(tmp2); /* now use complementary approach to compute approximation to ||R||_2 */ for ( i = limit-1; i >= 0; i-- ) { sum = 0.0; for ( j = i+1; j < limit; j++ ) sum += QR->me[i][j]*y->ve[j]; y->ve[i] = (sum >= 0.0) ? 1.0 : -1.0; y->ve[i] = (QR->me[i][i] >= 0.0) ? y->ve[i] : - y->ve[i]; } /* now apply power method to R^T.R */ for ( i = 0; i < 3; i++ ) { tmp1 = v_norm2(y); sv_mlt(1/tmp1,y,y); Umlt(QR,y,y); tmp2 = v_norm2(y); sv_mlt(1/tmp2,y,y); UTmlt(QR,y,y); } norm2 = sqrt(tmp1)*sqrt(tmp2); /* printf("QRcondest: norm1 = %g, norm2 = %g\n",norm1,norm2); */ return norm1*norm2; } meschach-1.2b/solve.c100644 764 764 15243 5673124374 14202 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. */ /* solve.c 1.2 11/25/87 */ static char rcsid[] = "$Id: solve.c,v 1.3 1994/01/13 05:29:57 des Exp $"; #include #include "matrix2.h" #include /* Most matrix factorisation routines are in-situ unless otherwise specified */ /* Usolve -- back substitution with optional over-riding diagonal -- can be in-situ but doesn't need to be */ VEC *Usolve(matrix,b,out,diag) MAT *matrix; VEC *b, *out; double diag; { u_int dim /* , j */; int i, i_lim; Real **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum, tiny; if ( matrix==(MAT *)NULL || b==(VEC *)NULL ) error(E_NULL,"Usolve"); dim = min(matrix->m,matrix->n); if ( b->dim < dim ) error(E_SIZES,"Usolve"); if ( out==(VEC *)NULL || out->dim < dim ) out = v_resize(out,matrix->n); mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; tiny = 10.0/HUGE_VAL; for ( i=dim-1; i>=0; i-- ) if ( b_ent[i] != 0.0 ) break; else out_ent[i] = 0.0; i_lim = i; for ( ; i>=0; i-- ) { sum = b_ent[i]; mat_row = &(mat_ent[i][i+1]); out_col = &(out_ent[i+1]); sum -= __ip__(mat_row,out_col,i_lim-i); /****************************************************** for ( j=i+1; j<=i_lim; j++ ) sum -= mat_ent[i][j]*out_ent[j]; sum -= (*mat_row++)*(*out_col++); ******************************************************/ if ( diag==0.0 ) { if ( fabs(mat_ent[i][i]) <= tiny*fabs(sum) ) error(E_SING,"Usolve"); else out_ent[i] = sum/mat_ent[i][i]; } else out_ent[i] = sum/diag; } return (out); } /* Lsolve -- forward elimination with (optional) default diagonal value */ VEC *Lsolve(matrix,b,out,diag) MAT *matrix; VEC *b,*out; double diag; { u_int dim, i, i_lim /* , j */; Real **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum, tiny; if ( matrix==(MAT *)NULL || b==(VEC *)NULL ) error(E_NULL,"Lsolve"); dim = min(matrix->m,matrix->n); if ( b->dim < dim ) error(E_SIZES,"Lsolve"); if ( out==(VEC *)NULL || out->dim < dim ) out = v_resize(out,matrix->n); mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; for ( i=0; im,U->n); if ( b->dim < dim ) error(E_SIZES,"UTsolve"); out = v_resize(out,U->n); U_me = U->me; b_ve = b->ve; out_ve = out->ve; tiny = 10.0/HUGE_VAL; for ( i=0; idim); MEM_COPY(&(b_ve[i_lim]),&(out_ve[i_lim]),(dim-i_lim)*sizeof(Real)); } if ( diag == 0.0 ) { for ( ; im,A->n); if ( b->dim < dim ) error(E_SIZES,"Dsolve"); x = v_resize(x,A->n); tiny = 10.0/HUGE_VAL; dim = b->dim; for ( i=0; ime[i][i]) <= tiny*fabs(b->ve[i]) ) error(E_SING,"Dsolve"); else x->ve[i] = b->ve[i]/A->me[i][i]; return (x); } /* LTsolve -- back substitution with optional over-riding diagonal using the LOWER triangular part of matrix -- can be in-situ but doesn't need to be */ VEC *LTsolve(L,b,out,diag) MAT *L; VEC *b, *out; double diag; { u_int dim; int i, i_lim; Real **L_me, *b_ve, *out_ve, tmp, invdiag, tiny; if ( ! L || ! b ) error(E_NULL,"LTsolve"); dim = min(L->m,L->n); if ( b->dim < dim ) error(E_SIZES,"LTsolve"); out = v_resize(out,L->n); L_me = L->me; b_ve = b->ve; out_ve = out->ve; tiny = 10.0/HUGE_VAL; for ( i=dim-1; i>=0; i-- ) if ( b_ve[i] != 0.0 ) break; i_lim = i; if ( b != out ) { __zero__(out_ve,out->dim); MEM_COPY(b_ve,out_ve,(i_lim+1)*sizeof(Real)); } if ( diag == 0.0 ) { for ( ; i>=0; i-- ) { tmp = L_me[i][i]; if ( fabs(tmp) <= tiny*fabs(out_ve[i]) ) error(E_SING,"LTsolve"); out_ve[i] /= tmp; __mltadd__(out_ve,L_me[i],-out_ve[i],i); } } else { invdiag = 1.0/diag; for ( ; i>=0; i-- ) { out_ve[i] *= invdiag; __mltadd__(out_ve,L_me[i],-out_ve[i],i); } } return (out); } meschach-1.2b/hsehldr.c100644 764 764 11177 5673124301 14473 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Files for matrix computations Householder transformation file. Contains routines for calculating householder transformations, applying them to vectors and matrices by both row & column. */ /* hsehldr.c 1.3 10/8/87 */ static char rcsid[] = "$Id: hsehldr.c,v 1.2 1994/01/13 05:36:29 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include /* hhvec -- calulates Householder vector to eliminate all entries after the i0 entry of the vector vec. It is returned as out. May be in-situ */ VEC *hhvec(vec,i0,beta,out,newval) VEC *vec,*out; u_int i0; Real *beta,*newval; { Real norm; out = _v_copy(vec,out,i0); norm = sqrt(_in_prod(out,out,i0)); if ( norm <= 0.0 ) { *beta = 0.0; return (out); } *beta = 1.0/(norm * (norm+fabs(out->ve[i0]))); if ( out->ve[i0] > 0.0 ) *newval = -norm; else *newval = norm; out->ve[i0] -= *newval; return (out); } /* hhtrvec -- apply Householder transformation to vector -- may be in-situ */ VEC *hhtrvec(hh,beta,i0,in,out) VEC *hh,*in,*out; /* hh = Householder vector */ u_int i0; double beta; { Real scale; /* u_int i; */ if ( hh==(VEC *)NULL || in==(VEC *)NULL ) error(E_NULL,"hhtrvec"); if ( in->dim != hh->dim ) error(E_SIZES,"hhtrvec"); if ( i0 > in->dim ) error(E_BOUNDS,"hhtrvec"); scale = beta*_in_prod(hh,in,i0); out = v_copy(in,out); __mltadd__(&(out->ve[i0]),&(hh->ve[i0]),-scale,(int)(in->dim-i0)); /************************************************************ for ( i=i0; idim; i++ ) out->ve[i] = in->ve[i] - scale*hh->ve[i]; ************************************************************/ return (out); } /* hhtrrows -- transform a matrix by a Householder vector by rows starting at row i0 from column j0 -- in-situ */ MAT *hhtrrows(M,i0,j0,hh,beta) MAT *M; u_int i0, j0; VEC *hh; double beta; { Real ip, scale; int i /*, j */; if ( M==(MAT *)NULL || hh==(VEC *)NULL ) error(E_NULL,"hhtrrows"); if ( M->n != hh->dim ) error(E_RANGE,"hhtrrows"); if ( i0 > M->m || j0 > M->n ) error(E_BOUNDS,"hhtrrows"); if ( beta == 0.0 ) return (M); /* for each row ... */ for ( i = i0; i < M->m; i++ ) { /* compute inner product */ ip = __ip__(&(M->me[i][j0]),&(hh->ve[j0]),(int)(M->n-j0)); /************************************************** ip = 0.0; for ( j = j0; j < M->n; j++ ) ip += M->me[i][j]*hh->ve[j]; **************************************************/ scale = beta*ip; if ( scale == 0.0 ) continue; /* do operation */ __mltadd__(&(M->me[i][j0]),&(hh->ve[j0]),-scale, (int)(M->n-j0)); /************************************************** for ( j = j0; j < M->n; j++ ) M->me[i][j] -= scale*hh->ve[j]; **************************************************/ } return (M); } /* hhtrcols -- transform a matrix by a Householder vector by columns starting at row i0 from column j0 -- in-situ */ MAT *hhtrcols(M,i0,j0,hh,beta) MAT *M; u_int i0, j0; VEC *hh; double beta; { /* Real ip, scale; */ int i /*, k */; static VEC *w = VNULL; if ( M==(MAT *)NULL || hh==(VEC *)NULL ) error(E_NULL,"hhtrcols"); if ( M->m != hh->dim ) error(E_SIZES,"hhtrcols"); if ( i0 > M->m || j0 > M->n ) error(E_BOUNDS,"hhtrcols"); if ( beta == 0.0 ) return (M); w = v_resize(w,M->n); MEM_STAT_REG(w,TYPE_VEC); v_zero(w); for ( i = i0; i < M->m; i++ ) if ( hh->ve[i] != 0.0 ) __mltadd__(&(w->ve[j0]),&(M->me[i][j0]),hh->ve[i], (int)(M->n-j0)); for ( i = i0; i < M->m; i++ ) if ( hh->ve[i] != 0.0 ) __mltadd__(&(M->me[i][j0]),&(w->ve[j0]),-beta*hh->ve[i], (int)(M->n-j0)); return (M); } meschach-1.2b/givens.c100644 764 764 7153 5735556375 14337 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Files for matrix computations Givens operations file. Contains routines for calculating and applying givens rotations for/to vectors and also to matrices by row and by column. */ /* givens.c 1.2 11/25/87 */ static char rcsid[] = "$Id: givens.c,v 1.3 1995/03/27 15:41:15 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include /* givens -- returns c,s parameters for Givens rotation to eliminate y in the vector [ x y ]' */ void givens(x,y,c,s) double x,y; Real *c,*s; { Real norm; norm = sqrt(x*x+y*y); if ( norm == 0.0 ) { *c = 1.0; *s = 0.0; } /* identity */ else { *c = x/norm; *s = y/norm; } } /* rot_vec -- apply Givens rotation to x's i & k components */ VEC *rot_vec(x,i,k,c,s,out) VEC *x,*out; u_int i,k; double c,s; { Real temp; if ( x==VNULL ) error(E_NULL,"rot_vec"); if ( i >= x->dim || k >= x->dim ) error(E_RANGE,"rot_vec"); out = v_copy(x,out); /* temp = c*out->ve[i] + s*out->ve[k]; */ temp = c*v_entry(out,i) + s*v_entry(out,k); /* out->ve[k] = -s*out->ve[i] + c*out->ve[k]; */ v_set_val(out,k,-s*v_entry(out,i)+c*v_entry(out,k)); /* out->ve[i] = temp; */ v_set_val(out,i,temp); return (out); } /* rot_rows -- premultiply mat by givens rotation described by c,s */ MAT *rot_rows(mat,i,k,c,s,out) MAT *mat,*out; u_int i,k; double c,s; { u_int j; Real temp; if ( mat==(MAT *)NULL ) error(E_NULL,"rot_rows"); if ( i >= mat->m || k >= mat->m ) error(E_RANGE,"rot_rows"); if ( mat != out ) out = m_copy(mat,m_resize(out,mat->m,mat->n)); for ( j=0; jn; j++ ) { /* temp = c*out->me[i][j] + s*out->me[k][j]; */ temp = c*m_entry(out,i,j) + s*m_entry(out,k,j); /* out->me[k][j] = -s*out->me[i][j] + c*out->me[k][j]; */ m_set_val(out,k,j, -s*m_entry(out,i,j) + c*m_entry(out,k,j)); /* out->me[i][j] = temp; */ m_set_val(out,i,j, temp); } return (out); } /* rot_cols -- postmultiply mat by givens rotation described by c,s */ MAT *rot_cols(mat,i,k,c,s,out) MAT *mat,*out; u_int i,k; double c,s; { u_int j; Real temp; if ( mat==(MAT *)NULL ) error(E_NULL,"rot_cols"); if ( i >= mat->n || k >= mat->n ) error(E_RANGE,"rot_cols"); if ( mat != out ) out = m_copy(mat,m_resize(out,mat->m,mat->n)); for ( j=0; jm; j++ ) { /* temp = c*out->me[j][i] + s*out->me[j][k]; */ temp = c*m_entry(out,j,i) + s*m_entry(out,j,k); /* out->me[j][k] = -s*out->me[j][i] + c*out->me[j][k]; */ m_set_val(out,j,k, -s*m_entry(out,j,i) + c*m_entry(out,j,k)); /* out->me[j][i] = temp; */ m_set_val(out,j,i,temp); } return (out); } meschach-1.2b/update.c100644 764 764 6561 5673124426 14315 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. */ /* update.c 1.3 11/25/87 */ static char rcsid[] = "$Id: update.c,v 1.2 1994/01/13 05:26:06 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include /* Most matrix factorisation routines are in-situ unless otherwise specified */ /* LDLupdate -- updates a CHolesky factorisation, replacing LDL' by MD~M' = LDL' + alpha.w.w' Note: w is overwritten Ref: Gill et al Math Comp 28, p516 Algorithm C1 */ MAT *LDLupdate(CHmat,w,alpha) MAT *CHmat; VEC *w; double alpha; { u_int i,j; Real diag,new_diag,beta,p; if ( CHmat==(MAT *)NULL || w==(VEC *)NULL ) error(E_NULL,"LDLupdate"); if ( CHmat->m != CHmat->n || w->dim != CHmat->m ) error(E_SIZES,"LDLupdate"); for ( j=0; j < w->dim; j++ ) { p = w->ve[j]; diag = CHmat->me[j][j]; new_diag = CHmat->me[j][j] = diag + alpha*p*p; if ( new_diag <= 0.0 ) error(E_POSDEF,"LDLupdate"); beta = p*alpha/new_diag; alpha *= diag/new_diag; for ( i=j+1; i < w->dim; i++ ) { w->ve[i] -= p*CHmat->me[i][j]; CHmat->me[i][j] += beta*w->ve[i]; CHmat->me[j][i] = CHmat->me[i][j]; } } return (CHmat); } /* QRupdate -- updates QR factorisation in expanded form (seperate matrices) Finds Q+, R+ s.t. Q+.R+ = Q.(R+u.v') and Q+ orthogonal, R+ upper triang Ref: Golub & van Loan Matrix Computations pp437-443 -- does not update Q if it is NULL */ MAT *QRupdate(Q,R,u,v) MAT *Q,*R; VEC *u,*v; { int i,j,k; Real c,s,temp; if ( ! R || ! u || ! v ) error(E_NULL,"QRupdate"); if ( ( Q && ( Q->m != Q->n || R->m != Q->n ) ) || u->dim != R->m || v->dim != R->n ) error(E_SIZES,"QRupdate"); /* find largest k s.t. u[k] != 0 */ for ( k=R->m-1; k>=0; k-- ) if ( u->ve[k] != 0.0 ) break; /* transform R+u.v' to Hessenberg form */ for ( i=k-1; i>=0; i-- ) { /* get Givens rotation */ givens(u->ve[i],u->ve[i+1],&c,&s); rot_rows(R,i,i+1,c,s,R); if ( Q ) rot_cols(Q,i,i+1,c,s,Q); rot_vec(u,i,i+1,c,s,u); } /* add into R */ temp = u->ve[0]; for ( j=0; jn; j++ ) R->me[0][j] += temp*v->ve[j]; /* transform Hessenberg to upper triangular */ for ( i=0; ime[i][i],R->me[i+1][i],&c,&s); rot_rows(R,i,i+1,c,s,R); if ( Q ) rot_cols(Q,i,i+1,c,s,Q); } return R; } meschach-1.2b/norm.c100644 764 764 10133 5673124456 14017 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* A collection of functions for computing norms: scaled and unscaled */ static char rcsid[] = "$Id: norm.c,v 1.6 1994/01/13 05:34:35 des Exp $"; #include #include "matrix.h" #include /* _v_norm1 -- computes (scaled) 1-norms of vectors */ double _v_norm1(x,scale) VEC *x, *scale; { int i, dim; Real s, sum; if ( x == (VEC *)NULL ) error(E_NULL,"_v_norm1"); dim = x->dim; sum = 0.0; if ( scale == (VEC *)NULL ) for ( i = 0; i < dim; i++ ) sum += fabs(x->ve[i]); else if ( scale->dim < dim ) error(E_SIZES,"_v_norm1"); else for ( i = 0; i < dim; i++ ) { s = scale->ve[i]; sum += ( s== 0.0 ) ? fabs(x->ve[i]) : fabs(x->ve[i]/s); } return sum; } /* square -- returns x^2 */ double square(x) double x; { return x*x; } /* cube -- returns x^3 */ double cube(x) double x; { return x*x*x; } /* _v_norm2 -- computes (scaled) 2-norm (Euclidean norm) of vectors */ double _v_norm2(x,scale) VEC *x, *scale; { int i, dim; Real s, sum; if ( x == (VEC *)NULL ) error(E_NULL,"_v_norm2"); dim = x->dim; sum = 0.0; if ( scale == (VEC *)NULL ) for ( i = 0; i < dim; i++ ) sum += square(x->ve[i]); else if ( scale->dim < dim ) error(E_SIZES,"_v_norm2"); else for ( i = 0; i < dim; i++ ) { s = scale->ve[i]; sum += ( s== 0.0 ) ? square(x->ve[i]) : square(x->ve[i]/s); } return sqrt(sum); } #define max(a,b) ((a) > (b) ? (a) : (b)) /* _v_norm_inf -- computes (scaled) infinity-norm (supremum norm) of vectors */ double _v_norm_inf(x,scale) VEC *x, *scale; { int i, dim; Real s, maxval, tmp; if ( x == (VEC *)NULL ) error(E_NULL,"_v_norm_inf"); dim = x->dim; maxval = 0.0; if ( scale == (VEC *)NULL ) for ( i = 0; i < dim; i++ ) { tmp = fabs(x->ve[i]); maxval = max(maxval,tmp); } else if ( scale->dim < dim ) error(E_SIZES,"_v_norm_inf"); else for ( i = 0; i < dim; i++ ) { s = scale->ve[i]; tmp = ( s== 0.0 ) ? fabs(x->ve[i]) : fabs(x->ve[i]/s); maxval = max(maxval,tmp); } return maxval; } /* m_norm1 -- compute matrix 1-norm -- unscaled */ double m_norm1(A) MAT *A; { int i, j, m, n; Real maxval, sum; if ( A == (MAT *)NULL ) error(E_NULL,"m_norm1"); m = A->m; n = A->n; maxval = 0.0; for ( j = 0; j < n; j++ ) { sum = 0.0; for ( i = 0; i < m; i ++ ) sum += fabs(A->me[i][j]); maxval = max(maxval,sum); } return maxval; } /* m_norm_inf -- compute matrix infinity-norm -- unscaled */ double m_norm_inf(A) MAT *A; { int i, j, m, n; Real maxval, sum; if ( A == (MAT *)NULL ) error(E_NULL,"m_norm_inf"); m = A->m; n = A->n; maxval = 0.0; for ( i = 0; i < m; i++ ) { sum = 0.0; for ( j = 0; j < n; j ++ ) sum += fabs(A->me[i][j]); maxval = max(maxval,sum); } return maxval; } /* m_norm_frob -- compute matrix frobenius-norm -- unscaled */ double m_norm_frob(A) MAT *A; { int i, j, m, n; Real sum; if ( A == (MAT *)NULL ) error(E_NULL,"m_norm_frob"); m = A->m; n = A->n; sum = 0.0; for ( i = 0; i < m; i++ ) for ( j = 0; j < n; j ++ ) sum += square(A->me[i][j]); return sqrt(sum); } meschach-1.2b/hessen.c100644 764 764 7737 5735556620 14332 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing routines for determining Hessenberg factorisations. */ static char rcsid[] = "$Id: hessen.c,v 1.2 1994/01/13 05:36:24 des Exp $"; #include #include "matrix.h" #include "matrix2.h" /* Hfactor -- compute Hessenberg factorisation in compact form. -- factorisation performed in situ -- for details of the compact form see QRfactor.c and matrix2.doc */ MAT *Hfactor(A, diag, beta) MAT *A; VEC *diag, *beta; { static VEC *tmp1 = VNULL; int k, limit; if ( ! A || ! diag || ! beta ) error(E_NULL,"Hfactor"); if ( diag->dim < A->m - 1 || beta->dim < A->m - 1 ) error(E_SIZES,"Hfactor"); if ( A->m != A->n ) error(E_SQUARE,"Hfactor"); limit = A->m - 1; tmp1 = v_resize(tmp1,A->m); MEM_STAT_REG(tmp1,TYPE_VEC); for ( k = 0; k < limit; k++ ) { get_col(A,(u_int)k,tmp1); /* printf("the %d'th column = "); v_output(tmp1); */ hhvec(tmp1,k+1,&beta->ve[k],tmp1,&A->me[k+1][k]); /* diag->ve[k] = tmp1->ve[k+1]; */ v_set_val(diag,k,v_entry(tmp1,k+1)); /* printf("H/h vector = "); v_output(tmp1); */ /* printf("from the %d'th entry\n",k+1); */ /* printf("beta = %g\n",beta->ve[k]); */ /* hhtrcols(A,k+1,k+1,tmp1,beta->ve[k]); */ /* hhtrrows(A,0 ,k+1,tmp1,beta->ve[k]); */ hhtrcols(A,k+1,k+1,tmp1,v_entry(beta,k)); hhtrrows(A,0 ,k+1,tmp1,v_entry(beta,k)); /* printf("A = "); m_output(A); */ } return (A); } /* makeHQ -- construct the Hessenberg orthogonalising matrix Q; -- i.e. Hess M = Q.M.Q' */ MAT *makeHQ(H, diag, beta, Qout) MAT *H, *Qout; VEC *diag, *beta; { int i, j, limit; static VEC *tmp1 = VNULL, *tmp2 = VNULL; if ( H==(MAT *)NULL || diag==(VEC *)NULL || beta==(VEC *)NULL ) error(E_NULL,"makeHQ"); limit = H->m - 1; if ( diag->dim < limit || beta->dim < limit ) error(E_SIZES,"makeHQ"); if ( H->m != H->n ) error(E_SQUARE,"makeHQ"); Qout = m_resize(Qout,H->m,H->m); tmp1 = v_resize(tmp1,H->m); tmp2 = v_resize(tmp2,H->m); MEM_STAT_REG(tmp1,TYPE_VEC); MEM_STAT_REG(tmp2,TYPE_VEC); for ( i = 0; i < H->m; i++ ) { /* tmp1 = i'th basis vector */ for ( j = 0; j < H->m; j++ ) /* tmp1->ve[j] = 0.0; */ v_set_val(tmp1,j,0.0); /* tmp1->ve[i] = 1.0; */ v_set_val(tmp1,i,1.0); /* apply H/h transforms in reverse order */ for ( j = limit-1; j >= 0; j-- ) { get_col(H,(u_int)j,tmp2); /* tmp2->ve[j+1] = diag->ve[j]; */ v_set_val(tmp2,j+1,v_entry(diag,j)); hhtrvec(tmp2,beta->ve[j],j+1,tmp1,tmp1); } /* insert into Qout */ set_col(Qout,(u_int)i,tmp1); } return (Qout); } /* makeH -- construct actual Hessenberg matrix */ MAT *makeH(H,Hout) MAT *H, *Hout; { int i, j, limit; if ( H==(MAT *)NULL ) error(E_NULL,"makeH"); if ( H->m != H->n ) error(E_SQUARE,"makeH"); Hout = m_resize(Hout,H->m,H->m); Hout = m_copy(H,Hout); limit = H->m; for ( i = 1; i < limit; i++ ) for ( j = 0; j < i-1; j++ ) /* Hout->me[i][j] = 0.0;*/ m_set_val(Hout,i,j,0.0); return (Hout); } meschach-1.2b/symmeig.c100644 764 764 13560 5735556707 14534 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing routines for symmetric eigenvalue problems */ #include #include "matrix.h" #include "matrix2.h" #include static char rcsid[] = "$Id: symmeig.c,v 1.6 1995/03/27 15:45:55 des Exp $"; #define SQRT2 1.4142135623730949 #define sgn(x) ( (x) >= 0 ? 1 : -1 ) /* trieig -- finds eigenvalues of symmetric tridiagonal matrices -- matrix represented by a pair of vectors a (diag entries) and b (sub- & super-diag entries) -- eigenvalues in a on return */ VEC *trieig(a,b,Q) VEC *a, *b; MAT *Q; { int i, i_min, i_max, n, split; Real *a_ve, *b_ve; Real b_sqr, bk, ak1, bk1, ak2, bk2, z; Real c, c2, cs, s, s2, d, mu; if ( ! a || ! b ) error(E_NULL,"trieig"); if ( a->dim != b->dim + 1 || ( Q && Q->m != a->dim ) ) error(E_SIZES,"trieig"); if ( Q && Q->m != Q->n ) error(E_SQUARE,"trieig"); n = a->dim; a_ve = a->ve; b_ve = b->ve; i_min = 0; while ( i_min < n ) /* outer while loop */ { /* find i_max to suit; submatrix i_min..i_max should be irreducible */ i_max = n-1; for ( i = i_min; i < n-1; i++ ) if ( b_ve[i] == 0.0 ) { i_max = i; break; } if ( i_max <= i_min ) { /* printf("# i_min = %d, i_max = %d\n",i_min,i_max); */ i_min = i_max + 1; continue; /* outer while loop */ } /* printf("# i_min = %d, i_max = %d\n",i_min,i_max); */ /* repeatedly perform QR method until matrix splits */ split = FALSE; while ( ! split ) /* inner while loop */ { /* find Wilkinson shift */ d = (a_ve[i_max-1] - a_ve[i_max])/2; b_sqr = b_ve[i_max-1]*b_ve[i_max-1]; mu = a_ve[i_max] - b_sqr/(d + sgn(d)*sqrt(d*d+b_sqr)); /* printf("# Wilkinson shift = %g\n",mu); */ /* initial Givens' rotation */ givens(a_ve[i_min]-mu,b_ve[i_min],&c,&s); s = -s; /* printf("# c = %g, s = %g\n",c,s); */ if ( fabs(c) < SQRT2 ) { c2 = c*c; s2 = 1-c2; } else { s2 = s*s; c2 = 1-s2; } cs = c*s; ak1 = c2*a_ve[i_min]+s2*a_ve[i_min+1]-2*cs*b_ve[i_min]; bk1 = cs*(a_ve[i_min]-a_ve[i_min+1]) + (c2-s2)*b_ve[i_min]; ak2 = s2*a_ve[i_min]+c2*a_ve[i_min+1]+2*cs*b_ve[i_min]; bk2 = ( i_min < i_max-1 ) ? c*b_ve[i_min+1] : 0.0; z = ( i_min < i_max-1 ) ? -s*b_ve[i_min+1] : 0.0; a_ve[i_min] = ak1; a_ve[i_min+1] = ak2; b_ve[i_min] = bk1; if ( i_min < i_max-1 ) b_ve[i_min+1] = bk2; if ( Q ) rot_cols(Q,i_min,i_min+1,c,-s,Q); /* printf("# z = %g\n",z); */ /* printf("# a [temp1] =\n"); v_output(a); */ /* printf("# b [temp1] =\n"); v_output(b); */ for ( i = i_min+1; i < i_max; i++ ) { /* get Givens' rotation for sub-block -- k == i-1 */ givens(b_ve[i-1],z,&c,&s); s = -s; /* printf("# c = %g, s = %g\n",c,s); */ /* perform Givens' rotation on sub-block */ if ( fabs(c) < SQRT2 ) { c2 = c*c; s2 = 1-c2; } else { s2 = s*s; c2 = 1-s2; } cs = c*s; bk = c*b_ve[i-1] - s*z; ak1 = c2*a_ve[i]+s2*a_ve[i+1]-2*cs*b_ve[i]; bk1 = cs*(a_ve[i]-a_ve[i+1]) + (c2-s2)*b_ve[i]; ak2 = s2*a_ve[i]+c2*a_ve[i+1]+2*cs*b_ve[i]; bk2 = ( i+1 < i_max ) ? c*b_ve[i+1] : 0.0; z = ( i+1 < i_max ) ? -s*b_ve[i+1] : 0.0; a_ve[i] = ak1; a_ve[i+1] = ak2; b_ve[i] = bk1; if ( i < i_max-1 ) b_ve[i+1] = bk2; if ( i > i_min ) b_ve[i-1] = bk; if ( Q ) rot_cols(Q,i,i+1,c,-s,Q); /* printf("# a [temp2] =\n"); v_output(a); */ /* printf("# b [temp2] =\n"); v_output(b); */ } /* test to see if matrix should be split */ for ( i = i_min; i < i_max; i++ ) if ( fabs(b_ve[i]) < MACHEPS* (fabs(a_ve[i])+fabs(a_ve[i+1])) ) { b_ve[i] = 0.0; split = TRUE; } /* printf("# a =\n"); v_output(a); */ /* printf("# b =\n"); v_output(b); */ } } return a; } /* symmeig -- computes eigenvalues of a dense symmetric matrix -- A **must** be symmetric on entry -- eigenvalues stored in out -- Q contains orthogonal matrix of eigenvectors -- returns vector of eigenvalues */ VEC *symmeig(A,Q,out) MAT *A, *Q; VEC *out; { int i; static MAT *tmp = MNULL; static VEC *b = VNULL, *diag = VNULL, *beta = VNULL; if ( ! A ) error(E_NULL,"symmeig"); if ( A->m != A->n ) error(E_SQUARE,"symmeig"); if ( ! out || out->dim != A->m ) out = v_resize(out,A->m); tmp = m_resize(tmp,A->m,A->n); tmp = m_copy(A,tmp); b = v_resize(b,A->m - 1); diag = v_resize(diag,(u_int)A->m); beta = v_resize(beta,(u_int)A->m); MEM_STAT_REG(tmp,TYPE_MAT); MEM_STAT_REG(b,TYPE_VEC); MEM_STAT_REG(diag,TYPE_VEC); MEM_STAT_REG(beta,TYPE_VEC); Hfactor(tmp,diag,beta); if ( Q ) makeHQ(tmp,diag,beta,Q); for ( i = 0; i < A->m - 1; i++ ) { out->ve[i] = tmp->me[i][i]; b->ve[i] = tmp->me[i][i+1]; } out->ve[i] = tmp->me[i][i]; trieig(out,b,Q); return out; } meschach-1.2b/schur.c100644 764 764 44007 5673124161 14170 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing routines for computing the Schur decomposition of a real non-symmetric matrix See also: hessen.c */ #include #include "matrix.h" #include "matrix2.h" #include static char rcsid[] = "$Id: schur.c,v 1.7 1994/03/17 05:36:53 des Exp $"; #ifndef ANSI_C static void hhldr3(x,y,z,nu1,beta,newval) double x, y, z; Real *nu1, *beta, *newval; #else static void hhldr3(double x, double y, double z, Real *nu1, Real *beta, Real *newval) #endif { Real alpha; if ( x >= 0.0 ) alpha = sqrt(x*x+y*y+z*z); else alpha = -sqrt(x*x+y*y+z*z); *nu1 = x + alpha; *beta = 1.0/(alpha*(*nu1)); *newval = alpha; } #ifndef ANSI_C static void hhldr3cols(A,k,j0,beta,nu1,nu2,nu3) MAT *A; int k, j0; double beta, nu1, nu2, nu3; #else static void hhldr3cols(MAT *A, int k, int j0, double beta, double nu1, double nu2, double nu3) #endif { Real **A_me, ip, prod; int j, n; if ( k < 0 || k+3 > A->m || j0 < 0 ) error(E_BOUNDS,"hhldr3cols"); A_me = A->me; n = A->n; /* printf("hhldr3cols:(l.%d) j0 = %d, k = %d, A at 0x%lx, m = %d, n = %d\n", __LINE__, j0, k, (long)A, A->m, A->n); */ /* printf("hhldr3cols: A (dumped) =\n"); m_dump(stdout,A); */ for ( j = j0; j < n; j++ ) { /***** ip = nu1*A_me[k][j] + nu2*A_me[k+1][j] + nu3*A_me[k+2][j]; prod = ip*beta; A_me[k][j] -= prod*nu1; A_me[k+1][j] -= prod*nu2; A_me[k+2][j] -= prod*nu3; *****/ /* printf("hhldr3cols: j = %d\n", j); */ ip = nu1*m_entry(A,k,j)+nu2*m_entry(A,k+1,j)+nu3*m_entry(A,k+2,j); prod = ip*beta; /***** m_set_val(A,k ,j,m_entry(A,k ,j) - prod*nu1); m_set_val(A,k+1,j,m_entry(A,k+1,j) - prod*nu2); m_set_val(A,k+2,j,m_entry(A,k+2,j) - prod*nu3); *****/ m_add_val(A,k ,j,-prod*nu1); m_add_val(A,k+1,j,-prod*nu2); m_add_val(A,k+2,j,-prod*nu3); } /* printf("hhldr3cols:(l.%d) j0 = %d, k = %d, m = %d, n = %d\n", __LINE__, j0, k, A->m, A->n); */ /* putc('\n',stdout); */ } #ifndef ANSI_C static void hhldr3rows(A,k,i0,beta,nu1,nu2,nu3) MAT *A; int k, i0; double beta, nu1, nu2, nu3; #else static void hhldr3rows(MAT *A, int k, int i0, double beta, double nu1, double nu2, double nu3) #endif { Real **A_me, ip, prod; int i, m; /* printf("hhldr3rows:(l.%d) A at 0x%lx\n", __LINE__, (long)A); */ /* printf("hhldr3rows: k = %d\n", k); */ if ( k < 0 || k+3 > A->n ) error(E_BOUNDS,"hhldr3rows"); A_me = A->me; m = A->m; i0 = min(i0,m-1); for ( i = 0; i <= i0; i++ ) { /**** ip = nu1*A_me[i][k] + nu2*A_me[i][k+1] + nu3*A_me[i][k+2]; prod = ip*beta; A_me[i][k] -= prod*nu1; A_me[i][k+1] -= prod*nu2; A_me[i][k+2] -= prod*nu3; ****/ ip = nu1*m_entry(A,i,k)+nu2*m_entry(A,i,k+1)+nu3*m_entry(A,i,k+2); prod = ip*beta; m_add_val(A,i,k , - prod*nu1); m_add_val(A,i,k+1, - prod*nu2); m_add_val(A,i,k+2, - prod*nu3); } } /* schur -- computes the Schur decomposition of the matrix A in situ -- optionally, gives Q matrix such that Q^T.A.Q is upper triangular -- returns upper triangular Schur matrix */ MAT *schur(A,Q) MAT *A, *Q; { int i, j, iter, k, k_min, k_max, k_tmp, n, split; Real beta2, c, discrim, dummy, nu1, s, t, tmp, x, y, z; Real **A_me; Real sqrt_macheps; static VEC *diag=VNULL, *beta=VNULL; if ( ! A ) error(E_NULL,"schur"); if ( A->m != A->n || ( Q && Q->m != Q->n ) ) error(E_SQUARE,"schur"); if ( Q != MNULL && Q->m != A->m ) error(E_SIZES,"schur"); n = A->n; diag = v_resize(diag,A->n); beta = v_resize(beta,A->n); MEM_STAT_REG(diag,TYPE_VEC); MEM_STAT_REG(beta,TYPE_VEC); /* compute Hessenberg form */ Hfactor(A,diag,beta); /* save Q if necessary */ if ( Q ) Q = makeHQ(A,diag,beta,Q); makeH(A,A); sqrt_macheps = sqrt(MACHEPS); k_min = 0; A_me = A->me; while ( k_min < n ) { Real a00, a01, a10, a11; double scale, t, numer, denom; /* find k_max to suit: submatrix k_min..k_max should be irreducible */ k_max = n-1; for ( k = k_min; k < k_max; k++ ) /* if ( A_me[k+1][k] == 0.0 ) */ if ( m_entry(A,k+1,k) == 0.0 ) { k_max = k; break; } if ( k_max <= k_min ) { k_min = k_max + 1; continue; /* outer loop */ } /* check to see if we have a 2 x 2 block with complex eigenvalues */ if ( k_max == k_min + 1 ) { /* tmp = A_me[k_min][k_min] - A_me[k_max][k_max]; */ a00 = m_entry(A,k_min,k_min); a01 = m_entry(A,k_min,k_max); a10 = m_entry(A,k_max,k_min); a11 = m_entry(A,k_max,k_max); tmp = a00 - a11; /* discrim = tmp*tmp + 4*A_me[k_min][k_max]*A_me[k_max][k_min]; */ discrim = tmp*tmp + 4*a01*a10; if ( discrim < 0.0 ) { /* yes -- e-vals are complex -- put 2 x 2 block in form [a b; c a]; then eigenvalues have real part a & imag part sqrt(|bc|) */ numer = - tmp; denom = ( a01+a10 >= 0.0 ) ? (a01+a10) + sqrt((a01+a10)*(a01+a10)+tmp*tmp) : (a01+a10) - sqrt((a01+a10)*(a01+a10)+tmp*tmp); if ( denom != 0.0 ) { /* t = s/c = numer/denom */ t = numer/denom; scale = c = 1.0/sqrt(1+t*t); s = c*t; } else { c = 1.0; s = 0.0; } rot_cols(A,k_min,k_max,c,s,A); rot_rows(A,k_min,k_max,c,s,A); if ( Q != MNULL ) rot_cols(Q,k_min,k_max,c,s,Q); k_min = k_max + 1; continue; } else /* discrim >= 0; i.e. block has two real eigenvalues */ { /* no -- e-vals are not complex; split 2 x 2 block and continue */ /* s/c = numer/denom */ numer = ( tmp >= 0.0 ) ? - tmp - sqrt(discrim) : - tmp + sqrt(discrim); denom = 2*a01; if ( fabs(numer) < fabs(denom) ) { /* t = s/c = numer/denom */ t = numer/denom; scale = c = 1.0/sqrt(1+t*t); s = c*t; } else if ( numer != 0.0 ) { /* t = c/s = denom/numer */ t = denom/numer; scale = 1.0/sqrt(1+t*t); c = fabs(t)*scale; s = ( t >= 0.0 ) ? scale : -scale; } else /* numer == denom == 0 */ { c = 0.0; s = 1.0; } rot_cols(A,k_min,k_max,c,s,A); rot_rows(A,k_min,k_max,c,s,A); /* A->me[k_max][k_min] = 0.0; */ if ( Q != MNULL ) rot_cols(Q,k_min,k_max,c,s,Q); k_min = k_max + 1; /* go to next block */ continue; } } /* now have r x r block with r >= 2: apply Francis QR step until block splits */ split = FALSE; iter = 0; while ( ! split ) { iter++; /* set up Wilkinson/Francis complex shift */ k_tmp = k_max - 1; a00 = m_entry(A,k_tmp,k_tmp); a01 = m_entry(A,k_tmp,k_max); a10 = m_entry(A,k_max,k_tmp); a11 = m_entry(A,k_max,k_max); /* treat degenerate cases differently -- if there are still no splits after five iterations and the bottom 2 x 2 looks degenerate, force it to split */ if ( iter >= 5 && fabs(a00-a11) < sqrt_macheps*(fabs(a00)+fabs(a11)) && (fabs(a01) < sqrt_macheps*(fabs(a00)+fabs(a11)) || fabs(a10) < sqrt_macheps*(fabs(a00)+fabs(a11))) ) { if ( fabs(a01) < sqrt_macheps*(fabs(a00)+fabs(a11)) ) m_set_val(A,k_tmp,k_max,0.0); if ( fabs(a10) < sqrt_macheps*(fabs(a00)+fabs(a11)) ) { m_set_val(A,k_max,k_tmp,0.0); split = TRUE; continue; } } s = a00 + a11; t = a00*a11 - a01*a10; /* break loop if a 2 x 2 complex block */ if ( k_max == k_min + 1 && s*s < 4.0*t ) { split = TRUE; continue; } /* perturb shift if convergence is slow */ if ( (iter % 10) == 0 ) { s += iter*0.02; t += iter*0.02; } /* set up Householder transformations */ k_tmp = k_min + 1; /******************** x = A_me[k_min][k_min]*A_me[k_min][k_min] + A_me[k_min][k_tmp]*A_me[k_tmp][k_min] - s*A_me[k_min][k_min] + t; y = A_me[k_tmp][k_min]* (A_me[k_min][k_min]+A_me[k_tmp][k_tmp]-s); if ( k_min + 2 <= k_max ) z = A_me[k_tmp][k_min]*A_me[k_min+2][k_tmp]; else z = 0.0; ********************/ a00 = m_entry(A,k_min,k_min); a01 = m_entry(A,k_min,k_tmp); a10 = m_entry(A,k_tmp,k_min); a11 = m_entry(A,k_tmp,k_tmp); /******************** a00 = A->me[k_min][k_min]; a01 = A->me[k_min][k_tmp]; a10 = A->me[k_tmp][k_min]; a11 = A->me[k_tmp][k_tmp]; ********************/ x = a00*a00 + a01*a10 - s*a00 + t; y = a10*(a00+a11-s); if ( k_min + 2 <= k_max ) z = a10* /* m_entry(A,k_min+2,k_tmp) */ A->me[k_min+2][k_tmp]; else z = 0.0; for ( k = k_min; k <= k_max-1; k++ ) { if ( k < k_max - 1 ) { hhldr3(x,y,z,&nu1,&beta2,&dummy); tracecatch(hhldr3cols(A,k,max(k-1,0), beta2,nu1,y,z),"schur"); tracecatch(hhldr3rows(A,k,min(n-1,k+3),beta2,nu1,y,z),"schur"); if ( Q != MNULL ) hhldr3rows(Q,k,n-1,beta2,nu1,y,z); } else { givens(x,y,&c,&s); rot_cols(A,k,k+1,c,s,A); rot_rows(A,k,k+1,c,s,A); if ( Q ) rot_cols(Q,k,k+1,c,s,Q); } /* if ( k >= 2 ) m_set_val(A,k,k-2,0.0); */ /* x = A_me[k+1][k]; */ x = m_entry(A,k+1,k); if ( k <= k_max - 2 ) /* y = A_me[k+2][k];*/ y = m_entry(A,k+2,k); else y = 0.0; if ( k <= k_max - 3 ) /* z = A_me[k+3][k]; */ z = m_entry(A,k+3,k); else z = 0.0; } /* if ( k_min > 0 ) m_set_val(A,k_min,k_min-1,0.0); if ( k_max < n - 1 ) m_set_val(A,k_max+1,k_max,0.0); */ for ( k = k_min; k <= k_max-2; k++ ) { /* zero appropriate sub-diagonals */ m_set_val(A,k+2,k,0.0); if ( k < k_max-2 ) m_set_val(A,k+3,k,0.0); } /* test to see if matrix should split */ for ( k = k_min; k < k_max; k++ ) if ( fabs(A_me[k+1][k]) < MACHEPS* (fabs(A_me[k][k])+fabs(A_me[k+1][k+1])) ) { A_me[k+1][k] = 0.0; split = TRUE; } } } /* polish up A by zeroing strictly lower triangular elements and small sub-diagonal elements */ for ( i = 0; i < A->m; i++ ) for ( j = 0; j < i-1; j++ ) A_me[i][j] = 0.0; for ( i = 0; i < A->m - 1; i++ ) if ( fabs(A_me[i+1][i]) < MACHEPS* (fabs(A_me[i][i])+fabs(A_me[i+1][i+1])) ) A_me[i+1][i] = 0.0; return A; } /* schur_vals -- compute real & imaginary parts of eigenvalues -- assumes T contains a block upper triangular matrix as produced by schur() -- real parts stored in real_pt, imaginary parts in imag_pt */ void schur_evals(T,real_pt,imag_pt) MAT *T; VEC *real_pt, *imag_pt; { int i, n; Real discrim, **T_me; Real diff, sum, tmp; if ( ! T || ! real_pt || ! imag_pt ) error(E_NULL,"schur_evals"); if ( T->m != T->n ) error(E_SQUARE,"schur_evals"); n = T->n; T_me = T->me; real_pt = v_resize(real_pt,(u_int)n); imag_pt = v_resize(imag_pt,(u_int)n); i = 0; while ( i < n ) { if ( i < n-1 && T_me[i+1][i] != 0.0 ) { /* should be a complex eigenvalue */ sum = 0.5*(T_me[i][i]+T_me[i+1][i+1]); diff = 0.5*(T_me[i][i]-T_me[i+1][i+1]); discrim = diff*diff + T_me[i][i+1]*T_me[i+1][i]; if ( discrim < 0.0 ) { /* yes -- complex e-vals */ real_pt->ve[i] = real_pt->ve[i+1] = sum; imag_pt->ve[i] = sqrt(-discrim); imag_pt->ve[i+1] = - imag_pt->ve[i]; } else { /* no -- actually both real */ tmp = sqrt(discrim); real_pt->ve[i] = sum + tmp; real_pt->ve[i+1] = sum - tmp; imag_pt->ve[i] = imag_pt->ve[i+1] = 0.0; } i += 2; } else { /* real eigenvalue */ real_pt->ve[i] = T_me[i][i]; imag_pt->ve[i] = 0.0; i++; } } } /* schur_vecs -- returns eigenvectors computed from the real Schur decomposition of a matrix -- T is the block upper triangular Schur matrix -- Q is the orthognal matrix where A = Q.T.Q^T -- if Q is null, the eigenvectors of T are returned -- X_re is the real part of the matrix of eigenvectors, and X_im is the imaginary part of the matrix. -- X_re is returned */ MAT *schur_vecs(T,Q,X_re,X_im) MAT *T, *Q, *X_re, *X_im; { int i, j, limit; Real t11_re, t11_im, t12, t21, t22_re, t22_im; Real l_re, l_im, det_re, det_im, invdet_re, invdet_im, val1_re, val1_im, val2_re, val2_im, tmp_val1_re, tmp_val1_im, tmp_val2_re, tmp_val2_im, **T_me; Real sum, diff, discrim, magdet, norm, scale; static VEC *tmp1_re=VNULL, *tmp1_im=VNULL, *tmp2_re=VNULL, *tmp2_im=VNULL; if ( ! T || ! X_re ) error(E_NULL,"schur_vecs"); if ( T->m != T->n || X_re->m != X_re->n || ( Q != MNULL && Q->m != Q->n ) || ( X_im != MNULL && X_im->m != X_im->n ) ) error(E_SQUARE,"schur_vecs"); if ( T->m != X_re->m || ( Q != MNULL && T->m != Q->m ) || ( X_im != MNULL && T->m != X_im->m ) ) error(E_SIZES,"schur_vecs"); tmp1_re = v_resize(tmp1_re,T->m); tmp1_im = v_resize(tmp1_im,T->m); tmp2_re = v_resize(tmp2_re,T->m); tmp2_im = v_resize(tmp2_im,T->m); MEM_STAT_REG(tmp1_re,TYPE_VEC); MEM_STAT_REG(tmp1_im,TYPE_VEC); MEM_STAT_REG(tmp2_re,TYPE_VEC); MEM_STAT_REG(tmp2_im,TYPE_VEC); T_me = T->me; i = 0; while ( i < T->m ) { if ( i+1 < T->m && T->me[i+1][i] != 0.0 ) { /* complex eigenvalue */ sum = 0.5*(T_me[i][i]+T_me[i+1][i+1]); diff = 0.5*(T_me[i][i]-T_me[i+1][i+1]); discrim = diff*diff + T_me[i][i+1]*T_me[i+1][i]; l_re = l_im = 0.0; if ( discrim < 0.0 ) { /* yes -- complex e-vals */ l_re = sum; l_im = sqrt(-discrim); } else /* not correct Real Schur form */ error(E_RANGE,"schur_vecs"); } else { l_re = T_me[i][i]; l_im = 0.0; } v_zero(tmp1_im); v_rand(tmp1_re); sv_mlt(MACHEPS,tmp1_re,tmp1_re); /* solve (T-l.I)x = tmp1 */ limit = ( l_im != 0.0 ) ? i+1 : i; /* printf("limit = %d\n",limit); */ for ( j = limit+1; j < T->m; j++ ) tmp1_re->ve[j] = 0.0; j = limit; while ( j >= 0 ) { if ( j > 0 && T->me[j][j-1] != 0.0 ) { /* 2 x 2 diagonal block */ /* printf("checkpoint A\n"); */ val1_re = tmp1_re->ve[j-1] - __ip__(&(tmp1_re->ve[j+1]),&(T->me[j-1][j+1]),limit-j); /* printf("checkpoint B\n"); */ val1_im = tmp1_im->ve[j-1] - __ip__(&(tmp1_im->ve[j+1]),&(T->me[j-1][j+1]),limit-j); /* printf("checkpoint C\n"); */ val2_re = tmp1_re->ve[j] - __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint D\n"); */ val2_im = tmp1_im->ve[j] - __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint E\n"); */ t11_re = T_me[j-1][j-1] - l_re; t11_im = - l_im; t22_re = T_me[j][j] - l_re; t22_im = - l_im; t12 = T_me[j-1][j]; t21 = T_me[j][j-1]; scale = fabs(T_me[j-1][j-1]) + fabs(T_me[j][j]) + fabs(t12) + fabs(t21) + fabs(l_re) + fabs(l_im); det_re = t11_re*t22_re - t11_im*t22_im - t12*t21; det_im = t11_re*t22_im + t11_im*t22_re; magdet = det_re*det_re+det_im*det_im; if ( sqrt(magdet) < MACHEPS*scale ) { det_re = MACHEPS*scale; magdet = det_re*det_re+det_im*det_im; } invdet_re = det_re/magdet; invdet_im = - det_im/magdet; tmp_val1_re = t22_re*val1_re-t22_im*val1_im-t12*val2_re; tmp_val1_im = t22_im*val1_re+t22_re*val1_im-t12*val2_im; tmp_val2_re = t11_re*val2_re-t11_im*val2_im-t21*val1_re; tmp_val2_im = t11_im*val2_re+t11_re*val2_im-t21*val1_im; tmp1_re->ve[j-1] = invdet_re*tmp_val1_re - invdet_im*tmp_val1_im; tmp1_im->ve[j-1] = invdet_im*tmp_val1_re + invdet_re*tmp_val1_im; tmp1_re->ve[j] = invdet_re*tmp_val2_re - invdet_im*tmp_val2_im; tmp1_im->ve[j] = invdet_im*tmp_val2_re + invdet_re*tmp_val2_im; j -= 2; } else { t11_re = T_me[j][j] - l_re; t11_im = - l_im; magdet = t11_re*t11_re + t11_im*t11_im; scale = fabs(T_me[j][j]) + fabs(l_re); if ( sqrt(magdet) < MACHEPS*scale ) { t11_re = MACHEPS*scale; magdet = t11_re*t11_re + t11_im*t11_im; } invdet_re = t11_re/magdet; invdet_im = - t11_im/magdet; /* printf("checkpoint F\n"); */ val1_re = tmp1_re->ve[j] - __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint G\n"); */ val1_im = tmp1_im->ve[j] - __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint H\n"); */ tmp1_re->ve[j] = invdet_re*val1_re - invdet_im*val1_im; tmp1_im->ve[j] = invdet_im*val1_re + invdet_re*val1_im; j -= 1; } } norm = v_norm_inf(tmp1_re) + v_norm_inf(tmp1_im); sv_mlt(1/norm,tmp1_re,tmp1_re); if ( l_im != 0.0 ) sv_mlt(1/norm,tmp1_im,tmp1_im); mv_mlt(Q,tmp1_re,tmp2_re); if ( l_im != 0.0 ) mv_mlt(Q,tmp1_im,tmp2_im); if ( l_im != 0.0 ) norm = sqrt(in_prod(tmp2_re,tmp2_re)+in_prod(tmp2_im,tmp2_im)); else norm = v_norm2(tmp2_re); sv_mlt(1/norm,tmp2_re,tmp2_re); if ( l_im != 0.0 ) sv_mlt(1/norm,tmp2_im,tmp2_im); if ( l_im != 0.0 ) { if ( ! X_im ) error(E_NULL,"schur_vecs"); set_col(X_re,i,tmp2_re); set_col(X_im,i,tmp2_im); sv_mlt(-1.0,tmp2_im,tmp2_im); set_col(X_re,i+1,tmp2_re); set_col(X_im,i+1,tmp2_im); i += 2; } else { set_col(X_re,i,tmp2_re); if ( X_im != MNULL ) set_col(X_im,i,tmp1_im); /* zero vector */ i += 1; } } return X_re; } meschach-1.2b/svd.c100644 764 764 23275 5673124203 13641 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing routines for computing the SVD of matrices */ #include #include "matrix.h" #include "matrix2.h" #include static char rcsid[] = "$Id: svd.c,v 1.6 1994/01/13 05:44:16 des Exp $"; #define sgn(x) ((x) >= 0 ? 1 : -1) #define MAX_STACK 100 /* fixsvd -- fix minor details about SVD -- make singular values non-negative -- sort singular values in decreasing order -- variables as for bisvd() -- no argument checking */ static void fixsvd(d,U,V) VEC *d; MAT *U, *V; { int i, j, k, l, r, stack[MAX_STACK], sp; Real tmp, v; /* make singular values non-negative */ for ( i = 0; i < d->dim; i++ ) if ( d->ve[i] < 0.0 ) { d->ve[i] = - d->ve[i]; if ( U != MNULL ) for ( j = 0; j < U->m; j++ ) U->me[i][j] = - U->me[i][j]; } /* sort singular values */ /* nonrecursive implementation of quicksort due to R.Sedgewick, "Algorithms in C", p. 122 (1990) */ sp = -1; l = 0; r = d->dim - 1; for ( ; ; ) { while ( r > l ) { /* i = partition(d->ve,l,r) */ v = d->ve[r]; i = l - 1; j = r; for ( ; ; ) { /* inequalities are "backwards" for **decreasing** order */ while ( d->ve[++i] > v ) ; while ( d->ve[--j] < v ) ; if ( i >= j ) break; /* swap entries in d->ve */ tmp = d->ve[i]; d->ve[i] = d->ve[j]; d->ve[j] = tmp; /* swap rows of U & V as well */ if ( U != MNULL ) for ( k = 0; k < U->n; k++ ) { tmp = U->me[i][k]; U->me[i][k] = U->me[j][k]; U->me[j][k] = tmp; } if ( V != MNULL ) for ( k = 0; k < V->n; k++ ) { tmp = V->me[i][k]; V->me[i][k] = V->me[j][k]; V->me[j][k] = tmp; } } tmp = d->ve[i]; d->ve[i] = d->ve[r]; d->ve[r] = tmp; if ( U != MNULL ) for ( k = 0; k < U->n; k++ ) { tmp = U->me[i][k]; U->me[i][k] = U->me[r][k]; U->me[r][k] = tmp; } if ( V != MNULL ) for ( k = 0; k < V->n; k++ ) { tmp = V->me[i][k]; V->me[i][k] = V->me[r][k]; V->me[r][k] = tmp; } /* end i = partition(...) */ if ( i - l > r - i ) { stack[++sp] = l; stack[++sp] = i-1; l = i+1; } else { stack[++sp] = i+1; stack[++sp] = r; r = i-1; } } if ( sp < 0 ) break; r = stack[sp--]; l = stack[sp--]; } } /* bisvd -- svd of a bidiagonal m x n matrix represented by d (diagonal) and f (super-diagonals) -- returns with d set to the singular values, f zeroed -- if U, V non-NULL, the orthogonal operations are accumulated in U, V; if U, V == I on entry, then SVD == U^T.A.V where A is initial matrix -- returns d on exit */ VEC *bisvd(d,f,U,V) VEC *d, *f; MAT *U, *V; { int i, j, n; int i_min, i_max, split; Real c, s, shift, size, z; Real d_tmp, diff, t11, t12, t22, *d_ve, *f_ve; if ( ! d || ! f ) error(E_NULL,"bisvd"); if ( d->dim != f->dim + 1 ) error(E_SIZES,"bisvd"); n = d->dim; if ( ( U && U->n < n ) || ( V && V->m < n ) ) error(E_SIZES,"bisvd"); if ( ( U && U->m != U->n ) || ( V && V->m != V->n ) ) error(E_SQUARE,"bisvd"); if ( n == 1 ) return d; d_ve = d->ve; f_ve = f->ve; size = v_norm_inf(d) + v_norm_inf(f); i_min = 0; while ( i_min < n ) /* outer while loop */ { /* find i_max to suit; submatrix i_min..i_max should be irreducible */ i_max = n - 1; for ( i = i_min; i < n - 1; i++ ) if ( d_ve[i] == 0.0 || f_ve[i] == 0.0 ) { i_max = i; if ( f_ve[i] != 0.0 ) { /* have to ``chase'' f[i] element out of matrix */ z = f_ve[i]; f_ve[i] = 0.0; for ( j = i; j < n-1 && z != 0.0; j++ ) { givens(d_ve[j+1],z, &c, &s); s = -s; d_ve[j+1] = c*d_ve[j+1] - s*z; if ( j+1 < n-1 ) { z = s*f_ve[j+1]; f_ve[j+1] = c*f_ve[j+1]; } if ( U ) rot_rows(U,i,j+1,c,s,U); } } break; } if ( i_max <= i_min ) { i_min = i_max + 1; continue; } /* printf("bisvd: i_min = %d, i_max = %d\n",i_min,i_max); */ split = FALSE; while ( ! split ) { /* compute shift */ t11 = d_ve[i_max-1]*d_ve[i_max-1] + (i_max > i_min+1 ? f_ve[i_max-2]*f_ve[i_max-2] : 0.0); t12 = d_ve[i_max-1]*f_ve[i_max-1]; t22 = d_ve[i_max]*d_ve[i_max] + f_ve[i_max-1]*f_ve[i_max-1]; /* use e-val of [[t11,t12],[t12,t22]] matrix closest to t22 */ diff = (t11-t22)/2; shift = t22 - t12*t12/(diff + sgn(diff)*sqrt(diff*diff+t12*t12)); /* initial Givens' rotation */ givens(d_ve[i_min]*d_ve[i_min]-shift, d_ve[i_min]*f_ve[i_min], &c, &s); /* do initial Givens' rotations */ d_tmp = c*d_ve[i_min] + s*f_ve[i_min]; f_ve[i_min] = c*f_ve[i_min] - s*d_ve[i_min]; d_ve[i_min] = d_tmp; z = s*d_ve[i_min+1]; d_ve[i_min+1] = c*d_ve[i_min+1]; if ( V ) rot_rows(V,i_min,i_min+1,c,s,V); /* 2nd Givens' rotation */ givens(d_ve[i_min],z, &c, &s); d_ve[i_min] = c*d_ve[i_min] + s*z; d_tmp = c*d_ve[i_min+1] - s*f_ve[i_min]; f_ve[i_min] = s*d_ve[i_min+1] + c*f_ve[i_min]; d_ve[i_min+1] = d_tmp; if ( i_min+1 < i_max ) { z = s*f_ve[i_min+1]; f_ve[i_min+1] = c*f_ve[i_min+1]; } if ( U ) rot_rows(U,i_min,i_min+1,c,s,U); for ( i = i_min+1; i < i_max; i++ ) { /* get Givens' rotation for zeroing z */ givens(f_ve[i-1],z, &c, &s); f_ve[i-1] = c*f_ve[i-1] + s*z; d_tmp = c*d_ve[i] + s*f_ve[i]; f_ve[i] = c*f_ve[i] - s*d_ve[i]; d_ve[i] = d_tmp; z = s*d_ve[i+1]; d_ve[i+1] = c*d_ve[i+1]; if ( V ) rot_rows(V,i,i+1,c,s,V); /* get 2nd Givens' rotation */ givens(d_ve[i],z, &c, &s); d_ve[i] = c*d_ve[i] + s*z; d_tmp = c*d_ve[i+1] - s*f_ve[i]; f_ve[i] = c*f_ve[i] + s*d_ve[i+1]; d_ve[i+1] = d_tmp; if ( i+1 < i_max ) { z = s*f_ve[i+1]; f_ve[i+1] = c*f_ve[i+1]; } if ( U ) rot_rows(U,i,i+1,c,s,U); } /* should matrix be split? */ for ( i = i_min; i < i_max; i++ ) if ( fabs(f_ve[i]) < MACHEPS*(fabs(d_ve[i])+fabs(d_ve[i+1])) ) { split = TRUE; f_ve[i] = 0.0; } else if ( fabs(d_ve[i]) < MACHEPS*size ) { split = TRUE; d_ve[i] = 0.0; } /* printf("bisvd: d =\n"); v_output(d); */ /* printf("bisvd: f = \n"); v_output(f); */ } } fixsvd(d,U,V); return d; } /* bifactor -- perform preliminary factorisation for bisvd -- updates U and/or V, which ever is not NULL */ MAT *bifactor(A,U,V) MAT *A, *U, *V; { int k; static VEC *tmp1=VNULL, *tmp2=VNULL; Real beta; if ( ! A ) error(E_NULL,"bifactor"); if ( ( U && ( U->m != U->n ) ) || ( V && ( V->m != V->n ) ) ) error(E_SQUARE,"bifactor"); if ( ( U && U->m != A->m ) || ( V && V->m != A->n ) ) error(E_SIZES,"bifactor"); tmp1 = v_resize(tmp1,A->m); tmp2 = v_resize(tmp2,A->n); MEM_STAT_REG(tmp1,TYPE_VEC); MEM_STAT_REG(tmp2,TYPE_VEC); if ( A->m >= A->n ) for ( k = 0; k < A->n; k++ ) { get_col(A,k,tmp1); hhvec(tmp1,k,&beta,tmp1,&(A->me[k][k])); hhtrcols(A,k,k+1,tmp1,beta); if ( U ) hhtrcols(U,k,0,tmp1,beta); if ( k+1 >= A->n ) continue; get_row(A,k,tmp2); hhvec(tmp2,k+1,&beta,tmp2,&(A->me[k][k+1])); hhtrrows(A,k+1,k+1,tmp2,beta); if ( V ) hhtrcols(V,k+1,0,tmp2,beta); } else for ( k = 0; k < A->m; k++ ) { get_row(A,k,tmp2); hhvec(tmp2,k,&beta,tmp2,&(A->me[k][k])); hhtrrows(A,k+1,k,tmp2,beta); if ( V ) hhtrcols(V,k,0,tmp2,beta); if ( k+1 >= A->m ) continue; get_col(A,k,tmp1); hhvec(tmp1,k+1,&beta,tmp1,&(A->me[k+1][k])); hhtrcols(A,k+1,k+1,tmp1,beta); if ( U ) hhtrcols(U,k+1,0,tmp1,beta); } return A; } /* svd -- returns vector of singular values in d -- also updates U and/or V, if one or the other is non-NULL -- destroys A */ VEC *svd(A,U,V,d) MAT *A, *U, *V; VEC *d; { static VEC *f=VNULL; int i, limit; MAT *A_tmp; if ( ! A ) error(E_NULL,"svd"); if ( ( U && ( U->m != U->n ) ) || ( V && ( V->m != V->n ) ) ) error(E_SQUARE,"svd"); if ( ( U && U->m != A->m ) || ( V && V->m != A->n ) ) error(E_SIZES,"svd"); A_tmp = m_copy(A,MNULL); if ( U != MNULL ) m_ident(U); if ( V != MNULL ) m_ident(V); limit = min(A_tmp->m,A_tmp->n); d = v_resize(d,limit); f = v_resize(f,limit-1); MEM_STAT_REG(f,TYPE_VEC); bifactor(A_tmp,U,V); if ( A_tmp->m >= A_tmp->n ) for ( i = 0; i < limit; i++ ) { d->ve[i] = A_tmp->me[i][i]; if ( i+1 < limit ) f->ve[i] = A_tmp->me[i][i+1]; } else for ( i = 0; i < limit; i++ ) { d->ve[i] = A_tmp->me[i][i]; if ( i+1 < limit ) f->ve[i] = A_tmp->me[i+1][i]; } if ( A_tmp->m >= A_tmp->n ) bisvd(d,f,U,V); else bisvd(d,f,V,U); M_FREE(A_tmp); return d; } meschach-1.2b/fft.c100644 764 764 7464 5673124544 13616 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Fast Fourier Transform routine Loosely based on the Fortran routine in Rabiner & Gold's "Digital Signal Processing" */ static char rcsid[] = "$Id: fft.c,v 1.3 1994/01/13 05:45:33 des Exp $"; #include #include "matrix.h" #include "matrix2.h" #include /* fft -- d.i.t. fast Fourier transform -- radix-2 FFT only -- vector extended to a power of 2 */ void fft(x_re,x_im) VEC *x_re, *x_im; { int i, ip, j, k, li, n, length; Real *xr, *xi; Real theta, pi = 3.1415926535897932384; Real w_re, w_im, u_re, u_im, t_re, t_im; Real tmp, tmpr, tmpi; if ( ! x_re || ! x_im ) error(E_NULL,"fft"); if ( x_re->dim != x_im->dim ) error(E_SIZES,"fft"); n = 1; while ( x_re->dim > n ) n *= 2; x_re = v_resize(x_re,n); x_im = v_resize(x_im,n); printf("# fft: x_re =\n"); v_output(x_re); printf("# fft: x_im =\n"); v_output(x_im); xr = x_re->ve; xi = x_im->ve; /* Decimation in time (DIT) algorithm */ j = 0; for ( i = 0; i < n-1; i++ ) { if ( i < j ) { tmp = xr[i]; xr[i] = xr[j]; xr[j] = tmp; tmp = xi[i]; xi[i] = xi[j]; xi[j] = tmp; } k = n / 2; while ( k <= j ) { j -= k; k /= 2; } j += k; } /* Actual FFT */ for ( li = 1; li < n; li *= 2 ) { length = 2*li; theta = pi/li; u_re = 1.0; u_im = 0.0; if ( li == 1 ) { w_re = -1.0; w_im = 0.0; } else if ( li == 2 ) { w_re = 0.0; w_im = 1.0; } else { w_re = cos(theta); w_im = sin(theta); } for ( j = 0; j < li; j++ ) { for ( i = j; i < n; i += length ) { ip = i + li; /* step 1 */ t_re = xr[ip]*u_re - xi[ip]*u_im; t_im = xr[ip]*u_im + xi[ip]*u_re; /* step 2 */ xr[ip] = xr[i] - t_re; xi[ip] = xi[i] - t_im; /* step 3 */ xr[i] += t_re; xi[i] += t_im; } tmpr = u_re*w_re - u_im*w_im; tmpi = u_im*w_re + u_re*w_im; u_re = tmpr; u_im = tmpi; } } } /* ifft -- inverse FFT using the same interface as fft() */ void ifft(x_re,x_im) VEC *x_re, *x_im; { /* we just use complex conjugates */ sv_mlt(-1.0,x_im,x_im); fft(x_re,x_im); sv_mlt(-1.0/((double)(x_re->dim)),x_im,x_im); } meschach-1.2b/mfunc.c100644 764 764 21775 5673124600 14161 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains routines for computing functions of matrices especially polynomials and exponential functions Copyright (C) Teresa Leyk and David Stewart, 1993 */ #include #include "matrix.h" #include "matrix2.h" #include static char rcsid[] = "$Id: mfunc.c,v 1.2 1994/11/01 05:57:56 des Exp $"; /* _m_pow -- computes integer powers of a square matrix A, A^p -- uses tmp as temporary workspace */ MAT *_m_pow(A, p, tmp, out) MAT *A, *tmp, *out; int p; { int it_cnt, k, max_bit; /* File containing routines for evaluating matrix functions esp. the exponential function */ #define Z(k) (((k) & 1) ? tmp : out) if ( ! A ) error(E_NULL,"_m_pow"); if ( A->m != A->n ) error(E_SQUARE,"_m_pow"); if ( p < 0 ) error(E_NEG,"_m_pow"); out = m_resize(out,A->m,A->n); tmp = m_resize(tmp,A->m,A->n); if ( p == 0 ) m_ident(out); else if ( p > 0 ) { it_cnt = 1; for ( max_bit = 0; ; max_bit++ ) if ( (p >> (max_bit+1)) == 0 ) break; tmp = m_copy(A,tmp); for ( k = 0; k < max_bit; k++ ) { m_mlt(Z(it_cnt),Z(it_cnt),Z(it_cnt+1)); it_cnt++; if ( p & (1 << (max_bit-1)) ) { m_mlt(A,Z(it_cnt),Z(it_cnt+1)); /* m_copy(Z(it_cnt),out); */ it_cnt++; } p <<= 1; } if (it_cnt & 1) out = m_copy(Z(it_cnt),out); } return out; #undef Z } /* m_pow -- computes integer powers of a square matrix A, A^p */ MAT *m_pow(A, p, out) MAT *A, *out; int p; { static MAT *wkspace, *tmp; if ( ! A ) error(E_NULL,"m_pow"); if ( A->m != A->n ) error(E_SQUARE,"m_pow"); wkspace = m_resize(wkspace,A->m,A->n); MEM_STAT_REG(wkspace,TYPE_MAT); if ( p < 0 ) { tmp = m_resize(tmp,A->m,A->n); MEM_STAT_REG(tmp,TYPE_MAT); tracecatch(m_inverse(A,tmp),"m_pow"); return _m_pow(tmp, -p, wkspace, out); } else return _m_pow(A, p, wkspace, out); } /**************************************************/ /* _m_exp -- compute matrix exponential of A and save it in out -- uses Pade approximation followed by repeated squaring -- eps is the tolerance used for the Pade approximation -- A is not changed -- q_out - degree of the Pade approximation (q_out,q_out) -- j_out - the power of 2 for scaling the matrix A such that ||A/2^j_out|| <= 0.5 */ MAT *_m_exp(A,eps,out,q_out,j_out) MAT *A,*out; double eps; int *q_out, *j_out; { static MAT *D = MNULL, *Apow = MNULL, *N = MNULL, *Y = MNULL; static VEC *c1 = VNULL, *tmp = VNULL; VEC y0, y1; /* additional structures */ static PERM *pivot = PNULL; int j, k, l, q, r, s, j2max, t; double inf_norm, eqq, power2, c, sign; if ( ! A ) error(E_SIZES,"_m_exp"); if ( A->m != A->n ) error(E_SIZES,"_m_exp"); if ( A == out ) error(E_INSITU,"_m_exp"); if ( eps < 0.0 ) error(E_RANGE,"_m_exp"); else if (eps == 0.0) eps = MACHEPS; N = m_resize(N,A->m,A->n); D = m_resize(D,A->m,A->n); Apow = m_resize(Apow,A->m,A->n); out = m_resize(out,A->m,A->n); MEM_STAT_REG(N,TYPE_MAT); MEM_STAT_REG(D,TYPE_MAT); MEM_STAT_REG(Apow,TYPE_MAT); /* normalise A to have ||A||_inf <= 1 */ inf_norm = m_norm_inf(A); if (inf_norm <= 0.0) { m_ident(out); *q_out = -1; *j_out = 0; return out; } else { j2max = floor(1+log(inf_norm)/log(2.0)); j2max = max(0, j2max); } power2 = 1.0; for ( k = 1; k <= j2max; k++ ) power2 *= 2; power2 = 1.0/power2; if ( j2max > 0 ) sm_mlt(power2,A,A); /* compute order for polynomial approximation */ eqq = 1.0/6.0; for ( q = 1; eqq > eps; q++ ) eqq /= 16.0*(2.0*q+1.0)*(2.0*q+3.0); /* construct vector of coefficients */ c1 = v_resize(c1,q+1); MEM_STAT_REG(c1,TYPE_VEC); c1->ve[0] = 1.0; for ( k = 1; k <= q; k++ ) c1->ve[k] = c1->ve[k-1]*(q-k+1)/((2*q-k+1)*(double)k); tmp = v_resize(tmp,A->n); MEM_STAT_REG(tmp,TYPE_VEC); s = (int)floor(sqrt((double)q/2.0)); if ( s <= 0 ) s = 1; _m_pow(A,s,out,Apow); r = q/s; Y = m_resize(Y,s,A->n); MEM_STAT_REG(Y,TYPE_MAT); /* y0 and y1 are pointers to rows of Y, N and D */ y0.dim = y0.max_dim = A->n; y1.dim = y1.max_dim = A->n; m_zero(Y); m_zero(N); m_zero(D); for( j = 0; j < A->n; j++ ) { if (j > 0) Y->me[0][j-1] = 0.0; y0.ve = Y->me[0]; y0.ve[j] = 1.0; for ( k = 0; k < s-1; k++ ) { y1.ve = Y->me[k+1]; mv_mlt(A,&y0,&y1); y0.ve = y1.ve; } y0.ve = N->me[j]; y1.ve = D->me[j]; t = s*r; for ( l = 0; l <= q-t; l++ ) { c = c1->ve[t+l]; sign = ((t+l) & 1) ? -1.0 : 1.0; __mltadd__(y0.ve,Y->me[l],c, Y->n); __mltadd__(y1.ve,Y->me[l],c*sign,Y->n); } for (k=1; k <= r; k++) { v_copy(mv_mlt(Apow,&y0,tmp),&y0); v_copy(mv_mlt(Apow,&y1,tmp),&y1); t = s*(r-k); for (l=0; l < s; l++) { c = c1->ve[t+l]; sign = ((t+l) & 1) ? -1.0 : 1.0; __mltadd__(y0.ve,Y->me[l],c, Y->n); __mltadd__(y1.ve,Y->me[l],c*sign,Y->n); } } } pivot = px_resize(pivot,A->m); MEM_STAT_REG(pivot,TYPE_PERM); /* note that N and D are transposed, therefore we use LUTsolve; out is saved row-wise, and must be transposed after this */ LUfactor(D,pivot); for (k=0; k < A->n; k++) { y0.ve = N->me[k]; y1.ve = out->me[k]; LUTsolve(D,pivot,&y0,&y1); } m_transp(out,out); /* Use recursive squaring to turn the normalised exponential to the true exponential */ #define Z(k) ((k) & 1 ? Apow : out) for( k = 1; k <= j2max; k++) m_mlt(Z(k-1),Z(k-1),Z(k)); if (Z(k) == out) m_copy(Apow,out); /* output parameters */ *j_out = j2max; *q_out = q; /* restore the matrix A */ sm_mlt(1.0/power2,A,A); return out; #undef Z } /* simple interface for _m_exp */ MAT *m_exp(A,eps,out) MAT *A,*out; double eps; { int q_out, j_out; return _m_exp(A,eps,out,&q_out,&j_out); } /*--------------------------------*/ /* m_poly -- computes sum_i a[i].A^i, where i=0,1,...dim(a); -- uses C. Van Loan's fast and memory efficient method */ MAT *m_poly(A,a,out) MAT *A,*out; VEC *a; { static MAT *Apow = MNULL, *Y = MNULL; static VEC *tmp; VEC y0, y1; /* additional vectors */ int j, k, l, q, r, s, t; if ( ! A || ! a ) error(E_NULL,"m_poly"); if ( A->m != A->n ) error(E_SIZES,"m_poly"); if ( A == out ) error(E_INSITU,"m_poly"); out = m_resize(out,A->m,A->n); Apow = m_resize(Apow,A->m,A->n); MEM_STAT_REG(Apow,TYPE_MAT); tmp = v_resize(tmp,A->n); MEM_STAT_REG(tmp,TYPE_VEC); q = a->dim - 1; if ( q == 0 ) { m_zero(out); for (j=0; j < out->n; j++) out->me[j][j] = a->ve[0]; return out; } else if ( q == 1) { sm_mlt(a->ve[1],A,out); for (j=0; j < out->n; j++) out->me[j][j] += a->ve[0]; return out; } s = (int)floor(sqrt((double)q/2.0)); if ( s <= 0 ) s = 1; _m_pow(A,s,out,Apow); r = q/s; Y = m_resize(Y,s,A->n); MEM_STAT_REG(Y,TYPE_MAT); /* pointers to rows of Y */ y0.dim = y0.max_dim = A->n; y1.dim = y1.max_dim = A->n; m_zero(Y); m_zero(out); #define Z(k) ((k) & 1 ? tmp : &y0) #define ZZ(k) ((k) & 1 ? tmp->ve : y0.ve) for( j = 0; j < A->n; j++) { if( j > 0 ) Y->me[0][j-1] = 0.0; Y->me[0][j] = 1.0; y0.ve = Y->me[0]; for (k = 0; k < s-1; k++) { y1.ve = Y->me[k+1]; mv_mlt(A,&y0,&y1); y0.ve = y1.ve; } y0.ve = out->me[j]; t = s*r; for ( l = 0; l <= q-t; l++ ) __mltadd__(y0.ve,Y->me[l],a->ve[t+l],Y->n); for (k=1; k <= r; k++) { mv_mlt(Apow,Z(k-1),Z(k)); t = s*(r-k); for (l=0; l < s; l++) __mltadd__(ZZ(k),Y->me[l],a->ve[t+l],Y->n); } if (Z(k) == &y0) v_copy(tmp,&y0); } m_transp(out,out); return out; } meschach-1.2b/bdfactor.c100644 764 764 34175 5673124632 14640 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Band matrix factorisation routines */ /* bdfactor.c 18/11/93 */ static char rcsid[] = "$Id: "; #include #include "matrix2.h" #include /* generate band matrix for a matrix with n columns, lb subdiagonals and ub superdiagonals; Way of saving a band of a matrix: first we save subdiagonals (from 0 to lb-1); then main diagonal (in the lb row) and then superdiagonals (from lb+1 to lb+ub) in such a way that the elements which were previously in one column are now also in one column */ BAND *bd_get(lb,ub,n) int lb, ub, n; { BAND *A; if (lb < 0 || ub < 0 || n <= 0) error(E_NEG,"bd_get"); if ((A = NEW(BAND)) == (BAND *)NULL) error(E_MEM,"bd_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_BAND,0,sizeof(BAND)); mem_numvar(TYPE_BAND,1); } lb = A->lb = min(n-1,lb); ub = A->ub = min(n-1,ub); A->mat = m_get(lb+ub+1,n); return A; } int bd_free(A) BAND *A; { if ( A == (BAND *)NULL || A->lb < 0 || A->ub < 0 ) /* don't trust it */ return (-1); if (A->mat) m_free(A->mat); if (mem_info_is_on()) { mem_bytes(TYPE_BAND,sizeof(BAND),0); mem_numvar(TYPE_BAND,-1); } free((char *)A); return 0; } /* resize band matrix */ BAND *bd_resize(A,new_lb,new_ub,new_n) BAND *A; int new_lb,new_ub,new_n; { int lb,ub,i,j,l,shift,umin; Real **Av; if (new_lb < 0 || new_ub < 0 || new_n <= 0) error(E_NEG,"bd_resize"); if ( ! A ) return bd_get(new_lb,new_ub,new_n); if ( A->lb+A->ub+1 > A->mat->m ) error(E_INTERN,"bd_resize"); if ( A->lb == new_lb && A->ub == new_ub && A->mat->n == new_n ) return A; lb = A->lb; ub = A->ub; Av = A->mat->me; umin = min(ub,new_ub); /* ensure that unused triangles at edges are zero'd */ for ( i = 0; i < lb; i++ ) for ( j = A->mat->n - lb + i; j < A->mat->n; j++ ) Av[i][j] = 0.0; for ( i = lb+1,l=1; l <= umin; i++,l++ ) for ( j = 0; j < l; j++ ) Av[i][j] = 0.0; new_lb = A->lb = min(new_lb,new_n-1); new_ub = A->ub = min(new_ub,new_n-1); A->mat = m_resize(A->mat,new_lb+new_ub+1,new_n); Av = A->mat->me; /* if new_lb != lb then move the rows to get the main diag in the new_lb row */ if (new_lb > lb) { shift = new_lb-lb; for (i=lb+umin, l=i+shift; i >= 0; i--,l--) MEM_COPY(Av[i],Av[l],new_n*sizeof(Real)); for (l=shift-1; l >= 0; l--) __zero__(Av[l],new_n); } else if (new_lb < lb) { shift = lb - new_lb; for (i=shift, l=0; i <= lb+umin; i++,l++) MEM_COPY(Av[i],Av[l],new_n*sizeof(Real)); for (i=lb+umin+1; i <= new_lb+new_ub; i++) __zero__(Av[i],new_n); } return A; } BAND *bd_copy(A,B) BAND *A,*B; { int lb,ub,i,j,n; if ( !A ) error(E_NULL,"bd_copy"); if (A == B) return B; n = A->mat->n; if ( !B ) B = bd_get(A->lb,A->ub,n); else if (B->lb != A->lb || B->ub != A->ub || B->mat->n != n ) B = bd_resize(B,A->lb,A->ub,n); if (A->mat == B->mat) return B; ub = B->ub = A->ub; lb = B->lb = A->lb; for ( i=0, j=n-lb; i <= lb; i++, j++ ) MEM_COPY(A->mat->me[i],B->mat->me[i],j*sizeof(Real)); for ( i=lb+1, j=1; i <= lb+ub; i++, j++ ) MEM_COPY(A->mat->me[i]+j,B->mat->me[i]+j,(n - j)*sizeof(Real)); return B; } /* copy band matrix to a square matrix */ MAT *band2mat(bA,A) BAND *bA; MAT *A; { int i,j,l,n,n1; int lb, ub; Real **bmat; if ( !bA || !A) error(E_NULL,"band2mat"); if ( bA->mat == A ) error(E_INSITU,"band2mat"); ub = bA->ub; lb = bA->lb; n = bA->mat->n; n1 = n-1; bmat = bA->mat->me; A = m_resize(A,n,n); m_zero(A); for (j=0; j < n; j++) for (i=min(n1,j+lb),l=lb+j-i; i >= max(0,j-ub); i--,l++) A->me[i][j] = bmat[l][j]; return A; } /* copy a square matrix to a band matrix with lb subdiagonals and ub superdiagonals */ BAND *mat2band(A,lb,ub,bA) BAND *bA; MAT *A; int lb, ub; { int i, j, l, n1; Real **bmat; if (! A || ! bA) error(E_NULL,"mat2band"); if (ub < 0 || lb < 0) error(E_SIZES,"mat2band"); if (bA->mat == A) error(E_INSITU,"mat2band"); n1 = A->n-1; lb = min(n1,lb); ub = min(n1,ub); bA = bd_resize(bA,lb,ub,n1+1); bmat = bA->mat->me; for (j=0; j <= n1; j++) for (i=min(n1,j+lb),l=lb+j-i; i >= max(0,j-ub); i--,l++) bmat[l][j] = A->me[i][j]; return bA; } /* transposition of matrix in; out - matrix after transposition; can be done in situ */ BAND *bd_transp(in,out) BAND *in, *out; { int i, j, jj, l, k, lb, ub, lub, n, n1; int in_situ; Real **in_v, **out_v; if ( in == (BAND *)NULL || in->mat == (MAT *)NULL ) error(E_NULL,"bd_transp"); lb = in->lb; ub = in->ub; lub = lb+ub; n = in->mat->n; n1 = n-1; in_situ = ( in == out ); if ( ! in_situ ) out = bd_resize(out,ub,lb,n); else { /* only need to swap lb and ub fields */ out->lb = ub; out->ub = lb; } in_v = in->mat->me; if (! in_situ) { int sh_in,sh_out; out_v = out->mat->me; for (i=0, l=lub, k=lb-i; i <= lub; i++,l--,k--) { sh_in = max(-k,0); sh_out = max(k,0); MEM_COPY(&(in_v[i][sh_in]),&(out_v[l][sh_out]), (n-sh_in-sh_out)*sizeof(Real)); /********************************** for (j=n1-sh_out, jj=n1-sh_in; j >= sh_in; j--,jj--) { out_v[l][jj] = in_v[i][j]; } **********************************/ } } else if (ub == lb) { Real tmp; for (i=0, l=lub, k=lb-i; i < lb; i++,l--,k--) { for (j=n1-k, jj=n1; j >= 0; j--,jj--) { tmp = in_v[l][jj]; in_v[l][jj] = in_v[i][j]; in_v[i][j] = tmp; } } } else if (ub > lb) { /* hence i-ub <= 0 & l-lb >= 0 */ int p,pp,lbi; for (i=0, l=lub; i < (lub+1)/2; i++,l--) { lbi = lb-i; for (j=l-lb, jj=0, p=max(-lbi,0), pp = max(l-ub,0); j <= n1; j++,jj++,p++,pp++) { in_v[l][pp] = in_v[i][p]; in_v[i][jj] = in_v[l][j]; } for ( ; p <= n1-max(lbi,0); p++,pp++) in_v[l][pp] = in_v[i][p]; } if (lub%2 == 0) { /* shift only */ i = lub/2; for (j=max(i-lb,0), jj=0; jj <= n1-ub+i; j++,jj++) in_v[i][jj] = in_v[i][j]; } } else { /* ub < lb, hence ub-l <= 0 & lb-i >= 0 */ int p,pp,ubi; for (i=0, l=lub; i < (lub+1)/2; i++,l--) { ubi = i-ub; for (j=n1-max(lb-l,0), jj=n1-max(-ubi,0), p=n1-lb+i, pp=n1; p >= 0; j--, jj--, pp--, p--) { in_v[i][jj] = in_v[l][j]; in_v[l][pp] = in_v[i][p]; } for ( ; jj >= max(ubi,0); j--, jj--) in_v[i][jj] = in_v[l][j]; } if (lub%2 == 0) { /* shift only */ i = lub/2; for (j=n1-lb+i, jj=n1-max(ub-i,0); j >= 0; j--, jj--) in_v[i][jj] = in_v[i][j]; } } return out; } /* bdLUfactor -- gaussian elimination with partial pivoting -- on entry, the matrix A in band storage with elements in rows 0 to lb+ub; The jth column of A is stored in the jth column of band A (bA) as follows: bA->mat->me[lb+j-i][j] = A->me[i][j] for max(0,j-lb) <= i <= min(A->n-1,j+ub); -- on exit: U is stored as an upper triangular matrix with lb+ub superdiagonals in rows lb to 2*lb+ub, and the matrix L is stored in rows 0 to lb-1. Matrix U is permuted, whereas L is not permuted !!! Therefore we save some memory. */ BAND *bdLUfactor(bA,pivot) BAND *bA; PERM *pivot; { int i, j, k, l, n, n1, lb, ub, lub, k_end, k_lub; int i_max, shift; Real **bA_v; Real max1, temp; if ( bA==(BAND *)NULL || pivot==(PERM *)NULL ) error(E_NULL,"bdLUfactor"); lb = bA->lb; ub = bA->ub; lub = lb+ub; n = bA->mat->n; n1 = n-1; lub = lb+ub; if ( pivot->size != n ) error(E_SIZES,"bdLUfactor"); /* initialise pivot with identity permutation */ for ( i=0; i < n; i++ ) pivot->pe[i] = i; /* extend band matrix */ /* extended part is filled with zeros */ bA = bd_resize(bA,lb,min(n1,lub),n); bA_v = bA->mat->me; /* main loop */ for ( k=0; k < n1; k++ ) { k_end = max(0,lb+k-n1); k_lub = min(k+lub,n1); /* find the best pivot row */ max1 = 0.0; i_max = -1; for ( i=lb; i >= k_end; i-- ) { temp = fabs(bA_v[i][k]); if ( temp > max1 ) { max1 = temp; i_max = i; } } /* if no pivot then ignore column k... */ if ( i_max == -1 ) continue; /* do we pivot ? */ if ( i_max != lb ) /* yes we do... */ { /* save transposition using non-shifted indices */ shift = lb-i_max; px_transp(pivot,k+shift,k); for ( i=lb, j=k; j <= k_lub; i++,j++ ) { temp = bA_v[i][j]; bA_v[i][j] = bA_v[i-shift][j]; bA_v[i-shift][j] = temp; } } /* row operations */ for ( i=lb-1; i >= k_end; i-- ) { temp = bA_v[i][k] /= bA_v[lb][k]; shift = lb-i; for ( j=k+1,l=i+1; j <= k_lub; l++,j++ ) bA_v[l][j] -= temp*bA_v[l+shift][j]; } } return bA; } /* bdLUsolve -- given an LU factorisation in bA, solve bA*x=b */ /* pivot is changed upon return */ VEC *bdLUsolve(bA,pivot,b,x) BAND *bA; PERM *pivot; VEC *b,*x; { int i,j,l,n,n1,pi,lb,ub,jmin, maxj; Real c; Real **bA_v; if ( bA==(BAND *)NULL || b==(VEC *)NULL || pivot==(PERM *)NULL ) error(E_NULL,"bdLUsolve"); if ( bA->mat->n != b->dim || bA->mat->n != pivot->size) error(E_SIZES,"bdLUsolve"); lb = bA->lb; ub = bA->ub; n = b->dim; n1 = n-1; bA_v = bA->mat->me; x = v_resize(x,b->dim); px_vec(pivot,b,x); /* solve Lx = b; implicit diagonal = 1 L is not permuted, therefore it must be permuted now */ px_inv(pivot,pivot); for (j=0; j < n; j++) { jmin = j+1; c = x->ve[j]; maxj = max(0,j+lb-n1); for (i=jmin,l=lb-1; l >= maxj; i++,l--) { if ( (pi = pivot->pe[i]) < jmin) pi = pivot->pe[i] = pivot->pe[pi]; x->ve[pi] -= bA_v[l][j]*c; } } /* solve Ux = b; explicit diagonal */ x->ve[n1] /= bA_v[lb][n1]; for (i=n-2; i >= 0; i--) { c = x->ve[i]; for (j=min(n1,i+ub), l=lb+j-i; j > i; j--,l--) c -= bA_v[l][j]*x->ve[j]; x->ve[i] = c/bA_v[lb][i]; } return (x); } /* LDLfactor -- L.D.L' factorisation of A in-situ; A is a band matrix it works using only lower bandwidth & main diagonal so it is possible to set A->ub = 0 */ BAND *bdLDLfactor(A) BAND *A; { int i,j,k,n,n1,lb,ki,jk,ji,lbkm,lbkp; Real **Av; Real c, cc; if ( ! A ) error(E_NULL,"bdLDLfactor"); if (A->lb == 0) return A; lb = A->lb; n = A->mat->n; n1 = n-1; Av = A->mat->me; for (k=0; k < n; k++) { lbkm = lb-k; lbkp = lb+k; /* matrix D */ c = Av[lb][k]; for (j=max(0,-lbkm), jk=lbkm+j; j < k; j++, jk++) { cc = Av[jk][j]; c -= Av[lb][j]*cc*cc; } if (c == 0.0) error(E_SING,"bdLDLfactor"); Av[lb][k] = c; /* matrix L */ for (i=min(n1,lbkp), ki=lbkp-i; i > k; i--,ki++) { c = Av[ki][k]; for (j=max(0,i-lb), ji=lb+j-i, jk=lbkm+j; j < k; j++, ji++, jk++) c -= Av[lb][j]*Av[ji][j]*Av[jk][j]; Av[ki][k] = c/Av[lb][k]; } } return A; } /* solve A*x = b, where A is factorized by Choleski LDL^T factorization */ VEC *bdLDLsolve(A,b,x) BAND *A; VEC *b, *x; { int i,j,l,n,n1,lb,ilb; Real **Av, *Avlb; Real c; if ( ! A || ! b ) error(E_NULL,"bdLDLsolve"); if ( A->mat->n != b->dim ) error(E_SIZES,"bdLDLsolve"); n = A->mat->n; n1 = n-1; x = v_resize(x,n); lb = A->lb; Av = A->mat->me; Avlb = Av[lb]; /* solve L*y = b */ x->ve[0] = b->ve[0]; for (i=1; i < n; i++) { ilb = i-lb; c = b->ve[i]; for (j=max(0,ilb), l=j-ilb; j < i; j++,l++) c -= Av[l][j]*x->ve[j]; x->ve[i] = c; } /* solve D*z = y */ for (i=0; i < n; i++) x->ve[i] /= Avlb[i]; /* solve L^T*x = z */ for (i=n-2; i >= 0; i--) { ilb = i+lb; c = x->ve[i]; for (j=min(n1,ilb), l=ilb-j; j > i; j--,l++) c -= Av[l][i]*x->ve[j]; x->ve[i] = c; } return x; } /* ****************************************************** This function is a contribution from Ruediger Franke. His e-mail addres is: Ruediger.Franke@rz.tu-ilmenau.de ****************************************************** */ /* bd_mv_mlt -- * computes out = A * x * may not work in situ (x != out) */ VEC *bd_mv_mlt(A, x, out) BAND *A; VEC *x, *out; { int i, j, j_end, k; int start_idx, end_idx; int n, m, lb, ub; Real **A_me; Real *x_ve; Real sum; if (!A || !x) error(E_NULL,"bd_mv_mlt"); if (x->dim != A->mat->n) error(E_SIZES,"bd_mv_mlt"); if (!out || out->dim != A->mat->n) out = v_resize(out, A->mat->n); if (out == x) error(E_INSITU,"bd_mv_mlt"); n = A->mat->n; m = A->mat->m; lb = A->lb; ub = A->ub; A_me = A->mat->me; start_idx = lb; end_idx = m + n-1 - ub; for (i=0; ive + k; sum = 0.0; for (; j < j_end; j++, k++) sum += A_me[j][k] * *x_ve++; out->ve[i] = sum; } return out; } meschach-1.2b/sparse.c100644 764 764 56325 5537010527 14346 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse matrix package See also: sparse.h, matrix.h */ #include #include #include #include "sparse.h" static char rcsid[] = "$Id: sparse.c,v 1.10 1994/03/08 05:46:07 des Exp $"; #define MINROWLEN 10 /* sp_get_val -- returns the (i,j) entry of the sparse matrix A */ double sp_get_val(A,i,j) SPMAT *A; int i, j; { SPROW *r; int idx; if ( A == SMNULL ) error(E_NULL,"sp_get_val"); if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) error(E_SIZES,"sp_get_val"); r = A->row+i; idx = sprow_idx(r,j); if ( idx < 0 ) return 0.0; /* else */ return r->elt[idx].val; } /* sp_set_val -- sets the (i,j) entry of the sparse matrix A */ double sp_set_val(A,i,j,val) SPMAT *A; int i, j; double val; { SPROW *r; int idx, idx2, new_len; if ( A == SMNULL ) error(E_NULL,"sp_set_val"); if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) error(E_SIZES,"sp_set_val"); r = A->row+i; idx = sprow_idx(r,j); /* printf("sp_set_val: idx = %d\n",idx); */ if ( idx >= 0 ) { r->elt[idx].val = val; return val; } /* else */ if ( idx < -1 ) { /* Note: this destroys the column & diag access paths */ A->flag_col = A->flag_diag = FALSE; /* shift & insert new value */ idx = -(idx+2); /* this is the intended insertion index */ if ( r->len >= r->maxlen ) { r->len = r->maxlen; new_len = max(2*r->maxlen+1,5); if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt), new_len*sizeof(row_elt)); } r->elt = RENEW(r->elt,new_len,row_elt); if ( ! r->elt ) /* can't allocate */ error(E_MEM,"sp_set_val"); r->maxlen = 2*r->maxlen+1; } for ( idx2 = r->len-1; idx2 >= idx; idx2-- ) MEM_COPY((char *)(&(r->elt[idx2])), (char *)(&(r->elt[idx2+1])),sizeof(row_elt)); /************************************************************ if ( idx < r->len ) MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), (r->len-idx)*sizeof(row_elt)); ************************************************************/ r->len++; r->elt[idx].col = j; return r->elt[idx].val = val; } /* else -- idx == -1, error in index/matrix! */ return 0.0; } /* sp_mv_mlt -- sparse matrix/dense vector multiply -- result is in out, which is returned unless out==NULL on entry -- if out==NULL on entry then the result vector is created */ VEC *sp_mv_mlt(A,x,out) SPMAT *A; VEC *x, *out; { int i, j_idx, m, n, max_idx; Real sum, *x_ve; SPROW *r; row_elt *elts; if ( ! A || ! x ) error(E_NULL,"sp_mv_mlt"); if ( x->dim != A->n ) error(E_SIZES,"sp_mv_mlt"); if ( ! out || out->dim < A->m ) out = v_resize(out,A->m); if ( out == x ) error(E_INSITU,"sp_mv_mlt"); m = A->m; n = A->n; x_ve = x->ve; for ( i = 0; i < m; i++ ) { sum = 0.0; r = &(A->row[i]); max_idx = r->len; elts = r->elt; for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) sum += elts->val*x_ve[elts->col]; out->ve[i] = sum; } return out; } /* sp_vm_mlt -- sparse matrix/dense vector multiply from left -- result is in out, which is returned unless out==NULL on entry -- if out==NULL on entry then result vector is created & returned */ VEC *sp_vm_mlt(A,x,out) SPMAT *A; VEC *x, *out; { int i, j_idx, m, n, max_idx; Real tmp, *x_ve, *out_ve; SPROW *r; row_elt *elts; if ( ! A || ! x ) error(E_NULL,"sp_vm_mlt"); if ( x->dim != A->m ) error(E_SIZES,"sp_vm_mlt"); if ( ! out || out->dim < A->n ) out = v_resize(out,A->n); if ( out == x ) error(E_INSITU,"sp_vm_mlt"); m = A->m; n = A->n; v_zero(out); x_ve = x->ve; out_ve = out->ve; for ( i = 0; i < m; i++ ) { r = A->row+i; max_idx = r->len; elts = r->elt; tmp = x_ve[i]; for ( j_idx = 0; j_idx < max_idx; j_idx++, elts++ ) out_ve[elts->col] += elts->val*tmp; } return out; } /* sp_get -- get sparse matrix -- len is number of elements available for each row without allocating further memory */ SPMAT *sp_get(m,n,maxlen) int m, n, maxlen; { SPMAT *A; SPROW *rows; int i; if ( m < 0 || n < 0 ) error(E_NEG,"sp_get"); maxlen = max(maxlen,1); A = NEW(SPMAT); if ( ! A ) /* can't allocate */ error(E_MEM,"sp_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT)); mem_numvar(TYPE_SPMAT,1); } /* fprintf(stderr,"Have SPMAT structure\n"); */ A->row = rows = NEW_A(m,SPROW); if ( ! A->row ) /* can't allocate */ error(E_MEM,"sp_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,m*sizeof(SPROW)); } /* fprintf(stderr,"Have row structure array\n"); */ A->start_row = NEW_A(n,int); A->start_idx = NEW_A(n,int); if ( ! A->start_row || ! A->start_idx ) /* can't allocate */ error(E_MEM,"sp_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,2*n*sizeof(int)); } for ( i = 0; i < n; i++ ) A->start_row[i] = A->start_idx[i] = -1; /* fprintf(stderr,"Have start_row array\n"); */ A->m = A->max_m = m; A->n = A->max_n = n; for ( i = 0; i < m; i++, rows++ ) { rows->elt = NEW_A(maxlen,row_elt); if ( ! rows->elt ) error(E_MEM,"sp_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,maxlen*sizeof(row_elt)); } /* fprintf(stderr,"Have row %d element array\n",i); */ rows->len = 0; rows->maxlen = maxlen; rows->diag = -1; } return A; } /* sp_free -- frees up the memory for a sparse matrix */ int sp_free(A) SPMAT *A; { SPROW *r; int i; if ( ! A ) return -1; if ( A->start_row != (int *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0); } free((char *)(A->start_row)); } if ( A->start_idx != (int *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,A->max_n*sizeof(int),0); } free((char *)(A->start_idx)); } if ( ! A->row ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0); mem_numvar(TYPE_SPMAT,-1); } free((char *)A); return 0; } for ( i = 0; i < A->m; i++ ) { r = &(A->row[i]); if ( r->elt != (row_elt *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,A->row[i].maxlen*sizeof(row_elt),0); } free((char *)(r->elt)); } } if (mem_info_is_on()) { if (A->row) mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW),0); mem_bytes(TYPE_SPMAT,sizeof(SPMAT),0); mem_numvar(TYPE_SPMAT,-1); } free((char *)(A->row)); free((char *)A); return 0; } /* sp_copy -- constructs a copy of a given matrix -- note that the max_len fields (etc) are no larger in the copy than necessary -- result is returned */ SPMAT *sp_copy(A) SPMAT *A; { SPMAT *out; SPROW *row1, *row2; int i; if ( A == SMNULL ) error(E_NULL,"sp_copy"); if ( ! (out=NEW(SPMAT)) ) error(E_MEM,"sp_copy"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,sizeof(SPMAT)); mem_numvar(TYPE_SPMAT,1); } out->m = out->max_m = A->m; out->n = out->max_n = A->n; /* set up rows */ if ( ! (out->row=NEW_A(A->m,SPROW)) ) error(E_MEM,"sp_copy"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,A->m*sizeof(SPROW)); } for ( i = 0; i < A->m; i++ ) { row1 = &(A->row[i]); row2 = &(out->row[i]); if ( ! (row2->elt=NEW_A(max(row1->len,3),row_elt)) ) error(E_MEM,"sp_copy"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,max(row1->len,3)*sizeof(row_elt)); } row2->len = row1->len; row2->maxlen = max(row1->len,3); row2->diag = row1->diag; MEM_COPY((char *)(row1->elt),(char *)(row2->elt), row1->len*sizeof(row_elt)); } /* set up start arrays -- for column access */ if ( ! (out->start_idx=NEW_A(A->n,int)) || ! (out->start_row=NEW_A(A->n,int)) ) error(E_MEM,"sp_copy"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,2*A->n*sizeof(int)); } MEM_COPY((char *)(A->start_idx),(char *)(out->start_idx), A->n*sizeof(int)); MEM_COPY((char *)(A->start_row),(char *)(out->start_row), A->n*sizeof(int)); return out; } /* sp_col_access -- set column access path; i.e. nxt_row, nxt_idx fields -- returns A */ SPMAT *sp_col_access(A) SPMAT *A; { int i, j, j_idx, len, m, n; SPROW *row; row_elt *r_elt; int *start_row, *start_idx; if ( A == SMNULL ) error(E_NULL,"sp_col_access"); m = A->m; n = A->n; /* initialise start_row and start_idx */ start_row = A->start_row; start_idx = A->start_idx; for ( j = 0; j < n; j++ ) { *start_row++ = -1; *start_idx++ = -1; } start_row = A->start_row; start_idx = A->start_idx; /* now work UP the rows, setting nxt_row, nxt_idx fields */ for ( i = m-1; i >= 0; i-- ) { row = &(A->row[i]); r_elt = row->elt; len = row->len; for ( j_idx = 0; j_idx < len; j_idx++, r_elt++ ) { j = r_elt->col; r_elt->nxt_row = start_row[j]; r_elt->nxt_idx = start_idx[j]; start_row[j] = i; start_idx[j] = j_idx; } } A->flag_col = TRUE; return A; } /* sp_diag_access -- set diagonal access path(s) */ SPMAT *sp_diag_access(A) SPMAT *A; { int i, m; SPROW *row; if ( A == SMNULL ) error(E_NULL,"sp_diag_access"); m = A->m; row = A->row; for ( i = 0; i < m; i++, row++ ) row->diag = sprow_idx(row,i); A->flag_diag = TRUE; return A; } /* sp_m2dense -- convert a sparse matrix to a dense one */ MAT *sp_m2dense(A,out) SPMAT *A; MAT *out; { int i, j_idx; SPROW *row; row_elt *elt; if ( ! A ) error(E_NULL,"sp_m2dense"); if ( ! out || out->m < A->m || out->n < A->n ) out = m_get(A->m,A->n); m_zero(out); for ( i = 0; i < A->m; i++ ) { row = &(A->row[i]); elt = row->elt; for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) out->me[i][elt->col] = elt->val; } return out; } /* C = A+B, can be in situ */ SPMAT *sp_add(A,B,C) SPMAT *A, *B, *C; { int i, in_situ; SPROW *rc; static SPROW *tmp; if ( ! A || ! B ) error(E_NULL,"sp_add"); if ( A->m != B->m || A->n != B->n ) error(E_SIZES,"sp_add"); if (C == A || C == B) in_situ = TRUE; else in_situ = FALSE; if ( ! C ) C = sp_get(A->m,A->n,5); else { if ( C->m != A->m || C->n != A->n ) error(E_SIZES,"sp_add"); if (!in_situ) sp_zero(C); } if (tmp == (SPROW *)NULL && in_situ) { tmp = sprow_get(MINROWLEN); MEM_STAT_REG(tmp,TYPE_SPROW); } if (in_situ) for (i=0; i < A->m; i++) { rc = &(C->row[i]); sprow_add(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW); sprow_resize(rc,tmp->len,TYPE_SPMAT); MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); rc->len = tmp->len; } else for (i=0; i < A->m; i++) { sprow_add(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT); } C->flag_col = C->flag_diag = FALSE; return C; } /* C = A-B, cannot be in situ */ SPMAT *sp_sub(A,B,C) SPMAT *A, *B, *C; { int i, in_situ; SPROW *rc; static SPROW *tmp; if ( ! A || ! B ) error(E_NULL,"sp_sub"); if ( A->m != B->m || A->n != B->n ) error(E_SIZES,"sp_sub"); if (C == A || C == B) in_situ = TRUE; else in_situ = FALSE; if ( ! C ) C = sp_get(A->m,A->n,5); else { if ( C->m != A->m || C->n != A->n ) error(E_SIZES,"sp_sub"); if (!in_situ) sp_zero(C); } if (tmp == (SPROW *)NULL && in_situ) { tmp = sprow_get(MINROWLEN); MEM_STAT_REG(tmp,TYPE_SPROW); } if (in_situ) for (i=0; i < A->m; i++) { rc = &(C->row[i]); sprow_sub(&(A->row[i]),&(B->row[i]),0,tmp,TYPE_SPROW); sprow_resize(rc,tmp->len,TYPE_SPMAT); MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); rc->len = tmp->len; } else for (i=0; i < A->m; i++) { sprow_sub(&(A->row[i]),&(B->row[i]),0,&(C->row[i]),TYPE_SPMAT); } C->flag_col = C->flag_diag = FALSE; return C; } /* C = A+alpha*B, cannot be in situ */ SPMAT *sp_mltadd(A,B,alpha,C) SPMAT *A, *B, *C; double alpha; { int i, in_situ; SPROW *rc; static SPROW *tmp; if ( ! A || ! B ) error(E_NULL,"sp_mltadd"); if ( A->m != B->m || A->n != B->n ) error(E_SIZES,"sp_mltadd"); if (C == A || C == B) in_situ = TRUE; else in_situ = FALSE; if ( ! C ) C = sp_get(A->m,A->n,5); else { if ( C->m != A->m || C->n != A->n ) error(E_SIZES,"sp_mltadd"); if (!in_situ) sp_zero(C); } if (tmp == (SPROW *)NULL && in_situ) { tmp = sprow_get(MINROWLEN); MEM_STAT_REG(tmp,TYPE_SPROW); } if (in_situ) for (i=0; i < A->m; i++) { rc = &(C->row[i]); sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0,tmp,TYPE_SPROW); sprow_resize(rc,tmp->len,TYPE_SPMAT); MEM_COPY(tmp->elt,rc->elt,tmp->len*sizeof(row_elt)); rc->len = tmp->len; } else for (i=0; i < A->m; i++) { sprow_mltadd(&(A->row[i]),&(B->row[i]),alpha,0, &(C->row[i]),TYPE_SPMAT); } C->flag_col = C->flag_diag = FALSE; return C; } /* B = alpha*A, can be in situ */ SPMAT *sp_smlt(A,alpha,B) SPMAT *A, *B; double alpha; { int i; if ( ! A ) error(E_NULL,"sp_smlt"); if ( ! B ) B = sp_get(A->m,A->n,5); else if ( A->m != B->m || A->n != B->n ) error(E_SIZES,"sp_smlt"); for (i=0; i < A->m; i++) { sprow_smlt(&(A->row[i]),alpha,0,&(B->row[i]),TYPE_SPMAT); } return B; } /* sp_zero -- zero all the (represented) elements of a sparse matrix */ SPMAT *sp_zero(A) SPMAT *A; { int i, idx, len; row_elt *elt; if ( ! A ) error(E_NULL,"sp_zero"); for ( i = 0; i < A->m; i++ ) { elt = A->row[i].elt; len = A->row[i].len; for ( idx = 0; idx < len; idx++ ) (*elt++).val = 0.0; } return A; } /* sp_copy2 -- copy sparse matrix (type 2) -- keeps structure of the OUT matrix */ SPMAT *sp_copy2(A,OUT) SPMAT *A, *OUT; { int i /* , idx, len1, len2 */; SPROW *r1, *r2; static SPROW *scratch = (SPROW *)NULL; /* row_elt *e1, *e2; */ if ( ! A ) error(E_NULL,"sp_copy2"); if ( ! OUT ) OUT = sp_get(A->m,A->n,10); if ( ! scratch ) { scratch = sprow_xpd(scratch,MINROWLEN,TYPE_SPROW); MEM_STAT_REG(scratch,TYPE_SPROW); } if ( OUT->m < A->m ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW), A->m*sizeof(SPROW)); } OUT->row = RENEW(OUT->row,A->m,SPROW); if ( ! OUT->row ) error(E_MEM,"sp_copy2"); for ( i = OUT->m; i < A->m; i++ ) { OUT->row[i].elt = NEW_A(MINROWLEN,row_elt); if ( ! OUT->row[i].elt ) error(E_MEM,"sp_copy2"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt)); } OUT->row[i].maxlen = MINROWLEN; OUT->row[i].len = 0; } OUT->m = A->m; } OUT->flag_col = OUT->flag_diag = FALSE; /* sp_zero(OUT); */ for ( i = 0; i < A->m; i++ ) { r1 = &(A->row[i]); r2 = &(OUT->row[i]); sprow_copy(r1,r2,scratch,TYPE_SPROW); if ( r2->maxlen < scratch->len ) sprow_xpd(r2,scratch->len,TYPE_SPMAT); MEM_COPY((char *)(scratch->elt),(char *)(r2->elt), scratch->len*sizeof(row_elt)); r2->len = scratch->len; /******************************************************* e1 = r1->elt; e2 = r2->elt; len1 = r1->len; len2 = r2->len; for ( idx = 0; idx < len2; idx++, e2++ ) e2->val = 0.0; for ( idx = 0; idx < len1; idx++, e1++ ) sprow_set_val(r2,e1->col,e1->val); *******************************************************/ } sp_col_access(OUT); return OUT; } /* sp_resize -- resize a sparse matrix -- don't destroying any contents if possible -- returns resized matrix */ SPMAT *sp_resize(A,m,n) SPMAT *A; int m, n; { int i, len; SPROW *r; if (m < 0 || n < 0) error(E_NEG,"sp_resize"); if ( ! A ) return sp_get(m,n,10); if (m == A->m && n == A->n) return A; if ( m <= A->max_m ) { for ( i = A->m; i < m; i++ ) A->row[i].len = 0; A->m = m; } else { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,A->max_m*sizeof(SPROW), m*sizeof(SPROW)); } A->row = RENEW(A->row,(unsigned)m,SPROW); if ( ! A->row ) error(E_MEM,"sp_resize"); for ( i = A->m; i < m; i++ ) { if ( ! (A->row[i].elt = NEW_A(MINROWLEN,row_elt)) ) error(E_MEM,"sp_resize"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,0,MINROWLEN*sizeof(row_elt)); } A->row[i].len = 0; A->row[i].maxlen = MINROWLEN; } A->m = A->max_m = m; } /* update number of rows */ A->n = n; /* do we need to increase the size of start_idx[] and start_row[] ? */ if ( n > A->max_n ) { /* only have to update the start_idx & start_row arrays */ if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT,2*A->max_n*sizeof(int), 2*n*sizeof(int)); } A->start_row = RENEW(A->start_row,(unsigned)n,int); A->start_idx = RENEW(A->start_idx,(unsigned)n,int); if ( ! A->start_row || ! A->start_idx ) error(E_MEM,"sp_resize"); A->max_n = n; /* ...and update max_n */ return A; } if ( n <= A->n ) /* make sure that all rows are truncated just before column n */ for ( i = 0; i < A->m; i++ ) { r = &(A->row[i]); len = sprow_idx(r,n); if ( len < 0 ) len = -(len+2); if ( len < 0 ) error(E_MEM,"sp_resize"); r->len = len; } return A; } /* sp_compact -- removes zeros and near-zeros from a sparse matrix */ SPMAT *sp_compact(A,tol) SPMAT *A; double tol; { int i, idx1, idx2; SPROW *r; row_elt *elt1, *elt2; if ( ! A ) error(E_NULL,"sp_compact"); if ( tol < 0.0 ) error(E_RANGE,"sp_compact"); A->flag_col = A->flag_diag = FALSE; for ( i = 0; i < A->m; i++ ) { r = &(A->row[i]); elt1 = elt2 = r->elt; idx1 = idx2 = 0; while ( idx1 < r->len ) { /* printf("# sp_compact: idx1 = %d, idx2 = %d\n",idx1,idx2); */ if ( fabs(elt1->val) <= tol ) { idx1++; elt1++; continue; } if ( elt1 != elt2 ) MEM_COPY(elt1,elt2,sizeof(row_elt)); idx1++; elt1++; idx2++; elt2++; } r->len = idx2; } return A; } /* varying number of arguments */ #ifdef ANSI_C /* To allocate memory to many arguments. The function should be called: sp_get_vars(m,n,deg,&x,&y,&z,...,NULL); where int m,n,deg; SPMAT *x, *y, *z,...; The last argument should be NULL ! m x n is the dimension of matrices x,y,z,... returned value is equal to the number of allocated variables */ int sp_get_vars(int m,int n,int deg,...) { va_list ap; int i=0; SPMAT **par; va_start(ap, deg); while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ *par = sp_get(m,n,deg); i++; } va_end(ap); return i; } /* To resize memory for many arguments. The function should be called: sp_resize_vars(m,n,&x,&y,&z,...,NULL); where int m,n; SPMAT *x, *y, *z,...; The last argument should be NULL ! m X n is the resized dimension of matrices x,y,z,... returned value is equal to the number of allocated variables. If one of x,y,z,.. arguments is NULL then memory is allocated to this argument. */ int sp_resize_vars(int m,int n,...) { va_list ap; int i=0; SPMAT **par; va_start(ap, n); while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ *par = sp_resize(*par,m,n); i++; } va_end(ap); return i; } /* To deallocate memory for many arguments. The function should be called: sp_free_vars(&x,&y,&z,...,NULL); where SPMAT *x, *y, *z,...; The last argument should be NULL ! There must be at least one not NULL argument. returned value is equal to the number of allocated variables. Returned value of x,y,z,.. is VNULL. */ int sp_free_vars(SPMAT **va,...) { va_list ap; int i=1; SPMAT **par; sp_free(*va); *va = (SPMAT *) NULL; va_start(ap, va); while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ sp_free(*par); *par = (SPMAT *)NULL; i++; } va_end(ap); return i; } #elif VARARGS /* To allocate memory to many arguments. The function should be called: sp_get_vars(m,n,deg,&x,&y,&z,...,NULL); where int m,n,deg; SPMAT *x, *y, *z,...; The last argument should be NULL ! m x n is the dimension of matrices x,y,z,... returned value is equal to the number of allocated variables */ int sp_get_vars(va_alist) va_dcl { va_list ap; int i=0, m, n, deg; SPMAT **par; va_start(ap); m = va_arg(ap,int); n = va_arg(ap,int); deg = va_arg(ap,int); while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ *par = sp_get(m,n,deg); i++; } va_end(ap); return i; } /* To resize memory for many arguments. The function should be called: sp_resize_vars(m,n,&x,&y,&z,...,NULL); where int m,n; SPMAT *x, *y, *z,...; The last argument should be NULL ! m X n is the resized dimension of matrices x,y,z,... returned value is equal to the number of allocated variables. If one of x,y,z,.. arguments is NULL then memory is allocated to this argument. */ int sp_resize_vars(va_alist) va_dcl { va_list ap; int i=0, m, n; SPMAT **par; va_start(ap); m = va_arg(ap,int); n = va_arg(ap,int); while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ *par = sp_resize(*par,m,n); i++; } va_end(ap); return i; } /* To deallocate memory for many arguments. The function should be called: sp_free_vars(&x,&y,&z,...,NULL); where SPMAT *x, *y, *z,...; The last argument should be NULL ! There must be at least one not NULL argument. returned value is equal to the number of allocated variables. Returned value of x,y,z,.. is VNULL. */ int sp_free_vars(va_alist) va_dcl { va_list ap; int i=0; SPMAT **par; va_start(ap); while (par = va_arg(ap,SPMAT **)) { /* NULL ends the list*/ sp_free(*par); *par = (SPMAT *)NULL; i++; } va_end(ap); return i; } #endif meschach-1.2b/sprow.c100644 764 764 42403 5515156667 14227 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse rows package See also: sparse.h, matrix.h */ #include #include #include #include "sparse.h" static char rcsid[] = "$Id: sprow.c,v 1.1 1994/01/13 05:35:36 des Exp $"; #define MINROWLEN 10 /* sprow_dump - prints relevant information about the sparse row r */ void sprow_dump(fp,r) FILE *fp; SPROW *r; { int j_idx; row_elt *elts; fprintf(fp,"SparseRow dump:\n"); if ( ! r ) { fprintf(fp,"*** NULL row ***\n"); return; } fprintf(fp,"row: len = %d, maxlen = %d, diag idx = %d\n", r->len,r->maxlen,r->diag); fprintf(fp,"element list @ 0x%lx\n",(long)(r->elt)); if ( ! r->elt ) { fprintf(fp,"*** NULL element list ***\n"); return; } elts = r->elt; for ( j_idx = 0; j_idx < r->len; j_idx++, elts++ ) fprintf(fp,"Col: %d, Val: %g, nxt_row = %d, nxt_idx = %d\n", elts->col,elts->val,elts->nxt_row,elts->nxt_idx); fprintf(fp,"\n"); } /* sprow_idx -- get index into row for a given column in a given row -- return -1 on error -- return -(idx+2) where idx is index to insertion point */ int sprow_idx(r,col) SPROW *r; int col; { register int lo, hi, mid; int tmp; register row_elt *r_elt; /******************************************* if ( r == (SPROW *)NULL ) return -1; if ( col < 0 ) return -1; *******************************************/ r_elt = r->elt; if ( r->len <= 0 ) return -2; /* try the hint */ /* if ( hint >= 0 && hint < r->len && r_elt[hint].col == col ) return hint; */ /* otherwise use binary search... */ /* code from K&R Ch. 6, p. 125 */ lo = 0; hi = r->len - 1; mid = lo; while ( lo <= hi ) { mid = (hi + lo)/2; if ( (tmp=r_elt[mid].col-col) > 0 ) hi = mid-1; else if ( tmp < 0 ) lo = mid+1; else /* tmp == 0 */ return mid; } tmp = r_elt[mid].col - col; if ( tmp > 0 ) return -(mid+2); /* insert at mid */ else /* tmp < 0 */ return -(mid+3); /* insert at mid+1 */ } /* sprow_get -- gets, initialises and returns a SPROW structure -- max. length is maxlen */ SPROW *sprow_get(maxlen) int maxlen; { SPROW *r; if ( maxlen < 0 ) error(E_NEG,"sprow_get"); r = NEW(SPROW); if ( ! r ) error(E_MEM,"sprow_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPROW,0,sizeof(SPROW)); mem_numvar(TYPE_SPROW,1); } r->elt = NEW_A(maxlen,row_elt); if ( ! r->elt ) error(E_MEM,"sprow_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_SPROW,0,maxlen*sizeof(row_elt)); } r->len = 0; r->maxlen = maxlen; r->diag = -1; return r; } /* sprow_xpd -- expand row by means of realloc() -- type must be TYPE_SPMAT if r is a row of a SPMAT structure, otherwise it must be TYPE_SPROW -- returns r */ SPROW *sprow_xpd(r,n,type) SPROW *r; int n,type; { int newlen; if ( ! r ) { r = NEW(SPROW); if (! r ) error(E_MEM,"sprow_xpd"); else if ( mem_info_is_on()) { if (type != TYPE_SPMAT && type != TYPE_SPROW) warning(WARN_WRONG_TYPE,"sprow_xpd"); mem_bytes(type,0,sizeof(SPROW)); if (type == TYPE_SPROW) mem_numvar(type,1); } } if ( ! r->elt ) { r->elt = NEW_A((unsigned)n,row_elt); if ( ! r->elt ) error(E_MEM,"sprow_xpd"); else if (mem_info_is_on()) { mem_bytes(type,0,n*sizeof(row_elt)); } r->len = 0; r->maxlen = n; return r; } if ( n <= r->len ) newlen = max(2*r->len + 1,MINROWLEN); else newlen = n; if ( newlen <= r->maxlen ) { MEM_ZERO((char *)(&(r->elt[r->len])), (newlen-r->len)*sizeof(row_elt)); r->len = newlen; } else { if (mem_info_is_on()) { mem_bytes(type,r->maxlen*sizeof(row_elt), newlen*sizeof(row_elt)); } r->elt = RENEW(r->elt,newlen,row_elt); if ( ! r->elt ) error(E_MEM,"sprow_xpd"); r->maxlen = newlen; r->len = newlen; } return r; } /* sprow_resize -- resize a SPROW variable by means of realloc() -- n is a new size -- returns r */ SPROW *sprow_resize(r,n,type) SPROW *r; int n,type; { if (n < 0) error(E_NEG,"sprow_resize"); if ( ! r ) return sprow_get(n); if (n == r->len) return r; if ( ! r->elt ) { r->elt = NEW_A((unsigned)n,row_elt); if ( ! r->elt ) error(E_MEM,"sprow_resize"); else if (mem_info_is_on()) { mem_bytes(type,0,n*sizeof(row_elt)); } r->maxlen = r->len = n; return r; } if ( n <= r->maxlen ) r->len = n; else { if (mem_info_is_on()) { mem_bytes(type,r->maxlen*sizeof(row_elt), n*sizeof(row_elt)); } r->elt = RENEW(r->elt,n,row_elt); if ( ! r->elt ) error(E_MEM,"sprow_resize"); r->maxlen = r->len = n; } return r; } /* release a row of a matrix */ int sprow_free(r) SPROW *r; { if ( ! r ) return -1; if (mem_info_is_on()) { mem_bytes(TYPE_SPROW,sizeof(SPROW),0); mem_numvar(TYPE_SPROW,-1); } if ( r->elt ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPROW,r->maxlen*sizeof(row_elt),0); } free((char *)r->elt); } free((char *)r); return 0; } /* sprow_merge -- merges r1 and r2 into r_out -- cannot be done in-situ -- type must be SPMAT or SPROW depending on whether r_out is a row of a SPMAT structure or a SPROW variable -- returns r_out */ SPROW *sprow_merge(r1,r2,r_out,type) SPROW *r1, *r2, *r_out; int type; { int idx1, idx2, idx_out, len1, len2, len_out; row_elt *elt1, *elt2, *elt_out; if ( ! r1 || ! r2 ) error(E_NULL,"sprow_merge"); if ( ! r_out ) r_out = sprow_get(MINROWLEN); if ( r1 == r_out || r2 == r_out ) error(E_INSITU,"sprow_merge"); /* Initialise */ len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; idx1 = idx2 = idx_out = 0; elt1 = r1->elt; elt2 = r2->elt; elt_out = r_out->elt; while ( idx1 < len1 || idx2 < len2 ) { if ( idx_out >= len_out ) { /* r_out is too small */ r_out->len = idx_out; r_out = sprow_xpd(r_out,0,type); len_out = r_out->len; elt_out = &(r_out->elt[idx_out]); } if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) { elt_out->col = elt1->col; elt_out->val = elt1->val; if ( elt1->col == elt2->col && idx2 < len2 ) { elt2++; idx2++; } elt1++; idx1++; } else { elt_out->col = elt2->col; elt_out->val = elt2->val; elt2++; idx2++; } elt_out++; idx_out++; } r_out->len = idx_out; return r_out; } /* sprow_copy -- copies r1 and r2 into r_out -- cannot be done in-situ -- type must be SPMAT or SPROW depending on whether r_out is a row of a SPMAT structure or a SPROW variable -- returns r_out */ SPROW *sprow_copy(r1,r2,r_out,type) SPROW *r1, *r2, *r_out; int type; { int idx1, idx2, idx_out, len1, len2, len_out; row_elt *elt1, *elt2, *elt_out; if ( ! r1 || ! r2 ) error(E_NULL,"sprow_copy"); if ( ! r_out ) r_out = sprow_get(MINROWLEN); if ( r1 == r_out || r2 == r_out ) error(E_INSITU,"sprow_copy"); /* Initialise */ len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; idx1 = idx2 = idx_out = 0; elt1 = r1->elt; elt2 = r2->elt; elt_out = r_out->elt; while ( idx1 < len1 || idx2 < len2 ) { while ( idx_out >= len_out ) { /* r_out is too small */ r_out->len = idx_out; r_out = sprow_xpd(r_out,0,type); len_out = r_out->maxlen; elt_out = &(r_out->elt[idx_out]); } if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) { elt_out->col = elt1->col; elt_out->val = elt1->val; if ( elt1->col == elt2->col && idx2 < len2 ) { elt2++; idx2++; } elt1++; idx1++; } else { elt_out->col = elt2->col; elt_out->val = 0.0; elt2++; idx2++; } elt_out++; idx_out++; } r_out->len = idx_out; return r_out; } /* sprow_mltadd -- sets r_out <- r1 + alpha.r2 -- cannot be in situ -- only for columns j0, j0+1, ... -- type must be SPMAT or SPROW depending on whether r_out is a row of a SPMAT structure or a SPROW variable -- returns r_out */ SPROW *sprow_mltadd(r1,r2,alpha,j0,r_out,type) SPROW *r1, *r2, *r_out; double alpha; int j0, type; { int idx1, idx2, idx_out, len1, len2, len_out; row_elt *elt1, *elt2, *elt_out; if ( ! r1 || ! r2 ) error(E_NULL,"sprow_mltadd"); if ( r1 == r_out || r2 == r_out ) error(E_INSITU,"sprow_mltadd"); if ( j0 < 0 ) error(E_BOUNDS,"sprow_mltadd"); if ( ! r_out ) r_out = sprow_get(MINROWLEN); /* Initialise */ len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; /* idx1 = idx2 = idx_out = 0; */ idx1 = sprow_idx(r1,j0); idx2 = sprow_idx(r2,j0); idx_out = sprow_idx(r_out,j0); idx1 = (idx1 < 0) ? -(idx1+2) : idx1; idx2 = (idx2 < 0) ? -(idx2+2) : idx2; idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; elt1 = &(r1->elt[idx1]); elt2 = &(r2->elt[idx2]); elt_out = &(r_out->elt[idx_out]); while ( idx1 < len1 || idx2 < len2 ) { if ( idx_out >= len_out ) { /* r_out is too small */ r_out->len = idx_out; r_out = sprow_xpd(r_out,0,type); len_out = r_out->maxlen; elt_out = &(r_out->elt[idx_out]); } if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) { elt_out->col = elt1->col; elt_out->val = elt1->val; if ( idx2 < len2 && elt1->col == elt2->col ) { elt_out->val += alpha*elt2->val; elt2++; idx2++; } elt1++; idx1++; } else { elt_out->col = elt2->col; elt_out->val = alpha*elt2->val; elt2++; idx2++; } elt_out++; idx_out++; } r_out->len = idx_out; return r_out; } /* sprow_add -- sets r_out <- r1 + r2 -- cannot be in situ -- only for columns j0, j0+1, ... -- type must be SPMAT or SPROW depending on whether r_out is a row of a SPMAT structure or a SPROW variable -- returns r_out */ SPROW *sprow_add(r1,r2,j0,r_out,type) SPROW *r1, *r2, *r_out; int j0, type; { int idx1, idx2, idx_out, len1, len2, len_out; row_elt *elt1, *elt2, *elt_out; if ( ! r1 || ! r2 ) error(E_NULL,"sprow_add"); if ( r1 == r_out || r2 == r_out ) error(E_INSITU,"sprow_add"); if ( j0 < 0 ) error(E_BOUNDS,"sprow_add"); if ( ! r_out ) r_out = sprow_get(MINROWLEN); /* Initialise */ len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; /* idx1 = idx2 = idx_out = 0; */ idx1 = sprow_idx(r1,j0); idx2 = sprow_idx(r2,j0); idx_out = sprow_idx(r_out,j0); idx1 = (idx1 < 0) ? -(idx1+2) : idx1; idx2 = (idx2 < 0) ? -(idx2+2) : idx2; idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; elt1 = &(r1->elt[idx1]); elt2 = &(r2->elt[idx2]); elt_out = &(r_out->elt[idx_out]); while ( idx1 < len1 || idx2 < len2 ) { if ( idx_out >= len_out ) { /* r_out is too small */ r_out->len = idx_out; r_out = sprow_xpd(r_out,0,type); len_out = r_out->maxlen; elt_out = &(r_out->elt[idx_out]); } if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) { elt_out->col = elt1->col; elt_out->val = elt1->val; if ( idx2 < len2 && elt1->col == elt2->col ) { elt_out->val += elt2->val; elt2++; idx2++; } elt1++; idx1++; } else { elt_out->col = elt2->col; elt_out->val = elt2->val; elt2++; idx2++; } elt_out++; idx_out++; } r_out->len = idx_out; return r_out; } /* sprow_sub -- sets r_out <- r1 - r2 -- cannot be in situ -- only for columns j0, j0+1, ... -- type must be SPMAT or SPROW depending on whether r_out is a row of a SPMAT structure or a SPROW variable -- returns r_out */ SPROW *sprow_sub(r1,r2,j0,r_out,type) SPROW *r1, *r2, *r_out; int j0, type; { int idx1, idx2, idx_out, len1, len2, len_out; row_elt *elt1, *elt2, *elt_out; if ( ! r1 || ! r2 ) error(E_NULL,"sprow_sub"); if ( r1 == r_out || r2 == r_out ) error(E_INSITU,"sprow_sub"); if ( j0 < 0 ) error(E_BOUNDS,"sprow_sub"); if ( ! r_out ) r_out = sprow_get(MINROWLEN); /* Initialise */ len1 = r1->len; len2 = r2->len; len_out = r_out->maxlen; /* idx1 = idx2 = idx_out = 0; */ idx1 = sprow_idx(r1,j0); idx2 = sprow_idx(r2,j0); idx_out = sprow_idx(r_out,j0); idx1 = (idx1 < 0) ? -(idx1+2) : idx1; idx2 = (idx2 < 0) ? -(idx2+2) : idx2; idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; elt1 = &(r1->elt[idx1]); elt2 = &(r2->elt[idx2]); elt_out = &(r_out->elt[idx_out]); while ( idx1 < len1 || idx2 < len2 ) { if ( idx_out >= len_out ) { /* r_out is too small */ r_out->len = idx_out; r_out = sprow_xpd(r_out,0,type); len_out = r_out->maxlen; elt_out = &(r_out->elt[idx_out]); } if ( idx2 >= len2 || (idx1 < len1 && elt1->col <= elt2->col) ) { elt_out->col = elt1->col; elt_out->val = elt1->val; if ( idx2 < len2 && elt1->col == elt2->col ) { elt_out->val -= elt2->val; elt2++; idx2++; } elt1++; idx1++; } else { elt_out->col = elt2->col; elt_out->val = -elt2->val; elt2++; idx2++; } elt_out++; idx_out++; } r_out->len = idx_out; return r_out; } /* sprow_smlt -- sets r_out <- alpha*r1 -- can be in situ -- only for columns j0, j0+1, ... -- returns r_out */ SPROW *sprow_smlt(r1,alpha,j0,r_out,type) SPROW *r1, *r_out; double alpha; int j0, type; { int idx1, idx_out, len1; row_elt *elt1, *elt_out; if ( ! r1 ) error(E_NULL,"sprow_smlt"); if ( j0 < 0 ) error(E_BOUNDS,"sprow_smlt"); if ( ! r_out ) r_out = sprow_get(MINROWLEN); /* Initialise */ len1 = r1->len; idx1 = sprow_idx(r1,j0); idx_out = sprow_idx(r_out,j0); idx1 = (idx1 < 0) ? -(idx1+2) : idx1; idx_out = (idx_out < 0) ? -(idx_out+2) : idx_out; elt1 = &(r1->elt[idx1]); r_out = sprow_resize(r_out,idx_out+len1-idx1,type); elt_out = &(r_out->elt[idx_out]); for ( ; idx1 < len1; elt1++,elt_out++,idx1++,idx_out++ ) { elt_out->col = elt1->col; elt_out->val = alpha*elt1->val; } r_out->len = idx_out; return r_out; } /* sprow_foutput -- print a representation of r on stream fp */ void sprow_foutput(fp,r) FILE *fp; SPROW *r; { int i, len; row_elt *e; if ( ! r ) { fprintf(fp,"SparseRow: **** NULL ****\n"); return; } len = r->len; fprintf(fp,"SparseRow: length: %d\n",len); for ( i = 0, e = r->elt; i < len; i++, e++ ) fprintf(fp,"Column %d: %g, next row: %d, next index %d\n", e->col, e->val, e->nxt_row, e->nxt_idx); } /* sprow_set_val -- sets the j-th column entry of the sparse row r -- Note: destroys the usual column & row access paths */ double sprow_set_val(r,j,val) SPROW *r; int j; double val; { int idx, idx2, new_len; if ( ! r ) error(E_NULL,"sprow_set_val"); idx = sprow_idx(r,j); if ( idx >= 0 ) { r->elt[idx].val = val; return val; } /* else */ if ( idx < -1 ) { /* shift & insert new value */ idx = -(idx+2); /* this is the intended insertion index */ if ( r->len >= r->maxlen ) { r->len = r->maxlen; new_len = max(2*r->maxlen+1,5); if (mem_info_is_on()) { mem_bytes(TYPE_SPROW,r->maxlen*sizeof(row_elt), new_len*sizeof(row_elt)); } r->elt = RENEW(r->elt,new_len,row_elt); if ( ! r->elt ) /* can't allocate */ error(E_MEM,"sprow_set_val"); r->maxlen = 2*r->maxlen+1; } for ( idx2 = r->len-1; idx2 >= idx; idx2-- ) MEM_COPY((char *)(&(r->elt[idx2])), (char *)(&(r->elt[idx2+1])),sizeof(row_elt)); /************************************************************ if ( idx < r->len ) MEM_COPY((char *)(&(r->elt[idx])),(char *)(&(r->elt[idx+1])), (r->len-idx)*sizeof(row_elt)); ************************************************************/ r->len++; r->elt[idx].col = j; r->elt[idx].nxt_row = -1; r->elt[idx].nxt_idx = -1; return r->elt[idx].val = val; } /* else -- idx == -1, error in index/matrix! */ return 0.0; } meschach-1.2b/sparseio.c100644 764 764 20041 5515156546 14670 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file has the routines for sparse matrix input/output It works in conjunction with sparse.c, sparse.h etc */ #include #include "sparse.h" static char rcsid[] = "$Id: sparseio.c,v 1.4 1994/01/13 05:34:25 des Exp $"; /* local variables */ static char line[MAXLINE]; /* sp_foutput -- output sparse matrix A to file/stream fp */ void sp_foutput(fp,A) FILE *fp; SPMAT *A; { int i, j_idx, m /* , n */; SPROW *rows; row_elt *elts; fprintf(fp,"SparseMatrix: "); if ( A == SMNULL ) { fprintf(fp,"*** NULL ***\n"); error(E_NULL,"sp_foutput"); return; } fprintf(fp,"%d by %d\n",A->m,A->n); m = A->m; /* n = A->n; */ if ( ! (rows=A->row) ) { fprintf(fp,"*** NULL rows ***\n"); error(E_NULL,"sp_foutput"); return; } for ( i = 0; i < m; i++ ) { fprintf(fp,"row %d: ",i); if ( ! (elts=rows[i].elt) ) { fprintf(fp,"*** NULL element list ***\n"); continue; } for ( j_idx = 0; j_idx < rows[i].len; j_idx++ ) { fprintf(fp,"%d:%-20.15g ",elts[j_idx].col, elts[j_idx].val); if ( j_idx % 3 == 2 && j_idx != rows[i].len-1 ) fprintf(fp,"\n "); } fprintf(fp,"\n"); } fprintf(fp,"#\n"); /* to stop looking beyond for next entry */ } /* sp_foutput2 -- print out sparse matrix **as a dense matrix** -- see output format used in matrix.h etc */ /****************************************************************** void sp_foutput2(fp,A) FILE *fp; SPMAT *A; { int cnt, i, j, j_idx; SPROW *r; row_elt *elt; if ( A == SMNULL ) { fprintf(fp,"Matrix: *** NULL ***\n"); return; } fprintf(fp,"Matrix: %d by %d\n",A->m,A->n); for ( i = 0; i < A->m; i++ ) { fprintf(fp,"row %d:",i); r = &(A->row[i]); elt = r->elt; cnt = j = j_idx = 0; while ( j_idx < r->len || j < A->n ) { if ( j_idx >= r->len ) fprintf(fp,"%14.9g ",0.0); else if ( j < elt[j_idx].col ) fprintf(fp,"%14.9g ",0.0); else fprintf(fp,"%14.9g ",elt[j_idx++].val); if ( cnt++ % 4 == 3 ) fprintf(fp,"\n"); j++; } fprintf(fp,"\n"); } } ******************************************************************/ /* sp_dump -- prints ALL relevant information about the sparse matrix A */ void sp_dump(fp,A) FILE *fp; SPMAT *A; { int i, j, j_idx; SPROW *rows; row_elt *elts; fprintf(fp,"SparseMatrix dump:\n"); if ( ! A ) { fprintf(fp,"*** NULL ***\n"); return; } fprintf(fp,"Matrix at 0x%lx\n",(long)A); fprintf(fp,"Dimensions: %d by %d\n",A->m,A->n); fprintf(fp,"MaxDimensions: %d by %d\n",A->max_m,A->max_n); fprintf(fp,"flag_col = %d, flag_diag = %d\n",A->flag_col,A->flag_diag); fprintf(fp,"start_row @ 0x%lx:\n",(long)(A->start_row)); for ( j = 0; j < A->n; j++ ) { fprintf(fp,"%d ",A->start_row[j]); if ( j % 10 == 9 ) fprintf(fp,"\n"); } fprintf(fp,"\n"); fprintf(fp,"start_idx @ 0x%lx:\n",(long)(A->start_idx)); for ( j = 0; j < A->n; j++ ) { fprintf(fp,"%d ",A->start_idx[j]); if ( j % 10 == 9 ) fprintf(fp,"\n"); } fprintf(fp,"\n"); fprintf(fp,"Rows @ 0x%lx:\n",(long)(A->row)); if ( ! A->row ) { fprintf(fp,"*** NULL row ***\n"); return; } rows = A->row; for ( i = 0; i < A->m; i++ ) { fprintf(fp,"row %d: len = %d, maxlen = %d, diag idx = %d\n", i,rows[i].len,rows[i].maxlen,rows[i].diag); fprintf(fp,"element list @ 0x%lx\n",(long)(rows[i].elt)); if ( ! rows[i].elt ) { fprintf(fp,"*** NULL element list ***\n"); continue; } elts = rows[i].elt; for ( j_idx = 0; j_idx < rows[i].len; j_idx++, elts++ ) fprintf(fp,"Col: %d, Val: %g, nxt_row = %d, nxt_idx = %d\n", elts->col,elts->val,elts->nxt_row,elts->nxt_idx); fprintf(fp,"\n"); } } #define MAXSCRATCH 100 /* sp_finput -- input sparse matrix from stream/file fp -- uses friendly input routine if fp is a tty -- uses format identical to output format otherwise */ SPMAT *sp_finput(fp) FILE *fp; { int i, len, ret_val; int col, curr_col, m, n, tmp, tty; Real val; SPMAT *A; SPROW *rows; row_elt scratch[MAXSCRATCH]; /* cannot handle >= MAXSCRATCH elements in a row */ for ( i = 0; i < MAXSCRATCH; i++ ) scratch[i].nxt_row = scratch[i].nxt_idx = -1; tty = isatty(fileno(fp)); if ( tty ) { fprintf(stderr,"SparseMatrix: "); do { fprintf(stderr,"input rows cols: "); if ( ! fgets(line,MAXLINE,fp) ) error(E_INPUT,"sp_finput"); } while ( sscanf(line,"%u %u",&m,&n) != 2 ); A = sp_get(m,n,5); rows = A->row; for ( i = 0; i < m; i++ ) { fprintf(stderr,"Row %d:\n",i); fprintf(stderr,"Enter or 'e' to end row\n"); curr_col = -1; for ( len = 0; len < MAXSCRATCH; len++ ) { do { fprintf(stderr,"Entry %d: ",len); if ( ! fgets(line,MAXLINE,fp) ) error(E_INPUT,"sp_finput"); if ( *line == 'e' || *line == 'E' ) break; #if REAL == DOUBLE } while ( sscanf(line,"%u %lf",&col,&val) != 2 || #elif REAL == FLOAT } while ( sscanf(line,"%u %f",&col,&val) != 2 || #endif col >= n || col <= curr_col ); if ( *line == 'e' || *line == 'E' ) break; scratch[len].col = col; scratch[len].val = val; curr_col = col; } /* Note: len = # elements in row */ if ( len > 5 ) { if (mem_info_is_on()) { mem_bytes(TYPE_SPMAT, A->row[i].maxlen*sizeof(row_elt), len*sizeof(row_elt)); } rows[i].elt = (row_elt *)realloc((char *)rows[i].elt, len*sizeof(row_elt)); rows[i].maxlen = len; } MEM_COPY(scratch,rows[i].elt,len*sizeof(row_elt)); rows[i].len = len; rows[i].diag = sprow_idx(&(rows[i]),i); } } else /* not tty */ { ret_val = 0; skipjunk(fp); fscanf(fp,"SparseMatrix:"); skipjunk(fp); if ( (ret_val=fscanf(fp,"%u by %u",&m,&n)) != 2 ) error((ret_val == EOF) ? E_EOF : E_FORMAT,"sp_finput"); A = sp_get(m,n,5); /* initialise start_row */ for ( i = 0; i < A->n; i++ ) A->start_row[i] = -1; rows = A->row; for ( i = 0; i < m; i++ ) { /* printf("Reading row # %d\n",i); */ rows[i].diag = -1; skipjunk(fp); if ( (ret_val=fscanf(fp,"row %d :",&tmp)) != 1 || tmp != i ) error((ret_val == EOF) ? E_EOF : E_FORMAT, "sp_finput"); curr_col = -1; for ( len = 0; len < MAXSCRATCH; len++ ) { #if REAL == DOUBLE if ( (ret_val=fscanf(fp,"%u : %lf",&col,&val)) != 2 ) #elif REAL == FLOAT if ( (ret_val=fscanf(fp,"%u : %f",&col,&val)) != 2 ) #endif break; if ( col <= curr_col || col >= n ) error(E_FORMAT,"sp_finput"); scratch[len].col = col; scratch[len].val = val; } if ( ret_val == EOF ) error(E_EOF,"sp_finput"); if ( len > rows[i].maxlen ) { rows[i].elt = (row_elt *)realloc((char *)rows[i].elt, len*sizeof(row_elt)); rows[i].maxlen = len; } MEM_COPY(scratch,rows[i].elt,len*sizeof(row_elt)); rows[i].len = len; /* printf("Have read row # %d\n",i); */ rows[i].diag = sprow_idx(&(rows[i]),i); /* printf("Have set diag index for row # %d\n",i); */ } } return A; } meschach-1.2b/spchfctr.c100644 764 764 37001 5673124744 14663 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse Cholesky factorisation code To be used with sparse.h, sparse.c etc */ static char rcsid[] = "$Id: spchfctr.c,v 1.4 1994/01/13 05:31:32 des Exp $"; #include #include "sparse2.h" #include #ifndef MALLOCDECL #ifndef ANSI_C extern char *calloc(), *realloc(); #endif #endif /* sprow_ip -- finds the (partial) inner product of a pair of sparse rows -- uses a "merging" approach & assumes column ordered rows -- row indices for inner product are all < lim */ double sprow_ip(row1, row2, lim) SPROW *row1, *row2; int lim; { int idx1, idx2, len1, len2, tmp; int sprow_idx(); register row_elt *elts1, *elts2; register Real sum; elts1 = row1->elt; elts2 = row2->elt; len1 = row1->len; len2 = row2->len; sum = 0.0; if ( len1 <= 0 || len2 <= 0 ) return 0.0; if ( elts1->col >= lim || elts2->col >= lim ) return 0.0; /* use sprow_idx() to speed up inner product where one row is much longer than the other */ idx1 = idx2 = 0; if ( len1 > 2*len2 ) { idx1 = sprow_idx(row1,elts2->col); idx1 = (idx1 < 0) ? -(idx1+2) : idx1; if ( idx1 < 0 ) error(E_UNKNOWN,"sprow_ip"); len1 -= idx1; } else if ( len2 > 2*len1 ) { idx2 = sprow_idx(row2,elts1->col); idx2 = (idx2 < 0) ? -(idx2+2) : idx2; if ( idx2 < 0 ) error(E_UNKNOWN,"sprow_ip"); len2 -= idx2; } if ( len1 <= 0 || len2 <= 0 ) return 0.0; elts1 = &(elts1[idx1]); elts2 = &(elts2[idx2]); for ( ; ; ) /* forever do... */ { if ( (tmp=elts1->col-elts2->col) < 0 ) { len1--; elts1++; if ( ! len1 || elts1->col >= lim ) break; } else if ( tmp > 0 ) { len2--; elts2++; if ( ! len2 || elts2->col >= lim ) break; } else { sum += elts1->val * elts2->val; len1--; elts1++; len2--; elts2++; if ( ! len1 || ! len2 || elts1->col >= lim || elts2->col >= lim ) break; } } return sum; } /* sprow_sqr -- returns same as sprow_ip(row, row, lim) */ double sprow_sqr(row, lim) SPROW *row; int lim; { register row_elt *elts; int idx, len; register Real sum, tmp; sum = 0.0; elts = row->elt; len = row->len; for ( idx = 0; idx < len; idx++, elts++ ) { if ( elts->col >= lim ) break; tmp = elts->val; sum += tmp*tmp; } return sum; } static int *scan_row = (int *)NULL, *scan_idx = (int *)NULL, *col_list = (int *)NULL; static int scan_len = 0; /* set_scan -- expand scan_row and scan_idx arrays -- return new length */ int set_scan(new_len) int new_len; { if ( new_len <= scan_len ) return scan_len; if ( new_len <= scan_len+5 ) new_len += 5; if ( ! scan_row || ! scan_idx || ! col_list ) { scan_row = (int *)calloc(new_len,sizeof(int)); scan_idx = (int *)calloc(new_len,sizeof(int)); col_list = (int *)calloc(new_len,sizeof(int)); } else { scan_row = (int *)realloc((char *)scan_row,new_len*sizeof(int)); scan_idx = (int *)realloc((char *)scan_idx,new_len*sizeof(int)); col_list = (int *)realloc((char *)col_list,new_len*sizeof(int)); } if ( ! scan_row || ! scan_idx || ! col_list ) error(E_MEM,"set_scan"); return new_len; } /* spCHfactor -- sparse Cholesky factorisation -- only the lower triangular part of A (incl. diagonal) is used */ SPMAT *spCHfactor(A) SPMAT *A; { register int i; int idx, k, m, minim, n, num_scan, diag_idx, tmp1; Real pivot, tmp2; SPROW *r_piv, *r_op; row_elt *elt_piv, *elt_op, *old_elt; if ( A == SMNULL ) error(E_NULL,"spCHfactor"); if ( A->m != A->n ) error(E_SQUARE,"spCHfactor"); /* set up access paths if not already done so */ sp_col_access(A); sp_diag_access(A); /* printf("spCHfactor() -- checkpoint 1\n"); */ m = A->m; n = A->n; for ( k = 0; k < m; k++ ) { r_piv = &(A->row[k]); if ( r_piv->len > scan_len ) set_scan(r_piv->len); elt_piv = r_piv->elt; diag_idx = sprow_idx2(r_piv,k,r_piv->diag); if ( diag_idx < 0 ) error(E_POSDEF,"spCHfactor"); old_elt = &(elt_piv[diag_idx]); for ( i = 0; i < r_piv->len; i++ ) { if ( elt_piv[i].col > k ) break; col_list[i] = elt_piv[i].col; scan_row[i] = elt_piv[i].nxt_row; scan_idx[i] = elt_piv[i].nxt_idx; } /* printf("spCHfactor() -- checkpoint 2\n"); */ num_scan = i; /* number of actual entries in scan_row etc. */ /* printf("num_scan = %d\n",num_scan); */ /* set diagonal entry of Cholesky factor */ tmp2 = elt_piv[diag_idx].val - sprow_sqr(r_piv,k); if ( tmp2 <= 0.0 ) error(E_POSDEF,"spCHfactor"); elt_piv[diag_idx].val = pivot = sqrt(tmp2); /* now set the k-th column of the Cholesky factors */ /* printf("k = %d\n",k); */ for ( ; ; ) /* forever do... */ { /* printf("spCHfactor() -- checkpoint 3\n"); */ /* find next row where something (non-trivial) happens i.e. find min(scan_row) */ /* printf("scan_row: "); */ minim = n; for ( i = 0; i < num_scan; i++ ) { tmp1 = scan_row[i]; /* printf("%d ",tmp1); */ minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; } /* printf("minim = %d\n",minim); */ /* printf("col_list: "); */ /********************************************************************** for ( i = 0; i < num_scan; i++ ) printf("%d ",col_list[i]); printf("\n"); **********************************************************************/ if ( minim >= n ) break; /* nothing more to do for this column */ r_op = &(A->row[minim]); elt_op = r_op->elt; /* set next entry in column k of Cholesky factors */ idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]); if ( idx < 0 ) { /* fill-in */ sp_set_val(A,minim,k, -sprow_ip(r_piv,r_op,k)/pivot); /* in case a realloc() has occurred... */ elt_op = r_op->elt; /* now set up column access path again */ idx = sprow_idx2(r_op,k,-(idx+2)); tmp1 = old_elt->nxt_row; old_elt->nxt_row = minim; r_op->elt[idx].nxt_row = tmp1; tmp1 = old_elt->nxt_idx; old_elt->nxt_idx = idx; r_op->elt[idx].nxt_idx = tmp1; } else elt_op[idx].val = (elt_op[idx].val - sprow_ip(r_piv,r_op,k))/pivot; /* printf("spCHfactor() -- checkpoint 4\n"); */ /* remember current element in column k for column chain */ idx = sprow_idx2(r_op,k,idx); old_elt = &(r_op->elt[idx]); /* update scan_row */ /* printf("spCHfactor() -- checkpoint 5\n"); */ /* printf("minim = %d\n",minim); */ for ( i = 0; i < num_scan; i++ ) { if ( scan_row[i] != minim ) continue; idx = sprow_idx2(r_op,col_list[i],scan_idx[i]); if ( idx < 0 ) { scan_row[i] = -1; continue; } scan_row[i] = elt_op[idx].nxt_row; scan_idx[i] = elt_op[idx].nxt_idx; /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */ /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */ } } /* printf("spCHfactor() -- checkpoint 6\n"); */ /* sp_dump(stdout,A); */ /* printf("\n\n\n"); */ } return A; } /* spCHsolve -- solve L.L^T.out=b where L is a sparse matrix, -- out, b dense vectors -- returns out; operation may be in-situ */ VEC *spCHsolve(L,b,out) SPMAT *L; VEC *b, *out; { int i, j_idx, n, scan_idx, scan_row; SPROW *row; row_elt *elt; Real diag_val, sum, *out_ve; if ( L == SMNULL || b == VNULL ) error(E_NULL,"spCHsolve"); if ( L->m != L->n ) error(E_SQUARE,"spCHsolve"); if ( b->dim != L->m ) error(E_SIZES,"spCHsolve"); if ( ! L->flag_col ) sp_col_access(L); if ( ! L->flag_diag ) sp_diag_access(L); out = v_copy(b,out); out_ve = out->ve; /* forward substitution: solve L.x=b for x */ n = L->n; for ( i = 0; i < n; i++ ) { sum = out_ve[i]; row = &(L->row[i]); elt = row->elt; for ( j_idx = 0; j_idx < row->len; j_idx++, elt++ ) { if ( elt->col >= i ) break; sum -= elt->val*out_ve[elt->col]; } if ( row->diag >= 0 ) out_ve[i] = sum/(row->elt[row->diag].val); else error(E_SING,"spCHsolve"); } /* backward substitution: solve L^T.out = x for out */ for ( i = n-1; i >= 0; i-- ) { sum = out_ve[i]; row = &(L->row[i]); /* Note that row->diag >= 0 by above loop */ elt = &(row->elt[row->diag]); diag_val = elt->val; /* scan down column */ scan_idx = elt->nxt_idx; scan_row = elt->nxt_row; while ( scan_row >= 0 /* && scan_idx >= 0 */ ) { row = &(L->row[scan_row]); elt = &(row->elt[scan_idx]); sum -= elt->val*out_ve[scan_row]; scan_idx = elt->nxt_idx; scan_row = elt->nxt_row; } out_ve[i] = sum/diag_val; } return out; } /* spICHfactor -- sparse Incomplete Cholesky factorisation -- does a Cholesky factorisation assuming NO FILL-IN -- as for spCHfactor(), only the lower triangular part of A is used */ SPMAT *spICHfactor(A) SPMAT *A; { int k, m, n, nxt_row, nxt_idx, diag_idx; Real pivot, tmp2; SPROW *r_piv, *r_op; row_elt *elt_piv, *elt_op; if ( A == SMNULL ) error(E_NULL,"spICHfactor"); if ( A->m != A->n ) error(E_SQUARE,"spICHfactor"); /* set up access paths if not already done so */ if ( ! A->flag_col ) sp_col_access(A); if ( ! A->flag_diag ) sp_diag_access(A); m = A->m; n = A->n; for ( k = 0; k < m; k++ ) { r_piv = &(A->row[k]); diag_idx = r_piv->diag; if ( diag_idx < 0 ) error(E_POSDEF,"spICHfactor"); elt_piv = r_piv->elt; /* set diagonal entry of Cholesky factor */ tmp2 = elt_piv[diag_idx].val - sprow_sqr(r_piv,k); if ( tmp2 <= 0.0 ) error(E_POSDEF,"spICHfactor"); elt_piv[diag_idx].val = pivot = sqrt(tmp2); /* find next row where something (non-trivial) happens */ nxt_row = elt_piv[diag_idx].nxt_row; nxt_idx = elt_piv[diag_idx].nxt_idx; /* now set the k-th column of the Cholesky factors */ while ( nxt_row >= 0 && nxt_idx >= 0 ) { /* nxt_row and nxt_idx give next next row (& index) of the entry to be modified */ r_op = &(A->row[nxt_row]); elt_op = r_op->elt; elt_op[nxt_idx].val = (elt_op[nxt_idx].val - sprow_ip(r_piv,r_op,k))/pivot; nxt_row = elt_op[nxt_idx].nxt_row; nxt_idx = elt_op[nxt_idx].nxt_idx; } } return A; } /* spCHsymb -- symbolic sparse Cholesky factorisation -- does NOT do any floating point arithmetic; just sets up the structure -- only the lower triangular part of A (incl. diagonal) is used */ SPMAT *spCHsymb(A) SPMAT *A; { register int i; int idx, k, m, minim, n, num_scan, diag_idx, tmp1; SPROW *r_piv, *r_op; row_elt *elt_piv, *elt_op, *old_elt; if ( A == SMNULL ) error(E_NULL,"spCHsymb"); if ( A->m != A->n ) error(E_SQUARE,"spCHsymb"); /* set up access paths if not already done so */ if ( ! A->flag_col ) sp_col_access(A); if ( ! A->flag_diag ) sp_diag_access(A); /* printf("spCHsymb() -- checkpoint 1\n"); */ m = A->m; n = A->n; for ( k = 0; k < m; k++ ) { r_piv = &(A->row[k]); if ( r_piv->len > scan_len ) set_scan(r_piv->len); elt_piv = r_piv->elt; diag_idx = sprow_idx2(r_piv,k,r_piv->diag); if ( diag_idx < 0 ) error(E_POSDEF,"spCHsymb"); old_elt = &(elt_piv[diag_idx]); for ( i = 0; i < r_piv->len; i++ ) { if ( elt_piv[i].col > k ) break; col_list[i] = elt_piv[i].col; scan_row[i] = elt_piv[i].nxt_row; scan_idx[i] = elt_piv[i].nxt_idx; } /* printf("spCHsymb() -- checkpoint 2\n"); */ num_scan = i; /* number of actual entries in scan_row etc. */ /* printf("num_scan = %d\n",num_scan); */ /* now set the k-th column of the Cholesky factors */ /* printf("k = %d\n",k); */ for ( ; ; ) /* forever do... */ { /* printf("spCHsymb() -- checkpoint 3\n"); */ /* find next row where something (non-trivial) happens i.e. find min(scan_row) */ minim = n; for ( i = 0; i < num_scan; i++ ) { tmp1 = scan_row[i]; /* printf("%d ",tmp1); */ minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; } if ( minim >= n ) break; /* nothing more to do for this column */ r_op = &(A->row[minim]); elt_op = r_op->elt; /* set next entry in column k of Cholesky factors */ idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]); if ( idx < 0 ) { /* fill-in */ sp_set_val(A,minim,k,0.0); /* in case a realloc() has occurred... */ elt_op = r_op->elt; /* now set up column access path again */ idx = sprow_idx2(r_op,k,-(idx+2)); tmp1 = old_elt->nxt_row; old_elt->nxt_row = minim; r_op->elt[idx].nxt_row = tmp1; tmp1 = old_elt->nxt_idx; old_elt->nxt_idx = idx; r_op->elt[idx].nxt_idx = tmp1; } /* printf("spCHsymb() -- checkpoint 4\n"); */ /* remember current element in column k for column chain */ idx = sprow_idx2(r_op,k,idx); old_elt = &(r_op->elt[idx]); /* update scan_row */ /* printf("spCHsymb() -- checkpoint 5\n"); */ /* printf("minim = %d\n",minim); */ for ( i = 0; i < num_scan; i++ ) { if ( scan_row[i] != minim ) continue; idx = sprow_idx2(r_op,col_list[i],scan_idx[i]); if ( idx < 0 ) { scan_row[i] = -1; continue; } scan_row[i] = elt_op[idx].nxt_row; scan_idx[i] = elt_op[idx].nxt_idx; /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */ /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */ } } /* printf("spCHsymb() -- checkpoint 6\n"); */ } return A; } /* comp_AAT -- compute A.A^T where A is a given sparse matrix */ SPMAT *comp_AAT(A) SPMAT *A; { SPMAT *AAT; SPROW *r, *r2; row_elt *elts, *elts2; int i, idx, idx2, j, m, minim, n, num_scan, tmp1; Real ip; if ( ! A ) error(E_NULL,"comp_AAT"); m = A->m; n = A->n; /* set up column access paths */ if ( ! A->flag_col ) sp_col_access(A); AAT = sp_get(m,m,10); for ( i = 0; i < m; i++ ) { /* initialisation */ r = &(A->row[i]); elts = r->elt; /* set up scan lists for this row */ if ( r->len > scan_len ) set_scan(r->len); for ( j = 0; j < r->len; j++ ) { col_list[j] = elts[j].col; scan_row[j] = elts[j].nxt_row; scan_idx[j] = elts[j].nxt_idx; } num_scan = r->len; /* scan down the rows for next non-zero not associated with a diagonal entry */ for ( ; ; ) { minim = m; for ( idx = 0; idx < num_scan; idx++ ) { tmp1 = scan_row[idx]; minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; } if ( minim >= m ) break; r2 = &(A->row[minim]); if ( minim > i ) { ip = sprow_ip(r,r2,n); sp_set_val(AAT,minim,i,ip); sp_set_val(AAT,i,minim,ip); } /* update scan entries */ elts2 = r2->elt; for ( idx = 0; idx < num_scan; idx++ ) { if ( scan_row[idx] != minim || scan_idx[idx] < 0 ) continue; idx2 = scan_idx[idx]; scan_row[idx] = elts2[idx2].nxt_row; scan_idx[idx] = elts2[idx2].nxt_idx; } } /* set the diagonal entry */ sp_set_val(AAT,i,i,sprow_sqr(r,n)); } return AAT; } meschach-1.2b/splufctr.c100644 764 764 25070 5673124701 14705 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse LU factorisation See also: sparse.[ch] etc for details about sparse matrices */ #include #include "sparse2.h" #include /* Macro for speedup */ /* #define sprow_idx2(r,c,hint) \ ( ( (hint) >= 0 && (r)->elt[hint].col == (c)) ? hint : sprow_idx((r),(c)) ) */ /* spLUfactor -- sparse LU factorisation with pivoting -- uses partial pivoting and Markowitz criterion |a[p][k]| >= alpha * max_i |a[i][k]| -- creates fill-in as needed -- in situ factorisation */ SPMAT *spLUfactor(A,px,alpha) SPMAT *A; PERM *px; double alpha; { int i, best_i, k, idx, len, best_len, m, n; SPROW *r, *r_piv, tmp_row; static SPROW *merge = (SPROW *)NULL; Real max_val, tmp; static VEC *col_vals=VNULL; if ( ! A || ! px ) error(E_NULL,"spLUfctr"); if ( alpha <= 0.0 || alpha > 1.0 ) error(E_RANGE,"alpha in spLUfctr"); if ( px->size <= A->m ) px = px_resize(px,A->m); px_ident(px); col_vals = v_resize(col_vals,A->m); MEM_STAT_REG(col_vals,TYPE_VEC); m = A->m; n = A->n; if ( ! A->flag_col ) sp_col_access(A); if ( ! A->flag_diag ) sp_diag_access(A); A->flag_col = A->flag_diag = FALSE; if ( ! merge ) { merge = sprow_get(20); MEM_STAT_REG(merge,TYPE_SPROW); } for ( k = 0; k < n; k++ ) { /* find pivot row/element for partial pivoting */ /* get first row with a non-zero entry in the k-th column */ max_val = 0.0; for ( i = k; i < m; i++ ) { r = &(A->row[i]); idx = sprow_idx(r,k); if ( idx < 0 ) tmp = 0.0; else tmp = r->elt[idx].val; if ( fabs(tmp) > max_val ) max_val = fabs(tmp); col_vals->ve[i] = tmp; } if ( max_val == 0.0 ) continue; best_len = n+1; /* only if no possibilities */ best_i = -1; for ( i = k; i < m; i++ ) { tmp = fabs(col_vals->ve[i]); if ( tmp == 0.0 ) continue; if ( tmp >= alpha*max_val ) { r = &(A->row[i]); idx = sprow_idx(r,k); len = (r->len) - idx; if ( len < best_len ) { best_len = len; best_i = i; } } } /* swap row #best_i with row #k */ MEM_COPY(&(A->row[best_i]),&tmp_row,sizeof(SPROW)); MEM_COPY(&(A->row[k]),&(A->row[best_i]),sizeof(SPROW)); MEM_COPY(&tmp_row,&(A->row[k]),sizeof(SPROW)); /* swap col_vals entries */ tmp = col_vals->ve[best_i]; col_vals->ve[best_i] = col_vals->ve[k]; col_vals->ve[k] = tmp; px_transp(px,k,best_i); r_piv = &(A->row[k]); for ( i = k+1; i < n; i++ ) { /* compute and set multiplier */ tmp = col_vals->ve[i]/col_vals->ve[k]; if ( tmp != 0.0 ) sp_set_val(A,i,k,tmp); else continue; /* perform row operations */ merge->len = 0; r = &(A->row[i]); sprow_mltadd(r,r_piv,-tmp,k+1,merge,TYPE_SPROW); idx = sprow_idx(r,k+1); if ( idx < 0 ) idx = -(idx+2); /* see if r needs expanding */ if ( r->maxlen < idx + merge->len ) sprow_xpd(r,idx+merge->len,TYPE_SPMAT); r->len = idx+merge->len; MEM_COPY((char *)(merge->elt),(char *)&(r->elt[idx]), merge->len*sizeof(row_elt)); } } return A; } /* spLUsolve -- solve A.x = b using factored matrix A from spLUfactor() -- returns x -- may not be in-situ */ VEC *spLUsolve(A,pivot,b,x) SPMAT *A; PERM *pivot; VEC *b, *x; { int i, idx, len, lim; Real sum, *x_ve; SPROW *r; row_elt *elt; if ( ! A || ! b ) error(E_NULL,"spLUsolve"); if ( (pivot != PNULL && A->m != pivot->size) || A->m != b->dim ) error(E_SIZES,"spLUsolve"); if ( ! x || x->dim != A->n ) x = v_resize(x,A->n); if ( pivot != PNULL ) x = px_vec(pivot,b,x); else x = v_copy(b,x); x_ve = x->ve; lim = min(A->m,A->n); for ( i = 0; i < lim; i++ ) { sum = x_ve[i]; r = &(A->row[i]); len = r->len; elt = r->elt; for ( idx = 0; idx < len && elt->col < i; idx++, elt++ ) sum -= elt->val*x_ve[elt->col]; x_ve[i] = sum; } for ( i = lim-1; i >= 0; i-- ) { sum = x_ve[i]; r = &(A->row[i]); len = r->len; elt = &(r->elt[len-1]); for ( idx = len-1; idx >= 0 && elt->col > i; idx--, elt-- ) sum -= elt->val*x_ve[elt->col]; if ( idx < 0 || elt->col != i || elt->val == 0.0 ) error(E_SING,"spLUsolve"); x_ve[i] = sum/elt->val; } return x; } /* spLUTsolve -- solve A.x = b using factored matrix A from spLUfactor() -- returns x -- may not be in-situ */ VEC *spLUTsolve(A,pivot,b,x) SPMAT *A; PERM *pivot; VEC *b, *x; { int i, idx, lim, rownum; Real sum, *tmp_ve; /* SPROW *r; */ row_elt *elt; static VEC *tmp=VNULL; if ( ! A || ! b ) error(E_NULL,"spLUTsolve"); if ( (pivot != PNULL && A->m != pivot->size) || A->m != b->dim ) error(E_SIZES,"spLUTsolve"); tmp = v_copy(b,tmp); MEM_STAT_REG(tmp,TYPE_VEC); if ( ! A->flag_col ) sp_col_access(A); if ( ! A->flag_diag ) sp_diag_access(A); lim = min(A->m,A->n); tmp_ve = tmp->ve; /* solve U^T.tmp = b */ for ( i = 0; i < lim; i++ ) { sum = tmp_ve[i]; rownum = A->start_row[i]; idx = A->start_idx[i]; if ( rownum < 0 || idx < 0 ) error(E_SING,"spLUTsolve"); while ( rownum < i && rownum >= 0 && idx >= 0 ) { elt = &(A->row[rownum].elt[idx]); sum -= elt->val*tmp_ve[rownum]; rownum = elt->nxt_row; idx = elt->nxt_idx; } if ( rownum != i ) error(E_SING,"spLUTsolve"); elt = &(A->row[rownum].elt[idx]); if ( elt->val == 0.0 ) error(E_SING,"spLUTsolve"); tmp_ve[i] = sum/elt->val; } /* now solve L^T.tmp = (old) tmp */ for ( i = lim-1; i >= 0; i-- ) { sum = tmp_ve[i]; rownum = i; idx = A->row[rownum].diag; if ( idx < 0 ) error(E_NULL,"spLUTsolve"); elt = &(A->row[rownum].elt[idx]); rownum = elt->nxt_row; idx = elt->nxt_idx; while ( rownum < lim && rownum >= 0 && idx >= 0 ) { elt = &(A->row[rownum].elt[idx]); sum -= elt->val*tmp_ve[rownum]; rownum = elt->nxt_row; idx = elt->nxt_idx; } tmp_ve[i] = sum; } if ( pivot != PNULL ) x = pxinv_vec(pivot,tmp,x); else x = v_copy(tmp,x); return x; } /* spILUfactor -- sparse modified incomplete LU factorisation with no pivoting -- all pivot entries are ensured to be >= alpha in magnitude -- setting alpha = 0 gives incomplete LU factorisation -- no fill-in is generated -- in situ factorisation */ SPMAT *spILUfactor(A,alpha) SPMAT *A; double alpha; { int i, k, idx, idx_piv, m, n, old_idx, old_idx_piv; SPROW *r, *r_piv; Real piv_val, tmp; /* printf("spILUfactor: entered\n"); */ if ( ! A ) error(E_NULL,"spILUfactor"); if ( alpha < 0.0 ) error(E_RANGE,"[alpha] in spILUfactor"); m = A->m; n = A->n; sp_diag_access(A); sp_col_access(A); for ( k = 0; k < n; k++ ) { /* printf("spILUfactor(l.%d): checkpoint A: k = %d\n",__LINE__,k); */ /* printf("spILUfactor(l.%d): A =\n", __LINE__); */ /* sp_output(A); */ r_piv = &(A->row[k]); idx_piv = r_piv->diag; if ( idx_piv < 0 ) { sprow_set_val(r_piv,k,alpha); idx_piv = sprow_idx(r_piv,k); } /* printf("spILUfactor: checkpoint B\n"); */ if ( idx_piv < 0 ) error(E_BOUNDS,"spILUfactor"); old_idx_piv = idx_piv; piv_val = r_piv->elt[idx_piv].val; /* printf("spILUfactor: checkpoint C\n"); */ if ( fabs(piv_val) < alpha ) piv_val = ( piv_val < 0.0 ) ? -alpha : alpha; if ( piv_val == 0.0 ) /* alpha == 0.0 too! */ error(E_SING,"spILUfactor"); /* go to next row with a non-zero in this column */ i = r_piv->elt[idx_piv].nxt_row; old_idx = idx = r_piv->elt[idx_piv].nxt_idx; while ( i >= k ) { /* printf("spILUfactor: checkpoint D: i = %d\n",i); */ /* perform row operations */ r = &(A->row[i]); /* idx = sprow_idx(r,k); */ /* printf("spLUfactor(l.%d) i = %d, idx = %d\n", __LINE__, i, idx); */ if ( idx < 0 ) { idx = r->elt[old_idx].nxt_idx; i = r->elt[old_idx].nxt_row; continue; } /* printf("spILUfactor: checkpoint E\n"); */ /* compute and set multiplier */ r->elt[idx].val = tmp = r->elt[idx].val/piv_val; /* printf("spILUfactor: piv_val = %g, multiplier = %g\n", piv_val, tmp); */ /* printf("spLUfactor(l.%d) multiplier = %g\n", __LINE__, tmp); */ if ( tmp == 0.0 ) { idx = r->elt[old_idx].nxt_idx; i = r->elt[old_idx].nxt_row; continue; } /* idx = sprow_idx(r,k+1); */ /* if ( idx < 0 ) idx = -(idx+2); */ idx_piv++; idx++; /* now look beyond the multiplier entry */ /* printf("spILUfactor: checkpoint F: idx = %d, idx_piv = %d\n", idx, idx_piv); */ while ( idx_piv < r_piv->len && idx < r->len ) { /* printf("spILUfactor: checkpoint G: idx = %d, idx_piv = %d\n", idx, idx_piv); */ if ( r_piv->elt[idx_piv].col < r->elt[idx].col ) idx_piv++; else if ( r_piv->elt[idx_piv].col > r->elt[idx].col ) idx++; else /* column numbers match */ { /* printf("spILUfactor(l.%d) subtract %g times the ", __LINE__, tmp); */ /* printf("(%d,%d) entry to the (%d,%d) entry\n", k, r_piv->elt[idx_piv].col, i, r->elt[idx].col); */ r->elt[idx].val -= tmp*r_piv->elt[idx_piv].val; idx++; idx_piv++; } } /* bump to next row with a non-zero in column k */ /* printf("spILUfactor(l.%d) column = %d, row[%d] =\n", __LINE__, r->elt[old_idx].col, i); */ /* sprow_foutput(stdout,r); */ i = r->elt[old_idx].nxt_row; old_idx = idx = r->elt[old_idx].nxt_idx; /* printf("spILUfactor(l.%d) i = %d, idx = %d\n", __LINE__, i, idx); */ /* and restore idx_piv to index of pivot entry */ idx_piv = old_idx_piv; } } /* printf("spILUfactor: exiting\n"); */ return A; } meschach-1.2b/spbkp.c100644 764 764 105354 5673124772 14216 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse matrix Bunch--Kaufman--Parlett factorisation and solve Radical revision started Thu 05th Nov 1992, 09:36:12 AM to use Karen George's suggestion of leaving the the row elements unordered Radical revision completed Mon 07th Dec 1992, 10:59:57 AM */ static char rcsid[] = "$Id: spbkp.c,v 1.5 1994/01/13 05:44:35 des Exp $"; #include #include "sparse2.h" #include #ifdef MALLOCDECL #include #endif #define alpha 0.6403882032022076 /* = (1+sqrt(17))/8 */ #define btos(x) ((x) ? "TRUE" : "FALSE") /* assume no use of sqr() uses side-effects */ #define sqr(x) ((x)*(x)) /* unord_get_idx -- returns index (encoded if entry not allocated) of the element of row r with column j -- uses linear search */ int unord_get_idx(r,j) SPROW *r; int j; { int idx; row_elt *e; if ( ! r || ! r->elt ) error(E_NULL,"unord_get_idx"); for ( idx = 0, e = r->elt; idx < r->len; idx++, e++ ) if ( e->col == j ) break; if ( idx >= r->len ) return -(r->len+2); else return idx; } /* unord_get_val -- returns value of the (i,j) entry of A -- same assumptions as unord_get_idx() */ double unord_get_val(A,i,j) SPMAT *A; int i, j; { SPROW *r; int idx; if ( ! A ) error(E_NULL,"unord_get_val"); if ( i < 0 || i >= A->m || j < 0 || j >= A->n ) error(E_BOUNDS,"unord_get_val"); r = &(A->row[i]); idx = unord_get_idx(r,j); if ( idx < 0 ) return 0.0; else return r->elt[idx].val; } /* bkp_swap_elt -- swaps the (i,j) with the (k,l) entry of sparse matrix -- either or both of the entries may be unallocated */ static SPMAT *bkp_swap_elt(A,i1,j1,idx1,i2,j2,idx2) SPMAT *A; int i1, j1, idx1, i2, j2, idx2; { int tmp_row, tmp_idx; SPROW *r1, *r2; row_elt *e1, *e2; Real tmp; if ( ! A ) error(E_NULL,"bkp_swap_elt"); if ( i1 < 0 || j1 < 0 || i2 < 0 || j2 < 0 || i1 >= A->m || j1 >= A->n || i2 >= A->m || j2 >= A->n ) { error(E_BOUNDS,"bkp_swap_elt"); } if ( i1 == i2 && j1 == j2 ) return A; if ( idx1 < 0 && idx2 < 0 ) /* neither allocated */ return A; r1 = &(A->row[i1]); r2 = &(A->row[i2]); /* if ( idx1 >= r1->len || idx2 >= r2->len ) error(E_BOUNDS,"bkp_swap_elt"); */ if ( idx1 < 0 ) /* assume not allocated */ { idx1 = r1->len; if ( idx1 >= r1->maxlen ) { tracecatch(sprow_xpd(r1,2*r1->maxlen+1,TYPE_SPMAT), "bkp_swap_elt"); } r1->len = idx1+1; r1->elt[idx1].col = j1; r1->elt[idx1].val = 0.0; /* now patch up column access path */ tmp_row = -1; tmp_idx = j1; chase_col(A,j1,&tmp_row,&tmp_idx,i1-1); if ( tmp_row < 0 ) { r1->elt[idx1].nxt_row = A->start_row[j1]; r1->elt[idx1].nxt_idx = A->start_idx[j1]; A->start_row[j1] = i1; A->start_idx[j1] = idx1; } else { row_elt *tmp_e; tmp_e = &(A->row[tmp_row].elt[tmp_idx]); r1->elt[idx1].nxt_row = tmp_e->nxt_row; r1->elt[idx1].nxt_idx = tmp_e->nxt_idx; tmp_e->nxt_row = i1; tmp_e->nxt_idx = idx1; } } else if ( r1->elt[idx1].col != j1 ) error(E_INTERN,"bkp_swap_elt"); if ( idx2 < 0 ) { idx2 = r2->len; if ( idx2 >= r2->maxlen ) { tracecatch(sprow_xpd(r2,2*r2->maxlen+1,TYPE_SPMAT), "bkp_swap_elt"); } r2->len = idx2+1; r2->elt[idx2].col = j2; r2->elt[idx2].val = 0.0; /* now patch up column access path */ tmp_row = -1; tmp_idx = j2; chase_col(A,j2,&tmp_row,&tmp_idx,i2-1); if ( tmp_row < 0 ) { r2->elt[idx2].nxt_row = A->start_row[j2]; r2->elt[idx2].nxt_idx = A->start_idx[j2]; A->start_row[j2] = i2; A->start_idx[j2] = idx2; } else { row_elt *tmp_e; tmp_e = &(A->row[tmp_row].elt[tmp_idx]); r2->elt[idx2].nxt_row = tmp_e->nxt_row; r2->elt[idx2].nxt_idx = tmp_e->nxt_idx; tmp_e->nxt_row = i2; tmp_e->nxt_idx = idx2; } } else if ( r2->elt[idx2].col != j2 ) error(E_INTERN,"bkp_swap_elt"); e1 = &(r1->elt[idx1]); e2 = &(r2->elt[idx2]); tmp = e1->val; e1->val = e2->val; e2->val = tmp; return A; } /* bkp_bump_col -- bumps row and idx to next entry in column j */ row_elt *bkp_bump_col(A, j, row, idx) SPMAT *A; int j, *row, *idx; { SPROW *r; row_elt *e; if ( *row < 0 ) { *row = A->start_row[j]; *idx = A->start_idx[j]; } else { r = &(A->row[*row]); e = &(r->elt[*idx]); if ( e->col != j ) error(E_INTERN,"bkp_bump_col"); *row = e->nxt_row; *idx = e->nxt_idx; } if ( *row < 0 ) return (row_elt *)NULL; else return &(A->row[*row].elt[*idx]); } /* bkp_interchange -- swap rows/cols i and j (symmetric pivot) -- uses just the upper triangular part */ SPMAT *bkp_interchange(A, i1, i2) SPMAT *A; int i1, i2; { int tmp_row, tmp_idx; int row1, row2, idx1, idx2, tmp_row1, tmp_idx1, tmp_row2, tmp_idx2; SPROW *r1, *r2; row_elt *e1, *e2; IVEC *done_list = IVNULL; if ( ! A ) error(E_NULL,"bkp_interchange"); if ( i1 < 0 || i1 >= A->n || i2 < 0 || i2 >= A->n ) error(E_BOUNDS,"bkp_interchange"); if ( A->m != A->n ) error(E_SQUARE,"bkp_interchange"); if ( i1 == i2 ) return A; if ( i1 > i2 ) { tmp_idx = i1; i1 = i2; i2 = tmp_idx; } done_list = iv_resize(done_list,A->n); for ( tmp_idx = 0; tmp_idx < A->n; tmp_idx++ ) done_list->ive[tmp_idx] = FALSE; row1 = -1; idx1 = i1; row2 = -1; idx2 = i2; e1 = bkp_bump_col(A,i1,&row1,&idx1); e2 = bkp_bump_col(A,i2,&row2,&idx2); while ( (row1 >= 0 && row1 < i1) || (row2 >= 0 && row2 < i1) ) /* Note: "row2 < i1" not "row2 < i2" as we must stop before the "knee bend" */ { if ( row1 >= 0 && row1 < i1 && ( row1 < row2 || row2 < 0 ) ) { tmp_row1 = row1; tmp_idx1 = idx1; e1 = bkp_bump_col(A,i1,&tmp_row1,&tmp_idx1); if ( ! done_list->ive[row1] ) { if ( row1 == row2 ) bkp_swap_elt(A,row1,i1,idx1,row1,i2,idx2); else bkp_swap_elt(A,row1,i1,idx1,row1,i2,-1); done_list->ive[row1] = TRUE; } row1 = tmp_row1; idx1 = tmp_idx1; } else if ( row2 >= 0 && row2 < i1 && ( row2 < row1 || row1 < 0 ) ) { tmp_row2 = row2; tmp_idx2 = idx2; e2 = bkp_bump_col(A,i2,&tmp_row2,&tmp_idx2); if ( ! done_list->ive[row2] ) { if ( row1 == row2 ) bkp_swap_elt(A,row2,i1,idx1,row2,i2,idx2); else bkp_swap_elt(A,row2,i1,-1,row2,i2,idx2); done_list->ive[row2] = TRUE; } row2 = tmp_row2; idx2 = tmp_idx2; } else if ( row1 == row2 ) { tmp_row1 = row1; tmp_idx1 = idx1; e1 = bkp_bump_col(A,i1,&tmp_row1,&tmp_idx1); tmp_row2 = row2; tmp_idx2 = idx2; e2 = bkp_bump_col(A,i2,&tmp_row2,&tmp_idx2); if ( ! done_list->ive[row1] ) { bkp_swap_elt(A,row1,i1,idx1,row2,i2,idx2); done_list->ive[row1] = TRUE; } row1 = tmp_row1; idx1 = tmp_idx1; row2 = tmp_row2; idx2 = tmp_idx2; } } /* ensure we are **past** the first knee */ while ( row2 >= 0 && row2 <= i1 ) e2 = bkp_bump_col(A,i2,&row2,&idx2); /* at/after 1st "knee bend" */ r1 = &(A->row[i1]); idx1 = 0; e1 = &(r1->elt[idx1]); while ( row2 >= 0 && row2 < i2 ) { /* used for update of e2 at end of loop */ tmp_row = row2; tmp_idx = idx2; if ( ! done_list->ive[row2] ) { r2 = &(A->row[row2]); bkp_bump_col(A,i2,&tmp_row,&tmp_idx); done_list->ive[row2] = TRUE; tmp_idx1 = unord_get_idx(r1,row2); tracecatch(bkp_swap_elt(A,row2,i2,idx2,i1,row2,tmp_idx1), "bkp_interchange"); } /* update e1 and e2 */ row2 = tmp_row; idx2 = tmp_idx; e2 = ( row2 >= 0 ) ? &(A->row[row2].elt[idx2]) : (row_elt *)NULL; } idx1 = 0; e1 = r1->elt; while ( idx1 < r1->len ) { if ( e1->col >= i2 || e1->col <= i1 ) { idx1++; e1++; continue; } if ( ! done_list->ive[e1->col] ) { tmp_idx2 = unord_get_idx(&(A->row[e1->col]),i2); tracecatch(bkp_swap_elt(A,i1,e1->col,idx1,e1->col,i2,tmp_idx2), "bkp_interchange"); done_list->ive[e1->col] = TRUE; } idx1++; e1++; } /* at/after 2nd "knee bend" */ idx1 = 0; e1 = &(r1->elt[idx1]); r2 = &(A->row[i2]); idx2 = 0; e2 = &(r2->elt[idx2]); while ( idx1 < r1->len ) { if ( e1->col <= i2 ) { idx1++; e1++; continue; } if ( ! done_list->ive[e1->col] ) { tmp_idx2 = unord_get_idx(r2,e1->col); tracecatch(bkp_swap_elt(A,i1,e1->col,idx1,i2,e1->col,tmp_idx2), "bkp_interchange"); done_list->ive[e1->col] = TRUE; } idx1++; e1++; } idx2 = 0; e2 = r2->elt; while ( idx2 < r2->len ) { if ( e2->col <= i2 ) { idx2++; e2++; continue; } if ( ! done_list->ive[e2->col] ) { tmp_idx1 = unord_get_idx(r1,e2->col); tracecatch(bkp_swap_elt(A,i2,e2->col,idx2,i1,e2->col,tmp_idx1), "bkp_interchange"); done_list->ive[e2->col] = TRUE; } idx2++; e2++; } /* now interchange the digonal entries! */ idx1 = unord_get_idx(&(A->row[i1]),i1); idx2 = unord_get_idx(&(A->row[i2]),i2); if ( idx1 >= 0 || idx2 >= 0 ) { tracecatch(bkp_swap_elt(A,i1,i1,idx1,i2,i2,idx2), "bkp_interchange"); } return A; } /* iv_min -- returns minimum of an integer vector -- sets index to the position in iv if index != NULL */ int iv_min(iv,index) IVEC *iv; int *index; { int i, i_min, min_val, tmp; if ( ! iv ) error(E_NULL,"iv_min"); if ( iv->dim <= 0 ) error(E_SIZES,"iv_min"); i_min = 0; min_val = iv->ive[0]; for ( i = 1; i < iv->dim; i++ ) { tmp = iv->ive[i]; if ( tmp < min_val ) { min_val = tmp; i_min = i; } } if ( index != (int *)NULL ) *index = i_min; return min_val; } /* max_row_col -- returns max { |A[j][k]| : k >= i, k != j, k != l } given j using symmetry and only the upper triangular part of A */ static double max_row_col(A,i,j,l) SPMAT *A; int i, j, l; { int row_num, idx; SPROW *r; row_elt *e; Real max_val, tmp; if ( ! A ) error(E_NULL,"max_row_col"); if ( i < 0 || i > A->n || j < 0 || j >= A->n ) error(E_BOUNDS,"max_row_col"); max_val = 0.0; idx = unord_get_idx(&(A->row[i]),j); if ( idx < 0 ) { row_num = -1; idx = j; e = chase_past(A,j,&row_num,&idx,i); } else { row_num = i; e = &(A->row[i].elt[idx]); } while ( row_num >= 0 && row_num < j ) { if ( row_num != l ) { tmp = fabs(e->val); if ( tmp > max_val ) max_val = tmp; } e = bump_col(A,j,&row_num,&idx); } r = &(A->row[j]); for ( idx = 0, e = r->elt; idx < r->len; idx++, e++ ) { if ( e->col > j && e->col != l ) { tmp = fabs(e->val); if ( tmp > max_val ) max_val = tmp; } } return max_val; } /* nonzeros -- counts non-zeros in A */ static int nonzeros(A) SPMAT *A; { int cnt, i; if ( ! A ) return 0; cnt = 0; for ( i = 0; i < A->m; i++ ) cnt += A->row[i].len; return cnt; } /* chk_col_access -- for spBKPfactor() -- checks that column access path is OK */ int chk_col_access(A) SPMAT *A; { int cnt_nz, j, row, idx; SPROW *r; row_elt *e; if ( ! A ) error(E_NULL,"chk_col_access"); /* count nonzeros as we go down columns */ cnt_nz = 0; for ( j = 0; j < A->n; j++ ) { row = A->start_row[j]; idx = A->start_idx[j]; while ( row >= 0 ) { if ( row >= A->m || idx < 0 ) return FALSE; r = &(A->row[row]); if ( idx >= r->len ) return FALSE; e = &(r->elt[idx]); if ( e->nxt_row >= 0 && e->nxt_row <= row ) return FALSE; row = e->nxt_row; idx = e->nxt_idx; cnt_nz++; } } if ( cnt_nz != nonzeros(A) ) return FALSE; else return TRUE; } /* col_cmp -- compare two columns -- for sorting rows using qsort() */ static int col_cmp(e1,e2) row_elt *e1, *e2; { return e1->col - e2->col; } /* spBKPfactor -- sparse Bunch-Kaufman-Parlett factorisation of A in-situ -- A is factored into the form P'AP = MDM' where P is a permutation matrix, M lower triangular and D is block diagonal with blocks of size 1 or 2 -- P is stored in pivot; blocks[i]==i iff D[i][i] is a block */ SPMAT *spBKPfactor(A,pivot,blocks,tol) SPMAT *A; PERM *pivot, *blocks; double tol; { int i, j, k, l, n, onebyone, r; int idx, idx1, idx_piv; int row_num; int best_deg, best_j, best_l, best_cost, mark_cost, deg, deg_j, deg_l, ignore_deg; int list_idx, list_idx2, old_list_idx; SPROW *row, *r_piv, *r1_piv; row_elt *e, *e1; Real aii, aip1, aip1i; Real det, max_j, max_l, s, t; static IVEC *scan_row = IVNULL, *scan_idx = IVNULL, *col_list = IVNULL, *tmp_iv = IVNULL; static IVEC *deg_list = IVNULL; static IVEC *orig_idx = IVNULL, *orig1_idx = IVNULL; static PERM *order = PNULL; if ( ! A || ! pivot || ! blocks ) error(E_NULL,"spBKPfactor"); if ( A->m != A->n ) error(E_SQUARE,"spBKPfactor"); if ( A->m != pivot->size || pivot->size != blocks->size ) error(E_SIZES,"spBKPfactor"); if ( tol <= 0.0 || tol > 1.0 ) error(E_RANGE,"spBKPfactor"); n = A->n; px_ident(pivot); px_ident(blocks); sp_col_access(A); sp_diag_access(A); ignore_deg = FALSE; deg_list = iv_resize(deg_list,n); order = px_resize(order,n); MEM_STAT_REG(deg_list,TYPE_IVEC); MEM_STAT_REG(order,TYPE_PERM); scan_row = iv_resize(scan_row,5); scan_idx = iv_resize(scan_idx,5); col_list = iv_resize(col_list,5); orig_idx = iv_resize(orig_idx,5); orig_idx = iv_resize(orig1_idx,5); orig_idx = iv_resize(tmp_iv,5); MEM_STAT_REG(scan_row,TYPE_IVEC); MEM_STAT_REG(scan_idx,TYPE_IVEC); MEM_STAT_REG(col_list,TYPE_IVEC); MEM_STAT_REG(orig_idx,TYPE_IVEC); MEM_STAT_REG(orig1_idx,TYPE_IVEC); MEM_STAT_REG(tmp_iv,TYPE_IVEC); for ( i = 0; i < n-1; i = onebyone ? i+1 : i+2 ) { /* now we want to use a Markowitz-style selection rule for determining which rows to swap and whether to use 1x1 or 2x2 pivoting */ /* get list of degrees of nodes */ deg_list = iv_resize(deg_list,n-i); if ( ! ignore_deg ) for ( j = i; j < n; j++ ) deg_list->ive[j-i] = 0; else { for ( j = i; j < n; j++ ) deg_list->ive[j-i] = 1; if ( i < n ) deg_list->ive[0] = 0; } order = px_resize(order,n-i); px_ident(order); if ( ! ignore_deg ) { for ( j = i; j < n; j++ ) { /* idx = sprow_idx(&(A->row[j]),j+1); */ /* idx = fixindex(idx); */ idx = 0; row = &(A->row[j]); e = &(row->elt[idx]); /* deg_list->ive[j-i] += row->len - idx; */ for ( ; idx < row->len; idx++, e++ ) if ( e->col >= i ) deg_list->ive[e->col - i]++; } /* now deg_list[k] == degree of node k+i */ /* now sort them into increasing order */ iv_sort(deg_list,order); /* now deg_list[idx] == degree of node i+order[idx] */ } /* now we can chase through the nodes in order of increasing degree, picking out the ones that satisfy our stability criterion */ list_idx = 0; r = -1; best_j = best_l = -1; for ( deg = 0; deg <= n; deg++ ) { Real ajj, all, ajl; if ( list_idx >= deg_list->dim ) break; /* That's all folks! */ old_list_idx = list_idx; while ( list_idx < deg_list->dim && deg_list->ive[list_idx] <= deg ) { j = i+order->pe[list_idx]; if ( j < i ) continue; /* can we use row/col j for a 1 x 1 pivot? */ /* find max_j = max_{k>=i} {|A[k][j]|,|A[j][k]|} */ ajj = fabs(unord_get_val(A,j,j)); if ( ajj == 0.0 ) { list_idx++; continue; /* can't use this for 1 x 1 pivot */ } max_j = max_row_col(A,i,j,-1); if ( ajj >= tol/* *alpha */ *max_j ) { onebyone = TRUE; best_j = j; best_deg = deg_list->ive[list_idx]; break; } list_idx++; } if ( best_j >= 0 ) break; best_cost = 2*n; /* > any possible Markowitz cost (bound) */ best_j = best_l = -1; list_idx = old_list_idx; while ( list_idx < deg_list->dim && deg_list->ive[list_idx] <= deg ) { j = i+order->pe[list_idx]; ajj = fabs(unord_get_val(A,j,j)); for ( list_idx2 = 0; list_idx2 < list_idx; list_idx2++ ) { deg_j = deg; deg_l = deg_list->ive[list_idx2]; l = i+order->pe[list_idx2]; if ( l < i ) continue; /* try using rows/cols (j,l) for a 2 x 2 pivot block */ all = fabs(unord_get_val(A,l,l)); ajl = ( j > l ) ? fabs(unord_get_val(A,l,j)) : fabs(unord_get_val(A,j,l)); det = fabs(ajj*all - ajl*ajl); if ( det == 0.0 ) continue; max_j = max_row_col(A,i,j,l); max_l = max_row_col(A,i,l,j); if ( tol*(all*max_j+ajl*max_l) < det && tol*(ajl*max_j+ajj*max_l) < det ) { /* acceptably stable 2 x 2 pivot */ /* this is actually an overestimate of the Markowitz cost for choosing (j,l) */ mark_cost = (ajj == 0.0) ? ((all == 0.0) ? deg_j+deg_l : deg_j+2*deg_l) : ((all == 0.0) ? 2*deg_j+deg_l : 2*(deg_j+deg_l)); if ( mark_cost < best_cost ) { onebyone = FALSE; best_cost = mark_cost; best_j = j; best_l = l; best_deg = deg_j; } } } list_idx++; } if ( best_j >= 0 ) break; } if ( best_deg > (int)floor(0.8*(n-i)) ) ignore_deg = TRUE; /* now do actual interchanges */ if ( best_j >= 0 && onebyone ) { bkp_interchange(A,i,best_j); px_transp(pivot,i,best_j); } else if ( best_j >= 0 && best_l >= 0 && ! onebyone ) { if ( best_j == i || best_j == i+1 ) { if ( best_l == i || best_l == i+1 ) { /* no pivoting, but must update blocks permutation */ px_transp(blocks,i,i+1); goto dopivot; } bkp_interchange(A,(best_j == i) ? i+1 : i,best_l); px_transp(pivot,(best_j == i) ? i+1 : i,best_l); } else if ( best_l == i || best_l == i+1 ) { bkp_interchange(A,(best_l == i) ? i+1 : i,best_j); px_transp(pivot,(best_l == i) ? i+1 : i,best_j); } else /* best_j & best_l outside i, i+1 */ { if ( i != best_j ) { bkp_interchange(A,i,best_j); px_transp(pivot,i,best_j); } if ( i+1 != best_l ) { bkp_interchange(A,i+1,best_l); px_transp(pivot,i+1,best_l); } } } else /* can't pivot &/or nothing to pivot */ continue; /* update blocks permutation */ if ( ! onebyone ) px_transp(blocks,i,i+1); dopivot: if ( onebyone ) { int idx_j, idx_k, s_idx, s_idx2; row_elt *e_ij, *e_ik; r_piv = &(A->row[i]); idx_piv = unord_get_idx(r_piv,i); /* if idx_piv < 0 then aii == 0 and no pivoting can be done; -- this means that we should continue to the next iteration */ if ( idx_piv < 0 ) continue; aii = r_piv->elt[idx_piv].val; if ( aii == 0.0 ) continue; /* for ( j = i+1; j < n; j++ ) { ... pivot step ... } */ /* initialise scan_... etc for the 1 x 1 pivot */ scan_row = iv_resize(scan_row,r_piv->len); scan_idx = iv_resize(scan_idx,r_piv->len); col_list = iv_resize(col_list,r_piv->len); orig_idx = iv_resize(orig_idx,r_piv->len); row_num = i; s_idx = idx = 0; e = &(r_piv->elt[idx]); for ( idx = 0; idx < r_piv->len; idx++, e++ ) { if ( e->col < i ) continue; scan_row->ive[s_idx] = i; scan_idx->ive[s_idx] = idx; orig_idx->ive[s_idx] = idx; col_list->ive[s_idx] = e->col; s_idx++; } scan_row = iv_resize(scan_row,s_idx); scan_idx = iv_resize(scan_idx,s_idx); col_list = iv_resize(col_list,s_idx); orig_idx = iv_resize(orig_idx,s_idx); order = px_resize(order,scan_row->dim); px_ident(order); iv_sort(col_list,order); tmp_iv = iv_resize(tmp_iv,scan_row->dim); for ( idx = 0; idx < order->size; idx++ ) tmp_iv->ive[idx] = scan_idx->ive[order->pe[idx]]; iv_copy(tmp_iv,scan_idx); for ( idx = 0; idx < order->size; idx++ ) tmp_iv->ive[idx] = scan_row->ive[order->pe[idx]]; iv_copy(tmp_iv,scan_row); for ( idx = 0; idx < scan_row->dim; idx++ ) tmp_iv->ive[idx] = orig_idx->ive[order->pe[idx]]; iv_copy(tmp_iv,orig_idx); /* now do actual pivot */ /* for ( j = i+1; j < n-1; j++ ) .... */ for ( s_idx = 0; s_idx < scan_row->dim; s_idx++ ) { idx_j = orig_idx->ive[s_idx]; if ( idx_j < 0 ) error(E_INTERN,"spBKPfactor"); e_ij = &(r_piv->elt[idx_j]); j = e_ij->col; if ( j < i+1 ) continue; scan_to(A,scan_row,scan_idx,col_list,j); /* compute multiplier */ t = e_ij->val / aii; /* for ( k = j; k < n; k++ ) { .... update A[j][k] .... } */ /* this is the row in which pivoting is done */ row = &(A->row[j]); for ( s_idx2 = s_idx; s_idx2 < scan_row->dim; s_idx2++ ) { idx_k = orig_idx->ive[s_idx2]; e_ik = &(r_piv->elt[idx_k]); k = e_ik->col; /* k >= j since col_list has been sorted */ if ( scan_row->ive[s_idx2] == j ) { /* no fill-in -- can be done directly */ idx = scan_idx->ive[s_idx2]; /* idx = sprow_idx2(row,k,idx); */ row->elt[idx].val -= t*e_ik->val; } else { /* fill-in -- insert entry & patch column */ int old_row, old_idx; row_elt *old_e, *new_e; old_row = scan_row->ive[s_idx2]; old_idx = scan_idx->ive[s_idx2]; /* old_idx = sprow_idx2(&(A->row[old_row]),k,old_idx); */ if ( old_idx < 0 ) error(E_INTERN,"spBKPfactor"); /* idx = sprow_idx(row,k); */ /* idx = fixindex(idx); */ idx = row->len; /* sprow_set_val(row,k,-t*e_ik->val); */ if ( row->len >= row->maxlen ) { tracecatch(sprow_xpd(row,2*row->maxlen+1,TYPE_SPMAT), "spBKPfactor"); } row->len = idx+1; new_e = &(row->elt[idx]); new_e->val = -t*e_ik->val; new_e->col = k; old_e = &(A->row[old_row].elt[old_idx]); new_e->nxt_row = old_e->nxt_row; new_e->nxt_idx = old_e->nxt_idx; old_e->nxt_row = j; old_e->nxt_idx = idx; } } e_ij->val = t; } } else /* onebyone == FALSE */ { /* do 2 x 2 pivot */ int idx_k, idx1_k, s_idx, s_idx2; int old_col; row_elt *e_tmp; r_piv = &(A->row[i]); idx_piv = unord_get_idx(r_piv,i); aii = aip1i = 0.0; e_tmp = r_piv->elt; for ( idx_piv = 0; idx_piv < r_piv->len; idx_piv++, e_tmp++ ) if ( e_tmp->col == i ) aii = e_tmp->val; else if ( e_tmp->col == i+1 ) aip1i = e_tmp->val; r1_piv = &(A->row[i+1]); e_tmp = r1_piv->elt; aip1 = unord_get_val(A,i+1,i+1); det = aii*aip1 - aip1i*aip1i; /* Must have det < 0 */ if ( aii == 0.0 && aip1i == 0.0 ) { /* error(E_RANGE,"spBKPfactor"); */ onebyone = TRUE; continue; /* cannot pivot */ } if ( det == 0.0 ) { if ( aii != 0.0 ) error(E_RANGE,"spBKPfactor"); onebyone = TRUE; continue; /* cannot pivot */ } aip1i = aip1i/det; aii = aii/det; aip1 = aip1/det; /* initialise scan_... etc for the 2 x 2 pivot */ s_idx = r_piv->len + r1_piv->len; scan_row = iv_resize(scan_row,s_idx); scan_idx = iv_resize(scan_idx,s_idx); col_list = iv_resize(col_list,s_idx); orig_idx = iv_resize(orig_idx,s_idx); orig1_idx = iv_resize(orig1_idx,s_idx); e = r_piv->elt; for ( idx = 0; idx < r_piv->len; idx++, e++ ) { scan_row->ive[idx] = i; scan_idx->ive[idx] = idx; col_list->ive[idx] = e->col; orig_idx->ive[idx] = idx; orig1_idx->ive[idx] = -1; } e = r_piv->elt; e1 = r1_piv->elt; for ( idx = 0; idx < r1_piv->len; idx++, e1++ ) { scan_row->ive[idx+r_piv->len] = i+1; scan_idx->ive[idx+r_piv->len] = idx; col_list->ive[idx+r_piv->len] = e1->col; orig_idx->ive[idx+r_piv->len] = -1; orig1_idx->ive[idx+r_piv->len] = idx; } e1 = r1_piv->elt; order = px_resize(order,scan_row->dim); px_ident(order); iv_sort(col_list,order); tmp_iv = iv_resize(tmp_iv,scan_row->dim); for ( idx = 0; idx < order->size; idx++ ) tmp_iv->ive[idx] = scan_idx->ive[order->pe[idx]]; iv_copy(tmp_iv,scan_idx); for ( idx = 0; idx < order->size; idx++ ) tmp_iv->ive[idx] = scan_row->ive[order->pe[idx]]; iv_copy(tmp_iv,scan_row); for ( idx = 0; idx < scan_row->dim; idx++ ) tmp_iv->ive[idx] = orig_idx->ive[order->pe[idx]]; iv_copy(tmp_iv,orig_idx); for ( idx = 0; idx < scan_row->dim; idx++ ) tmp_iv->ive[idx] = orig1_idx->ive[order->pe[idx]]; iv_copy(tmp_iv,orig1_idx); s_idx = 0; old_col = -1; for ( idx = 0; idx < scan_row->dim; idx++ ) { if ( col_list->ive[idx] == old_col ) { if ( scan_row->ive[idx] == i ) { scan_row->ive[s_idx-1] = scan_row->ive[idx]; scan_idx->ive[s_idx-1] = scan_idx->ive[idx]; col_list->ive[s_idx-1] = col_list->ive[idx]; orig_idx->ive[s_idx-1] = orig_idx->ive[idx]; orig1_idx->ive[s_idx-1] = orig1_idx->ive[idx-1]; } else if ( idx > 0 ) { scan_row->ive[s_idx-1] = scan_row->ive[idx-1]; scan_idx->ive[s_idx-1] = scan_idx->ive[idx-1]; col_list->ive[s_idx-1] = col_list->ive[idx-1]; orig_idx->ive[s_idx-1] = orig_idx->ive[idx-1]; orig1_idx->ive[s_idx-1] = orig1_idx->ive[idx]; } } else { scan_row->ive[s_idx] = scan_row->ive[idx]; scan_idx->ive[s_idx] = scan_idx->ive[idx]; col_list->ive[s_idx] = col_list->ive[idx]; orig_idx->ive[s_idx] = orig_idx->ive[idx]; orig1_idx->ive[s_idx] = orig1_idx->ive[idx]; s_idx++; } old_col = col_list->ive[idx]; } scan_row = iv_resize(scan_row,s_idx); scan_idx = iv_resize(scan_idx,s_idx); col_list = iv_resize(col_list,s_idx); orig_idx = iv_resize(orig_idx,s_idx); orig1_idx = iv_resize(orig1_idx,s_idx); /* for ( j = i+2; j < n; j++ ) { .... row operation .... } */ for ( s_idx = 0; s_idx < scan_row->dim; s_idx++ ) { int idx_piv, idx1_piv; Real aip1j, aij, aik, aip1k; row_elt *e_ik, *e_ip1k; j = col_list->ive[s_idx]; if ( j < i+2 ) continue; tracecatch(scan_to(A,scan_row,scan_idx,col_list,j), "spBKPfactor"); idx_piv = orig_idx->ive[s_idx]; aij = ( idx_piv < 0 ) ? 0.0 : r_piv->elt[idx_piv].val; /* aij = ( s_idx < r_piv->len ) ? r_piv->elt[s_idx].val : 0.0; */ /* aij = sp_get_val(A,i,j); */ idx1_piv = orig1_idx->ive[s_idx]; aip1j = ( idx1_piv < 0 ) ? 0.0 : r1_piv->elt[idx1_piv].val; /* aip1j = ( s_idx < r_piv->len ) ? 0.0 : r1_piv->elt[s_idx-r_piv->len].val; */ /* aip1j = sp_get_val(A,i+1,j); */ s = - aip1i*aip1j + aip1*aij; t = - aip1i*aij + aii*aip1j; /* for ( k = j; k < n; k++ ) { .... update entry .... } */ row = &(A->row[j]); /* set idx_k and idx1_k indices */ s_idx2 = s_idx; k = col_list->ive[s_idx2]; idx_k = orig_idx->ive[s_idx2]; idx1_k = orig1_idx->ive[s_idx2]; while ( s_idx2 < scan_row->dim ) { k = col_list->ive[s_idx2]; idx_k = orig_idx->ive[s_idx2]; idx1_k = orig1_idx->ive[s_idx2]; e_ik = ( idx_k < 0 ) ? (row_elt *)NULL : &(r_piv->elt[idx_k]); e_ip1k = ( idx1_k < 0 ) ? (row_elt *)NULL : &(r1_piv->elt[idx1_k]); aik = ( idx_k >= 0 ) ? e_ik->val : 0.0; aip1k = ( idx1_k >= 0 ) ? e_ip1k->val : 0.0; if ( scan_row->ive[s_idx2] == j ) { /* no fill-in */ row = &(A->row[j]); /* idx = sprow_idx(row,k); */ idx = scan_idx->ive[s_idx2]; if ( idx < 0 ) error(E_INTERN,"spBKPfactor"); row->elt[idx].val -= s*aik + t*aip1k; } else { /* fill-in -- insert entry & patch column */ Real tmp; int old_row, old_idx; row_elt *old_e, *new_e; tmp = - s*aik - t*aip1k; if ( tmp != 0.0 ) { row = &(A->row[j]); old_row = scan_row->ive[s_idx2]; old_idx = scan_idx->ive[s_idx2]; idx = row->len; if ( row->len >= row->maxlen ) { tracecatch(sprow_xpd(row,2*row->maxlen+1, TYPE_SPMAT), "spBKPfactor"); } row->len = idx + 1; /* idx = sprow_idx(row,k); */ new_e = &(row->elt[idx]); new_e->val = tmp; new_e->col = k; if ( old_row < 0 ) error(E_INTERN,"spBKPfactor"); /* old_idx = sprow_idx2(&(A->row[old_row]), k,old_idx); */ old_e = &(A->row[old_row].elt[old_idx]); new_e->nxt_row = old_e->nxt_row; new_e->nxt_idx = old_e->nxt_idx; old_e->nxt_row = j; old_e->nxt_idx = idx; } } /* update idx_k, idx1_k, s_idx2 etc */ s_idx2++; } /* store multipliers -- may involve fill-in (!) */ /* idx = sprow_idx(r_piv,j); */ idx = orig_idx->ive[s_idx]; if ( idx >= 0 ) { r_piv->elt[idx].val = s; } else if ( s != 0.0 ) { int old_row, old_idx; row_elt *new_e, *old_e; old_row = -1; old_idx = j; if ( i > 0 ) { tracecatch(chase_col(A,j,&old_row,&old_idx,i-1), "spBKPfactor"); } /* sprow_set_val(r_piv,j,s); */ idx = r_piv->len; if ( r_piv->len >= r_piv->maxlen ) { tracecatch(sprow_xpd(r_piv,2*r_piv->maxlen+1, TYPE_SPMAT), "spBKPfactor"); } r_piv->len = idx + 1; /* idx = sprow_idx(r_piv,j); */ /* if ( idx < 0 ) error(E_INTERN,"spBKPfactor"); */ new_e = &(r_piv->elt[idx]); new_e->val = s; new_e->col = j; if ( old_row < 0 ) { new_e->nxt_row = A->start_row[j]; new_e->nxt_idx = A->start_idx[j]; A->start_row[j] = i; A->start_idx[j] = idx; } else { /* old_idx = sprow_idx2(&(A->row[old_row]),j,old_idx);*/ if ( old_idx < 0 ) error(E_INTERN,"spBKPfactor"); old_e = &(A->row[old_row].elt[old_idx]); new_e->nxt_row = old_e->nxt_row; new_e->nxt_idx = old_e->nxt_idx; old_e->nxt_row = i; old_e->nxt_idx = idx; } } /* idx1 = sprow_idx(r1_piv,j); */ idx1 = orig1_idx->ive[s_idx]; if ( idx1 >= 0 ) { r1_piv->elt[idx1].val = t; } else if ( t != 0.0 ) { int old_row, old_idx; row_elt *new_e, *old_e; old_row = -1; old_idx = j; tracecatch(chase_col(A,j,&old_row,&old_idx,i), "spBKPfactor"); /* sprow_set_val(r1_piv,j,t); */ idx1 = r1_piv->len; if ( r1_piv->len >= r1_piv->maxlen ) { tracecatch(sprow_xpd(r1_piv,2*r1_piv->maxlen+1, TYPE_SPMAT), "spBKPfactor"); } r1_piv->len = idx1 + 1; /* idx1 = sprow_idx(r1_piv,j); */ /* if ( idx < 0 ) error(E_INTERN,"spBKPfactor"); */ new_e = &(r1_piv->elt[idx1]); new_e->val = t; new_e->col = j; if ( idx1 < 0 ) error(E_INTERN,"spBKPfactor"); new_e = &(r1_piv->elt[idx1]); if ( old_row < 0 ) { new_e->nxt_row = A->start_row[j]; new_e->nxt_idx = A->start_idx[j]; A->start_row[j] = i+1; A->start_idx[j] = idx1; } else { old_idx = sprow_idx2(&(A->row[old_row]),j,old_idx); if ( old_idx < 0 ) error(E_INTERN,"spBKPfactor"); old_e = &(A->row[old_row].elt[old_idx]); new_e->nxt_row = old_e->nxt_row; new_e->nxt_idx = old_e->nxt_idx; old_e->nxt_row = i+1; old_e->nxt_idx = idx1; } } } } } /* now sort the rows arrays */ for ( i = 0; i < A->m; i++ ) qsort(A->row[i].elt,A->row[i].len,sizeof(row_elt),(int(*)())col_cmp); A->flag_col = A->flag_diag = FALSE; return A; } /* spBKPsolve -- solves A.x = b where A has been factored a la BKPfactor() -- returns x, which is created if NULL */ VEC *spBKPsolve(A,pivot,block,b,x) SPMAT *A; PERM *pivot, *block; VEC *b, *x; { static VEC *tmp=VNULL; /* dummy storage needed */ int i /* , j */, n, onebyone; int row_num, idx; Real a11, a12, a22, b1, b2, det, sum, *tmp_ve, tmp_diag; SPROW *r; row_elt *e; if ( ! A || ! pivot || ! block || ! b ) error(E_NULL,"spBKPsolve"); if ( A->m != A->n ) error(E_SQUARE,"spBKPsolve"); n = A->n; if ( b->dim != n || pivot->size != n || block->size != n ) error(E_SIZES,"spBKPsolve"); x = v_resize(x,n); tmp = v_resize(tmp,n); MEM_STAT_REG(tmp,TYPE_VEC); tmp_ve = tmp->ve; if ( ! A->flag_col ) sp_col_access(A); px_vec(pivot,b,tmp); /* printf("# BKPsolve: effect of pivot: tmp =\n"); v_output(tmp); */ /* solve for lower triangular part */ for ( i = 0; i < n; i++ ) { sum = tmp_ve[i]; if ( block->pe[i] < i ) { /* for ( j = 0; j < i-1; j++ ) sum -= A_me[j][i]*tmp_ve[j]; */ row_num = -1; idx = i; e = bump_col(A,i,&row_num,&idx); while ( row_num >= 0 && row_num < i-1 ) { sum -= e->val*tmp_ve[row_num]; e = bump_col(A,i,&row_num,&idx); } } else { /* for ( j = 0; j < i; j++ ) sum -= A_me[j][i]*tmp_ve[j]; */ row_num = -1; idx = i; e = bump_col(A,i,&row_num,&idx); while ( row_num >= 0 && row_num < i ) { sum -= e->val*tmp_ve[row_num]; e = bump_col(A,i,&row_num,&idx); } } tmp_ve[i] = sum; } /* printf("# BKPsolve: solving L part: tmp =\n"); v_output(tmp); */ /* solve for diagonal part */ for ( i = 0; i < n; i = onebyone ? i+1 : i+2 ) { onebyone = ( block->pe[i] == i ); if ( onebyone ) { /* tmp_ve[i] /= A_me[i][i]; */ tmp_diag = sp_get_val(A,i,i); if ( tmp_diag == 0.0 ) error(E_SING,"spBKPsolve"); tmp_ve[i] /= tmp_diag; } else { a11 = sp_get_val(A,i,i); a22 = sp_get_val(A,i+1,i+1); a12 = sp_get_val(A,i,i+1); b1 = tmp_ve[i]; b2 = tmp_ve[i+1]; det = a11*a22-a12*a12; /* < 0 : see BKPfactor() */ if ( det == 0.0 ) error(E_SING,"BKPsolve"); det = 1/det; tmp_ve[i] = det*(a22*b1-a12*b2); tmp_ve[i+1] = det*(a11*b2-a12*b1); } } /* printf("# BKPsolve: solving D part: tmp =\n"); v_output(tmp); */ /* solve for transpose of lower triangular part */ for ( i = n-2; i >= 0; i-- ) { sum = tmp_ve[i]; if ( block->pe[i] > i ) { /* onebyone is false */ /* for ( j = i+2; j < n; j++ ) sum -= A_me[i][j]*tmp_ve[j]; */ if ( i+2 >= n ) continue; r = &(A->row[i]); idx = sprow_idx(r,i+2); idx = fixindex(idx); e = &(r->elt[idx]); for ( ; idx < r->len; idx++, e++ ) sum -= e->val*tmp_ve[e->col]; } else /* onebyone */ { /* for ( j = i+1; j < n; j++ ) sum -= A_me[i][j]*tmp_ve[j]; */ r = &(A->row[i]); idx = sprow_idx(r,i+1); idx = fixindex(idx); e = &(r->elt[idx]); for ( ; idx < r->len; idx++, e++ ) sum -= e->val*tmp_ve[e->col]; } tmp_ve[i] = sum; } /* printf("# BKPsolve: solving L^T part: tmp =\n");v_output(tmp); */ /* and do final permutation */ x = pxinv_vec(pivot,tmp,x); return x; } meschach-1.2b/spswap.c100644 764 764 16310 5673125046 14360 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse matrix swap and permutation routines Modified Mon 09th Nov 1992, 08:50:54 PM to use Karen George's suggestion to use unordered rows */ static char rcsid[] = "$Id: spswap.c,v 1.3 1994/01/13 05:44:43 des Exp $"; #include #include "sparse2.h" #include #define btos(x) ((x) ? "TRUE" : "FALSE") /* scan_to -- updates scan (int) vectors to point to the last row in each column with row # <= max_row, if any */ void scan_to(A, scan_row, scan_idx, col_list, max_row) SPMAT *A; IVEC *scan_row, *scan_idx, *col_list; int max_row; { int col, idx, j_idx, row_num; SPROW *r; row_elt *e; if ( ! A || ! scan_row || ! scan_idx || ! col_list ) error(E_NULL,"scan_to"); if ( scan_row->dim != scan_idx->dim || scan_idx->dim != col_list->dim ) error(E_SIZES,"scan_to"); if ( max_row < 0 ) return; if ( ! A->flag_col ) sp_col_access(A); for ( j_idx = 0; j_idx < scan_row->dim; j_idx++ ) { row_num = scan_row->ive[j_idx]; idx = scan_idx->ive[j_idx]; col = col_list->ive[j_idx]; if ( col < 0 || col >= A->n ) error(E_BOUNDS,"scan_to"); if ( row_num < 0 ) { idx = col; continue; } r = &(A->row[row_num]); if ( idx < 0 ) error(E_INTERN,"scan_to"); e = &(r->elt[idx]); if ( e->col != col ) error(E_INTERN,"scan_to"); if ( idx < 0 ) { printf("scan_to: row_num = %d, idx = %d, col = %d\n", row_num, idx, col); error(E_INTERN,"scan_to"); } /* if ( e->nxt_row <= max_row ) chase_col(A, col, &row_num, &idx, max_row); */ while ( e->nxt_row >= 0 && e->nxt_row <= max_row ) { row_num = e->nxt_row; idx = e->nxt_idx; e = &(A->row[row_num].elt[idx]); } /* printf("scan_to: computed j_idx = %d, row_num = %d, idx = %d\n", j_idx, row_num, idx); */ scan_row->ive[j_idx] = row_num; scan_idx->ive[j_idx] = idx; } } /* patch_col -- patches column access paths for fill-in */ void patch_col(A, col, old_row, old_idx, row_num, idx) SPMAT *A; int col, old_row, old_idx, row_num, idx; { SPROW *r; row_elt *e; if ( old_row >= 0 ) { r = &(A->row[old_row]); old_idx = sprow_idx2(r,col,old_idx); e = &(r->elt[old_idx]); e->nxt_row = row_num; e->nxt_idx = idx; } else { A->start_row[col] = row_num; A->start_idx[col] = idx; } } /* chase_col -- chases column access path in column col, starting with row_num and idx, to find last row # in this column <= max_row -- row_num is returned; idx is also set by this routine -- assumes that the column access paths (possibly without the nxt_idx fields) are set up */ row_elt *chase_col(A, col, row_num, idx, max_row) SPMAT *A; int col, *row_num, *idx, max_row; { int old_idx, old_row, tmp_idx, tmp_row; SPROW *r; row_elt *e; if ( col < 0 || col >= A->n ) error(E_BOUNDS,"chase_col"); tmp_row = *row_num; if ( tmp_row < 0 ) { if ( A->start_row[col] > max_row ) { tmp_row = -1; tmp_idx = col; return (row_elt *)NULL; } else { tmp_row = A->start_row[col]; tmp_idx = A->start_idx[col]; } } else tmp_idx = *idx; old_row = tmp_row; old_idx = tmp_idx; while ( tmp_row >= 0 && tmp_row < max_row ) { r = &(A->row[tmp_row]); /* tmp_idx = sprow_idx2(r,col,tmp_idx); */ if ( tmp_idx < 0 || tmp_idx >= r->len || r->elt[tmp_idx].col != col ) { #ifdef DEBUG printf("chase_col:error: col = %d, row # = %d, idx = %d\n", col, tmp_row, tmp_idx); printf("chase_col:error: old_row = %d, old_idx = %d\n", old_row, old_idx); printf("chase_col:error: A =\n"); sp_dump(stdout,A); #endif error(E_INTERN,"chase_col"); } e = &(r->elt[tmp_idx]); old_row = tmp_row; old_idx = tmp_idx; tmp_row = e->nxt_row; tmp_idx = e->nxt_idx; } if ( old_row > max_row ) { old_row = -1; old_idx = col; e = (row_elt *)NULL; } else if ( tmp_row <= max_row && tmp_row >= 0 ) { old_row = tmp_row; old_idx = tmp_idx; } *row_num = old_row; if ( old_row >= 0 ) *idx = old_idx; else *idx = col; return e; } /* chase_past -- as for chase_col except that we want the first row whose row # >= min_row; -1 indicates no such row */ row_elt *chase_past(A, col, row_num, idx, min_row) SPMAT *A; int col, *row_num, *idx, min_row; { SPROW *r; row_elt *e; int tmp_idx, tmp_row; tmp_row = *row_num; tmp_idx = *idx; chase_col(A,col,&tmp_row,&tmp_idx,min_row); if ( tmp_row < 0 ) /* use A->start_row[..] etc. */ { if ( A->start_row[col] < 0 ) tmp_row = -1; else { tmp_row = A->start_row[col]; tmp_idx = A->start_idx[col]; } } else if ( tmp_row < min_row ) { r = &(A->row[tmp_row]); if ( tmp_idx < 0 || tmp_idx >= r->len || r->elt[tmp_idx].col != col ) error(E_INTERN,"chase_past"); tmp_row = r->elt[tmp_idx].nxt_row; tmp_idx = r->elt[tmp_idx].nxt_idx; } *row_num = tmp_row; *idx = tmp_idx; if ( tmp_row < 0 ) e = (row_elt *)NULL; else { if ( tmp_idx < 0 || tmp_idx >= A->row[tmp_row].len || A->row[tmp_row].elt[tmp_idx].col != col ) error(E_INTERN,"bump_col"); e = &(A->row[tmp_row].elt[tmp_idx]); } return e; } /* bump_col -- move along to next nonzero entry in column col after row_num -- update row_num and idx */ row_elt *bump_col(A, col, row_num, idx) SPMAT *A; int col, *row_num, *idx; { SPROW *r; row_elt *e; int tmp_row, tmp_idx; tmp_row = *row_num; tmp_idx = *idx; /* printf("bump_col: col = %d, row# = %d, idx = %d\n", col, *row_num, *idx); */ if ( tmp_row < 0 ) { tmp_row = A->start_row[col]; tmp_idx = A->start_idx[col]; } else { r = &(A->row[tmp_row]); if ( tmp_idx < 0 || tmp_idx >= r->len || r->elt[tmp_idx].col != col ) error(E_INTERN,"bump_col"); e = &(r->elt[tmp_idx]); tmp_row = e->nxt_row; tmp_idx = e->nxt_idx; } if ( tmp_row < 0 ) { e = (row_elt *)NULL; tmp_idx = col; } else { if ( tmp_idx < 0 || tmp_idx >= A->row[tmp_row].len || A->row[tmp_row].elt[tmp_idx].col != col ) error(E_INTERN,"bump_col"); e = &(A->row[tmp_row].elt[tmp_idx]); } *row_num = tmp_row; *idx = tmp_idx; return e; } meschach-1.2b/iter0.c100644 764 764 21166 5741264434 14074 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* iter0.c 14/09/93 */ /* ITERATIVE METHODS - service functions */ /* functions for creating and releasing ITER structures; for memory information; for getting some values from an ITER variable; for changing values in an ITER variable; see also iter.c */ #include #include "iter.h" #include static char rcsid[] = "$Id: iter0.c,v 1.3 1995/01/30 14:50:56 des Exp $"; /* standard functions */ /* standard information */ void iter_std_info(ip,nres,res,Bres) ITER *ip; double nres; VEC *res, *Bres; { if (nres >= 0.0) printf(" %d. residual = %g\n",ip->steps,nres); else printf(" %d. residual = %g (WARNING !!! should be >= 0) \n", ip->steps,nres); } /* standard stopping criterion */ int iter_std_stop_crit(ip, nres, res, Bres) ITER *ip; double nres; VEC *res, *Bres; { /* standard stopping criterium */ if (nres <= ip->init_res*ip->eps) return TRUE; return FALSE; } /* iter_get - create a new structure pointing to ITER */ ITER *iter_get(lenb, lenx) int lenb, lenx; { ITER *ip; if ((ip = NEW(ITER)) == (ITER *) NULL) error(E_MEM,"iter_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_ITER,0,sizeof(ITER)); mem_numvar(TYPE_ITER,1); } /* default values */ ip->shared_x = FALSE; ip->shared_b = FALSE; ip->k = 0; ip->limit = ITER_LIMIT_DEF; ip->eps = ITER_EPS_DEF; ip->steps = 0; if (lenb > 0) ip->b = v_get(lenb); else ip->b = (VEC *)NULL; if (lenx > 0) ip->x = v_get(lenx); else ip->x = (VEC *)NULL; ip->Ax = (Fun_Ax) NULL; ip->A_par = NULL; ip->ATx = (Fun_Ax) NULL; ip->AT_par = NULL; ip->Bx = (Fun_Ax) NULL; ip->B_par = NULL; ip->info = iter_std_info; ip->stop_crit = iter_std_stop_crit; ip->init_res = 0.0; return ip; } /* iter_free - release memory */ int iter_free(ip) ITER *ip; { if (ip == (ITER *)NULL) return -1; if (mem_info_is_on()) { mem_bytes(TYPE_ITER,sizeof(ITER),0); mem_numvar(TYPE_ITER,-1); } if ( !ip->shared_x && ip->x != NULL ) v_free(ip->x); if ( !ip->shared_b && ip->b != NULL ) v_free(ip->b); free((char *)ip); return 0; } ITER *iter_resize(ip,new_lenb,new_lenx) ITER *ip; int new_lenb, new_lenx; { VEC *old; if ( ip == (ITER *) NULL) error(E_NULL,"iter_resize"); old = ip->x; ip->x = v_resize(ip->x,new_lenx); if ( ip->shared_x && old != ip->x ) warning(WARN_SHARED_VEC,"iter_resize"); old = ip->b; ip->b = v_resize(ip->b,new_lenb); if ( ip->shared_b && old != ip->b ) warning(WARN_SHARED_VEC,"iter_resize"); return ip; } /* print out ip structure - for diagnostic purposes mainly */ void iter_dump(fp,ip) ITER *ip; FILE *fp; { if (ip == NULL) { fprintf(fp," ITER structure: NULL\n"); return; } fprintf(fp,"\n ITER structure:\n"); fprintf(fp," ip->shared_x = %s, ip->shared_b = %s\n", (ip->shared_x ? "TRUE" : "FALSE"), (ip->shared_b ? "TRUE" : "FALSE") ); fprintf(fp," ip->k = %d, ip->limit = %d, ip->steps = %d, ip->eps = %g\n", ip->k,ip->limit,ip->steps,ip->eps); fprintf(fp," ip->x = 0x%p, ip->b = 0x%p\n",ip->x,ip->b); fprintf(fp," ip->Ax = 0x%p, ip->A_par = 0x%p\n",ip->Ax,ip->A_par); fprintf(fp," ip->ATx = 0x%p, ip->AT_par = 0x%p\n",ip->ATx,ip->AT_par); fprintf(fp," ip->Bx = 0x%p, ip->B_par = 0x%p\n",ip->Bx,ip->B_par); fprintf(fp," ip->info = 0x%p, ip->stop_crit = 0x%p, ip->init_res = %g\n", ip->info,ip->stop_crit,ip->init_res); fprintf(fp,"\n"); } /* copy the structure ip1 to ip2 preserving vectors x and b of ip2 (vectors x and b in ip2 are the same before and after iter_copy2) if ip2 == NULL then a new structure is created with x and b being NULL and other members are taken from ip1 */ ITER *iter_copy2(ip1,ip2) ITER *ip1, *ip2; { VEC *x, *b; int shx, shb; if (ip1 == (ITER *)NULL) error(E_NULL,"iter_copy2"); if (ip2 == (ITER *)NULL) { if ((ip2 = NEW(ITER)) == (ITER *) NULL) error(E_MEM,"iter_copy2"); else if (mem_info_is_on()) { mem_bytes(TYPE_ITER,0,sizeof(ITER)); mem_numvar(TYPE_ITER,1); } ip2->x = ip2->b = NULL; ip2->shared_x = ip2->shared_x = FALSE; } x = ip2->x; b = ip2->b; shb = ip2->shared_b; shx = ip2->shared_x; MEM_COPY(ip1,ip2,sizeof(ITER)); ip2->x = x; ip2->b = b; ip2->shared_x = shx; ip2->shared_b = shb; return ip2; } /* copy the structure ip1 to ip2 copying also the vectors x and b */ ITER *iter_copy(ip1,ip2) ITER *ip1, *ip2; { VEC *x, *b; if (ip1 == (ITER *)NULL) error(E_NULL,"iter_copy"); if (ip2 == (ITER *)NULL) { if ((ip2 = NEW(ITER)) == (ITER *) NULL) error(E_MEM,"iter_copy2"); else if (mem_info_is_on()) { mem_bytes(TYPE_ITER,0,sizeof(ITER)); mem_numvar(TYPE_ITER,1); } } x = ip2->x; b = ip2->b; MEM_COPY(ip1,ip2,sizeof(ITER)); if (ip1->x) ip2->x = v_copy(ip1->x,x); if (ip1->b) ip2->b = v_copy(ip1->b,b); ip2->shared_x = ip2->shared_b = FALSE; return ip2; } /*** functions to generate sparse matrices with random entries ***/ /* iter_gen_sym -- generate symmetric positive definite n x n matrix, nrow - number of nonzero entries in a row */ SPMAT *iter_gen_sym(n,nrow) int n, nrow; { SPMAT *A; VEC *u; Real s1; int i, j, k, k_max; if (nrow <= 1) nrow = 2; /* nrow should be even */ if ((nrow & 1)) nrow -= 1; A = sp_get(n,n,nrow); u = v_get(A->m); v_zero(u); for ( i = 0; i < A->m; i++ ) { k_max = ((rand() >> 8) % (nrow/2)); for ( k = 0; k <= k_max; k++ ) { j = (rand() >> 8) % A->n; s1 = mrand(); sp_set_val(A,i,j,s1); sp_set_val(A,j,i,s1); u->ve[i] += fabs(s1); u->ve[j] += fabs(s1); } } /* ensure that A is positive definite */ for ( i = 0; i < A->m; i++ ) sp_set_val(A,i,i,u->ve[i] + 1.0); V_FREE(u); return A; } /* iter_gen_nonsym -- generate non-symmetric m x n sparse matrix, m >= n nrow - number of entries in a row; diag - number which is put in diagonal entries and then permuted (if diag is zero then 1.0 is there) */ SPMAT *iter_gen_nonsym(m,n,nrow,diag) int m, n, nrow; double diag; { SPMAT *A; PERM *px; int i, j, k, k_max; Real s1; if (nrow <= 1) nrow = 2; if (diag == 0.0) diag = 1.0; A = sp_get(m,n,nrow); px = px_get(n); for ( i = 0; i < A->m; i++ ) { k_max = (rand() >> 8) % (nrow-1); for ( k = 0; k <= k_max; k++ ) { j = (rand() >> 8) % A->n; s1 = mrand(); sp_set_val(A,i,j,-s1); } } /* to make it likely that A is nonsingular, use pivot... */ for ( i = 0; i < 2*A->n; i++ ) { j = (rand() >> 8) % A->n; k = (rand() >> 8) % A->n; px_transp(px,j,k); } for ( i = 0; i < A->n; i++ ) sp_set_val(A,i,px->pe[i],diag); PX_FREE(px); return A; } /* iter_gen_nonsym -- generate non-symmetric positive definite n x n sparse matrix; nrow - number of entries in a row */ SPMAT *iter_gen_nonsym_posdef(n,nrow) int n, nrow; { SPMAT *A; PERM *px; VEC *u; int i, j, k, k_max; Real s1; if (nrow <= 1) nrow = 2; A = sp_get(n,n,nrow); px = px_get(n); u = v_get(A->m); v_zero(u); for ( i = 0; i < A->m; i++ ) { k_max = (rand() >> 8) % (nrow-1); for ( k = 0; k <= k_max; k++ ) { j = (rand() >> 8) % A->n; s1 = mrand(); sp_set_val(A,i,j,-s1); u->ve[i] += fabs(s1); } } /* ensure that A is positive definite */ for ( i = 0; i < A->m; i++ ) sp_set_val(A,i,i,u->ve[i] + 1.0); PX_FREE(px); V_FREE(u); return A; } meschach-1.2b/itersym.c100644 764 764 33300 5741264512 14533 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* itersym.c 17/09/93 */ /* ITERATIVE METHODS - implementation of several iterative methods; see also iter0.c */ #include #include "matrix.h" #include "matrix2.h" #include "sparse.h" #include "iter.h" #include static char rcsid[] = "$Id: itersym.c,v 1.2 1995/01/30 14:55:54 des Exp $"; #ifdef ANSI_C VEC *spCHsolve(SPMAT *,VEC *,VEC *); VEC *trieig(VEC *,VEC *,MAT *); #else VEC *spCHsolve(); VEC *trieig(); #endif /* iter_spcg -- a simple interface to iter_cg() which uses sparse matrix data structures -- assumes that LLT contains the Cholesky factorisation of the actual preconditioner; use always as follows: x = iter_spcg(A,LLT,b,eps,x,limit,steps); or x = iter_spcg(A,LLT,b,eps,VNULL,limit,steps); In the second case the solution vector is created. */ VEC *iter_spcg(A,LLT,b,eps,x,limit,steps) SPMAT *A, *LLT; VEC *b, *x; double eps; int *steps, limit; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *)A; ip->Bx = (Fun_Ax) spCHsolve; ip->B_par = (void *)LLT; ip->info = (Fun_info) NULL; ip->b = b; ip->eps = eps; ip->limit = limit; ip->x = x; iter_cg(ip); x = ip->x; if (steps) *steps = ip->steps; ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return x; } /* Conjugate gradients method; */ VEC *iter_cg(ip) ITER *ip; { static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; Real alpha, beta, inner, old_inner, nres; VEC *rr; /* rr == r or rr == z */ if (ip == INULL) error(E_NULL,"iter_cg"); if (!ip->Ax || !ip->b) error(E_NULL,"iter_cg"); if ( ip->x == ip->b ) error(E_INSITU,"iter_cg"); if (!ip->stop_crit) error(E_NULL,"iter_cg"); if ( ip->eps <= 0.0 ) ip->eps = MACHEPS; r = v_resize(r,ip->b->dim); p = v_resize(p,ip->b->dim); q = v_resize(q,ip->b->dim); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(p,TYPE_VEC); MEM_STAT_REG(q,TYPE_VEC); if (ip->Bx != (Fun_Ax)NULL) { z = v_resize(z,ip->b->dim); MEM_STAT_REG(z,TYPE_VEC); rr = z; } else rr = r; if (ip->x != VNULL) { if (ip->x->dim != ip->b->dim) error(E_SIZES,"iter_cg"); ip->Ax(ip->A_par,ip->x,p); /* p = A*x */ v_sub(ip->b,p,r); /* r = b - A*x */ } else { /* ip->x == 0 */ ip->x = v_get(ip->b->dim); ip->shared_x = FALSE; v_copy(ip->b,r); } old_inner = 0.0; for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ ) { if ( ip->Bx ) (ip->Bx)(ip->B_par,r,rr); /* rr = B*r */ inner = in_prod(rr,r); nres = sqrt(fabs(inner)); if (ip->info) ip->info(ip,nres,r,rr); if (ip->steps == 0) ip->init_res = nres; if ( ip->stop_crit(ip,nres,r,rr) ) break; if ( ip->steps ) /* if ( ip->steps > 0 ) ... */ { beta = inner/old_inner; p = v_mltadd(rr,p,beta,p); } else /* if ( ip->steps == 0 ) ... */ { beta = 0.0; p = v_copy(rr,p); old_inner = 0.0; } (ip->Ax)(ip->A_par,p,q); /* q = A*p */ alpha = in_prod(p,q); if (sqrt(fabs(alpha)) <= MACHEPS*ip->init_res) error(E_BREAKDOWN,"iter_cg"); alpha = inner/alpha; v_mltadd(ip->x,p,alpha,ip->x); v_mltadd(r,q,-alpha,r); old_inner = inner; } return ip->x; } /* iter_lanczos -- raw lanczos algorithm -- no re-orthogonalisation -- creates T matrix of size == m, but no larger than before beta_k == 0 -- uses passed routine to do matrix-vector multiplies */ void iter_lanczos(ip,a,b,beta2,Q) ITER *ip; VEC *a, *b; Real *beta2; MAT *Q; { int j; static VEC *v = VNULL, *w = VNULL, *tmp = VNULL; Real alpha, beta, c; if ( ! ip ) error(E_NULL,"iter_lanczos"); if ( ! ip->Ax || ! ip->x || ! a || ! b ) error(E_NULL,"iter_lanczos"); if ( ip->k <= 0 ) error(E_BOUNDS,"iter_lanczos"); if ( Q && ( Q->n < ip->x->dim || Q->m < ip->k ) ) error(E_SIZES,"iter_lanczos"); a = v_resize(a,(u_int)ip->k); b = v_resize(b,(u_int)(ip->k-1)); v = v_resize(v,ip->x->dim); w = v_resize(w,ip->x->dim); tmp = v_resize(tmp,ip->x->dim); MEM_STAT_REG(v,TYPE_VEC); MEM_STAT_REG(w,TYPE_VEC); MEM_STAT_REG(tmp,TYPE_VEC); beta = 1.0; v_zero(a); v_zero(b); if (Q) m_zero(Q); /* normalise x as w */ c = v_norm2(ip->x); if (c <= MACHEPS) { /* ip->x == 0 */ *beta2 = 0.0; return; } else sv_mlt(1.0/c,ip->x,w); (ip->Ax)(ip->A_par,w,v); for ( j = 0; j < ip->k; j++ ) { /* store w in Q if Q not NULL */ if ( Q ) set_row(Q,j,w); alpha = in_prod(w,v); a->ve[j] = alpha; v_mltadd(v,w,-alpha,v); beta = v_norm2(v); if ( beta == 0.0 ) { *beta2 = 0.0; return; } if ( j < ip->k-1 ) b->ve[j] = beta; v_copy(w,tmp); sv_mlt(1/beta,v,w); sv_mlt(-beta,tmp,v); (ip->Ax)(ip->A_par,w,tmp); v_add(v,tmp,v); } *beta2 = beta; } /* iter_splanczos -- version that uses sparse matrix data structure */ void iter_splanczos(A,m,x0,a,b,beta2,Q) SPMAT *A; int m; VEC *x0, *a, *b; Real *beta2; MAT *Q; { ITER *ip; ip = iter_get(0,0); ip->shared_x = ip->shared_b = TRUE; ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; ip->x = x0; ip->k = m; iter_lanczos(ip,a,b,beta2,Q); iter_free(ip); /* release only ITER structure */ } extern double frexp(), ldexp(); /* product -- returns the product of a long list of numbers -- answer stored in mant (mantissa) and expt (exponent) */ static double product(a,offset,expt) VEC *a; double offset; int *expt; { Real mant, tmp_fctr; int i, tmp_expt; if ( ! a ) error(E_NULL,"product"); mant = 1.0; *expt = 0; if ( offset == 0.0 ) for ( i = 0; i < a->dim; i++ ) { mant *= frexp(a->ve[i],&tmp_expt); *expt += tmp_expt; if ( ! (i % 10) ) { mant = frexp(mant,&tmp_expt); *expt += tmp_expt; } } else for ( i = 0; i < a->dim; i++ ) { tmp_fctr = a->ve[i] - offset; tmp_fctr += (tmp_fctr > 0.0 ) ? -MACHEPS*offset : MACHEPS*offset; mant *= frexp(tmp_fctr,&tmp_expt); *expt += tmp_expt; if ( ! (i % 10) ) { mant = frexp(mant,&tmp_expt); *expt += tmp_expt; } } mant = frexp(mant,&tmp_expt); *expt += tmp_expt; return mant; } /* product2 -- returns the product of a long list of numbers -- answer stored in mant (mantissa) and expt (exponent) */ static double product2(a,k,expt) VEC *a; int k; /* entry of a to leave out */ int *expt; { Real mant, mu, tmp_fctr; int i, tmp_expt; if ( ! a ) error(E_NULL,"product2"); if ( k < 0 || k >= a->dim ) error(E_BOUNDS,"product2"); mant = 1.0; *expt = 0; mu = a->ve[k]; for ( i = 0; i < a->dim; i++ ) { if ( i == k ) continue; tmp_fctr = a->ve[i] - mu; tmp_fctr += ( tmp_fctr > 0.0 ) ? -MACHEPS*mu : MACHEPS*mu; mant *= frexp(tmp_fctr,&tmp_expt); *expt += tmp_expt; if ( ! (i % 10) ) { mant = frexp(mant,&tmp_expt); *expt += tmp_expt; } } mant = frexp(mant,&tmp_expt); *expt += tmp_expt; return mant; } /* dbl_cmp -- comparison function to pass to qsort() */ static int dbl_cmp(x,y) Real *x, *y; { Real tmp; tmp = *x - *y; return (tmp > 0 ? 1 : tmp < 0 ? -1: 0); } /* iter_lanczos2 -- lanczos + error estimate for every e-val -- uses Cullum & Willoughby approach, Sparse Matrix Proc. 1978 -- returns multiple e-vals where multiple e-vals may not exist -- returns evals vector */ VEC *iter_lanczos2(ip,evals,err_est) ITER *ip; /* ITER structure */ VEC *evals; /* eigenvalue vector */ VEC *err_est; /* error estimates of eigenvalues */ { VEC *a; static VEC *b=VNULL, *a2=VNULL, *b2=VNULL; Real beta, pb_mant, det_mant, det_mant1, det_mant2; int i, pb_expt, det_expt, det_expt1, det_expt2; if ( ! ip ) error(E_NULL,"iter_lanczos2"); if ( ! ip->Ax || ! ip->x ) error(E_NULL,"iter_lanczos2"); if ( ip->k <= 0 ) error(E_RANGE,"iter_lanczos2"); a = evals; a = v_resize(a,(u_int)ip->k); b = v_resize(b,(u_int)(ip->k-1)); MEM_STAT_REG(b,TYPE_VEC); iter_lanczos(ip,a,b,&beta,MNULL); /* printf("# beta =%g\n",beta); */ pb_mant = 0.0; if ( err_est ) { pb_mant = product(b,(double)0.0,&pb_expt); /* printf("# pb_mant = %g, pb_expt = %d\n",pb_mant, pb_expt); */ } /* printf("# diags =\n"); v_output(a); */ /* printf("# off diags =\n"); v_output(b); */ a2 = v_resize(a2,a->dim - 1); b2 = v_resize(b2,b->dim - 1); MEM_STAT_REG(a2,TYPE_VEC); MEM_STAT_REG(b2,TYPE_VEC); for ( i = 0; i < a2->dim - 1; i++ ) { a2->ve[i] = a->ve[i+1]; b2->ve[i] = b->ve[i+1]; } a2->ve[a2->dim-1] = a->ve[a2->dim]; trieig(a,b,MNULL); /* sort evals as a courtesy */ qsort((void *)(a->ve),(int)(a->dim),sizeof(Real),(int (*)())dbl_cmp); /* error estimates */ if ( err_est ) { err_est = v_resize(err_est,(u_int)ip->k); trieig(a2,b2,MNULL); /* printf("# a =\n"); v_output(a); */ /* printf("# a2 =\n"); v_output(a2); */ for ( i = 0; i < a->dim; i++ ) { det_mant1 = product2(a,i,&det_expt1); det_mant2 = product(a2,(double)a->ve[i],&det_expt2); /* printf("# det_mant1=%g, det_expt1=%d\n", det_mant1,det_expt1); */ /* printf("# det_mant2=%g, det_expt2=%d\n", det_mant2,det_expt2); */ if ( det_mant1 == 0.0 ) { /* multiple e-val of T */ err_est->ve[i] = 0.0; continue; } else if ( det_mant2 == 0.0 ) { err_est->ve[i] = HUGE; continue; } if ( (det_expt1 + det_expt2) % 2 ) /* if odd... */ det_mant = sqrt(2.0*fabs(det_mant1*det_mant2)); else /* if even... */ det_mant = sqrt(fabs(det_mant1*det_mant2)); det_expt = (det_expt1+det_expt2)/2; err_est->ve[i] = fabs(beta* ldexp(pb_mant/det_mant,pb_expt-det_expt)); } } return a; } /* iter_splanczos2 -- version of iter_lanczos2() that uses sparse matrix data structure */ VEC *iter_splanczos2(A,m,x0,evals,err_est) SPMAT *A; int m; VEC *x0; /* initial vector */ VEC *evals; /* eigenvalue vector */ VEC *err_est; /* error estimates of eigenvalues */ { ITER *ip; VEC *a; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; ip->x = x0; ip->k = m; a = iter_lanczos2(ip,evals,err_est); ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return a; } /* Conjugate gradient method Another variant - mainly for testing */ VEC *iter_cg1(ip) ITER *ip; { static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; Real alpha; double inner,nres; VEC *rr; /* rr == r or rr == z */ if (ip == INULL) error(E_NULL,"iter_cg"); if (!ip->Ax || !ip->b) error(E_NULL,"iter_cg"); if ( ip->x == ip->b ) error(E_INSITU,"iter_cg"); if (!ip->stop_crit) error(E_NULL,"iter_cg"); if ( ip->eps <= 0.0 ) ip->eps = MACHEPS; r = v_resize(r,ip->b->dim); p = v_resize(p,ip->b->dim); q = v_resize(q,ip->b->dim); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(p,TYPE_VEC); MEM_STAT_REG(q,TYPE_VEC); if (ip->Bx != (Fun_Ax)NULL) { z = v_resize(z,ip->b->dim); MEM_STAT_REG(z,TYPE_VEC); rr = z; } else rr = r; if (ip->x != VNULL) { if (ip->x->dim != ip->b->dim) error(E_SIZES,"iter_cg"); ip->Ax(ip->A_par,ip->x,p); /* p = A*x */ v_sub(ip->b,p,r); /* r = b - A*x */ } else { /* ip->x == 0 */ ip->x = v_get(ip->b->dim); ip->shared_x = FALSE; v_copy(ip->b,r); } if (ip->Bx) (ip->Bx)(ip->B_par,r,p); else v_copy(r,p); inner = in_prod(p,r); nres = sqrt(fabs(inner)); if (ip->info) ip->info(ip,nres,r,p); if ( nres == 0.0) return ip->x; for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ ) { ip->Ax(ip->A_par,p,q); inner = in_prod(q,p); if (sqrt(fabs(inner)) <= MACHEPS*ip->init_res) error(E_BREAKDOWN,"iter_cg1"); alpha = in_prod(p,r)/inner; v_mltadd(ip->x,p,alpha,ip->x); v_mltadd(r,q,-alpha,r); rr = r; if (ip->Bx) { ip->Bx(ip->B_par,r,z); rr = z; } nres = in_prod(r,rr); if (nres < 0.0) { warning(WARN_RES_LESS_0,"iter_cg"); break; } nres = sqrt(fabs(nres)); if (ip->info) ip->info(ip,nres,r,z); if (ip->steps == 0) ip->init_res = nres; if ( ip->stop_crit(ip,nres,r,z) ) break; alpha = -in_prod(rr,q)/inner; v_mltadd(rr,p,alpha,p); } return ip->x; } meschach-1.2b/iternsym.c100644 764 764 74521 5741264613 14725 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* iter.c 17/09/93 */ /* ITERATIVE METHODS - implementation of several iterative methods; see also iter0.c */ #include #include "matrix.h" #include "matrix2.h" #include "sparse.h" #include "iter.h" #include static char rcsid[] = "$Id: iternsym.c,v 1.6 1995/01/30 14:53:01 des Exp $"; #ifdef ANSI_C VEC *spCHsolve(SPMAT *,VEC *,VEC *); #else VEC *spCHsolve(); #endif /* iter_cgs -- uses CGS to compute a solution x to A.x=b */ VEC *iter_cgs(ip,r0) ITER *ip; VEC *r0; { static VEC *p = VNULL, *q = VNULL, *r = VNULL, *u = VNULL; static VEC *v = VNULL, *z = VNULL; VEC *tmp; Real alpha, beta, nres, rho, old_rho, sigma, inner; if (ip == INULL) error(E_NULL,"iter_cgs"); if (!ip->Ax || !ip->b || !r0) error(E_NULL,"iter_cgs"); if ( ip->x == ip->b ) error(E_INSITU,"iter_cgs"); if (!ip->stop_crit) error(E_NULL,"iter_cgs"); if ( r0->dim != ip->b->dim ) error(E_SIZES,"iter_cgs"); if ( ip->eps <= 0.0 ) ip->eps = MACHEPS; p = v_resize(p,ip->b->dim); q = v_resize(q,ip->b->dim); r = v_resize(r,ip->b->dim); u = v_resize(u,ip->b->dim); v = v_resize(v,ip->b->dim); MEM_STAT_REG(p,TYPE_VEC); MEM_STAT_REG(q,TYPE_VEC); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(v,TYPE_VEC); if (ip->Bx) { z = v_resize(z,ip->b->dim); MEM_STAT_REG(z,TYPE_VEC); } if (ip->x != VNULL) { if (ip->x->dim != ip->b->dim) error(E_SIZES,"iter_cgs"); ip->Ax(ip->A_par,ip->x,v); /* v = A*x */ if (ip->Bx) { v_sub(ip->b,v,v); /* v = b - A*x */ (ip->Bx)(ip->B_par,v,r); /* r = B*(b-A*x) */ } else v_sub(ip->b,v,r); /* r = b-A*x */ } else { /* ip->x == 0 */ ip->x = v_get(ip->b->dim); /* x == 0 */ ip->shared_x = FALSE; if (ip->Bx) (ip->Bx)(ip->B_par,ip->b,r); /* r = B*b */ else v_copy(ip->b,r); /* r = b */ } v_zero(p); v_zero(q); old_rho = 1.0; for (ip->steps = 0; ip->steps <= ip->limit; ip->steps++) { inner = in_prod(r,r); nres = sqrt(fabs(inner)); if (ip->steps == 0) ip->init_res = nres; if (ip->info) ip->info(ip,nres,r,VNULL); if ( ip->stop_crit(ip,nres,r,VNULL) ) break; rho = in_prod(r0,r); if ( old_rho == 0.0 ) error(E_BREAKDOWN,"iter_cgs"); beta = rho/old_rho; v_mltadd(r,q,beta,u); v_mltadd(q,p,beta,v); v_mltadd(u,v,beta,p); (ip->Ax)(ip->A_par,p,q); if (ip->Bx) { (ip->Bx)(ip->B_par,q,z); tmp = z; } else tmp = q; sigma = in_prod(r0,tmp); if ( sigma == 0.0 ) error(E_BREAKDOWN,"iter_cgs"); alpha = rho/sigma; v_mltadd(u,tmp,-alpha,q); v_add(u,q,v); (ip->Ax)(ip->A_par,v,u); if (ip->Bx) { (ip->Bx)(ip->B_par,u,z); tmp = z; } else tmp = u; v_mltadd(r,tmp,-alpha,r); v_mltadd(ip->x,v,alpha,ip->x); old_rho = rho; } return ip->x; } /* iter_spcgs -- simple interface for SPMAT data structures use always as follows: x = iter_spcgs(A,B,b,r0,tol,x,limit,steps); or x = iter_spcgs(A,B,b,r0,tol,VNULL,limit,steps); In the second case the solution vector is created. If B is not NULL then it is a preconditioner. */ VEC *iter_spcgs(A,B,b,r0,tol,x,limit,steps) SPMAT *A, *B; VEC *b, *r0, *x; double tol; int *steps,limit; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; if (B) { ip->Bx = (Fun_Ax) sp_mv_mlt; ip->B_par = (void *) B; } else { ip->Bx = (Fun_Ax) NULL; ip->B_par = NULL; } ip->info = (Fun_info) NULL; ip->limit = limit; ip->b = b; ip->eps = tol; ip->x = x; iter_cgs(ip,r0); x = ip->x; if (steps) *steps = ip->steps; ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return x; } /* Routine for performing LSQR -- the least squares QR algorithm of Paige and Saunders: "LSQR: an algorithm for sparse linear equations and sparse least squares", ACM Trans. Math. Soft., v. 8 pp. 43--71 (1982) */ /* lsqr -- sparse CG-like least squares routine: -- finds min_x ||A.x-b||_2 using A defined through A & AT -- returns x (if x != NULL) */ VEC *iter_lsqr(ip) ITER *ip; { static VEC *u = VNULL, *v = VNULL, *w = VNULL, *tmp = VNULL; Real alpha, beta, phi, phi_bar; Real rho, rho_bar, rho_max, theta, nres; Real s, c; /* for Givens' rotations */ int m, n; if ( ! ip || ! ip->b || !ip->Ax || !ip->ATx ) error(E_NULL,"iter_lsqr"); if ( ip->x == ip->b ) error(E_INSITU,"iter_lsqr"); if (!ip->stop_crit || !ip->x) error(E_NULL,"iter_lsqr"); if ( ip->eps <= 0.0 ) ip->eps = MACHEPS; m = ip->b->dim; n = ip->x->dim; u = v_resize(u,(u_int)m); v = v_resize(v,(u_int)n); w = v_resize(w,(u_int)n); tmp = v_resize(tmp,(u_int)n); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(v,TYPE_VEC); MEM_STAT_REG(w,TYPE_VEC); MEM_STAT_REG(tmp,TYPE_VEC); if (ip->x != VNULL) { ip->Ax(ip->A_par,ip->x,u); /* u = A*x */ v_sub(ip->b,u,u); /* u = b-A*x */ } else { /* ip->x == 0 */ ip->x = v_get(ip->b->dim); ip->shared_x = FALSE; v_copy(ip->b,u); /* u = b */ } beta = v_norm2(u); if ( beta == 0.0 ) return ip->x; sv_mlt(1.0/beta,u,u); (ip->ATx)(ip->AT_par,u,v); alpha = v_norm2(v); if ( alpha == 0.0 ) return ip->x; sv_mlt(1.0/alpha,v,v); v_copy(v,w); phi_bar = beta; rho_bar = alpha; rho_max = 1.0; for (ip->steps = 0; ip->steps <= ip->limit; ip->steps++) { tmp = v_resize(tmp,m); (ip->Ax)(ip->A_par,v,tmp); v_mltadd(tmp,u,-alpha,u); beta = v_norm2(u); sv_mlt(1.0/beta,u,u); tmp = v_resize(tmp,n); (ip->ATx)(ip->AT_par,u,tmp); v_mltadd(tmp,v,-beta,v); alpha = v_norm2(v); sv_mlt(1.0/alpha,v,v); rho = sqrt(rho_bar*rho_bar+beta*beta); if ( rho > rho_max ) rho_max = rho; c = rho_bar/rho; s = beta/rho; theta = s*alpha; rho_bar = -c*alpha; phi = c*phi_bar; phi_bar = s*phi_bar; /* update ip->x & w */ if ( rho == 0.0 ) error(E_BREAKDOWN,"iter_lsqr"); v_mltadd(ip->x,w,phi/rho,ip->x); v_mltadd(v,w,-theta/rho,w); nres = fabs(phi_bar*alpha*c)*rho_max; if (ip->info) ip->info(ip,nres,w,VNULL); if (ip->steps == 0) ip->init_res = nres; if ( ip->stop_crit(ip,nres,w,VNULL) ) break; } return ip->x; } /* iter_splsqr -- simple interface for SPMAT data structures */ VEC *iter_splsqr(A,b,tol,x,limit,steps) SPMAT *A; VEC *b, *x; double tol; int *steps,limit; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; ip->ATx = (Fun_Ax) sp_vm_mlt; ip->AT_par = (void *) A; ip->Bx = (Fun_Ax) NULL; ip->B_par = NULL; ip->info = (Fun_info) NULL; ip->limit = limit; ip->b = b; ip->eps = tol; ip->x = x; iter_lsqr(ip); x = ip->x; if (steps) *steps = ip->steps; ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return x; } /* iter_arnoldi -- an implementation of the Arnoldi method; iterative refinement is applied. */ MAT *iter_arnoldi_iref(ip,h_rem,Q,H) ITER *ip; Real *h_rem; MAT *Q, *H; { static VEC *u=VNULL, *r=VNULL, *s=VNULL, *tmp=VNULL; VEC v; /* auxiliary vector */ int i,j; Real h_val, c; if (ip == INULL) error(E_NULL,"iter_arnoldi_iref"); if ( ! ip->Ax || ! Q || ! ip->x ) error(E_NULL,"iter_arnoldi_iref"); if ( ip->k <= 0 ) error(E_BOUNDS,"iter_arnoldi_iref"); if ( Q->n != ip->x->dim || Q->m != ip->k ) error(E_SIZES,"iter_arnoldi_iref"); m_zero(Q); H = m_resize(H,ip->k,ip->k); m_zero(H); u = v_resize(u,ip->x->dim); r = v_resize(r,ip->k); s = v_resize(s,ip->k); tmp = v_resize(tmp,ip->x->dim); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(s,TYPE_VEC); MEM_STAT_REG(tmp,TYPE_VEC); v.dim = v.max_dim = ip->x->dim; c = v_norm2(ip->x); if ( c <= 0.0) return H; else { v.ve = Q->me[0]; sv_mlt(1.0/c,ip->x,&v); } v_zero(r); v_zero(s); for ( i = 0; i < ip->k; i++ ) { v.ve = Q->me[i]; u = (ip->Ax)(ip->A_par,&v,u); for (j = 0; j <= i; j++) { v.ve = Q->me[j]; /* modified Gram-Schmidt */ r->ve[j] = in_prod(&v,u); v_mltadd(u,&v,-r->ve[j],u); } h_val = v_norm2(u); /* if u == 0 then we have an exact subspace */ if ( h_val <= 0.0 ) { *h_rem = h_val; return H; } /* iterative refinement -- ensures near orthogonality */ do { v_zero(tmp); for (j = 0; j <= i; j++) { v.ve = Q->me[j]; s->ve[j] = in_prod(&v,u); v_mltadd(tmp,&v,s->ve[j],tmp); } v_sub(u,tmp,u); v_add(r,s,r); } while ( v_norm2(s) > 0.1*(h_val = v_norm2(u)) ); /* now that u is nearly orthogonal to Q, update H */ set_col(H,i,r); /* check once again if h_val is zero */ if ( h_val <= 0.0 ) { *h_rem = h_val; return H; } if ( i == ip->k-1 ) { *h_rem = h_val; continue; } /* H->me[i+1][i] = h_val; */ m_set_val(H,i+1,i,h_val); v.ve = Q->me[i+1]; sv_mlt(1.0/h_val,u,&v); } return H; } /* iter_arnoldi -- an implementation of the Arnoldi method; modified Gram-Schmidt algorithm */ MAT *iter_arnoldi(ip,h_rem,Q,H) ITER *ip; Real *h_rem; MAT *Q, *H; { static VEC *u=VNULL, *r=VNULL; VEC v; /* auxiliary vector */ int i,j; Real h_val, c; if (ip == INULL) error(E_NULL,"iter_arnoldi"); if ( ! ip->Ax || ! Q || ! ip->x ) error(E_NULL,"iter_arnoldi"); if ( ip->k <= 0 ) error(E_BOUNDS,"iter_arnoldi"); if ( Q->n != ip->x->dim || Q->m != ip->k ) error(E_SIZES,"iter_arnoldi"); m_zero(Q); H = m_resize(H,ip->k,ip->k); m_zero(H); u = v_resize(u,ip->x->dim); r = v_resize(r,ip->k); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(r,TYPE_VEC); v.dim = v.max_dim = ip->x->dim; c = v_norm2(ip->x); if ( c <= 0.0) return H; else { v.ve = Q->me[0]; sv_mlt(1.0/c,ip->x,&v); } v_zero(r); for ( i = 0; i < ip->k; i++ ) { v.ve = Q->me[i]; u = (ip->Ax)(ip->A_par,&v,u); for (j = 0; j <= i; j++) { v.ve = Q->me[j]; /* modified Gram-Schmidt */ r->ve[j] = in_prod(&v,u); v_mltadd(u,&v,-r->ve[j],u); } h_val = v_norm2(u); /* if u == 0 then we have an exact subspace */ if ( h_val <= 0.0 ) { *h_rem = h_val; return H; } set_col(H,i,r); if ( i == ip->k-1 ) { *h_rem = h_val; continue; } /* H->me[i+1][i] = h_val; */ m_set_val(H,i+1,i,h_val); v.ve = Q->me[i+1]; sv_mlt(1.0/h_val,u,&v); } return H; } /* iter_sparnoldi -- uses arnoldi() with an explicit representation of A */ MAT *iter_sparnoldi(A,x0,m,h_rem,Q,H) SPMAT *A; VEC *x0; int m; Real *h_rem; MAT *Q, *H; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; ip->x = x0; ip->k = m; iter_arnoldi_iref(ip,h_rem,Q,H); ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return H; } /* for testing gmres */ static void test_gmres(ip,i,Q,R,givc,givs,h_val) ITER *ip; int i; MAT *Q, *R; VEC *givc, *givs; double h_val; { VEC vt, vt1; static MAT *Q1, *R1; int j; /* test Q*A*Q^T = R */ Q = m_resize(Q,i+1,ip->b->dim); Q1 = m_resize(Q1,i+1,ip->b->dim); R1 = m_resize(R1,i+1,i+1); MEM_STAT_REG(Q1,TYPE_MAT); MEM_STAT_REG(R1,TYPE_MAT); vt.dim = vt.max_dim = ip->b->dim; vt1.dim = vt1.max_dim = ip->b->dim; for (j=0; j <= i; j++) { vt.ve = Q->me[j]; vt1.ve = Q1->me[j]; ip->Ax(ip->A_par,&vt,&vt1); } mmtr_mlt(Q,Q1,R1); R1 = m_resize(R1,i+2,i+1); for (j=0; j < i; j++) R1->me[i+1][j] = 0.0; R1->me[i+1][i] = h_val; for (j = 0; j <= i; j++) { rot_rows(R1,j,j+1,givc->ve[j],givs->ve[j],R1); } R1 = m_resize(R1,i+1,i+1); m_sub(R,R1,R1); /* if (m_norm_inf(R1) > MACHEPS*ip->b->dim) */ printf(" %d. ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", ip->steps,m_norm_inf(R1),MACHEPS); /* check Q*Q^T = I */ Q = m_resize(Q,i+1,ip->b->dim); mmtr_mlt(Q,Q,R1); for (j=0; j <= i; j++) R1->me[j][j] -= 1.0; if (m_norm_inf(R1) > MACHEPS*ip->b->dim) printf(" ! m_norm_inf(Q*Q^T) = %g\n",m_norm_inf(R1)); } /* gmres -- generalised minimum residual algorithm of Saad & Schultz SIAM J. Sci. Stat. Comp. v.7, pp.856--869 (1986) */ VEC *iter_gmres(ip) ITER *ip; { static VEC *u=VNULL, *r=VNULL, *rhs = VNULL; static VEC *givs=VNULL, *givc=VNULL, *z = VNULL; static MAT *Q = MNULL, *R = MNULL; VEC *rr, v, v1; /* additional pointers (not real vectors) */ int i,j, done; Real nres; /* Real last_h; */ if (ip == INULL) error(E_NULL,"iter_gmres"); if ( ! ip->Ax || ! ip->b ) error(E_NULL,"iter_gmres"); if ( ! ip->stop_crit ) error(E_NULL,"iter_gmres"); if ( ip->k <= 0 ) error(E_BOUNDS,"iter_gmres"); if (ip->x != VNULL && ip->x->dim != ip->b->dim) error(E_SIZES,"iter_gmres"); if (ip->eps <= 0.0) ip->eps = MACHEPS; r = v_resize(r,ip->k+1); u = v_resize(u,ip->b->dim); rhs = v_resize(rhs,ip->k+1); givs = v_resize(givs,ip->k); /* Givens rotations */ givc = v_resize(givc,ip->k); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(rhs,TYPE_VEC); MEM_STAT_REG(givs,TYPE_VEC); MEM_STAT_REG(givc,TYPE_VEC); R = m_resize(R,ip->k+1,ip->k); Q = m_resize(Q,ip->k,ip->b->dim); MEM_STAT_REG(R,TYPE_MAT); MEM_STAT_REG(Q,TYPE_MAT); if (ip->x == VNULL) { /* ip->x == 0 */ ip->x = v_get(ip->b->dim); ip->shared_x = FALSE; } v.dim = v.max_dim = ip->b->dim; /* v and v1 are pointers to rows */ v1.dim = v1.max_dim = ip->b->dim; /* of matrix Q */ if (ip->Bx != (Fun_Ax)NULL) { /* if precondition is defined */ z = v_resize(z,ip->b->dim); MEM_STAT_REG(z,TYPE_VEC); } done = FALSE; for (ip->steps = 0; ip->steps < ip->limit; ) { /* restart */ ip->Ax(ip->A_par,ip->x,u); /* u = A*x */ v_sub(ip->b,u,u); /* u = b - A*x */ rr = u; /* rr is a pointer only */ if (ip->Bx) { (ip->Bx)(ip->B_par,u,z); /* tmp = B*(b-A*x) */ rr = z; } nres = v_norm2(rr); if (ip->steps == 0) { if (ip->info) ip->info(ip,nres,VNULL,VNULL); ip->init_res = nres; } if ( nres == 0.0 ) { done = TRUE; break; } v.ve = Q->me[0]; sv_mlt(1.0/nres,rr,&v); v_zero(r); v_zero(rhs); rhs->ve[0] = nres; for ( i = 0; i < ip->k && ip->steps < ip->limit; i++ ) { ip->steps++; v.ve = Q->me[i]; (ip->Ax)(ip->A_par,&v,u); rr = u; if (ip->Bx) { (ip->Bx)(ip->B_par,u,z); rr = z; } if (i < ip->k - 1) { v1.ve = Q->me[i+1]; v_copy(rr,&v1); for (j = 0; j <= i; j++) { v.ve = Q->me[j]; /* r->ve[j] = in_prod(&v,rr); */ /* modified Gram-Schmidt algorithm */ r->ve[j] = in_prod(&v,&v1); v_mltadd(&v1,&v,-r->ve[j],&v1); } r->ve[i+1] = nres = v_norm2(&v1); if (nres <= MACHEPS*ip->init_res) { for (j = 0; j < i; j++) rot_vec(r,j,j+1,givc->ve[j],givs->ve[j],r); set_col(R,i,r); done = TRUE; break; } sv_mlt(1.0/nres,&v1,&v1); } else { /* i == ip->k - 1 */ /* Q->me[ip->k] need not be computed */ for (j = 0; j <= i; j++) { v.ve = Q->me[j]; r->ve[j] = in_prod(&v,rr); } nres = in_prod(rr,rr) - in_prod(r,r); if (sqrt(fabs(nres)) <= MACHEPS*ip->init_res) { for (j = 0; j < i; j++) rot_vec(r,j,j+1,givc->ve[j],givs->ve[j],r); set_col(R,i,r); done = TRUE; break; } if (nres < 0.0) { /* do restart */ i--; ip->steps--; break; } r->ve[i+1] = sqrt(nres); } /* QR update */ /* last_h = r->ve[i+1]; */ /* for test only */ for (j = 0; j < i; j++) rot_vec(r,j,j+1,givc->ve[j],givs->ve[j],r); givens(r->ve[i],r->ve[i+1],&givc->ve[i],&givs->ve[i]); rot_vec(r,i,i+1,givc->ve[i],givs->ve[i],r); rot_vec(rhs,i,i+1,givc->ve[i],givs->ve[i],rhs); set_col(R,i,r); nres = fabs((double) rhs->ve[i+1]); if (ip->info) ip->info(ip,nres,VNULL,VNULL); if ( ip->stop_crit(ip,nres,VNULL,VNULL) ) { done = TRUE; break; } } /* use ixi submatrix of R */ if (i >= ip->k) i = ip->k - 1; R = m_resize(R,i+1,i+1); rhs = v_resize(rhs,i+1); /* test only */ /* test_gmres(ip,i,Q,R,givc,givs,last_h); */ Usolve(R,rhs,rhs,0.0); /* solve a system: R*x = rhs */ /* new approximation */ for (j = 0; j <= i; j++) { v.ve = Q->me[j]; v_mltadd(ip->x,&v,rhs->ve[j],ip->x); } if (done) break; /* back to old dimensions */ rhs = v_resize(rhs,ip->k+1); R = m_resize(R,ip->k+1,ip->k); } return ip->x; } /* iter_spgmres - a simple interface to iter_gmres */ VEC *iter_spgmres(A,B,b,tol,x,k,limit,steps) SPMAT *A, *B; VEC *b, *x; double tol; int *steps,k,limit; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; if (B) { ip->Bx = (Fun_Ax) sp_mv_mlt; ip->B_par = (void *) B; } else { ip->Bx = (Fun_Ax) NULL; ip->B_par = NULL; } ip->k = k; ip->limit = limit; ip->info = (Fun_info) NULL; ip->b = b; ip->eps = tol; ip->x = x; iter_gmres(ip); x = ip->x; if (steps) *steps = ip->steps; ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return x; } /* for testing mgcr */ static void test_mgcr(ip,i,Q,R) ITER *ip; int i; MAT *Q, *R; { VEC vt, vt1; static MAT *R1; static VEC *r, *r1; VEC *rr; int k,j; Real sm; /* check Q*Q^T = I */ vt.dim = vt.max_dim = ip->b->dim; vt1.dim = vt1.max_dim = ip->b->dim; Q = m_resize(Q,i+1,ip->b->dim); R1 = m_resize(R1,i+1,i+1); r = v_resize(r,ip->b->dim); r1 = v_resize(r1,ip->b->dim); MEM_STAT_REG(R1,TYPE_MAT); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(r1,TYPE_VEC); m_zero(R1); for (k=1; k <= i; k++) for (j=1; j <= i; j++) { vt.ve = Q->me[k]; vt1.ve = Q->me[j]; R1->me[k][j] = in_prod(&vt,&vt1); } for (j=1; j <= i; j++) R1->me[j][j] -= 1.0; if (m_norm_inf(R1) > MACHEPS*ip->b->dim) printf(" ! (mgcr:) m_norm_inf(Q*Q^T) = %g\n",m_norm_inf(R1)); /* check (r_i,Ap_j) = 0 for j <= i */ ip->Ax(ip->A_par,ip->x,r); v_sub(ip->b,r,r); rr = r; if (ip->Bx) { ip->Bx(ip->B_par,r,r1); rr = r1; } printf(" ||r|| = %g\n",v_norm2(rr)); sm = 0.0; for (j = 1; j <= i; j++) { vt.ve = Q->me[j]; sm = max(sm,in_prod(&vt,rr)); } if (sm >= MACHEPS*ip->b->dim) printf(" ! (mgcr:) max_j (r,Ap_j) = %g\n",sm); } /* iter_mgcr -- modified generalized conjugate residual algorithm; fast version of GCR; */ VEC *iter_mgcr(ip) ITER *ip; { static VEC *As, *beta, *alpha, *z; static MAT *N, *H; VEC *rr, v, s; /* additional pointer and structures */ Real nres; /* norm of a residual */ Real dd; /* coefficient d_i */ int i,j; int done; /* if TRUE then stop the iterative process */ int dim; /* dimension of the problem */ /* ip cannot be NULL */ if (ip == INULL) error(E_NULL,"mgcr"); /* Ax, b and stopping criterion must be given */ if (! ip->Ax || ! ip->b || ! ip->stop_crit) error(E_NULL,"mgcr"); /* at least one direction vector must exist */ if ( ip->k <= 0) error(E_BOUNDS,"mgcr"); /* if the vector x is given then b and x must have the same dimension */ if ( ip->x && ip->x->dim != ip->b->dim) error(E_SIZES,"mgcr"); if (ip->eps <= 0.0) ip->eps = MACHEPS; dim = ip->b->dim; As = v_resize(As,dim); alpha = v_resize(alpha,ip->k); beta = v_resize(beta,ip->k); MEM_STAT_REG(As,TYPE_VEC); MEM_STAT_REG(alpha,TYPE_VEC); MEM_STAT_REG(beta,TYPE_VEC); H = m_resize(H,ip->k,ip->k); N = m_resize(N,ip->k,dim); MEM_STAT_REG(H,TYPE_MAT); MEM_STAT_REG(N,TYPE_MAT); /* if a preconditioner is defined */ if (ip->Bx) { z = v_resize(z,dim); MEM_STAT_REG(z,TYPE_VEC); } /* if x is NULL then it is assumed that x has entries with value zero */ if ( ! ip->x ) { ip->x = v_get(ip->b->dim); ip->shared_x = FALSE; } /* v and s are additional pointers to rows of N */ /* they must have the same dimension as rows of N */ v.dim = v.max_dim = s.dim = s.max_dim = dim; done = FALSE; for (ip->steps = 0; ip->steps < ip->limit; ) { (*ip->Ax)(ip->A_par,ip->x,As); /* As = A*x */ v_sub(ip->b,As,As); /* As = b - A*x */ rr = As; /* rr is an additional pointer */ /* if a preconditioner is defined */ if (ip->Bx) { (*ip->Bx)(ip->B_par,As,z); /* z = B*(b-A*x) */ rr = z; } /* norm of the residual */ nres = v_norm2(rr); dd = nres; /* dd = ||r_i|| */ /* check if the norm of the residual is zero */ if (ip->steps == 0) { /* information for a user */ if (ip->info) (*ip->info)(ip,nres,As,rr); ip->init_res = fabs(nres); } if (nres == 0.0) { /* iterative process is finished */ done = TRUE; break; } /* save this residual in the first row of N */ v.ve = N->me[0]; v_copy(rr,&v); for (i = 0; i < ip->k && ip->steps < ip->limit; i++) { ip->steps++; v.ve = N->me[i]; /* pointer to a row of N (=s_i) */ /* note that we must use here &v, not v */ (*ip->Ax)(ip->A_par,&v,As); rr = As; /* As = A*s_i */ if (ip->Bx) { (*ip->Bx)(ip->B_par,As,z); /* z = B*A*s_i */ rr = z; } if (i < ip->k - 1) { s.ve = N->me[i+1]; /* pointer to a row of N (=s_{i+1}) */ v_copy(rr,&s); /* s_{i+1} = B*A*s_i */ for (j = 0; j <= i-1; j++) { v.ve = N->me[j+1]; /* pointer to a row of N (=s_{j+1}) */ /* beta->ve[j] = in_prod(&v,rr); */ /* beta_{j,i} */ /* modified Gram-Schmidt algorithm */ beta->ve[j] = in_prod(&v,&s); /* beta_{j,i} */ /* s_{i+1} -= beta_{j,i}*s_{j+1} */ v_mltadd(&s,&v,- beta->ve[j],&s); } /* beta_{i,i} = ||s_{i+1}||_2 */ beta->ve[i] = nres = v_norm2(&s); if ( nres <= MACHEPS*ip->init_res) { /* s_{i+1} == 0 */ i--; done = TRUE; break; } sv_mlt(1.0/nres,&s,&s); /* normalize s_{i+1} */ v.ve = N->me[0]; alpha->ve[i] = in_prod(&v,&s); /* alpha_i = (s_0 , s_{i+1}) */ } else { for (j = 0; j <= i-1; j++) { v.ve = N->me[j+1]; /* pointer to a row of N (=s_{j+1}) */ beta->ve[j] = in_prod(&v,rr); /* beta_{j,i} */ } nres = in_prod(rr,rr); /* rr = B*A*s_{k-1} */ for (j = 0; j <= i-1; j++) nres -= beta->ve[j]*beta->ve[j]; if (sqrt(fabs(nres)) <= MACHEPS*ip->init_res) { /* s_k is zero */ i--; done = TRUE; break; } if (nres < 0.0) { /* do restart */ i--; ip->steps--; break; } beta->ve[i] = sqrt(nres); /* beta_{k-1,k-1} */ v.ve = N->me[0]; alpha->ve[i] = in_prod(&v,rr); for (j = 0; j <= i-1; j++) alpha->ve[i] -= beta->ve[j]*alpha->ve[j]; alpha->ve[i] /= beta->ve[i]; /* alpha_{k-1} */ } set_col(H,i,beta); /* other method of computing dd */ /* if (fabs((double)alpha->ve[i]) > dd) { nres = - dd*dd + alpha->ve[i]*alpha->ve[i]; nres = sqrt((double) nres); if (ip->info) (*ip->info)(ip,-nres,VNULL,VNULL); break; } */ /* to avoid overflow/underflow in computing dd */ /* dd *= cos(asin((double)(alpha->ve[i]/dd))); */ nres = alpha->ve[i]/dd; if (fabs(nres-1.0) <= MACHEPS*ip->init_res) dd = 0.0; else { nres = 1.0 - nres*nres; if (nres < 0.0) { nres = sqrt((double) -nres); if (ip->info) (*ip->info)(ip,-dd*nres,VNULL,VNULL); break; } dd *= sqrt((double) nres); } if (ip->info) (*ip->info)(ip,dd,VNULL,VNULL); if ( ip->stop_crit(ip,dd,VNULL,VNULL) ) { /* stopping criterion is satisfied */ done = TRUE; break; } } /* end of for */ if (i >= ip->k) i = ip->k - 1; /* use (i+1) by (i+1) submatrix of H */ H = m_resize(H,i+1,i+1); alpha = v_resize(alpha,i+1); Usolve(H,alpha,alpha,0.0); /* c_i is saved in alpha */ for (j = 0; j <= i; j++) { v.ve = N->me[j]; v_mltadd(ip->x,&v,alpha->ve[j],ip->x); } if (done) break; /* stop the iterative process */ alpha = v_resize(alpha,ip->k); H = m_resize(H,ip->k,ip->k); } /* end of while */ return ip->x; /* return the solution */ } /* iter_spmgcr - a simple interface to iter_mgcr */ /* no preconditioner */ VEC *iter_spmgcr(A,B,b,tol,x,k,limit,steps) SPMAT *A, *B; VEC *b, *x; double tol; int *steps,k,limit; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *) A; if (B) { ip->Bx = (Fun_Ax) sp_mv_mlt; ip->B_par = (void *) B; } else { ip->Bx = (Fun_Ax) NULL; ip->B_par = NULL; } ip->k = k; ip->limit = limit; ip->info = (Fun_info) NULL; ip->b = b; ip->eps = tol; ip->x = x; iter_mgcr(ip); x = ip->x; if (steps) *steps = ip->steps; ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return x; } /* Conjugate gradients method for a normal equation a preconditioner B must be symmetric !! */ VEC *iter_cgne(ip) ITER *ip; { static VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; Real alpha, beta, inner, old_inner, nres; VEC *rr1; /* pointer only */ if (ip == INULL) error(E_NULL,"iter_cgne"); if (!ip->Ax || ! ip->ATx || !ip->b) error(E_NULL,"iter_cgne"); if ( ip->x == ip->b ) error(E_INSITU,"iter_cgne"); if (!ip->stop_crit) error(E_NULL,"iter_cgne"); if ( ip->eps <= 0.0 ) ip->eps = MACHEPS; r = v_resize(r,ip->b->dim); p = v_resize(p,ip->b->dim); q = v_resize(q,ip->b->dim); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(p,TYPE_VEC); MEM_STAT_REG(q,TYPE_VEC); z = v_resize(z,ip->b->dim); MEM_STAT_REG(z,TYPE_VEC); if (ip->x) { if (ip->x->dim != ip->b->dim) error(E_SIZES,"iter_cgne"); ip->Ax(ip->A_par,ip->x,p); /* p = A*x */ v_sub(ip->b,p,z); /* z = b - A*x */ } else { /* ip->x == 0 */ ip->x = v_get(ip->b->dim); ip->shared_x = FALSE; v_copy(ip->b,z); } rr1 = z; if (ip->Bx) { (ip->Bx)(ip->B_par,rr1,p); rr1 = p; } (ip->ATx)(ip->AT_par,rr1,r); /* r = A^T*B*(b-A*x) */ old_inner = 0.0; for ( ip->steps = 0; ip->steps <= ip->limit; ip->steps++ ) { rr1 = r; if ( ip->Bx ) { (ip->Bx)(ip->B_par,r,z); /* rr = B*r */ rr1 = z; } inner = in_prod(r,rr1); nres = sqrt(fabs(inner)); if (ip->info) ip->info(ip,nres,r,rr1); if (ip->steps == 0) ip->init_res = nres; if ( ip->stop_crit(ip,nres,r,rr1) ) break; if ( ip->steps ) /* if ( ip->steps > 0 ) ... */ { beta = inner/old_inner; p = v_mltadd(rr1,p,beta,p); } else /* if ( ip->steps == 0 ) ... */ { beta = 0.0; p = v_copy(rr1,p); old_inner = 0.0; } (ip->Ax)(ip->A_par,p,q); /* q = A*p */ if (ip->Bx) { (ip->Bx)(ip->B_par,q,z); (ip->ATx)(ip->AT_par,z,q); rr1 = q; /* q = A^T*B*A*p */ } else { (ip->ATx)(ip->AT_par,q,z); /* z = A^T*A*p */ rr1 = z; } alpha = inner/in_prod(rr1,p); v_mltadd(ip->x,p,alpha,ip->x); v_mltadd(r,rr1,-alpha,r); old_inner = inner; } return ip->x; } /* iter_spcgne -- a simple interface to iter_cgne() which uses sparse matrix data structures -- assumes that B contains an actual preconditioner (or NULL) use always as follows: x = iter_spcgne(A,B,b,eps,x,limit,steps); or x = iter_spcgne(A,B,b,eps,VNULL,limit,steps); In the second case the solution vector is created. */ VEC *iter_spcgne(A,B,b,eps,x,limit,steps) SPMAT *A, *B; VEC *b, *x; double eps; int *steps, limit; { ITER *ip; ip = iter_get(0,0); ip->Ax = (Fun_Ax) sp_mv_mlt; ip->A_par = (void *)A; ip->ATx = (Fun_Ax) sp_vm_mlt; ip->AT_par = (void *)A; if (B) { ip->Bx = (Fun_Ax) sp_mv_mlt; ip->B_par = (void *)B; } else { ip->Bx = (Fun_Ax) NULL; ip->B_par = NULL; } ip->info = (Fun_info) NULL; ip->b = b; ip->eps = eps; ip->limit = limit; ip->x = x; iter_cgne(ip); x = ip->x; if (steps) *steps = ip->steps; ip->shared_x = ip->shared_b = TRUE; iter_free(ip); /* release only ITER structure */ return x; } meschach-1.2b/zmachine.c100644 764 764 10237 5673125330 14637 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains basic routines which are used by the functions involving complex vectors. These are the routines that should be modified in order to take full advantage of specialised architectures (pipelining, vector processors etc). */ static char *rcsid = "$Id: zmachine.c,v 1.1 1994/01/13 04:25:41 des Exp $"; #include "machine.h" #include "zmatrix.h" #include /* __zconj__ -- complex conjugate */ void __zconj__(zp,len) complex *zp; int len; { int i; for ( i = 0; i < len; i++ ) zp[i].im = - zp[i].im; } /* __zip__ -- inner product -- computes sum_i zp1[i].zp2[i] if flag == 0 sum_i zp1[i]*.zp2[i] if flag != 0 */ complex __zip__(zp1,zp2,len,flag) complex *zp1, *zp2; int flag, len; { complex sum; int i; sum.re = sum.im = 0.0; if ( flag ) { for ( i = 0; i < len; i++ ) { sum.re += zp1[i].re*zp2[i].re + zp1[i].im*zp2[i].im; sum.im += zp1[i].re*zp2[i].im - zp1[i].im*zp2[i].re; } } else { for ( i = 0; i < len; i++ ) { sum.re += zp1[i].re*zp2[i].re - zp1[i].im*zp2[i].im; sum.im += zp1[i].re*zp2[i].im + zp1[i].im*zp2[i].re; } } return sum; } /* __zmltadd__ -- scalar multiply and add i.e. complex saxpy -- computes zp1[i] += s.zp2[i] if flag == 0 -- computes zp1[i] += s.zp2[i]* if flag != 0 */ void __zmltadd__(zp1,zp2,s,len,flag) complex *zp1, *zp2, s; int flag, len; { int i; LongReal t_re, t_im; if ( ! flag ) { for ( i = 0; i < len; i++ ) { t_re = zp1[i].re + s.re*zp2[i].re - s.im*zp2[i].im; t_im = zp1[i].im + s.re*zp2[i].im + s.im*zp2[i].re; zp1[i].re = t_re; zp1[i].im = t_im; } } else { for ( i = 0; i < len; i++ ) { t_re = zp1[i].re + s.re*zp2[i].re + s.im*zp2[i].im; t_im = zp1[i].im - s.re*zp2[i].im + s.im*zp2[i].re; zp1[i].re = t_re; zp1[i].im = t_im; } } } /* __zmlt__ scalar complex multiply array c.f. sv_mlt() */ void __zmlt__(zp,s,out,len) complex *zp, s, *out; register int len; { int i; LongReal t_re, t_im; for ( i = 0; i < len; i++ ) { t_re = s.re*zp[i].re - s.im*zp[i].im; t_im = s.re*zp[i].im + s.im*zp[i].re; out[i].re = t_re; out[i].im = t_im; } } /* __zadd__ -- add complex arrays c.f. v_add() */ void __zadd__(zp1,zp2,out,len) complex *zp1, *zp2, *out; int len; { int i; for ( i = 0; i < len; i++ ) { out[i].re = zp1[i].re + zp2[i].re; out[i].im = zp1[i].im + zp2[i].im; } } /* __zsub__ -- subtract complex arrays c.f. v_sub() */ void __zsub__(zp1,zp2,out,len) complex *zp1, *zp2, *out; int len; { int i; for ( i = 0; i < len; i++ ) { out[i].re = zp1[i].re - zp2[i].re; out[i].im = zp1[i].im - zp2[i].im; } } /* __zzero__ -- zeros an array of complex numbers */ void __zzero__(zp,len) complex *zp; int len; { /* if a Real precision zero is equivalent to a string of nulls */ MEM_ZERO((char *)zp,len*sizeof(complex)); /* else, need to zero the array entry by entry */ /****************************** while ( len-- ) { zp->re = zp->im = 0.0; zp++; } ******************************/ } meschach-1.2b/zcopy.c100644 764 764 12124 5515147005 14200 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ static char rcsid[] = "$Id: zcopy.c,v 1.1 1994/01/13 04:28:42 des Exp $"; #include #include "zmatrix.h" /* _zm_copy -- copies matrix into new area */ ZMAT *_zm_copy(in,out,i0,j0) ZMAT *in,*out; u_int i0,j0; { u_int i /* ,j */; if ( in==ZMNULL ) error(E_NULL,"_zm_copy"); if ( in==out ) return (out); if ( out==ZMNULL || out->m < in->m || out->n < in->n ) out = zm_resize(out,in->m,in->n); for ( i=i0; i < in->m; i++ ) MEM_COPY(&(in->me[i][j0]),&(out->me[i][j0]), (in->n - j0)*sizeof(complex)); /* for ( j=j0; j < in->n; j++ ) out->me[i][j] = in->me[i][j]; */ return (out); } /* _zv_copy -- copies vector into new area */ ZVEC *_zv_copy(in,out,i0) ZVEC *in,*out; u_int i0; { /* u_int i,j; */ if ( in==ZVNULL ) error(E_NULL,"_zv_copy"); if ( in==out ) return (out); if ( out==ZVNULL || out->dim < in->dim ) out = zv_resize(out,in->dim); MEM_COPY(&(in->ve[i0]),&(out->ve[i0]),(in->dim - i0)*sizeof(complex)); /* for ( i=i0; i < in->dim; i++ ) out->ve[i] = in->ve[i]; */ return (out); } /* The z._move() routines are for moving blocks of memory around within Meschach data structures and for re-arranging matrices, vectors etc. */ /* zm_move -- copies selected pieces of a matrix -- moves the m0 x n0 submatrix with top-left cor-ordinates (i0,j0) to the corresponding submatrix of out with top-left co-ordinates (i1,j1) -- out is resized (& created) if necessary */ ZMAT *zm_move(in,i0,j0,m0,n0,out,i1,j1) ZMAT *in, *out; int i0, j0, m0, n0, i1, j1; { int i; if ( ! in ) error(E_NULL,"zm_move"); if ( i0 < 0 || j0 < 0 || i1 < 0 || j1 < 0 || m0 < 0 || n0 < 0 || i0+m0 > in->m || j0+n0 > in->n ) error(E_BOUNDS,"zm_move"); if ( ! out ) out = zm_resize(out,i1+m0,j1+n0); else if ( i1+m0 > out->m || j1+n0 > out->n ) out = zm_resize(out,max(out->m,i1+m0),max(out->n,j1+n0)); for ( i = 0; i < m0; i++ ) MEM_COPY(&(in->me[i0+i][j0]),&(out->me[i1+i][j1]), n0*sizeof(complex)); return out; } /* zv_move -- copies selected pieces of a vector -- moves the length dim0 subvector with initial index i0 to the corresponding subvector of out with initial index i1 -- out is resized if necessary */ ZVEC *zv_move(in,i0,dim0,out,i1) ZVEC *in, *out; int i0, dim0, i1; { if ( ! in ) error(E_NULL,"zv_move"); if ( i0 < 0 || dim0 < 0 || i1 < 0 || i0+dim0 > in->dim ) error(E_BOUNDS,"zv_move"); if ( (! out) || i1+dim0 > out->dim ) out = zv_resize(out,i1+dim0); MEM_COPY(&(in->ve[i0]),&(out->ve[i1]),dim0*sizeof(complex)); return out; } /* zmv_move -- copies selected piece of matrix to a vector -- moves the m0 x n0 submatrix with top-left co-ordinate (i0,j0) to the subvector with initial index i1 (and length m0*n0) -- rows are copied contiguously -- out is resized if necessary */ ZVEC *zmv_move(in,i0,j0,m0,n0,out,i1) ZMAT *in; ZVEC *out; int i0, j0, m0, n0, i1; { int dim1, i; if ( ! in ) error(E_NULL,"zmv_move"); if ( i0 < 0 || j0 < 0 || m0 < 0 || n0 < 0 || i1 < 0 || i0+m0 > in->m || j0+n0 > in->n ) error(E_BOUNDS,"zmv_move"); dim1 = m0*n0; if ( (! out) || i1+dim1 > out->dim ) out = zv_resize(out,i1+dim1); for ( i = 0; i < m0; i++ ) MEM_COPY(&(in->me[i0+i][j0]),&(out->ve[i1+i*n0]),n0*sizeof(complex)); return out; } /* zvm_move -- copies selected piece of vector to a matrix -- moves the subvector with initial index i0 and length m1*n1 to the m1 x n1 submatrix with top-left co-ordinate (i1,j1) -- copying is done by rows -- out is resized if necessary */ ZMAT *zvm_move(in,i0,out,i1,j1,m1,n1) ZVEC *in; ZMAT *out; int i0, i1, j1, m1, n1; { int dim0, i; if ( ! in ) error(E_NULL,"zvm_move"); if ( i0 < 0 || i1 < 0 || j1 < 0 || m1 < 0 || n1 < 0 || i0+m1*n1 > in->dim ) error(E_BOUNDS,"zvm_move"); if ( ! out ) out = zm_resize(out,i1+m1,j1+n1); else out = zm_resize(out,max(i1+m1,out->m),max(j1+n1,out->n)); dim0 = m1*n1; for ( i = 0; i < m1; i++ ) MEM_COPY(&(in->ve[i0+i*n1]),&(out->me[i1+i][j1]),n1*sizeof(complex)); return out; } meschach-1.2b/zmatio.c100644 764 764 24631 5515146505 14351 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ #include #include #include "zmatrix.h" static char rcsid[] = "$Id: zmatio.c,v 1.1 1994/01/13 04:25:18 des Exp $"; /* local variables */ static char line[MAXLINE]; /************************************************************************** Input routines **************************************************************************/ complex z_finput(fp) FILE *fp; { int io_code; complex z; skipjunk(fp); if ( isatty(fileno(fp)) ) { do { fprintf(stderr,"real and imag parts: "); if ( fgets(line,MAXLINE,fp) == NULL ) error(E_EOF,"z_finput"); #if REAL == DOUBLE io_code = sscanf(line,"%lf%lf",&z.re,&z.im); #elif REAL == FLOAT io_code = sscanf(line,"%f%f",&z.re,&z.im); #endif } while ( io_code != 2 ); } else #if REAL == DOUBLE if ( (io_code=fscanf(fp," (%lf,%lf)",&z.re,&z.im)) < 2 ) #elif REAL == FLOAT if ( (io_code=fscanf(fp," (%f,%f)",&z.re,&z.im)) < 2 ) #endif error((io_code == EOF) ? E_EOF : E_FORMAT,"z_finput"); return z; } ZMAT *zm_finput(fp,a) FILE *fp; ZMAT *a; { ZMAT *izm_finput(),*bzm_finput(); if ( isatty(fileno(fp)) ) return izm_finput(fp,a); else return bzm_finput(fp,a); } /* izm_finput -- interactive input of matrix */ ZMAT *izm_finput(fp,mat) FILE *fp; ZMAT *mat; { char c; u_int i, j, m, n, dynamic; /* dynamic set to TRUE if memory allocated here */ /* get matrix size */ if ( mat != ZMNULL && mat->mnm; n = mat->n; dynamic = FALSE; } else { dynamic = TRUE; do { fprintf(stderr,"ComplexMatrix: rows cols:"); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"izm_finput"); } while ( sscanf(line,"%u%u",&m,&n)<2 || m>MAXDIM || n>MAXDIM ); mat = zm_get(m,n); } /* input elements */ for ( i=0; ime[i][j].re,mat->me[i][j].im); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"izm_finput"); if ( (*line == 'b' || *line == 'B') && j > 0 ) { j--; dynamic = FALSE; goto redo2; } if ( (*line == 'f' || *line == 'F') && j < n-1 ) { j++; dynamic = FALSE; goto redo2; } } while ( *line=='\0' || #if REAL == DOUBLE sscanf(line,"%lf%lf", #elif REAL == FLOAT sscanf(line,"%f%f", #endif &mat->me[i][j].re,&mat->me[i][j].im)<1 ); fprintf(stderr,"Continue: "); fscanf(fp,"%c",&c); if ( c == 'n' || c == 'N' ) { dynamic = FALSE; goto redo; } if ( (c == 'b' || c == 'B') /* && i > 0 */ ) { if ( i > 0 ) i--; dynamic = FALSE; goto redo; } } return (mat); } /* bzm_finput -- batch-file input of matrix */ ZMAT *bzm_finput(fp,mat) FILE *fp; ZMAT *mat; { u_int i,j,m,n,dummy; int io_code; /* get dimension */ skipjunk(fp); if ((io_code=fscanf(fp," ComplexMatrix: %u by %u",&m,&n)) < 2 || m>MAXDIM || n>MAXDIM ) error(io_code==EOF ? E_EOF : E_FORMAT,"bzm_finput"); /* allocate memory if necessary */ if ( mat==ZMNULL || mat->mnme[i][j].re,&mat->me[i][j].im)) < 2 ) error(io_code==EOF ? E_EOF : E_FORMAT,"bzm_finput"); } } return (mat); } ZVEC *zv_finput(fp,x) FILE *fp; ZVEC *x; { ZVEC *izv_finput(),*bzv_finput(); if ( isatty(fileno(fp)) ) return izv_finput(fp,x); else return bzv_finput(fp,x); } /* izv_finput -- interactive input of vector */ ZVEC *izv_finput(fp,vec) FILE *fp; ZVEC *vec; { u_int i,dim,dynamic; /* dynamic set if memory allocated here */ /* get vector dimension */ if ( vec != ZVNULL && vec->dimdim; dynamic = FALSE; } else { dynamic = TRUE; do { fprintf(stderr,"ComplexVector: dim: "); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"izv_finput"); } while ( sscanf(line,"%u",&dim)<1 || dim>MAXDIM ); vec = zv_get(dim); } /* input elements */ for ( i=0; ive[i].re,vec->ve[i].im); if ( fgets(line,MAXLINE,fp)==NULL ) error(E_INPUT,"izv_finput"); if ( (*line == 'b' || *line == 'B') && i > 0 ) { i--; dynamic = FALSE; goto redo; } if ( (*line == 'f' || *line == 'F') && i < dim-1 ) { i++; dynamic = FALSE; goto redo; } } while ( *line=='\0' || #if REAL == DOUBLE sscanf(line,"%lf%lf", #elif REAL == FLOAT sscanf(line,"%f%f", #endif &vec->ve[i].re,&vec->ve[i].im) < 2 ); return (vec); } /* bzv_finput -- batch-file input of vector */ ZVEC *bzv_finput(fp,vec) FILE *fp; ZVEC *vec; { u_int i,dim; int io_code; /* get dimension */ skipjunk(fp); if ((io_code=fscanf(fp," ComplexVector: dim:%u",&dim)) < 1 || dim>MAXDIM ) error(io_code==EOF ? 7 : 6,"bzv_finput"); /* allocate memory if necessary */ if ( vec==ZVNULL || vec->dimve[i].re,&vec->ve[i].im)) < 2 ) error(io_code==EOF ? 7 : 6,"bzv_finput"); return (vec); } /************************************************************************** Output routines **************************************************************************/ static char *zformat = " (%14.9g, %14.9g) "; char *setzformat(f_string) char *f_string; { char *old_f_string; old_f_string = zformat; if ( f_string != (char *)NULL && *f_string != '\0' ) zformat = f_string; return old_f_string; } void z_foutput(fp,z) FILE *fp; complex z; { fprintf(fp,zformat,z.re,z.im); putc('\n',fp); } void zm_foutput(fp,a) FILE *fp; ZMAT *a; { u_int i, j, tmp; if ( a == ZMNULL ) { fprintf(fp,"ComplexMatrix: NULL\n"); return; } fprintf(fp,"ComplexMatrix: %d by %d\n",a->m,a->n); if ( a->me == (complex **)NULL ) { fprintf(fp,"NULL\n"); return; } for ( i=0; im; i++ ) /* for each row... */ { fprintf(fp,"row %u: ",i); for ( j=0, tmp=1; jn; j++, tmp++ ) { /* for each col in row... */ fprintf(fp,zformat,a->me[i][j].re,a->me[i][j].im); if ( ! (tmp % 2) ) putc('\n',fp); } if ( tmp % 2 != 1 ) putc('\n',fp); } } void zv_foutput(fp,x) FILE *fp; ZVEC *x; { u_int i, tmp; if ( x == ZVNULL ) { fprintf(fp,"ComplexVector: NULL\n"); return; } fprintf(fp,"ComplexVector: dim: %d\n",x->dim); if ( x->ve == (complex *)NULL ) { fprintf(fp,"NULL\n"); return; } for ( i=0, tmp=0; idim; i++, tmp++ ) { fprintf(fp,zformat,x->ve[i].re,x->ve[i].im); if ( (tmp % 2) == 1 ) putc('\n',fp); } if ( (tmp % 2) != 0 ) putc('\n',fp); } void zm_dump(fp,a) FILE *fp; ZMAT *a; { u_int i, j, tmp; if ( a == ZMNULL ) { fprintf(fp,"ComplexMatrix: NULL\n"); return; } fprintf(fp,"ComplexMatrix: %d by %d @ 0x%lx\n",a->m,a->n,(long)a); fprintf(fp,"\tmax_m = %d, max_n = %d, max_size = %d\n", a->max_m, a->max_n, a->max_size); if ( a->me == (complex **)NULL ) { fprintf(fp,"NULL\n"); return; } fprintf(fp,"a->me @ 0x%lx\n",(long)(a->me)); fprintf(fp,"a->base @ 0x%lx\n",(long)(a->base)); for ( i=0; im; i++ ) /* for each row... */ { fprintf(fp,"row %u: @ 0x%lx ",i,(long)(a->me[i])); for ( j=0, tmp=1; jn; j++, tmp++ ) { /* for each col in row... */ fprintf(fp,zformat,a->me[i][j].re,a->me[i][j].im); if ( ! (tmp % 2) ) putc('\n',fp); } if ( tmp % 2 != 1 ) putc('\n',fp); } } void zv_dump(fp,x) FILE *fp; ZVEC *x; { u_int i, tmp; if ( ! x ) { fprintf(fp,"ComplexVector: NULL\n"); return; } fprintf(fp,"ComplexVector: dim: %d @ 0x%lx\n",x->dim,(long)(x)); if ( ! x->ve ) { fprintf(fp,"NULL\n"); return; } fprintf(fp,"x->ve @ 0x%lx\n",(long)(x->ve)); for ( i=0, tmp=0; idim; i++, tmp++ ) { fprintf(fp,zformat,x->ve[i].re,x->ve[i].im); if ( tmp % 2 == 1 ) putc('\n',fp); } if ( tmp % 2 != 0 ) putc('\n',fp); } meschach-1.2b/zmemory.c100644 764 764 35655 5602126625 14556 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Memory allocation and de-allocation for complex matrices and vectors */ #include #include "zmatrix.h" static char rcsid[] = "$Id: zmemory.c,v 1.2 1994/04/05 02:13:14 des Exp $"; /* zv_zero -- zeros all entries of a complex vector -- uses __zzero__() */ ZVEC *zv_zero(x) ZVEC *x; { if ( ! x ) error(E_NULL,"zv_zero"); __zzero__(x->ve,x->dim); return x; } /* zm_zero -- zeros all entries of a complex matrix -- uses __zzero__() */ ZMAT *zm_zero(A) ZMAT *A; { int i; if ( ! A ) error(E_NULL,"zm_zero"); for ( i = 0; i < A->m; i++ ) __zzero__(A->me[i],A->n); return A; } /* zm_get -- gets an mxn complex matrix (in ZMAT form) */ ZMAT *zm_get(m,n) int m,n; { ZMAT *matrix; u_int i; if (m < 0 || n < 0) error(E_NEG,"zm_get"); if ((matrix=NEW(ZMAT)) == (ZMAT *)NULL ) error(E_MEM,"zm_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,0,sizeof(ZMAT)); mem_numvar(TYPE_ZMAT,1); } matrix->m = m; matrix->n = matrix->max_n = n; matrix->max_m = m; matrix->max_size = m*n; #ifndef SEGMENTED if ((matrix->base = NEW_A(m*n,complex)) == (complex *)NULL ) { free(matrix); error(E_MEM,"zm_get"); } else if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,0,m*n*sizeof(complex)); } #else matrix->base = (complex *)NULL; #endif if ((matrix->me = (complex **)calloc(m,sizeof(complex *))) == (complex **)NULL ) { free(matrix->base); free(matrix); error(E_MEM,"zm_get"); } else if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,0,m*sizeof(complex *)); } #ifndef SEGMENTED /* set up pointers */ for ( i=0; ime[i] = &(matrix->base[i*n]); #else for ( i = 0; i < m; i++ ) if ( (matrix->me[i]=NEW_A(n,complex)) == (complex *)NULL ) error(E_MEM,"zm_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,0,n*sizeof(complex)); } #endif return (matrix); } /* zv_get -- gets a ZVEC of dimension 'dim' -- Note: initialized to zero */ ZVEC *zv_get(size) int size; { ZVEC *vector; if (size < 0) error(E_NEG,"zv_get"); if ((vector=NEW(ZVEC)) == (ZVEC *)NULL ) error(E_MEM,"zv_get"); else if (mem_info_is_on()) { mem_bytes(TYPE_ZVEC,0,sizeof(ZVEC)); mem_numvar(TYPE_ZVEC,1); } vector->dim = vector->max_dim = size; if ((vector->ve=NEW_A(size,complex)) == (complex *)NULL ) { free(vector); error(E_MEM,"zv_get"); } else if (mem_info_is_on()) { mem_bytes(TYPE_ZVEC,0,size*sizeof(complex)); } return (vector); } /* zm_free -- returns ZMAT & asoociated memory back to memory heap */ int zm_free(mat) ZMAT *mat; { #ifdef SEGMENTED int i; #endif if ( mat==(ZMAT *)NULL || (int)(mat->m) < 0 || (int)(mat->n) < 0 ) /* don't trust it */ return (-1); #ifndef SEGMENTED if ( mat->base != (complex *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,mat->max_m*mat->max_n*sizeof(complex),0); } free((char *)(mat->base)); } #else for ( i = 0; i < mat->max_m; i++ ) if ( mat->me[i] != (complex *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,mat->max_n*sizeof(complex),0); } free((char *)(mat->me[i])); } #endif if ( mat->me != (complex **)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,mat->max_m*sizeof(complex *),0); } free((char *)(mat->me)); } if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,sizeof(ZMAT),0); mem_numvar(TYPE_ZMAT,-1); } free((char *)mat); return (0); } /* zv_free -- returns ZVEC & asoociated memory back to memory heap */ int zv_free(vec) ZVEC *vec; { if ( vec==(ZVEC *)NULL || (int)(vec->dim) < 0 ) /* don't trust it */ return (-1); if ( vec->ve == (complex *)NULL ) { if (mem_info_is_on()) { mem_bytes(TYPE_ZVEC,sizeof(ZVEC),0); mem_numvar(TYPE_ZVEC,-1); } free((char *)vec); } else { if (mem_info_is_on()) { mem_bytes(TYPE_ZVEC,vec->max_dim*sizeof(complex)+ sizeof(ZVEC),0); mem_numvar(TYPE_ZVEC,-1); } free((char *)vec->ve); free((char *)vec); } return (0); } /* zm_resize -- returns the matrix A of size new_m x new_n; A is zeroed -- if A == NULL on entry then the effect is equivalent to m_get() */ ZMAT *zm_resize(A,new_m,new_n) ZMAT *A; int new_m, new_n; { u_int i, new_max_m, new_max_n, new_size, old_m, old_n; if (new_m < 0 || new_n < 0) error(E_NEG,"zm_resize"); if ( ! A ) return zm_get(new_m,new_n); if (new_m == A->m && new_n == A->n) return A; old_m = A->m; old_n = A->n; if ( new_m > A->max_m ) { /* re-allocate A->me */ if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,A->max_m*sizeof(complex *), new_m*sizeof(complex *)); } A->me = RENEW(A->me,new_m,complex *); if ( ! A->me ) error(E_MEM,"zm_resize"); } new_max_m = max(new_m,A->max_m); new_max_n = max(new_n,A->max_n); #ifndef SEGMENTED new_size = new_max_m*new_max_n; if ( new_size > A->max_size ) { /* re-allocate A->base */ if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,A->max_m*A->max_n*sizeof(complex), new_size*sizeof(complex)); } A->base = RENEW(A->base,new_size,complex); if ( ! A->base ) error(E_MEM,"zm_resize"); A->max_size = new_size; } /* now set up A->me[i] */ for ( i = 0; i < new_m; i++ ) A->me[i] = &(A->base[i*new_n]); /* now shift data in matrix */ if ( old_n > new_n ) { for ( i = 1; i < min(old_m,new_m); i++ ) MEM_COPY((char *)&(A->base[i*old_n]), (char *)&(A->base[i*new_n]), sizeof(complex)*new_n); } else if ( old_n < new_n ) { for ( i = min(old_m,new_m)-1; i > 0; i-- ) { /* copy & then zero extra space */ MEM_COPY((char *)&(A->base[i*old_n]), (char *)&(A->base[i*new_n]), sizeof(complex)*old_n); __zzero__(&(A->base[i*new_n+old_n]),(new_n-old_n)); } __zzero__(&(A->base[old_n]),(new_n-old_n)); A->max_n = new_n; } /* zero out the new rows.. */ for ( i = old_m; i < new_m; i++ ) __zzero__(&(A->base[i*new_n]),new_n); #else if ( A->max_n < new_n ) { complex *tmp; for ( i = 0; i < A->max_m; i++ ) { if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,A->max_n*sizeof(complex), new_max_n*sizeof(complex)); } if ( (tmp = RENEW(A->me[i],new_max_n,complex)) == NULL ) error(E_MEM,"zm_resize"); else { A->me[i] = tmp; } } for ( i = A->max_m; i < new_max_m; i++ ) { if ( (tmp = NEW_A(new_max_n,complex)) == NULL ) error(E_MEM,"zm_resize"); else { A->me[i] = tmp; if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,0,new_max_n*sizeof(complex)); } } } } else if ( A->max_m < new_m ) { for ( i = A->max_m; i < new_m; i++ ) if ( (A->me[i] = NEW_A(new_max_n,complex)) == NULL ) error(E_MEM,"zm_resize"); else if (mem_info_is_on()) { mem_bytes(TYPE_ZMAT,0,new_max_n*sizeof(complex)); } } if ( old_n < new_n ) { for ( i = 0; i < old_m; i++ ) __zzero__(&(A->me[i][old_n]),new_n-old_n); } /* zero out the new rows.. */ for ( i = old_m; i < new_m; i++ ) __zzero__(A->me[i],new_n); #endif A->max_m = new_max_m; A->max_n = new_max_n; A->max_size = A->max_m*A->max_n; A->m = new_m; A->n = new_n; return A; } /* zv_resize -- returns the (complex) vector x with dim new_dim -- x is set to the zero vector */ ZVEC *zv_resize(x,new_dim) ZVEC *x; int new_dim; { if (new_dim < 0) error(E_NEG,"zv_resize"); if ( ! x ) return zv_get(new_dim); if (new_dim == x->dim) return x; if ( x->max_dim == 0 ) /* assume that it's from sub_zvec */ return zv_get(new_dim); if ( new_dim > x->max_dim ) { if (mem_info_is_on()) { mem_bytes(TYPE_ZVEC,x->max_dim*sizeof(complex), new_dim*sizeof(complex)); } x->ve = RENEW(x->ve,new_dim,complex); if ( ! x->ve ) error(E_MEM,"zv_resize"); x->max_dim = new_dim; } if ( new_dim > x->dim ) __zzero__(&(x->ve[x->dim]),new_dim - x->dim); x->dim = new_dim; return x; } /* varying arguments */ #ifdef ANSI_C #include /* To allocate memory to many arguments. The function should be called: zv_get_vars(dim,&x,&y,&z,...,NULL); where int dim; ZVEC *x, *y, *z,...; The last argument should be NULL ! dim is the length of vectors x,y,z,... returned value is equal to the number of allocated variables Other gec_... functions are similar. */ int zv_get_vars(int dim,...) { va_list ap; int i=0; ZVEC **par; va_start(ap, dim); while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ *par = zv_get(dim); i++; } va_end(ap); return i; } int zm_get_vars(int m,int n,...) { va_list ap; int i=0; ZMAT **par; va_start(ap, n); while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ *par = zm_get(m,n); i++; } va_end(ap); return i; } /* To resize memory for many arguments. The function should be called: v_resize_vars(new_dim,&x,&y,&z,...,NULL); where int new_dim; ZVEC *x, *y, *z,...; The last argument should be NULL ! rdim is the resized length of vectors x,y,z,... returned value is equal to the number of allocated variables. If one of x,y,z,.. arguments is NULL then memory is allocated to this argument. Other *_resize_list() functions are similar. */ int zv_resize_vars(int new_dim,...) { va_list ap; int i=0; ZVEC **par; va_start(ap, new_dim); while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ *par = zv_resize(*par,new_dim); i++; } va_end(ap); return i; } int zm_resize_vars(int m,int n,...) { va_list ap; int i=0; ZMAT **par; va_start(ap, n); while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ *par = zm_resize(*par,m,n); i++; } va_end(ap); return i; } /* To deallocate memory for many arguments. The function should be called: v_free_vars(&x,&y,&z,...,NULL); where ZVEC *x, *y, *z,...; The last argument should be NULL ! There must be at least one not NULL argument. returned value is equal to the number of allocated variables. Returned value of x,y,z,.. is VNULL. Other *_free_list() functions are similar. */ int zv_free_vars(ZVEC **pv,...) { va_list ap; int i=1; ZVEC **par; zv_free(*pv); *pv = ZVNULL; va_start(ap, pv); while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ zv_free(*par); *par = ZVNULL; i++; } va_end(ap); return i; } int zm_free_vars(ZMAT **va,...) { va_list ap; int i=1; ZMAT **par; zm_free(*va); *va = ZMNULL; va_start(ap, va); while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ zm_free(*par); *par = ZMNULL; i++; } va_end(ap); return i; } #elif VARARGS #include /* To allocate memory to many arguments. The function should be called: v_get_vars(dim,&x,&y,&z,...,NULL); where int dim; ZVEC *x, *y, *z,...; The last argument should be NULL ! dim is the length of vectors x,y,z,... returned value is equal to the number of allocated variables Other gec_... functions are similar. */ int zv_get_vars(va_alist) va_dcl { va_list ap; int dim,i=0; ZVEC **par; va_start(ap); dim = va_arg(ap,int); while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ *par = zv_get(dim); i++; } va_end(ap); return i; } int zm_get_vars(va_alist) va_dcl { va_list ap; int i=0, n, m; ZMAT **par; va_start(ap); m = va_arg(ap,int); n = va_arg(ap,int); while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ *par = zm_get(m,n); i++; } va_end(ap); return i; } /* To resize memory for many arguments. The function should be called: v_resize_vars(new_dim,&x,&y,&z,...,NULL); where int new_dim; ZVEC *x, *y, *z,...; The last argument should be NULL ! rdim is the resized length of vectors x,y,z,... returned value is equal to the number of allocated variables. If one of x,y,z,.. arguments is NULL then memory is allocated to this argument. Other *_resize_list() functions are similar. */ int zv_resize_vars(va_alist) va_dcl { va_list ap; int i=0, new_dim; ZVEC **par; va_start(ap); new_dim = va_arg(ap,int); while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ *par = zv_resize(*par,new_dim); i++; } va_end(ap); return i; } int zm_resize_vars(va_alist) va_dcl { va_list ap; int i=0, m, n; ZMAT **par; va_start(ap); m = va_arg(ap,int); n = va_arg(ap,int); while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ *par = zm_resize(*par,m,n); i++; } va_end(ap); return i; } /* To deallocate memory for many arguments. The function should be called: v_free_vars(&x,&y,&z,...,NULL); where ZVEC *x, *y, *z,...; The last argument should be NULL ! There must be at least one not NULL argument. returned value is equal to the number of allocated variables. Returned value of x,y,z,.. is VNULL. Other *_free_list() functions are similar. */ int zv_free_vars(va_alist) va_dcl { va_list ap; int i=0; ZVEC **par; va_start(ap); while (par = va_arg(ap,ZVEC **)) { /* NULL ends the list*/ zv_free(*par); *par = ZVNULL; i++; } va_end(ap); return i; } int zm_free_vars(va_alist) va_dcl { va_list ap; int i=0; ZMAT **par; va_start(ap); while (par = va_arg(ap,ZMAT **)) { /* NULL ends the list*/ zm_free(*par); *par = ZMNULL; i++; } va_end(ap); return i; } #endif meschach-1.2b/zvecop.c100644 764 764 25731 5537011132 14345 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ #include #include "matrix.h" #include "zmatrix.h" static char rcsid[] = "$Id: zvecop.c,v 1.2 1994/03/08 05:51:07 des Exp $"; /* _zin_prod -- inner product of two vectors from i0 downwards -- flag != 0 means compute sum_i a[i]*.b[i]; -- flag == 0 means compute sum_i a[i].b[i] */ complex _zin_prod(a,b,i0,flag) ZVEC *a,*b; u_int i0, flag; { u_int limit; if ( a==ZVNULL || b==ZVNULL ) error(E_NULL,"_zin_prod"); limit = min(a->dim,b->dim); if ( i0 > limit ) error(E_BOUNDS,"_zin_prod"); return __zip__(&(a->ve[i0]),&(b->ve[i0]),(int)(limit-i0),flag); } /* zv_mlt -- scalar-vector multiply -- may be in-situ */ ZVEC *zv_mlt(scalar,vector,out) complex scalar; ZVEC *vector,*out; { /* u_int dim, i; */ /* complex *out_ve, *vec_ve; */ if ( vector==ZVNULL ) error(E_NULL,"zv_mlt"); if ( out==ZVNULL || out->dim != vector->dim ) out = zv_resize(out,vector->dim); if ( scalar.re == 0.0 && scalar.im == 0.0 ) return zv_zero(out); if ( scalar.re == 1.0 && scalar.im == 0.0 ) return zv_copy(vector,out); __zmlt__(vector->ve,scalar,out->ve,(int)(vector->dim)); return (out); } /* zv_add -- vector addition -- may be in-situ */ ZVEC *zv_add(vec1,vec2,out) ZVEC *vec1,*vec2,*out; { u_int dim; if ( vec1==ZVNULL || vec2==ZVNULL ) error(E_NULL,"zv_add"); if ( vec1->dim != vec2->dim ) error(E_SIZES,"zv_add"); if ( out==ZVNULL || out->dim != vec1->dim ) out = zv_resize(out,vec1->dim); dim = vec1->dim; __zadd__(vec1->ve,vec2->ve,out->ve,(int)dim); return (out); } /* zv_mltadd -- scalar/vector multiplication and addition -- out = v1 + scale.v2 */ ZVEC *zv_mltadd(v1,v2,scale,out) ZVEC *v1,*v2,*out; complex scale; { /* register u_int dim, i; */ /* complex *out_ve, *v1_ve, *v2_ve; */ if ( v1==ZVNULL || v2==ZVNULL ) error(E_NULL,"zv_mltadd"); if ( v1->dim != v2->dim ) error(E_SIZES,"zv_mltadd"); if ( scale.re == 0.0 && scale.im == 0.0 ) return zv_copy(v1,out); if ( scale.re == 1.0 && scale.im == 0.0 ) return zv_add(v1,v2,out); if ( v2 != out ) { tracecatch(out = zv_copy(v1,out),"zv_mltadd"); /* dim = v1->dim; */ __zmltadd__(out->ve,v2->ve,scale,(int)(v1->dim),0); } else { tracecatch(out = zv_mlt(scale,v2,out),"zv_mltadd"); out = zv_add(v1,out,out); } return (out); } /* zv_sub -- vector subtraction -- may be in-situ */ ZVEC *zv_sub(vec1,vec2,out) ZVEC *vec1,*vec2,*out; { /* u_int i, dim; */ /* complex *out_ve, *vec1_ve, *vec2_ve; */ if ( vec1==ZVNULL || vec2==ZVNULL ) error(E_NULL,"zv_sub"); if ( vec1->dim != vec2->dim ) error(E_SIZES,"zv_sub"); if ( out==ZVNULL || out->dim != vec1->dim ) out = zv_resize(out,vec1->dim); __zsub__(vec1->ve,vec2->ve,out->ve,(int)(vec1->dim)); return (out); } /* zv_map -- maps function f over components of x: out[i] = f(x[i]) -- _zv_map sets out[i] = f(x[i],params) */ ZVEC *zv_map(f,x,out) #ifdef PROTOYPES_IN_STRUCT complex (*f)(complex); #else complex (*f)(); #endif ZVEC *x, *out; { complex *x_ve, *out_ve; int i, dim; if ( ! x || ! f ) error(E_NULL,"zv_map"); if ( ! out || out->dim != x->dim ) out = zv_resize(out,x->dim); dim = x->dim; x_ve = x->ve; out_ve = out->ve; for ( i = 0; i < dim; i++ ) out_ve[i] = (*f)(x_ve[i]); return out; } ZVEC *_zv_map(f,params,x,out) #ifdef PROTOTYPES_IN_STRUCT complex (*f)(void *,complex); #else complex (*f)(); #endif ZVEC *x, *out; void *params; { complex *x_ve, *out_ve; int i, dim; if ( ! x || ! f ) error(E_NULL,"_zv_map"); if ( ! out || out->dim != x->dim ) out = zv_resize(out,x->dim); dim = x->dim; x_ve = x->ve; out_ve = out->ve; for ( i = 0; i < dim; i++ ) out_ve[i] = (*f)(params,x_ve[i]); return out; } /* zv_lincomb -- returns sum_i a[i].v[i], a[i] real, v[i] vectors */ ZVEC *zv_lincomb(n,v,a,out) int n; /* number of a's and v's */ complex a[]; ZVEC *v[], *out; { int i; if ( ! a || ! v ) error(E_NULL,"zv_lincomb"); if ( n <= 0 ) return ZVNULL; for ( i = 1; i < n; i++ ) if ( out == v[i] ) error(E_INSITU,"zv_lincomb"); out = zv_mlt(a[0],v[0],out); for ( i = 1; i < n; i++ ) { if ( ! v[i] ) error(E_NULL,"zv_lincomb"); if ( v[i]->dim != out->dim ) error(E_SIZES,"zv_lincomb"); out = zv_mltadd(out,v[i],a[i],out); } return out; } #ifdef ANSI_C /* zv_linlist -- linear combinations taken from a list of arguments; calling: zv_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); where vi are vectors (ZVEC *) and ai are numbers (complex) */ ZVEC *zv_linlist(ZVEC *out,ZVEC *v1,complex a1,...) { va_list ap; ZVEC *par; complex a_par; if ( ! v1 ) return ZVNULL; va_start(ap, a1); out = zv_mlt(a1,v1,out); while (par = va_arg(ap,ZVEC *)) { /* NULL ends the list*/ a_par = va_arg(ap,complex); if (a_par.re == 0.0 && a_par.im == 0.0) continue; if ( out == par ) error(E_INSITU,"zv_linlist"); if ( out->dim != par->dim ) error(E_SIZES,"zv_linlist"); if (a_par.re == 1.0 && a_par.im == 0.0) out = zv_add(out,par,out); else if (a_par.re == -1.0 && a_par.im == 0.0) out = zv_sub(out,par,out); else out = zv_mltadd(out,par,a_par,out); } va_end(ap); return out; } #elif VARARGS /* zv_linlist -- linear combinations taken from a list of arguments; calling: zv_linlist(out,v1,a1,v2,a2,...,vn,an,NULL); where vi are vectors (ZVEC *) and ai are numbers (complex) */ ZVEC *zv_linlist(va_alist) va_dcl { va_list ap; ZVEC *par, *out; complex a_par; va_start(ap); out = va_arg(ap,ZVEC *); par = va_arg(ap,ZVEC *); if ( ! par ) { va_end(ap); return ZVNULL; } a_par = va_arg(ap,complex); out = zv_mlt(a_par,par,out); while (par = va_arg(ap,ZVEC *)) { /* NULL ends the list*/ a_par = va_arg(ap,complex); if (a_par.re == 0.0 && a_par.im == 0.0) continue; if ( out == par ) error(E_INSITU,"zv_linlist"); if ( out->dim != par->dim ) error(E_SIZES,"zv_linlist"); if (a_par.re == 1.0 && a_par.im == 0.0) out = zv_add(out,par,out); else if (a_par.re == -1.0 && a_par.im == 0.0) out = zv_sub(out,par,out); else out = zv_mltadd(out,par,a_par,out); } va_end(ap); return out; } #endif /* zv_star -- computes componentwise (Hadamard) product of x1 and x2 -- result out is returned */ ZVEC *zv_star(x1, x2, out) ZVEC *x1, *x2, *out; { int i; Real t_re, t_im; if ( ! x1 || ! x2 ) error(E_NULL,"zv_star"); if ( x1->dim != x2->dim ) error(E_SIZES,"zv_star"); out = zv_resize(out,x1->dim); for ( i = 0; i < x1->dim; i++ ) { /* out->ve[i] = x1->ve[i] * x2->ve[i]; */ t_re = x1->ve[i].re*x2->ve[i].re - x1->ve[i].im*x2->ve[i].im; t_im = x1->ve[i].re*x2->ve[i].im + x1->ve[i].im*x2->ve[i].re; out->ve[i].re = t_re; out->ve[i].im = t_im; } return out; } /* zv_slash -- computes componentwise ratio of x2 and x1 -- out[i] = x2[i] / x1[i] -- if x1[i] == 0 for some i, then raise E_SING error -- result out is returned */ ZVEC *zv_slash(x1, x2, out) ZVEC *x1, *x2, *out; { int i; Real r2, t_re, t_im; complex tmp; if ( ! x1 || ! x2 ) error(E_NULL,"zv_slash"); if ( x1->dim != x2->dim ) error(E_SIZES,"zv_slash"); out = zv_resize(out,x1->dim); for ( i = 0; i < x1->dim; i++ ) { r2 = x1->ve[i].re*x1->ve[i].re + x1->ve[i].im*x1->ve[i].im; if ( r2 == 0.0 ) error(E_SING,"zv_slash"); tmp.re = x1->ve[i].re / r2; tmp.im = - x1->ve[i].im / r2; t_re = tmp.re*x2->ve[i].re - tmp.im*x2->ve[i].im; t_im = tmp.re*x2->ve[i].im - tmp.im*x2->ve[i].re; out->ve[i].re = t_re; out->ve[i].im = t_im; } return out; } /* zv_sum -- returns sum of entries of a vector */ complex zv_sum(x) ZVEC *x; { int i; complex sum; if ( ! x ) error(E_NULL,"zv_sum"); sum.re = sum.im = 0.0; for ( i = 0; i < x->dim; i++ ) { sum.re += x->ve[i].re; sum.im += x->ve[i].im; } return sum; } /* px_zvec -- permute vector */ ZVEC *px_zvec(px,vector,out) PERM *px; ZVEC *vector,*out; { u_int old_i, i, size, start; complex tmp; if ( px==PNULL || vector==ZVNULL ) error(E_NULL,"px_zvec"); if ( px->size > vector->dim ) error(E_SIZES,"px_zvec"); if ( out==ZVNULL || out->dim < vector->dim ) out = zv_resize(out,vector->dim); size = px->size; if ( size == 0 ) return zv_copy(vector,out); if ( out != vector ) { for ( i=0; ipe[i] >= size ) error(E_BOUNDS,"px_vec"); else out->ve[i] = vector->ve[px->pe[i]]; } else { /* in situ algorithm */ start = 0; while ( start < size ) { old_i = start; i = px->pe[old_i]; if ( i >= size ) { start++; continue; } tmp = vector->ve[start]; while ( TRUE ) { vector->ve[old_i] = vector->ve[i]; px->pe[old_i] = i+size; old_i = i; i = px->pe[old_i]; if ( i >= size ) break; if ( i == start ) { vector->ve[old_i] = tmp; px->pe[old_i] = i+size; break; } } start++; } for ( i = 0; i < size; i++ ) if ( px->pe[i] < size ) error(E_BOUNDS,"px_vec"); else px->pe[i] = px->pe[i]-size; } return out; } /* pxinv_zvec -- apply the inverse of px to x, returning the result in out -- may NOT be in situ */ ZVEC *pxinv_zvec(px,x,out) PERM *px; ZVEC *x, *out; { u_int i, size; if ( ! px || ! x ) error(E_NULL,"pxinv_zvec"); if ( px->size > x->dim ) error(E_SIZES,"pxinv_zvec"); if ( ! out || out->dim < x->dim ) out = zv_resize(out,x->dim); size = px->size; if ( size == 0 ) return zv_copy(x,out); if ( out != x ) { for ( i=0; ipe[i] >= size ) error(E_BOUNDS,"pxinv_vec"); else out->ve[px->pe[i]] = x->ve[i]; } else { /* in situ algorithm --- cheat's way out */ px_inv(px,px); px_zvec(px,x,out); px_inv(px,px); } return out; } /* zv_rand -- randomise a complex vector; uniform in [0,1)+[0,1)*i */ ZVEC *zv_rand(x) ZVEC *x; { if ( ! x ) error(E_NULL,"zv_rand"); mrandlist((Real *)(x->ve),2*x->dim); return x; } meschach-1.2b/zmatop.c100644 764 764 35712 5735557177 14401 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ #include #include "zmatrix.h" static char rcsid[] = "$Id: zmatop.c,v 1.2 1995/03/27 15:49:03 des Exp $"; #define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) /* zm_add -- matrix addition -- may be in-situ */ ZMAT *zm_add(mat1,mat2,out) ZMAT *mat1,*mat2,*out; { u_int m,n,i; if ( mat1==ZMNULL || mat2==ZMNULL ) error(E_NULL,"zm_add"); if ( mat1->m != mat2->m || mat1->n != mat2->n ) error(E_SIZES,"zm_add"); if ( out==ZMNULL || out->m != mat1->m || out->n != mat1->n ) out = zm_resize(out,mat1->m,mat1->n); m = mat1->m; n = mat1->n; for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); /************************************************** for ( j=0; jme[i][j] = mat1->me[i][j]+mat2->me[i][j]; **************************************************/ } return (out); } /* zm_sub -- matrix subtraction -- may be in-situ */ ZMAT *zm_sub(mat1,mat2,out) ZMAT *mat1,*mat2,*out; { u_int m,n,i; if ( mat1==ZMNULL || mat2==ZMNULL ) error(E_NULL,"zm_sub"); if ( mat1->m != mat2->m || mat1->n != mat2->n ) error(E_SIZES,"zm_sub"); if ( out==ZMNULL || out->m != mat1->m || out->n != mat1->n ) out = zm_resize(out,mat1->m,mat1->n); m = mat1->m; n = mat1->n; for ( i=0; ime[i],mat2->me[i],out->me[i],(int)n); /************************************************** for ( j=0; jme[i][j] = mat1->me[i][j]-mat2->me[i][j]; **************************************************/ } return (out); } /* Note: In the following routines, "adjoint" means complex conjugate transpose: A* = conjugate(A^T) */ /* zm_mlt -- matrix-matrix multiplication */ ZMAT *zm_mlt(A,B,OUT) ZMAT *A,*B,*OUT; { u_int i, /* j, */ k, m, n, p; complex **A_v, **B_v /*, *B_row, *OUT_row, sum, tmp */; if ( A==ZMNULL || B==ZMNULL ) error(E_NULL,"zm_mlt"); if ( A->n != B->m ) error(E_SIZES,"zm_mlt"); if ( A == OUT || B == OUT ) error(E_INSITU,"zm_mlt"); m = A->m; n = A->n; p = B->n; A_v = A->me; B_v = B->me; if ( OUT==ZMNULL || OUT->m != A->m || OUT->n != B->n ) OUT = zm_resize(OUT,A->m,B->n); /**************************************************************** for ( i=0; ime[i][j] = sum; } ****************************************************************/ zm_zero(OUT); for ( i=0; ime[i],B_v[k],A_v[i][k],(int)p,Z_NOCONJ); /************************************************** B_row = B_v[k]; OUT_row = OUT->me[i]; for ( j=0; jn != B->n ) error(E_SIZES,"zmma_mlt"); if ( ! OUT || OUT->m != A->m || OUT->n != B->m ) OUT = zm_resize(OUT,A->m,B->m); limit = A->n; for ( i = 0; i < A->m; i++ ) for ( j = 0; j < B->m; j++ ) { OUT->me[i][j] = __zip__(B->me[j],A->me[i],(int)limit,Z_CONJ); /************************************************** sum = 0.0; A_row = A->me[i]; B_row = B->me[j]; for ( k = 0; k < limit; k++ ) sum += (*A_row++)*(*B_row++); OUT->me[i][j] = sum; **************************************************/ } return OUT; } /* zmam_mlt -- matrix adjoint-matrix multiplication -- A*.B is returned, result stored in OUT */ ZMAT *zmam_mlt(A,B,OUT) ZMAT *A, *B, *OUT; { int i, k, limit; /* complex *B_row, *OUT_row, multiplier; */ complex tmp; if ( ! A || ! B ) error(E_NULL,"zmam_mlt"); if ( A == OUT || B == OUT ) error(E_INSITU,"zmam_mlt"); if ( A->m != B->m ) error(E_SIZES,"zmam_mlt"); if ( ! OUT || OUT->m != A->n || OUT->n != B->n ) OUT = zm_resize(OUT,A->n,B->n); limit = B->n; zm_zero(OUT); for ( k = 0; k < A->m; k++ ) for ( i = 0; i < A->n; i++ ) { tmp.re = A->me[k][i].re; tmp.im = - A->me[k][i].im; if ( ! is_zero(tmp) ) __zmltadd__(OUT->me[i],B->me[k],tmp,(int)limit,Z_NOCONJ); } return OUT; } /* zmv_mlt -- matrix-vector multiplication -- Note: b is treated as a column vector */ ZVEC *zmv_mlt(A,b,out) ZMAT *A; ZVEC *b,*out; { u_int i, m, n; complex **A_v, *b_v /*, *A_row */; /* register complex sum; */ if ( A==ZMNULL || b==ZVNULL ) error(E_NULL,"zmv_mlt"); if ( A->n != b->dim ) error(E_SIZES,"zmv_mlt"); if ( b == out ) error(E_INSITU,"zmv_mlt"); if ( out == ZVNULL || out->dim != A->m ) out = zv_resize(out,A->m); m = A->m; n = A->n; A_v = A->me; b_v = b->ve; for ( i=0; ive[i] = __zip__(A_v[i],b_v,(int)n,Z_NOCONJ); /************************************************** A_row = A_v[i]; b_v = b->ve; for ( j=0; jve[i] = sum; **************************************************/ } return out; } /* zsm_mlt -- scalar-matrix multiply -- may be in-situ */ ZMAT *zsm_mlt(scalar,matrix,out) complex scalar; ZMAT *matrix,*out; { u_int m,n,i; if ( matrix==ZMNULL ) error(E_NULL,"zsm_mlt"); if ( out==ZMNULL || out->m != matrix->m || out->n != matrix->n ) out = zm_resize(out,matrix->m,matrix->n); m = matrix->m; n = matrix->n; for ( i=0; ime[i],scalar,out->me[i],(int)n); /************************************************** for ( j=0; jme[i][j] = scalar*matrix->me[i][j]; **************************************************/ return (out); } /* zvm_mlt -- vector adjoint-matrix multiplication */ ZVEC *zvm_mlt(A,b,out) ZMAT *A; ZVEC *b,*out; { u_int j,m,n; /* complex sum,**A_v,*b_v; */ if ( A==ZMNULL || b==ZVNULL ) error(E_NULL,"zvm_mlt"); if ( A->m != b->dim ) error(E_SIZES,"zvm_mlt"); if ( b == out ) error(E_INSITU,"zvm_mlt"); if ( out == ZVNULL || out->dim != A->n ) out = zv_resize(out,A->n); m = A->m; n = A->n; zv_zero(out); for ( j = 0; j < m; j++ ) if ( b->ve[j].re != 0.0 || b->ve[j].im != 0.0 ) __zmltadd__(out->ve,A->me[j],b->ve[j],(int)n,Z_CONJ); /************************************************** A_v = A->me; b_v = b->ve; for ( j=0; jve[j] = sum; } **************************************************/ return out; } /* zm_adjoint -- adjoint matrix */ ZMAT *zm_adjoint(in,out) ZMAT *in, *out; { int i, j; int in_situ; complex tmp; if ( in == ZMNULL ) error(E_NULL,"zm_adjoint"); if ( in == out && in->n != in->m ) error(E_INSITU2,"zm_adjoint"); in_situ = ( in == out ); if ( out == ZMNULL || out->m != in->n || out->n != in->m ) out = zm_resize(out,in->n,in->m); if ( ! in_situ ) { for ( i = 0; i < in->m; i++ ) for ( j = 0; j < in->n; j++ ) { out->me[j][i].re = in->me[i][j].re; out->me[j][i].im = - in->me[i][j].im; } } else { for ( i = 0 ; i < in->m; i++ ) { for ( j = 0; j < i; j++ ) { tmp.re = in->me[i][j].re; tmp.im = in->me[i][j].im; in->me[i][j].re = in->me[j][i].re; in->me[i][j].im = - in->me[j][i].im; in->me[j][i].re = tmp.re; in->me[j][i].im = - tmp.im; } in->me[i][i].im = - in->me[i][i].im; } } return out; } /* zswap_rows -- swaps rows i and j of matrix A upto column lim */ ZMAT *zswap_rows(A,i,j,lo,hi) ZMAT *A; int i, j, lo, hi; { int k; complex **A_me, tmp; if ( ! A ) error(E_NULL,"swap_rows"); if ( i < 0 || j < 0 || i >= A->m || j >= A->m ) error(E_SIZES,"swap_rows"); lo = max(0,lo); hi = min(hi,A->n-1); A_me = A->me; for ( k = lo; k <= hi; k++ ) { tmp = A_me[k][i]; A_me[k][i] = A_me[k][j]; A_me[k][j] = tmp; } return A; } /* zswap_cols -- swap columns i and j of matrix A upto row lim */ ZMAT *zswap_cols(A,i,j,lo,hi) ZMAT *A; int i, j, lo, hi; { int k; complex **A_me, tmp; if ( ! A ) error(E_NULL,"swap_cols"); if ( i < 0 || j < 0 || i >= A->n || j >= A->n ) error(E_SIZES,"swap_cols"); lo = max(0,lo); hi = min(hi,A->m-1); A_me = A->me; for ( k = lo; k <= hi; k++ ) { tmp = A_me[i][k]; A_me[i][k] = A_me[j][k]; A_me[j][k] = tmp; } return A; } /* mz_mltadd -- matrix-scalar multiply and add -- may be in situ -- returns out == A1 + s*A2 */ ZMAT *mz_mltadd(A1,A2,s,out) ZMAT *A1, *A2, *out; complex s; { /* register complex *A1_e, *A2_e, *out_e; */ /* register int j; */ int i, m, n; if ( ! A1 || ! A2 ) error(E_NULL,"mz_mltadd"); if ( A1->m != A2->m || A1->n != A2->n ) error(E_SIZES,"mz_mltadd"); if ( out != A1 && out != A2 ) out = zm_resize(out,A1->m,A1->n); if ( s.re == 0.0 && s.im == 0.0 ) return zm_copy(A1,out); if ( s.re == 1.0 && s.im == 0.0 ) return zm_add(A1,A2,out); out = zm_copy(A1,out); m = A1->m; n = A1->n; for ( i = 0; i < m; i++ ) { __zmltadd__(out->me[i],A2->me[i],s,(int)n,Z_NOCONJ); /************************************************** A1_e = A1->me[i]; A2_e = A2->me[i]; out_e = out->me[i]; for ( j = 0; j < n; j++ ) out_e[j] = A1_e[j] + s*A2_e[j]; **************************************************/ } return out; } /* zmv_mltadd -- matrix-vector multiply and add -- may not be in situ -- returns out == v1 + alpha*A*v2 */ ZVEC *zmv_mltadd(v1,v2,A,alpha,out) ZVEC *v1, *v2, *out; ZMAT *A; complex alpha; { /* register int j; */ int i, m, n; complex tmp, *v2_ve, *out_ve; if ( ! v1 || ! v2 || ! A ) error(E_NULL,"zmv_mltadd"); if ( out == v2 ) error(E_INSITU,"zmv_mltadd"); if ( v1->dim != A->m || v2->dim != A-> n ) error(E_SIZES,"zmv_mltadd"); tracecatch(out = zv_copy(v1,out),"zmv_mltadd"); v2_ve = v2->ve; out_ve = out->ve; m = A->m; n = A->n; if ( alpha.re == 0.0 && alpha.im == 0.0 ) return out; for ( i = 0; i < m; i++ ) { tmp = __zip__(A->me[i],v2_ve,(int)n,Z_NOCONJ); out_ve[i].re += alpha.re*tmp.re - alpha.im*tmp.im; out_ve[i].im += alpha.re*tmp.im + alpha.im*tmp.re; /************************************************** A_e = A->me[i]; sum = 0.0; for ( j = 0; j < n; j++ ) sum += A_e[j]*v2_ve[j]; out_ve[i] = v1->ve[i] + alpha*sum; **************************************************/ } return out; } /* zvm_mltadd -- vector-matrix multiply and add a la zvm_mlt() -- may not be in situ -- returns out == v1 + v2*.A */ ZVEC *zvm_mltadd(v1,v2,A,alpha,out) ZVEC *v1, *v2, *out; ZMAT *A; complex alpha; { int /* i, */ j, m, n; complex tmp, /* *A_e, */ *out_ve; if ( ! v1 || ! v2 || ! A ) error(E_NULL,"zvm_mltadd"); if ( v2 == out ) error(E_INSITU,"zvm_mltadd"); if ( v1->dim != A->n || A->m != v2->dim ) error(E_SIZES,"zvm_mltadd"); tracecatch(out = zv_copy(v1,out),"zvm_mltadd"); out_ve = out->ve; m = A->m; n = A->n; for ( j = 0; j < m; j++ ) { /* tmp = zmlt(v2->ve[j],alpha); */ tmp.re = v2->ve[j].re*alpha.re - v2->ve[j].im*alpha.im; tmp.im = v2->ve[j].re*alpha.im + v2->ve[j].im*alpha.re; if ( tmp.re != 0.0 || tmp.im != 0.0 ) __zmltadd__(out_ve,A->me[j],tmp,(int)n,Z_CONJ); /************************************************** A_e = A->me[j]; for ( i = 0; i < n; i++ ) out_ve[i] += A_e[i]*tmp; **************************************************/ } return out; } /* zget_col -- gets a specified column of a matrix; returned as a vector */ ZVEC *zget_col(mat,col,vec) int col; ZMAT *mat; ZVEC *vec; { u_int i; if ( mat==ZMNULL ) error(E_NULL,"zget_col"); if ( col < 0 || col >= mat->n ) error(E_RANGE,"zget_col"); if ( vec==ZVNULL || vec->dimm ) vec = zv_resize(vec,mat->m); for ( i=0; im; i++ ) vec->ve[i] = mat->me[i][col]; return (vec); } /* zget_row -- gets a specified row of a matrix and retruns it as a vector */ ZVEC *zget_row(mat,row,vec) int row; ZMAT *mat; ZVEC *vec; { int /* i, */ lim; if ( mat==ZMNULL ) error(E_NULL,"zget_row"); if ( row < 0 || row >= mat->m ) error(E_RANGE,"zget_row"); if ( vec==ZVNULL || vec->dimn ) vec = zv_resize(vec,mat->n); lim = min(mat->n,vec->dim); /* for ( i=0; in; i++ ) */ /* vec->ve[i] = mat->me[row][i]; */ MEMCOPY(mat->me[row],vec->ve,lim,complex); return (vec); } /* zset_col -- sets column of matrix to values given in vec (in situ) */ ZMAT *zset_col(mat,col,vec) ZMAT *mat; ZVEC *vec; int col; { u_int i,lim; if ( mat==ZMNULL || vec==ZVNULL ) error(E_NULL,"zset_col"); if ( col < 0 || col >= mat->n ) error(E_RANGE,"zset_col"); lim = min(mat->m,vec->dim); for ( i=0; ime[i][col] = vec->ve[i]; return (mat); } /* zset_row -- sets row of matrix to values given in vec (in situ) */ ZMAT *zset_row(mat,row,vec) ZMAT *mat; ZVEC *vec; int row; { u_int /* j, */ lim; if ( mat==ZMNULL || vec==ZVNULL ) error(E_NULL,"zset_row"); if ( row < 0 || row >= mat->m ) error(E_RANGE,"zset_row"); lim = min(mat->n,vec->dim); /* for ( j=j0; jme[row][j] = vec->ve[j]; */ MEMCOPY(vec->ve,mat->me[row],lim,complex); return (mat); } /* zm_rand -- randomise a complex matrix; uniform in [0,1)+[0,1)*i */ ZMAT *zm_rand(A) ZMAT *A; { int i; if ( ! A ) error(E_NULL,"zm_rand"); for ( i = 0; i < A->m; i++ ) mrandlist((Real *)(A->me[i]),2*A->n); return A; } meschach-1.2b/znorm.c100644 764 764 11020 5673125414 14200 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* A collection of functions for computing norms: scaled and unscaled Complex version */ static char rcsid[] = "$Id: znorm.c,v 1.1 1994/01/13 04:21:31 des Exp $"; #include #include "zmatrix.h" #include /* _zv_norm1 -- computes (scaled) 1-norms of vectors */ double _zv_norm1(x,scale) ZVEC *x; VEC *scale; { int i, dim; Real s, sum; if ( x == ZVNULL ) error(E_NULL,"_zv_norm1"); dim = x->dim; sum = 0.0; if ( scale == VNULL ) for ( i = 0; i < dim; i++ ) sum += zabs(x->ve[i]); else if ( scale->dim < dim ) error(E_SIZES,"_zv_norm1"); else for ( i = 0; i < dim; i++ ) { s = scale->ve[i]; sum += ( s== 0.0 ) ? zabs(x->ve[i]) : zabs(x->ve[i])/fabs(s); } return sum; } /* square -- returns x^2 */ /****************************** double square(x) double x; { return x*x; } ******************************/ #define square(x) ((x)*(x)) /* _zv_norm2 -- computes (scaled) 2-norm (Euclidean norm) of vectors */ double _zv_norm2(x,scale) ZVEC *x; VEC *scale; { int i, dim; Real s, sum; if ( x == ZVNULL ) error(E_NULL,"_zv_norm2"); dim = x->dim; sum = 0.0; if ( scale == VNULL ) for ( i = 0; i < dim; i++ ) sum += square(x->ve[i].re) + square(x->ve[i].im); else if ( scale->dim < dim ) error(E_SIZES,"_v_norm2"); else for ( i = 0; i < dim; i++ ) { s = scale->ve[i]; sum += ( s== 0.0 ) ? square(x->ve[i].re) + square(x->ve[i].im) : (square(x->ve[i].re) + square(x->ve[i].im))/square(s); } return sqrt(sum); } #define max(a,b) ((a) > (b) ? (a) : (b)) /* _zv_norm_inf -- computes (scaled) infinity-norm (supremum norm) of vectors */ double _zv_norm_inf(x,scale) ZVEC *x; VEC *scale; { int i, dim; Real s, maxval, tmp; if ( x == ZVNULL ) error(E_NULL,"_zv_norm_inf"); dim = x->dim; maxval = 0.0; if ( scale == VNULL ) for ( i = 0; i < dim; i++ ) { tmp = zabs(x->ve[i]); maxval = max(maxval,tmp); } else if ( scale->dim < dim ) error(E_SIZES,"_zv_norm_inf"); else for ( i = 0; i < dim; i++ ) { s = scale->ve[i]; tmp = ( s == 0.0 ) ? zabs(x->ve[i]) : zabs(x->ve[i])/fabs(s); maxval = max(maxval,tmp); } return maxval; } /* zm_norm1 -- compute matrix 1-norm -- unscaled -- complex version */ double zm_norm1(A) ZMAT *A; { int i, j, m, n; Real maxval, sum; if ( A == ZMNULL ) error(E_NULL,"zm_norm1"); m = A->m; n = A->n; maxval = 0.0; for ( j = 0; j < n; j++ ) { sum = 0.0; for ( i = 0; i < m; i ++ ) sum += zabs(A->me[i][j]); maxval = max(maxval,sum); } return maxval; } /* zm_norm_inf -- compute matrix infinity-norm -- unscaled -- complex version */ double zm_norm_inf(A) ZMAT *A; { int i, j, m, n; Real maxval, sum; if ( A == ZMNULL ) error(E_NULL,"zm_norm_inf"); m = A->m; n = A->n; maxval = 0.0; for ( i = 0; i < m; i++ ) { sum = 0.0; for ( j = 0; j < n; j ++ ) sum += zabs(A->me[i][j]); maxval = max(maxval,sum); } return maxval; } /* zm_norm_frob -- compute matrix frobenius-norm -- unscaled */ double zm_norm_frob(A) ZMAT *A; { int i, j, m, n; Real sum; if ( A == ZMNULL ) error(E_NULL,"zm_norm_frob"); m = A->m; n = A->n; sum = 0.0; for ( i = 0; i < m; i++ ) for ( j = 0; j < n; j ++ ) sum += square(A->me[i][j].re) + square(A->me[i][j].im); return sqrt(sum); } meschach-1.2b/zfunc.c100644 764 764 10714 5741264011 14162 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Elementary functions for complex numbers -- if not already defined */ #include "zmatrix.h" #include static char rcsid[] = "$Id: zfunc.c,v 1.3 1995/04/07 16:27:25 des Exp $"; #ifndef COMPLEX_H #ifndef zmake /* zmake -- create complex number real + i*imag */ complex zmake(real,imag) double real, imag; { complex w; /* == real + i*imag */ w.re = real; w.im = imag; return w; } #endif #ifndef zneg /* zneg -- returns negative of z */ complex zneg(z) complex z; { z.re = - z.re; z.im = - z.im; return z; } #endif #ifndef zabs /* zabs -- returns |z| */ double zabs(z) complex z; { Real x, y, tmp; int x_expt, y_expt; /* Note: we must ensure that overflow does not occur! */ x = ( z.re >= 0.0 ) ? z.re : -z.re; y = ( z.im >= 0.0 ) ? z.im : -z.im; if ( x < y ) { tmp = x; x = y; y = tmp; } if ( x == 0.0 ) /* then y == 0.0 as well */ return 0.0; x = frexp(x,&x_expt); y = frexp(y,&y_expt); y = ldexp(y,y_expt-x_expt); tmp = sqrt(x*x+y*y); return ldexp(tmp,x_expt); } #endif #ifndef zadd /* zadd -- returns z1+z2 */ complex zadd(z1,z2) complex z1, z2; { complex z; z.re = z1.re + z2.re; z.im = z1.im + z2.im; return z; } #endif #ifndef zsub /* zsub -- returns z1-z2 */ complex zsub(z1,z2) complex z1, z2; { complex z; z.re = z1.re - z2.re; z.im = z1.im - z2.im; return z; } #endif #ifndef zmlt /* zmlt -- returns z1*z2 */ complex zmlt(z1,z2) complex z1, z2; { complex z; z.re = z1.re * z2.re - z1.im * z2.im; z.im = z1.re * z2.im + z1.im * z2.re; return z; } #endif #ifndef zinv /* zmlt -- returns 1/z */ complex zinv(z) complex z; { Real x, y, tmp; int x_expt, y_expt; if ( z.re == 0.0 && z.im == 0.0 ) error(E_SING,"zinv"); /* Note: we must ensure that overflow does not occur! */ x = ( z.re >= 0.0 ) ? z.re : -z.re; y = ( z.im >= 0.0 ) ? z.im : -z.im; if ( x < y ) { tmp = x; x = y; y = tmp; } x = frexp(x,&x_expt); y = frexp(y,&y_expt); y = ldexp(y,y_expt-x_expt); tmp = 1.0/(x*x + y*y); z.re = z.re*tmp*ldexp(1.0,-2*x_expt); z.im = -z.im*tmp*ldexp(1.0,-2*x_expt); return z; } #endif #ifndef zdiv /* zdiv -- returns z1/z2 */ complex zdiv(z1,z2) complex z1, z2; { return zmlt(z1,zinv(z2)); } #endif #ifndef zsqrt /* zsqrt -- returns sqrt(z); uses branch with Re sqrt(z) >= 0 */ complex zsqrt(z) complex z; { complex w; /* == sqrt(z) at end */ Real alpha; alpha = sqrt(0.5*(fabs(z.re) + zabs(z))); if (alpha!=0) { if (z.re>=0.0) { w.re = alpha; w.im = z.im / (2.0*alpha); } else { w.re = fabs(z.im)/(2.0*alpha); w.im = ( z.im >= 0 ) ? alpha : - alpha; } } else w.re = w.im = 0.0; return w; } #endif #ifndef zexp /* zexp -- returns exp(z) */ complex zexp(z) complex z; { complex w; /* == exp(z) at end */ Real r; r = exp(z.re); w.re = r*cos(z.im); w.im = r*sin(z.im); return w; } #endif #ifndef zlog /* zlog -- returns log(z); uses principal branch with -pi <= Im log(z) <= pi */ complex zlog(z) complex z; { complex w; /* == log(z) at end */ w.re = log(zabs(z)); w.im = atan2(z.im,z.re); return w; } #endif #ifndef zconj complex zconj(z) complex z; { complex w; /* == conj(z) */ w.re = z.re; w.im = - z.im; return w; } #endif #endif meschach-1.2b/zlufctr.c100644 764 764 15354 5673125434 14544 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. Complex version */ static char rcsid[] = "$Id: zlufctr.c,v 1.1 1994/01/13 04:26:20 des Exp $"; #include #include "zmatrix.h" #include "zmatrix2.h" #include #define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) /* Most matrix factorisation routines are in-situ unless otherwise specified */ /* zLUfactor -- Gaussian elimination with scaled partial pivoting -- Note: returns LU matrix which is A */ ZMAT *zLUfactor(A,pivot) ZMAT *A; PERM *pivot; { u_int i, j, k, k_max, m, n; int i_max; Real dtemp, max1; complex **A_v, *A_piv, *A_row, temp; static VEC *scale = VNULL; if ( A==ZMNULL || pivot==PNULL ) error(E_NULL,"zLUfactor"); if ( pivot->size != A->m ) error(E_SIZES,"zLUfactor"); m = A->m; n = A->n; scale = v_resize(scale,A->m); MEM_STAT_REG(scale,TYPE_VEC); A_v = A->me; /* initialise pivot with identity permutation */ for ( i=0; ipe[i] = i; /* set scale parameters */ for ( i=0; ive[i] = max1; } /* main loop */ k_max = min(m,n)-1; for ( k=0; kve[i] > 0.0 ) { dtemp = zabs(A_v[i][k])/scale->ve[i]; if ( dtemp > max1 ) { max1 = dtemp; i_max = i; } } /* if no pivot then ignore column k... */ if ( i_max == -1 ) continue; /* do we pivot ? */ if ( i_max != k ) /* yes we do... */ { px_transp(pivot,i_max,k); for ( j=0; jm != A->n || A->n != b->dim ) error(E_SIZES,"zLUsolve"); x = px_zvec(pivot,b,x); /* x := P.b */ zLsolve(A,x,x,1.0); /* implicit diagonal = 1 */ zUsolve(A,x,x,0.0); /* explicit diagonal */ return (x); } /* zLUAsolve -- given an LU factorisation in A, solve A^*.x=b */ ZVEC *zLUAsolve(LU,pivot,b,x) ZMAT *LU; PERM *pivot; ZVEC *b,*x; { if ( ! LU || ! b || ! pivot ) error(E_NULL,"zLUAsolve"); if ( LU->m != LU->n || LU->n != b->dim ) error(E_SIZES,"zLUAsolve"); x = zv_copy(b,x); zUAsolve(LU,x,x,0.0); /* explicit diagonal */ zLAsolve(LU,x,x,1.0); /* implicit diagonal = 1 */ pxinv_zvec(pivot,x,x); /* x := P^*.x */ return (x); } /* zm_inverse -- returns inverse of A, provided A is not too rank deficient -- uses LU factorisation */ ZMAT *zm_inverse(A,out) ZMAT *A, *out; { int i; ZVEC *tmp, *tmp2; ZMAT *A_cp; PERM *pivot; if ( ! A ) error(E_NULL,"zm_inverse"); if ( A->m != A->n ) error(E_SQUARE,"zm_inverse"); if ( ! out || out->m < A->m || out->n < A->n ) out = zm_resize(out,A->m,A->n); A_cp = zm_copy(A,ZMNULL); tmp = zv_get(A->m); tmp2 = zv_get(A->m); pivot = px_get(A->m); tracecatch(zLUfactor(A_cp,pivot),"zm_inverse"); for ( i = 0; i < A->n; i++ ) { zv_zero(tmp); tmp->ve[i].re = 1.0; tmp->ve[i].im = 0.0; tracecatch(zLUsolve(A_cp,pivot,tmp,tmp2),"m_inverse"); zset_col(out,i,tmp2); } ZM_FREE(A_cp); ZV_FREE(tmp); ZV_FREE(tmp2); PX_FREE(pivot); return out; } /* zLUcondest -- returns an estimate of the condition number of LU given the LU factorisation in compact form */ double zLUcondest(LU,pivot) ZMAT *LU; PERM *pivot; { static ZVEC *y = ZVNULL, *z = ZVNULL; Real cond_est, L_norm, U_norm, norm, sn_inv; complex sum; int i, j, n; if ( ! LU || ! pivot ) error(E_NULL,"zLUcondest"); if ( LU->m != LU->n ) error(E_SQUARE,"zLUcondest"); if ( LU->n != pivot->size ) error(E_SIZES,"zLUcondest"); n = LU->n; y = zv_resize(y,n); z = zv_resize(z,n); MEM_STAT_REG(y,TYPE_ZVEC); MEM_STAT_REG(z,TYPE_ZVEC); cond_est = 0.0; /* should never be returned */ for ( i = 0; i < n; i++ ) { sum.re = 1.0; sum.im = 0.0; for ( j = 0; j < i; j++ ) /* sum -= LU->me[j][i]*y->ve[j]; */ sum = zsub(sum,zmlt(LU->me[j][i],y->ve[j])); /* sum -= (sum < 0.0) ? 1.0 : -1.0; */ sn_inv = 1.0 / zabs(sum); sum.re += sum.re * sn_inv; sum.im += sum.im * sn_inv; if ( is_zero(LU->me[i][i]) ) return HUGE; /* y->ve[i] = sum / LU->me[i][i]; */ y->ve[i] = zdiv(sum,LU->me[i][i]); } zLAsolve(LU,y,y,1.0); zLUsolve(LU,pivot,y,z); /* now estimate norm of A (even though it is not directly available) */ /* actually computes ||L||_inf.||U||_inf */ U_norm = 0.0; for ( i = 0; i < n; i++ ) { norm = 0.0; for ( j = i; j < n; j++ ) norm += zabs(LU->me[i][j]); if ( norm > U_norm ) U_norm = norm; } L_norm = 0.0; for ( i = 0; i < n; i++ ) { norm = 1.0; for ( j = 0; j < i; j++ ) norm += zabs(LU->me[i][j]); if ( norm > L_norm ) L_norm = norm; } tracecatch(cond_est = U_norm*L_norm*zv_norm_inf(z)/zv_norm_inf(y), "LUcondest"); return cond_est; } meschach-1.2b/zsolve.c100644 764 764 16625 5673125556 14404 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Matrix factorisation routines to work with the other matrix files. Complex case */ static char rcsid[] = "$Id: zsolve.c,v 1.1 1994/01/13 04:20:33 des Exp $"; #include #include "zmatrix2.h" #include #define is_zero(z) ((z).re == 0.0 && (z).im == 0.0 ) /* Most matrix factorisation routines are in-situ unless otherwise specified */ /* zUsolve -- back substitution with optional over-riding diagonal -- can be in-situ but doesn't need to be */ ZVEC *zUsolve(matrix,b,out,diag) ZMAT *matrix; ZVEC *b, *out; double diag; { u_int dim /* , j */; int i, i_lim; complex **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum; if ( matrix==ZMNULL || b==ZVNULL ) error(E_NULL,"zUsolve"); dim = min(matrix->m,matrix->n); if ( b->dim < dim ) error(E_SIZES,"zUsolve"); if ( out==ZVNULL || out->dim < dim ) out = zv_resize(out,matrix->n); mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; for ( i=dim-1; i>=0; i-- ) if ( ! is_zero(b_ent[i]) ) break; else out_ent[i].re = out_ent[i].im = 0.0; i_lim = i; for ( i = i_lim; i>=0; i-- ) { sum = b_ent[i]; mat_row = &(mat_ent[i][i+1]); out_col = &(out_ent[i+1]); sum = zsub(sum,__zip__(mat_row,out_col,i_lim-i,Z_NOCONJ)); /****************************************************** for ( j=i+1; j<=i_lim; j++ ) sum -= mat_ent[i][j]*out_ent[j]; sum -= (*mat_row++)*(*out_col++); ******************************************************/ if ( diag == 0.0 ) { if ( is_zero(mat_ent[i][i]) ) error(E_SING,"zUsolve"); else /* out_ent[i] = sum/mat_ent[i][i]; */ out_ent[i] = zdiv(sum,mat_ent[i][i]); } else { /* out_ent[i] = sum/diag; */ out_ent[i].re = sum.re / diag; out_ent[i].im = sum.im / diag; } } return (out); } /* zLsolve -- forward elimination with (optional) default diagonal value */ ZVEC *zLsolve(matrix,b,out,diag) ZMAT *matrix; ZVEC *b,*out; double diag; { u_int dim, i, i_lim /* , j */; complex **mat_ent, *mat_row, *b_ent, *out_ent, *out_col, sum; if ( matrix==ZMNULL || b==ZVNULL ) error(E_NULL,"zLsolve"); dim = min(matrix->m,matrix->n); if ( b->dim < dim ) error(E_SIZES,"zLsolve"); if ( out==ZVNULL || out->dim < dim ) out = zv_resize(out,matrix->n); mat_ent = matrix->me; b_ent = b->ve; out_ent = out->ve; for ( i=0; im,U->n); if ( b->dim < dim ) error(E_SIZES,"zUAsolve"); out = zv_resize(out,U->n); U_me = U->me; b_ve = b->ve; out_ve = out->ve; for ( i=0; idim); /* MEM_COPY(&(b_ve[i_lim]),&(out_ve[i_lim]), (dim-i_lim)*sizeof(complex)); */ MEMCOPY(&(b_ve[i_lim]),&(out_ve[i_lim]),dim-i_lim,complex); } if ( diag == 0.0 ) { for ( ; im,A->n); if ( b->dim < dim ) error(E_SIZES,"zDsolve"); x = zv_resize(x,A->n); dim = b->dim; for ( i=0; ime[i][i]) ) error(E_SING,"zDsolve"); else x->ve[i] = zdiv(b->ve[i],A->me[i][i]); return (x); } /* zLAsolve -- back substitution with optional over-riding diagonal using the LOWER triangular part of matrix -- can be in-situ but doesn't need to be */ ZVEC *zLAsolve(L,b,out,diag) ZMAT *L; ZVEC *b, *out; double diag; { u_int dim; int i, i_lim; complex **L_me, *b_ve, *out_ve, tmp; Real invdiag; if ( ! L || ! b ) error(E_NULL,"zLAsolve"); dim = min(L->m,L->n); if ( b->dim < dim ) error(E_SIZES,"zLAsolve"); out = zv_resize(out,L->n); L_me = L->me; b_ve = b->ve; out_ve = out->ve; for ( i=dim-1; i>=0; i-- ) if ( ! is_zero(b_ve[i]) ) break; i_lim = i; if ( b != out ) { __zzero__(out_ve,out->dim); /* MEM_COPY(b_ve,out_ve,(i_lim+1)*sizeof(complex)); */ MEMCOPY(b_ve,out_ve,i_lim+1,complex); } if ( diag == 0.0 ) { for ( ; i>=0; i-- ) { tmp = zconj(L_me[i][i]); if ( is_zero(tmp) ) error(E_SING,"zLAsolve"); out_ve[i] = zdiv(out_ve[i],tmp); tmp.re = - out_ve[i].re; tmp.im = - out_ve[i].im; __zmltadd__(out_ve,L_me[i],tmp,i,Z_CONJ); } } else { invdiag = 1.0/diag; for ( ; i>=0; i-- ) { out_ve[i].re *= invdiag; out_ve[i].im *= invdiag; tmp.re = - out_ve[i].re; tmp.im = - out_ve[i].im; __zmltadd__(out_ve,L_me[i],tmp,i,Z_CONJ); } } return (out); } meschach-1.2b/zmatlab.c100644 764 764 14010 5720207364 14465 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains routines for import/exporting complex data to/from MATLAB. The main routines are: ZMAT *zm_save(FILE *fp,ZMAT *A,char *name) ZVEC *zv_save(FILE *fp,ZVEC *x,char *name) complex z_save(FILE *fp,complex z,char *name) ZMAT *zm_load(FILE *fp,char **name) */ #include #include "zmatrix.h" #include "matlab.h" static char rcsid[] = "$Id: zmatlab.c,v 1.2 1995/02/14 20:13:27 des Exp $"; /* zm_save -- save matrix in ".mat" file for MATLAB -- returns matrix to be saved */ ZMAT *zm_save(fp,A,name) FILE *fp; ZMAT *A; char *name; { int i, j; matlab mat; if ( ! A ) error(E_NULL,"zm_save"); mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; mat.m = A->m; mat.n = A->n; mat.imag = TRUE; mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; /* write header */ fwrite(&mat,sizeof(matlab),1,fp); /* write name */ if ( name == (char *)NULL ) fwrite("",sizeof(char),1,fp); else fwrite(name,sizeof(char),(int)(mat.namlen),fp); /* write actual data */ #if ORDER == ROW_ORDER for ( i = 0; i < A->m; i++ ) for ( j = 0; j < A->n; j++ ) fwrite(&(A->me[i][j].re),sizeof(Real),1,fp); for ( i = 0; i < A->m; i++ ) for ( j = 0; j < A->n; j++ ) fwrite(&(A->me[i][j].im),sizeof(Real),1,fp); #else /* column major order: ORDER == COL_ORDER */ for ( j = 0; j < A->n; j++ ) for ( i = 0; i < A->m; i++ ) fwrite(&(A->me[i][j].re),sizeof(Real),1,fp); for ( j = 0; j < A->n; j++ ) for ( i = 0; i < A->m; i++ ) fwrite(&(A->me[i][j].im),sizeof(Real),1,fp); #endif return A; } /* zv_save -- save vector in ".mat" file for MATLAB -- saves it as a row vector -- returns vector to be saved */ ZVEC *zv_save(fp,x,name) FILE *fp; ZVEC *x; char *name; { int i; matlab mat; if ( ! x ) error(E_NULL,"zv_save"); mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; mat.m = x->dim; mat.n = 1; mat.imag = TRUE; mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; /* write header */ fwrite(&mat,sizeof(matlab),1,fp); /* write name */ if ( name == (char *)NULL ) fwrite("",sizeof(char),1,fp); else fwrite(name,sizeof(char),(int)(mat.namlen),fp); /* write actual data */ for ( i = 0; i < x->dim; i++ ) fwrite(&(x->ve[i].re),sizeof(Real),1,fp); for ( i = 0; i < x->dim; i++ ) fwrite(&(x->ve[i].im),sizeof(Real),1,fp); return x; } /* z_save -- saves complex number in ".mat" file for MATLAB -- returns complex number to be saved */ complex z_save(fp,z,name) FILE *fp; complex z; char *name; { matlab mat; mat.type = 1000*MACH_ID + 100*ORDER + 10*PRECISION + 0; mat.m = 1; mat.n = 1; mat.imag = TRUE; mat.namlen = (name == (char *)NULL) ? 1 : strlen(name)+1; /* write header */ fwrite(&mat,sizeof(matlab),1,fp); /* write name */ if ( name == (char *)NULL ) fwrite("",sizeof(char),1,fp); else fwrite(name,sizeof(char),(int)(mat.namlen),fp); /* write actual data */ fwrite(&z,sizeof(complex),1,fp); return z; } /* zm_load -- loads in a ".mat" file variable as produced by MATLAB -- matrix returned; imaginary parts ignored */ ZMAT *zm_load(fp,name) FILE *fp; char **name; { ZMAT *A; int i; int m_flag, o_flag, p_flag, t_flag; float f_temp; double d_temp; matlab mat; if ( fread(&mat,sizeof(matlab),1,fp) != 1 ) error(E_FORMAT,"zm_load"); if ( mat.type >= 10000 ) /* don't load a sparse matrix! */ error(E_FORMAT,"zm_load"); m_flag = (mat.type/1000) % 10; o_flag = (mat.type/100) % 10; p_flag = (mat.type/10) % 10; t_flag = (mat.type) % 10; if ( m_flag != MACH_ID ) error(E_FORMAT,"zm_load"); if ( t_flag != 0 ) error(E_FORMAT,"zm_load"); if ( p_flag != DOUBLE_PREC && p_flag != SINGLE_PREC ) error(E_FORMAT,"zm_load"); *name = (char *)malloc((unsigned)(mat.namlen)+1); if ( fread(*name,sizeof(char),(unsigned)(mat.namlen),fp) == 0 ) error(E_FORMAT,"zm_load"); A = zm_get((unsigned)(mat.m),(unsigned)(mat.n)); for ( i = 0; i < A->m*A->n; i++ ) { if ( p_flag == DOUBLE_PREC ) fread(&d_temp,sizeof(double),1,fp); else { fread(&f_temp,sizeof(float),1,fp); d_temp = f_temp; } if ( o_flag == ROW_ORDER ) A->me[i / A->n][i % A->n].re = d_temp; else if ( o_flag == COL_ORDER ) A->me[i % A->m][i / A->m].re = d_temp; else error(E_FORMAT,"zm_load"); } if ( mat.imag ) /* skip imaginary part */ for ( i = 0; i < A->m*A->n; i++ ) { if ( p_flag == DOUBLE_PREC ) fread(&d_temp,sizeof(double),1,fp); else { fread(&f_temp,sizeof(float),1,fp); d_temp = f_temp; } if ( o_flag == ROW_ORDER ) A->me[i / A->n][i % A->n].im = d_temp; else if ( o_flag == COL_ORDER ) A->me[i % A->m][i / A->m].im = d_temp; else error(E_FORMAT,"zm_load"); } return A; } meschach-1.2b/zhsehldr.c100644 764 764 12634 5673125640 14673 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Files for matrix computations Householder transformation file. Contains routines for calculating householder transformations, applying them to vectors and matrices by both row & column. Complex version */ static char rcsid[] = "$Id: zhsehldr.c,v 1.2 1994/04/07 01:43:47 des Exp $"; #include #include "zmatrix.h" #include "zmatrix2.h" #include #define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) /* zhhvec -- calulates Householder vector to eliminate all entries after the i0 entry of the vector vec. It is returned as out. May be in-situ */ ZVEC *zhhvec(vec,i0,beta,out,newval) ZVEC *vec,*out; int i0; Real *beta; complex *newval; { complex tmp; Real norm, abs_val; if ( i0 < 0 || i0 >= vec->dim ) error(E_BOUNDS,"zhhvec"); out = _zv_copy(vec,out,i0); tmp = _zin_prod(out,out,i0,Z_CONJ); if ( tmp.re <= 0.0 ) { *beta = 0.0; *newval = out->ve[i0]; return (out); } norm = sqrt(tmp.re); abs_val = zabs(out->ve[i0]); *beta = 1.0/(norm * (norm+abs_val)); if ( abs_val == 0.0 ) { newval->re = norm; newval->im = 0.0; } else { abs_val = -norm / abs_val; newval->re = abs_val*out->ve[i0].re; newval->im = abs_val*out->ve[i0].im; } abs_val = -norm / abs_val; out->ve[i0].re -= newval->re; out->ve[i0].im -= newval->im; return (out); } /* zhhtrvec -- apply Householder transformation to vector -- may be in-situ */ ZVEC *zhhtrvec(hh,beta,i0,in,out) ZVEC *hh,*in,*out; /* hh = Householder vector */ int i0; double beta; { complex scale, tmp; /* u_int i; */ if ( hh==ZVNULL || in==ZVNULL ) error(E_NULL,"zhhtrvec"); if ( in->dim != hh->dim ) error(E_SIZES,"zhhtrvec"); if ( i0 < 0 || i0 > in->dim ) error(E_BOUNDS,"zhhvec"); tmp = _zin_prod(hh,in,i0,Z_CONJ); scale.re = -beta*tmp.re; scale.im = -beta*tmp.im; out = zv_copy(in,out); __zmltadd__(&(out->ve[i0]),&(hh->ve[i0]),scale, (int)(in->dim-i0),Z_NOCONJ); /************************************************************ for ( i=i0; idim; i++ ) out->ve[i] = in->ve[i] - scale*hh->ve[i]; ************************************************************/ return (out); } /* zhhtrrows -- transform a matrix by a Householder vector by rows starting at row i0 from column j0 -- in-situ */ ZMAT *zhhtrrows(M,i0,j0,hh,beta) ZMAT *M; int i0, j0; ZVEC *hh; double beta; { complex ip, scale; int i /*, j */; if ( M==ZMNULL || hh==ZVNULL ) error(E_NULL,"zhhtrrows"); if ( M->n != hh->dim ) error(E_RANGE,"zhhtrrows"); if ( i0 < 0 || i0 > M->m || j0 < 0 || j0 > M->n ) error(E_BOUNDS,"zhhtrrows"); if ( beta == 0.0 ) return (M); /* for each row ... */ for ( i = i0; i < M->m; i++ ) { /* compute inner product */ ip = __zip__(&(M->me[i][j0]),&(hh->ve[j0]), (int)(M->n-j0),Z_NOCONJ); /************************************************** ip = 0.0; for ( j = j0; j < M->n; j++ ) ip += M->me[i][j]*hh->ve[j]; **************************************************/ scale.re = -beta*ip.re; scale.im = -beta*ip.im; /* if ( scale == 0.0 ) */ if ( is_zero(scale) ) continue; /* do operation */ __zmltadd__(&(M->me[i][j0]),&(hh->ve[j0]),scale, (int)(M->n-j0),Z_CONJ); /************************************************** for ( j = j0; j < M->n; j++ ) M->me[i][j] -= scale*hh->ve[j]; **************************************************/ } return (M); } /* zhhtrcols -- transform a matrix by a Householder vector by columns starting at row i0 from column j0 -- in-situ */ ZMAT *zhhtrcols(M,i0,j0,hh,beta) ZMAT *M; int i0, j0; ZVEC *hh; double beta; { /* Real ip, scale; */ complex scale; int i /*, k */; static ZVEC *w = ZVNULL; if ( M==ZMNULL || hh==ZVNULL ) error(E_NULL,"zhhtrcols"); if ( M->m != hh->dim ) error(E_SIZES,"zhhtrcols"); if ( i0 < 0 || i0 > M->m || j0 < 0 || j0 > M->n ) error(E_BOUNDS,"zhhtrcols"); if ( beta == 0.0 ) return (M); w = zv_resize(w,M->n); MEM_STAT_REG(w,TYPE_ZVEC); zv_zero(w); for ( i = i0; i < M->m; i++ ) /* if ( hh->ve[i] != 0.0 ) */ if ( ! is_zero(hh->ve[i]) ) __zmltadd__(&(w->ve[j0]),&(M->me[i][j0]),hh->ve[i], (int)(M->n-j0),Z_CONJ); for ( i = i0; i < M->m; i++ ) /* if ( hh->ve[i] != 0.0 ) */ if ( ! is_zero(hh->ve[i]) ) { scale.re = -beta*hh->ve[i].re; scale.im = -beta*hh->ve[i].im; __zmltadd__(&(M->me[i][j0]),&(w->ve[j0]),scale, (int)(M->n-j0),Z_CONJ); } return (M); } meschach-1.2b/zqrfctr.c100644 764 764 32724 5673125450 14544 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains the routines needed to perform QR factorisation of matrices, as well as Householder transformations. The internal "factored form" of a matrix A is not quite standard. The diagonal of A is replaced by the diagonal of R -- not by the 1st non-zero entries of the Householder vectors. The 1st non-zero entries are held in the diag parameter of QRfactor(). The reason for this non-standard representation is that it enables direct use of the Usolve() function rather than requiring that a seperate function be written just for this case. See, e.g., QRsolve() below for more details. Complex version */ static char rcsid[] = "$Id: zqrfctr.c,v 1.1 1994/01/13 04:21:22 des Exp $"; #include #include "zmatrix.h" #include "zmatrix2.h" #include #define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) #define sign(x) ((x) > 0.0 ? 1 : ((x) < 0.0 ? -1 : 0 )) /* Note: The usual representation of a Householder transformation is taken to be: P = I - beta.u.u* where beta = 2/(u*.u) and u is called the Householder vector (u* is the conjugate transposed vector of u */ /* zQRfactor -- forms the QR factorisation of A -- factorisation stored in compact form as described above (not quite standard format) */ ZMAT *zQRfactor(A,diag) ZMAT *A; ZVEC *diag; { u_int k,limit; Real beta; static ZVEC *tmp1=ZVNULL; if ( ! A || ! diag ) error(E_NULL,"zQRfactor"); limit = min(A->m,A->n); if ( diag->dim < limit ) error(E_SIZES,"zQRfactor"); tmp1 = zv_resize(tmp1,A->m); MEM_STAT_REG(tmp1,TYPE_ZVEC); for ( k=0; kve[k],tmp1,&A->me[k][k]); */ zhhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); diag->ve[k] = tmp1->ve[k]; /* apply H/holder vector to remaining columns */ /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ tracecatch(zhhtrcols(A,k,k+1,tmp1,beta),"zQRfactor"); } return (A); } /* zQRCPfactor -- forms the QR factorisation of A with column pivoting -- factorisation stored in compact form as described above ( not quite standard format ) */ ZMAT *zQRCPfactor(A,diag,px) ZMAT *A; ZVEC *diag; PERM *px; { u_int i, i_max, j, k, limit; static ZVEC *tmp1=ZVNULL, *tmp2=ZVNULL; static VEC *gamma=VNULL; Real beta; Real maxgamma, sum, tmp; complex ztmp; if ( ! A || ! diag || ! px ) error(E_NULL,"QRCPfactor"); limit = min(A->m,A->n); if ( diag->dim < limit || px->size != A->n ) error(E_SIZES,"QRCPfactor"); tmp1 = zv_resize(tmp1,A->m); tmp2 = zv_resize(tmp2,A->m); gamma = v_resize(gamma,A->n); MEM_STAT_REG(tmp1,TYPE_ZVEC); MEM_STAT_REG(tmp2,TYPE_ZVEC); MEM_STAT_REG(gamma,TYPE_VEC); /* initialise gamma and px */ for ( j=0; jn; j++ ) { px->pe[j] = j; sum = 0.0; for ( i=0; im; i++ ) sum += square(A->me[i][j].re) + square(A->me[i][j].im); gamma->ve[j] = sum; } for ( k=0; kve[k]; for ( i=k+1; in; i++ ) /* Loop invariant:maxgamma=gamma[i_max] >=gamma[l];l=k,...,i-1 */ if ( gamma->ve[i] > maxgamma ) { maxgamma = gamma->ve[i]; i_max = i; } /* swap columns if necessary */ if ( i_max != k ) { /* swap gamma values */ tmp = gamma->ve[k]; gamma->ve[k] = gamma->ve[i_max]; gamma->ve[i_max] = tmp; /* update column permutation */ px_transp(px,k,i_max); /* swap columns of A */ for ( i=0; im; i++ ) { ztmp = A->me[i][k]; A->me[i][k] = A->me[i][i_max]; A->me[i][i_max] = ztmp; } } /* get H/holder vector for the k-th column */ zget_col(A,k,tmp1); /* hhvec(tmp1,k,&beta->ve[k],tmp1,&A->me[k][k]); */ zhhvec(tmp1,k,&beta,tmp1,&A->me[k][k]); diag->ve[k] = tmp1->ve[k]; /* apply H/holder vector to remaining columns */ /* hhtrcols(A,k,k+1,tmp1,beta->ve[k]); */ zhhtrcols(A,k,k+1,tmp1,beta); /* update gamma values */ for ( j=k+1; jn; j++ ) gamma->ve[j] -= square(A->me[k][j].re)+square(A->me[k][j].im); } return (A); } /* zQsolve -- solves Qx = b, Q is an orthogonal matrix stored in compact form a la QRfactor() -- may be in-situ */ ZVEC *_zQsolve(QR,diag,b,x,tmp) ZMAT *QR; ZVEC *diag, *b, *x, *tmp; { u_int dynamic; int k, limit; Real beta, r_ii, tmp_val; limit = min(QR->m,QR->n); dynamic = FALSE; if ( ! QR || ! diag || ! b ) error(E_NULL,"_zQsolve"); if ( diag->dim < limit || b->dim != QR->m ) error(E_SIZES,"_zQsolve"); x = zv_resize(x,QR->m); if ( tmp == ZVNULL ) dynamic = TRUE; tmp = zv_resize(tmp,QR->m); /* apply H/holder transforms in normal order */ x = zv_copy(b,x); for ( k = 0 ; k < limit ; k++ ) { zget_col(QR,k,tmp); r_ii = zabs(tmp->ve[k]); tmp->ve[k] = diag->ve[k]; tmp_val = (r_ii*zabs(diag->ve[k])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; /* hhtrvec(tmp,beta->ve[k],k,x,x); */ zhhtrvec(tmp,beta,k,x,x); } if ( dynamic ) ZV_FREE(tmp); return (x); } /* zmakeQ -- constructs orthogonal matrix from Householder vectors stored in compact QR form */ ZMAT *zmakeQ(QR,diag,Qout) ZMAT *QR,*Qout; ZVEC *diag; { static ZVEC *tmp1=ZVNULL,*tmp2=ZVNULL; u_int i, limit; Real beta, r_ii, tmp_val; int j; limit = min(QR->m,QR->n); if ( ! QR || ! diag ) error(E_NULL,"zmakeQ"); if ( diag->dim < limit ) error(E_SIZES,"zmakeQ"); Qout = zm_resize(Qout,QR->m,QR->m); tmp1 = zv_resize(tmp1,QR->m); /* contains basis vec & columns of Q */ tmp2 = zv_resize(tmp2,QR->m); /* contains H/holder vectors */ MEM_STAT_REG(tmp1,TYPE_ZVEC); MEM_STAT_REG(tmp2,TYPE_ZVEC); for ( i=0; im ; i++ ) { /* get i-th column of Q */ /* set up tmp1 as i-th basis vector */ for ( j=0; jm ; j++ ) tmp1->ve[j].re = tmp1->ve[j].im = 0.0; tmp1->ve[i].re = 1.0; /* apply H/h transforms in reverse order */ for ( j=limit-1; j>=0; j-- ) { zget_col(QR,j,tmp2); r_ii = zabs(tmp2->ve[j]); tmp2->ve[j] = diag->ve[j]; tmp_val = (r_ii*zabs(diag->ve[j])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; /* hhtrvec(tmp2,beta->ve[j],j,tmp1,tmp1); */ zhhtrvec(tmp2,beta,j,tmp1,tmp1); } /* insert into Q */ zset_col(Qout,i,tmp1); } return (Qout); } /* zmakeR -- constructs upper triangular matrix from QR (compact form) -- may be in-situ (all it does is zero the lower 1/2) */ ZMAT *zmakeR(QR,Rout) ZMAT *QR,*Rout; { u_int i,j; if ( QR==ZMNULL ) error(E_NULL,"zmakeR"); Rout = zm_copy(QR,Rout); for ( i=1; im; i++ ) for ( j=0; jn && jme[i][j].re = Rout->me[i][j].im = 0.0; return (Rout); } /* zQRsolve -- solves the system Q.R.x=b where Q & R are stored in compact form -- returns x, which is created if necessary */ ZVEC *zQRsolve(QR,diag,b,x) ZMAT *QR; ZVEC *diag, *b, *x; { int limit; static ZVEC *tmp = ZVNULL; if ( ! QR || ! diag || ! b ) error(E_NULL,"zQRsolve"); limit = min(QR->m,QR->n); if ( diag->dim < limit || b->dim != QR->m ) error(E_SIZES,"zQRsolve"); tmp = zv_resize(tmp,limit); MEM_STAT_REG(tmp,TYPE_ZVEC); x = zv_resize(x,QR->n); _zQsolve(QR,diag,b,x,tmp); x = zUsolve(QR,x,x,0.0); x = zv_resize(x,QR->n); return x; } /* zQRAsolve -- solves the system (Q.R)*.x = b -- Q & R are stored in compact form -- returns x, which is created if necessary */ ZVEC *zQRAsolve(QR,diag,b,x) ZMAT *QR; ZVEC *diag, *b, *x; { int j, limit; Real beta, r_ii, tmp_val; static ZVEC *tmp = ZVNULL; if ( ! QR || ! diag || ! b ) error(E_NULL,"zQRAsolve"); limit = min(QR->m,QR->n); if ( diag->dim < limit || b->dim != QR->n ) error(E_SIZES,"zQRAsolve"); x = zv_resize(x,QR->m); x = zUAsolve(QR,b,x,0.0); x = zv_resize(x,QR->m); tmp = zv_resize(tmp,x->dim); MEM_STAT_REG(tmp,TYPE_ZVEC); printf("zQRAsolve: tmp->dim = %d, x->dim = %d\n", tmp->dim, x->dim); /* apply H/h transforms in reverse order */ for ( j=limit-1; j>=0; j-- ) { zget_col(QR,j,tmp); tmp = zv_resize(tmp,QR->m); r_ii = zabs(tmp->ve[j]); tmp->ve[j] = diag->ve[j]; tmp_val = (r_ii*zabs(diag->ve[j])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; zhhtrvec(tmp,beta,j,x,x); } return x; } /* zQRCPsolve -- solves A.x = b where A is factored by QRCPfactor() -- assumes that A is in the compact factored form */ ZVEC *zQRCPsolve(QR,diag,pivot,b,x) ZMAT *QR; ZVEC *diag; PERM *pivot; ZVEC *b, *x; { if ( ! QR || ! diag || ! pivot || ! b ) error(E_NULL,"zQRCPsolve"); if ( (QR->m > diag->dim && QR->n > diag->dim) || QR->n != pivot->size ) error(E_SIZES,"zQRCPsolve"); x = zQRsolve(QR,diag,b,x); x = pxinv_zvec(pivot,x,x); return x; } /* zUmlt -- compute out = upper_triang(U).x -- may be in situ */ ZVEC *zUmlt(U,x,out) ZMAT *U; ZVEC *x, *out; { int i, limit; if ( U == ZMNULL || x == ZVNULL ) error(E_NULL,"zUmlt"); limit = min(U->m,U->n); if ( limit != x->dim ) error(E_SIZES,"zUmlt"); if ( out == ZVNULL || out->dim < limit ) out = zv_resize(out,limit); for ( i = 0; i < limit; i++ ) out->ve[i] = __zip__(&(x->ve[i]),&(U->me[i][i]),limit - i,Z_NOCONJ); return out; } /* zUAmlt -- returns out = upper_triang(U)^T.x */ ZVEC *zUAmlt(U,x,out) ZMAT *U; ZVEC *x, *out; { /* complex sum; */ complex tmp; int i, limit; if ( U == ZMNULL || x == ZVNULL ) error(E_NULL,"zUAmlt"); limit = min(U->m,U->n); if ( out == ZVNULL || out->dim < limit ) out = zv_resize(out,limit); for ( i = limit-1; i >= 0; i-- ) { tmp = x->ve[i]; out->ve[i].re = out->ve[i].im = 0.0; __zmltadd__(&(out->ve[i]),&(U->me[i][i]),tmp,limit-i-1,Z_CONJ); } return out; } /* zQRcondest -- returns an estimate of the 2-norm condition number of the matrix factorised by QRfactor() or QRCPfactor() -- note that as Q does not affect the 2-norm condition number, it is not necessary to pass the diag, beta (or pivot) vectors -- generates a lower bound on the true condition number -- if the matrix is exactly singular, HUGE is returned -- note that QRcondest() is likely to be more reliable for matrices factored using QRCPfactor() */ double zQRcondest(QR) ZMAT *QR; { static ZVEC *y=ZVNULL; Real norm, norm1, norm2, tmp1, tmp2; complex sum, tmp; int i, j, limit; if ( QR == ZMNULL ) error(E_NULL,"zQRcondest"); limit = min(QR->m,QR->n); for ( i = 0; i < limit; i++ ) /* if ( QR->me[i][i] == 0.0 ) */ if ( is_zero(QR->me[i][i]) ) return HUGE; y = zv_resize(y,limit); MEM_STAT_REG(y,TYPE_ZVEC); /* use the trick for getting a unit vector y with ||R.y||_inf small from the LU condition estimator */ for ( i = 0; i < limit; i++ ) { sum.re = sum.im = 0.0; for ( j = 0; j < i; j++ ) /* sum -= QR->me[j][i]*y->ve[j]; */ sum = zsub(sum,zmlt(QR->me[j][i],y->ve[j])); /* sum -= (sum < 0.0) ? 1.0 : -1.0; */ norm1 = zabs(sum); if ( norm1 == 0.0 ) sum.re = 1.0; else { sum.re += sum.re / norm1; sum.im += sum.im / norm1; } /* y->ve[i] = sum / QR->me[i][i]; */ y->ve[i] = zdiv(sum,QR->me[i][i]); } zUAmlt(QR,y,y); /* now apply inverse power method to R*.R */ for ( i = 0; i < 3; i++ ) { tmp1 = zv_norm2(y); zv_mlt(zmake(1.0/tmp1,0.0),y,y); zUAsolve(QR,y,y,0.0); tmp2 = zv_norm2(y); zv_mlt(zmake(1.0/tmp2,0.0),y,y); zUsolve(QR,y,y,0.0); } /* now compute approximation for ||R^{-1}||_2 */ norm1 = sqrt(tmp1)*sqrt(tmp2); /* now use complementary approach to compute approximation to ||R||_2 */ for ( i = limit-1; i >= 0; i-- ) { sum.re = sum.im = 0.0; for ( j = i+1; j < limit; j++ ) sum = zadd(sum,zmlt(QR->me[i][j],y->ve[j])); if ( is_zero(QR->me[i][i]) ) return HUGE; tmp = zdiv(sum,QR->me[i][i]); if ( is_zero(tmp) ) { y->ve[i].re = 1.0; y->ve[i].im = 0.0; } else { norm = zabs(tmp); y->ve[i].re = sum.re / norm; y->ve[i].im = sum.im / norm; } /* y->ve[i] = (sum >= 0.0) ? 1.0 : -1.0; */ /* y->ve[i] = (QR->me[i][i] >= 0.0) ? y->ve[i] : - y->ve[i]; */ } /* now apply power method to R*.R */ for ( i = 0; i < 3; i++ ) { tmp1 = zv_norm2(y); zv_mlt(zmake(1.0/tmp1,0.0),y,y); zUmlt(QR,y,y); tmp2 = zv_norm2(y); zv_mlt(zmake(1.0/tmp2,0.0),y,y); zUAmlt(QR,y,y); } norm2 = sqrt(tmp1)*sqrt(tmp2); /* printf("QRcondest: norm1 = %g, norm2 = %g\n",norm1,norm2); */ return norm1*norm2; } meschach-1.2b/zgivens.c100644 764 764 11435 5735556776 14554 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Givens operations file. Contains routines for calculating and applying givens rotations for/to vectors and also to matrices by row and by column. Complex version. */ static char rcsid[] = "$Id: "; #include #include "zmatrix.h" #include "zmatrix2.h" #include /* (Complex) Givens rotation matrix: [ c -s ] [ s* c ] Note that c is real and s is complex */ /* zgivens -- returns c,s parameters for Givens rotation to eliminate y in the **column** vector [ x y ] */ void zgivens(x,y,c,s) complex x,y,*s; Real *c; { Real inv_norm, norm; complex tmp; /* this is a safe way of computing sqrt(|x|^2+|y|^2) */ tmp.re = zabs(x); tmp.im = zabs(y); norm = zabs(tmp); if ( norm == 0.0 ) { *c = 1.0; s->re = s->im = 0.0; } /* identity */ else { inv_norm = 1.0 / tmp.re; /* inv_norm = 1/|x| */ x.re *= inv_norm; x.im *= inv_norm; /* normalise x */ inv_norm = 1.0/norm; /* inv_norm = 1/||[x,y]||2 */ *c = tmp.re * inv_norm; /* now compute - conj(normalised x).y/||[x,y]||2 */ s->re = - inv_norm*(x.re*y.re + x.im*y.im); s->im = inv_norm*(x.re*y.im - x.im*y.re); } } /* rot_zvec -- apply Givens rotation to x's i & k components */ ZVEC *rot_zvec(x,i,k,c,s,out) ZVEC *x,*out; int i,k; double c; complex s; { complex temp1, temp2; if ( x==ZVNULL ) error(E_NULL,"rot_zvec"); if ( i < 0 || i >= x->dim || k < 0 || k >= x->dim ) error(E_RANGE,"rot_zvec"); if ( x != out ) out = zv_copy(x,out); /* temp1 = c*out->ve[i] - s*out->ve[k]; */ temp1.re = c*out->ve[i].re - s.re*out->ve[k].re + s.im*out->ve[k].im; temp1.im = c*out->ve[i].im - s.re*out->ve[k].im - s.im*out->ve[k].re; /* temp2 = c*out->ve[k] + zconj(s)*out->ve[i]; */ temp2.re = c*out->ve[k].re + s.re*out->ve[i].re + s.im*out->ve[i].im; temp2.im = c*out->ve[k].im + s.re*out->ve[i].im - s.im*out->ve[i].re; out->ve[i] = temp1; out->ve[k] = temp2; return (out); } /* zrot_rows -- premultiply mat by givens rotation described by c,s */ ZMAT *zrot_rows(mat,i,k,c,s,out) ZMAT *mat,*out; int i,k; double c; complex s; { u_int j; complex temp1, temp2; if ( mat==ZMNULL ) error(E_NULL,"zrot_rows"); if ( i < 0 || i >= mat->m || k < 0 || k >= mat->m ) error(E_RANGE,"zrot_rows"); if ( mat != out ) out = zm_copy(mat,zm_resize(out,mat->m,mat->n)); /* temp1 = c*out->me[i][j] - s*out->me[k][j]; */ for ( j=0; jn; j++ ) { /* temp1 = c*out->me[i][j] - s*out->me[k][j]; */ temp1.re = c*out->me[i][j].re - s.re*out->me[k][j].re + s.im*out->me[k][j].im; temp1.im = c*out->me[i][j].im - s.re*out->me[k][j].im - s.im*out->me[k][j].re; /* temp2 = c*out->me[k][j] + conj(s)*out->me[i][j]; */ temp2.re = c*out->me[k][j].re + s.re*out->me[i][j].re + s.im*out->me[i][j].im; temp2.im = c*out->me[k][j].im + s.re*out->me[i][j].im - s.im*out->me[i][j].re; out->me[i][j] = temp1; out->me[k][j] = temp2; } return (out); } /* zrot_cols -- postmultiply mat by adjoint Givens rotation described by c,s */ ZMAT *zrot_cols(mat,i,k,c,s,out) ZMAT *mat,*out; int i,k; double c; complex s; { u_int j; complex x, y; if ( mat==ZMNULL ) error(E_NULL,"zrot_cols"); if ( i < 0 || i >= mat->n || k < 0 || k >= mat->n ) error(E_RANGE,"zrot_cols"); if ( mat != out ) out = zm_copy(mat,zm_resize(out,mat->m,mat->n)); for ( j=0; jm; j++ ) { x = out->me[j][i]; y = out->me[j][k]; /* out->me[j][i] = c*x - conj(s)*y; */ out->me[j][i].re = c*x.re - s.re*y.re - s.im*y.im; out->me[j][i].im = c*x.im - s.re*y.im + s.im*y.re; /* out->me[j][k] = c*y + s*x; */ out->me[j][k].re = c*y.re + s.re*x.re - s.im*x.im; out->me[j][k].im = c*y.im + s.re*x.im + s.im*x.re; } return (out); } meschach-1.2b/zhessen.c100644 764 764 7603 5735557115 14514 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing routines for determining Hessenberg factorisations. Complex version */ static char rcsid[] = "$Id: zhessen.c,v 1.2 1995/03/27 15:47:50 des Exp $"; #include #include "zmatrix.h" #include "zmatrix2.h" /* zHfactor -- compute Hessenberg factorisation in compact form. -- factorisation performed in situ -- for details of the compact form see zQRfactor.c and zmatrix2.doc */ ZMAT *zHfactor(A, diag) ZMAT *A; ZVEC *diag; { static ZVEC *tmp1 = ZVNULL; Real beta; int k, limit; if ( ! A || ! diag ) error(E_NULL,"zHfactor"); if ( diag->dim < A->m - 1 ) error(E_SIZES,"zHfactor"); if ( A->m != A->n ) error(E_SQUARE,"zHfactor"); limit = A->m - 1; tmp1 = zv_resize(tmp1,A->m); MEM_STAT_REG(tmp1,TYPE_ZVEC); for ( k = 0; k < limit; k++ ) { zget_col(A,k,tmp1); zhhvec(tmp1,k+1,&beta,tmp1,&A->me[k+1][k]); diag->ve[k] = tmp1->ve[k+1]; /* printf("zHfactor: k = %d, beta = %g, tmp1 =\n",k,beta); zv_output(tmp1); */ zhhtrcols(A,k+1,k+1,tmp1,beta); zhhtrrows(A,0 ,k+1,tmp1,beta); /* printf("# at stage k = %d, A =\n",k); zm_output(A); */ } return (A); } /* zHQunpack -- unpack the compact representation of H and Q of a Hessenberg factorisation -- if either H or Q is NULL, then it is not unpacked -- it can be in situ with HQ == H -- returns HQ */ ZMAT *zHQunpack(HQ,diag,Q,H) ZMAT *HQ, *Q, *H; ZVEC *diag; { int i, j, limit; Real beta, r_ii, tmp_val; static ZVEC *tmp1 = ZVNULL, *tmp2 = ZVNULL; if ( HQ==ZMNULL || diag==ZVNULL ) error(E_NULL,"zHQunpack"); if ( HQ == Q || H == Q ) error(E_INSITU,"zHQunpack"); limit = HQ->m - 1; if ( diag->dim < limit ) error(E_SIZES,"zHQunpack"); if ( HQ->m != HQ->n ) error(E_SQUARE,"zHQunpack"); if ( Q != ZMNULL ) { Q = zm_resize(Q,HQ->m,HQ->m); tmp1 = zv_resize(tmp1,H->m); tmp2 = zv_resize(tmp2,H->m); MEM_STAT_REG(tmp1,TYPE_ZVEC); MEM_STAT_REG(tmp2,TYPE_ZVEC); for ( i = 0; i < H->m; i++ ) { /* tmp1 = i'th basis vector */ for ( j = 0; j < H->m; j++ ) tmp1->ve[j].re = tmp1->ve[j].im = 0.0; tmp1->ve[i].re = 1.0; /* apply H/h transforms in reverse order */ for ( j = limit-1; j >= 0; j-- ) { zget_col(HQ,j,tmp2); r_ii = zabs(tmp2->ve[j+1]); tmp2->ve[j+1] = diag->ve[j]; tmp_val = (r_ii*zabs(diag->ve[j])); beta = ( tmp_val == 0.0 ) ? 0.0 : 1.0/tmp_val; /* printf("zHQunpack: j = %d, beta = %g, tmp2 =\n", j,beta); zv_output(tmp2); */ zhhtrvec(tmp2,beta,j+1,tmp1,tmp1); } /* insert into Q */ zset_col(Q,i,tmp1); } } if ( H != ZMNULL ) { H = zm_copy(HQ,zm_resize(H,HQ->m,HQ->n)); limit = H->m; for ( i = 1; i < limit; i++ ) for ( j = 0; j < i-1; j++ ) H->me[i][j].re = H->me[i][j].im = 0.0; } return HQ; } meschach-1.2b/zschur.c100644 764 764 25726 5741264117 14373 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing routines for computing the Schur decomposition of a complex non-symmetric matrix See also: hessen.c Complex version */ #include #include "zmatrix.h" #include "zmatrix2.h" #include static char rcsid[] = "$Id: zschur.c,v 1.4 1995/04/07 16:28:58 des Exp $"; #define is_zero(z) ((z).re == 0.0 && (z).im == 0.0) #define b2s(t_or_f) ((t_or_f) ? "TRUE" : "FALSE") /* zschur -- computes the Schur decomposition of the matrix A in situ -- optionally, gives Q matrix such that Q^*.A.Q is upper triangular -- returns upper triangular Schur matrix */ ZMAT *zschur(A,Q) ZMAT *A, *Q; { int i, j, iter, k, k_min, k_max, k_tmp, n, split; Real c; complex det, discrim, lambda, lambda0, lambda1, s, sum, ztmp; complex x, y; /* for chasing algorithm */ complex **A_me; static ZVEC *diag=ZVNULL; if ( ! A ) error(E_NULL,"zschur"); if ( A->m != A->n || ( Q && Q->m != Q->n ) ) error(E_SQUARE,"zschur"); if ( Q != ZMNULL && Q->m != A->m ) error(E_SIZES,"zschur"); n = A->n; diag = zv_resize(diag,A->n); MEM_STAT_REG(diag,TYPE_ZVEC); /* compute Hessenberg form */ zHfactor(A,diag); /* save Q if necessary, and make A explicitly Hessenberg */ zHQunpack(A,diag,Q,A); k_min = 0; A_me = A->me; while ( k_min < n ) { /* find k_max to suit: submatrix k_min..k_max should be irreducible */ k_max = n-1; for ( k = k_min; k < k_max; k++ ) if ( is_zero(A_me[k+1][k]) ) { k_max = k; break; } if ( k_max <= k_min ) { k_min = k_max + 1; continue; /* outer loop */ } /* now have r x r block with r >= 2: apply Francis QR step until block splits */ split = FALSE; iter = 0; while ( ! split ) { complex a00, a01, a10, a11; iter++; /* set up Wilkinson/Francis complex shift */ /* use the smallest eigenvalue of the bottom 2 x 2 submatrix */ k_tmp = k_max - 1; a00 = A_me[k_tmp][k_tmp]; a01 = A_me[k_tmp][k_max]; a10 = A_me[k_max][k_tmp]; a11 = A_me[k_max][k_max]; ztmp.re = 0.5*(a00.re - a11.re); ztmp.im = 0.5*(a00.im - a11.im); discrim = zsqrt(zadd(zmlt(ztmp,ztmp),zmlt(a01,a10))); sum.re = 0.5*(a00.re + a11.re); sum.im = 0.5*(a00.im + a11.im); lambda0 = zadd(sum,discrim); lambda1 = zsub(sum,discrim); det = zsub(zmlt(a00,a11),zmlt(a01,a10)); if ( is_zero(lambda0) && is_zero(lambda1) ) { lambda.re = lambda.im = 0.0; } else if ( zabs(lambda0) > zabs(lambda1) ) lambda = zdiv(det,lambda0); else lambda = zdiv(det,lambda1); /* perturb shift if convergence is slow */ if ( (iter % 10) == 0 ) { lambda.re += iter*0.02; lambda.im += iter*0.02; } /* set up Householder transformations */ k_tmp = k_min + 1; x = zsub(A->me[k_min][k_min],lambda); y = A->me[k_min+1][k_min]; /* use Givens' rotations to "chase" off-Hessenberg entry */ for ( k = k_min; k <= k_max-1; k++ ) { zgivens(x,y,&c,&s); zrot_cols(A,k,k+1,c,s,A); zrot_rows(A,k,k+1,c,s,A); if ( Q != ZMNULL ) zrot_cols(Q,k,k+1,c,s,Q); /* zero things that should be zero */ if ( k > k_min ) A->me[k+1][k-1].re = A->me[k+1][k-1].im = 0.0; /* get next entry to chase along sub-diagonal */ x = A->me[k+1][k]; if ( k <= k_max - 2 ) y = A->me[k+2][k]; else y.re = y.im = 0.0; } for ( k = k_min; k <= k_max-2; k++ ) { /* zero appropriate sub-diagonals */ A->me[k+2][k].re = A->me[k+2][k].im = 0.0; } /* test to see if matrix should split */ for ( k = k_min; k < k_max; k++ ) if ( zabs(A_me[k+1][k]) < MACHEPS* (zabs(A_me[k][k])+zabs(A_me[k+1][k+1])) ) { A_me[k+1][k].re = A_me[k+1][k].im = 0.0; split = TRUE; } } } /* polish up A by zeroing strictly lower triangular elements and small sub-diagonal elements */ for ( i = 0; i < A->m; i++ ) for ( j = 0; j < i-1; j++ ) A_me[i][j].re = A_me[i][j].im = 0.0; for ( i = 0; i < A->m - 1; i++ ) if ( zabs(A_me[i+1][i]) < MACHEPS* (zabs(A_me[i][i])+zabs(A_me[i+1][i+1])) ) A_me[i+1][i].re = A_me[i+1][i].im = 0.0; return A; } #if 0 /* schur_vecs -- returns eigenvectors computed from the real Schur decomposition of a matrix -- T is the block upper triangular Schur matrix -- Q is the orthognal matrix where A = Q.T.Q^T -- if Q is null, the eigenvectors of T are returned -- X_re is the real part of the matrix of eigenvectors, and X_im is the imaginary part of the matrix. -- X_re is returned */ MAT *schur_vecs(T,Q,X_re,X_im) MAT *T, *Q, *X_re, *X_im; { int i, j, limit; Real t11_re, t11_im, t12, t21, t22_re, t22_im; Real l_re, l_im, det_re, det_im, invdet_re, invdet_im, val1_re, val1_im, val2_re, val2_im, tmp_val1_re, tmp_val1_im, tmp_val2_re, tmp_val2_im, **T_me; Real sum, diff, discrim, magdet, norm, scale; static VEC *tmp1_re=VNULL, *tmp1_im=VNULL, *tmp2_re=VNULL, *tmp2_im=VNULL; if ( ! T || ! X_re ) error(E_NULL,"schur_vecs"); if ( T->m != T->n || X_re->m != X_re->n || ( Q != MNULL && Q->m != Q->n ) || ( X_im != MNULL && X_im->m != X_im->n ) ) error(E_SQUARE,"schur_vecs"); if ( T->m != X_re->m || ( Q != MNULL && T->m != Q->m ) || ( X_im != MNULL && T->m != X_im->m ) ) error(E_SIZES,"schur_vecs"); tmp1_re = v_resize(tmp1_re,T->m); tmp1_im = v_resize(tmp1_im,T->m); tmp2_re = v_resize(tmp2_re,T->m); tmp2_im = v_resize(tmp2_im,T->m); MEM_STAT_REG(tmp1_re,TYPE_VEC); MEM_STAT_REG(tmp1_im,TYPE_VEC); MEM_STAT_REG(tmp2_re,TYPE_VEC); MEM_STAT_REG(tmp2_im,TYPE_VEC); T_me = T->me; i = 0; while ( i < T->m ) { if ( i+1 < T->m && T->me[i+1][i] != 0.0 ) { /* complex eigenvalue */ sum = 0.5*(T_me[i][i]+T_me[i+1][i+1]); diff = 0.5*(T_me[i][i]-T_me[i+1][i+1]); discrim = diff*diff + T_me[i][i+1]*T_me[i+1][i]; l_re = l_im = 0.0; if ( discrim < 0.0 ) { /* yes -- complex e-vals */ l_re = sum; l_im = sqrt(-discrim); } else /* not correct Real Schur form */ error(E_RANGE,"schur_vecs"); } else { l_re = T_me[i][i]; l_im = 0.0; } v_zero(tmp1_im); v_rand(tmp1_re); sv_mlt(MACHEPS,tmp1_re,tmp1_re); /* solve (T-l.I)x = tmp1 */ limit = ( l_im != 0.0 ) ? i+1 : i; /* printf("limit = %d\n",limit); */ for ( j = limit+1; j < T->m; j++ ) tmp1_re->ve[j] = 0.0; j = limit; while ( j >= 0 ) { if ( j > 0 && T->me[j][j-1] != 0.0 ) { /* 2 x 2 diagonal block */ /* printf("checkpoint A\n"); */ val1_re = tmp1_re->ve[j-1] - __ip__(&(tmp1_re->ve[j+1]),&(T->me[j-1][j+1]),limit-j); /* printf("checkpoint B\n"); */ val1_im = tmp1_im->ve[j-1] - __ip__(&(tmp1_im->ve[j+1]),&(T->me[j-1][j+1]),limit-j); /* printf("checkpoint C\n"); */ val2_re = tmp1_re->ve[j] - __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint D\n"); */ val2_im = tmp1_im->ve[j] - __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint E\n"); */ t11_re = T_me[j-1][j-1] - l_re; t11_im = - l_im; t22_re = T_me[j][j] - l_re; t22_im = - l_im; t12 = T_me[j-1][j]; t21 = T_me[j][j-1]; scale = fabs(T_me[j-1][j-1]) + fabs(T_me[j][j]) + fabs(t12) + fabs(t21) + fabs(l_re) + fabs(l_im); det_re = t11_re*t22_re - t11_im*t22_im - t12*t21; det_im = t11_re*t22_im + t11_im*t22_re; magdet = det_re*det_re+det_im*det_im; if ( sqrt(magdet) < MACHEPS*scale ) { det_re = MACHEPS*scale; magdet = det_re*det_re+det_im*det_im; } invdet_re = det_re/magdet; invdet_im = - det_im/magdet; tmp_val1_re = t22_re*val1_re-t22_im*val1_im-t12*val2_re; tmp_val1_im = t22_im*val1_re+t22_re*val1_im-t12*val2_im; tmp_val2_re = t11_re*val2_re-t11_im*val2_im-t21*val1_re; tmp_val2_im = t11_im*val2_re+t11_re*val2_im-t21*val1_im; tmp1_re->ve[j-1] = invdet_re*tmp_val1_re - invdet_im*tmp_val1_im; tmp1_im->ve[j-1] = invdet_im*tmp_val1_re + invdet_re*tmp_val1_im; tmp1_re->ve[j] = invdet_re*tmp_val2_re - invdet_im*tmp_val2_im; tmp1_im->ve[j] = invdet_im*tmp_val2_re + invdet_re*tmp_val2_im; j -= 2; } else { t11_re = T_me[j][j] - l_re; t11_im = - l_im; magdet = t11_re*t11_re + t11_im*t11_im; scale = fabs(T_me[j][j]) + fabs(l_re); if ( sqrt(magdet) < MACHEPS*scale ) { t11_re = MACHEPS*scale; magdet = t11_re*t11_re + t11_im*t11_im; } invdet_re = t11_re/magdet; invdet_im = - t11_im/magdet; /* printf("checkpoint F\n"); */ val1_re = tmp1_re->ve[j] - __ip__(&(tmp1_re->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint G\n"); */ val1_im = tmp1_im->ve[j] - __ip__(&(tmp1_im->ve[j+1]),&(T->me[j][j+1]),limit-j); /* printf("checkpoint H\n"); */ tmp1_re->ve[j] = invdet_re*val1_re - invdet_im*val1_im; tmp1_im->ve[j] = invdet_im*val1_re + invdet_re*val1_im; j -= 1; } } norm = v_norm_inf(tmp1_re) + v_norm_inf(tmp1_im); sv_mlt(1/norm,tmp1_re,tmp1_re); if ( l_im != 0.0 ) sv_mlt(1/norm,tmp1_im,tmp1_im); mv_mlt(Q,tmp1_re,tmp2_re); if ( l_im != 0.0 ) mv_mlt(Q,tmp1_im,tmp2_im); if ( l_im != 0.0 ) norm = sqrt(in_prod(tmp2_re,tmp2_re)+in_prod(tmp2_im,tmp2_im)); else norm = v_norm2(tmp2_re); sv_mlt(1/norm,tmp2_re,tmp2_re); if ( l_im != 0.0 ) sv_mlt(1/norm,tmp2_im,tmp2_im); if ( l_im != 0.0 ) { if ( ! X_im ) error(E_NULL,"schur_vecs"); set_col(X_re,i,tmp2_re); set_col(X_im,i,tmp2_im); sv_mlt(-1.0,tmp2_im,tmp2_im); set_col(X_re,i+1,tmp2_re); set_col(X_im,i+1,tmp2_im); i += 2; } else { set_col(X_re,i,tmp2_re); if ( X_im != MNULL ) set_col(X_im,i,tmp1_im); /* zero vector */ i += 1; } } return X_re; } #endif meschach-1.2b/conjgrad.c100644 764 764 20072 5515156771 14636 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Conjugate gradient routines file Uses sparse matrix input & sparse Cholesky factorisation in pccg(). All the following routines use routines to define a matrix rather than use any explicit representation (with the exeception of the pccg() pre-conditioner) The matrix A is defined by VEC *(*A)(void *params, VEC *x, VEC *y) where y = A.x on exit, and y is returned. The params argument is intended to make it easier to re-use & modify such routines. If we have a sparse matrix data structure SPMAT *A_mat; then these can be used by passing sp_mv_mlt as the function, and A_mat as the param. */ #include #include #include "matrix.h" #include "sparse.h" static char rcsid[] = "$Id: conjgrad.c,v 1.4 1994/01/13 05:36:45 des Exp $"; /* #define MAX_ITER 10000 */ static int max_iter = 10000; int cg_num_iters; /* matrix-as-routine type definition */ /* #ifdef ANSI_C */ /* typedef VEC *(*MTX_FN)(void *params, VEC *x, VEC *out); */ /* #else */ typedef VEC *(*MTX_FN)(); /* #endif */ #ifdef ANSI_C VEC *spCHsolve(SPMAT *,VEC *,VEC *); #else VEC *spCHsolve(); #endif /* cg_set_maxiter -- sets maximum number of iterations if numiter > 1 -- just returns current max_iter otherwise -- returns old maximum */ int cg_set_maxiter(numiter) int numiter; { int temp; if ( numiter < 2 ) return max_iter; temp = max_iter; max_iter = numiter; return temp; } /* pccg -- solves A.x = b using pre-conditioner M (assumed factored a la spCHfctr()) -- results are stored in x (if x != NULL), which is returned */ VEC *pccg(A,A_params,M_inv,M_params,b,eps,x) MTX_FN A, M_inv; VEC *b, *x; double eps; void *A_params, *M_params; { VEC *r = VNULL, *p = VNULL, *q = VNULL, *z = VNULL; int k; Real alpha, beta, ip, old_ip, norm_b; if ( ! A || ! b ) error(E_NULL,"pccg"); if ( x == b ) error(E_INSITU,"pccg"); x = v_resize(x,b->dim); if ( eps <= 0.0 ) eps = MACHEPS; r = v_get(b->dim); p = v_get(b->dim); q = v_get(b->dim); z = v_get(b->dim); norm_b = v_norm2(b); v_zero(x); r = v_copy(b,r); old_ip = 0.0; for ( k = 0; ; k++ ) { if ( v_norm2(r) < eps*norm_b ) break; if ( k > max_iter ) error(E_ITER,"pccg"); if ( M_inv ) (*M_inv)(M_params,r,z); else v_copy(r,z); /* M == identity */ ip = in_prod(z,r); if ( k ) /* if ( k > 0 ) ... */ { beta = ip/old_ip; p = v_mltadd(z,p,beta,p); } else /* if ( k == 0 ) ... */ { beta = 0.0; p = v_copy(z,p); old_ip = 0.0; } q = (*A)(A_params,p,q); alpha = ip/in_prod(p,q); x = v_mltadd(x,p,alpha,x); r = v_mltadd(r,q,-alpha,r); old_ip = ip; } cg_num_iters = k; V_FREE(p); V_FREE(q); V_FREE(r); V_FREE(z); return x; } /* sp_pccg -- a simple interface to pccg() which uses sparse matrix data structures -- assumes that LLT contains the Cholesky factorisation of the actual pre-conditioner */ VEC *sp_pccg(A,LLT,b,eps,x) SPMAT *A, *LLT; VEC *b, *x; double eps; { return pccg(sp_mv_mlt,A,spCHsolve,LLT,b,eps,x); } /* Routines for performing the CGS (Conjugate Gradient Squared) algorithm of P. Sonneveld: "CGS, a fast Lanczos-type solver for nonsymmetric linear systems", SIAM J. Sci. & Stat. Comp. v. 10, pp. 36--52 */ /* cgs -- uses CGS to compute a solution x to A.x=b -- the matrix A is not passed explicitly, rather a routine A is passed where A(x,Ax,params) computes Ax = A.x -- the computed solution is passed */ VEC *cgs(A,A_params,b,r0,tol,x) MTX_FN A; VEC *x, *b; VEC *r0; /* tilde r0 parameter -- should be random??? */ double tol; /* error tolerance used */ void *A_params; { VEC *p, *q, *r, *u, *v, *tmp1, *tmp2; Real alpha, beta, norm_b, rho, old_rho, sigma; int iter; if ( ! A || ! x || ! b || ! r0 ) error(E_NULL,"cgs"); if ( x->dim != b->dim || r0->dim != x->dim ) error(E_SIZES,"cgs"); if ( tol <= 0.0 ) tol = MACHEPS; p = v_get(x->dim); q = v_get(x->dim); r = v_get(x->dim); u = v_get(x->dim); v = v_get(x->dim); tmp1 = v_get(x->dim); tmp2 = v_get(x->dim); norm_b = v_norm2(b); (*A)(A_params,x,tmp1); v_sub(b,tmp1,r); v_zero(p); v_zero(q); old_rho = 1.0; iter = 0; while ( v_norm2(r) > tol*norm_b ) { if ( ++iter > max_iter ) break; /* error(E_ITER,"cgs"); */ rho = in_prod(r0,r); if ( old_rho == 0.0 ) error(E_SING,"cgs"); beta = rho/old_rho; v_mltadd(r,q,beta,u); v_mltadd(q,p,beta,tmp1); v_mltadd(u,tmp1,beta,p); (*A)(A_params,p,v); sigma = in_prod(r0,v); if ( sigma == 0.0 ) error(E_SING,"cgs"); alpha = rho/sigma; v_mltadd(u,v,-alpha,q); v_add(u,q,tmp1); (*A)(A_params,tmp1,tmp2); v_mltadd(r,tmp2,-alpha,r); v_mltadd(x,tmp1,alpha,x); old_rho = rho; } cg_num_iters = iter; V_FREE(p); V_FREE(q); V_FREE(r); V_FREE(u); V_FREE(v); V_FREE(tmp1); V_FREE(tmp2); return x; } /* sp_cgs -- simple interface for SPMAT data structures */ VEC *sp_cgs(A,b,r0,tol,x) SPMAT *A; VEC *b, *r0, *x; double tol; { return cgs(sp_mv_mlt,A,b,r0,tol,x); } /* Routine for performing LSQR -- the least squares QR algorithm of Paige and Saunders: "LSQR: an algorithm for sparse linear equations and sparse least squares", ACM Trans. Math. Soft., v. 8 pp. 43--71 (1982) */ /* lsqr -- sparse CG-like least squares routine: -- finds min_x ||A.x-b||_2 using A defined through A & AT -- returns x (if x != NULL) */ VEC *lsqr(A,AT,A_params,b,tol,x) MTX_FN A, AT; /* AT is A transposed */ VEC *x, *b; double tol; /* error tolerance used */ void *A_params; { VEC *u, *v, *w, *tmp; Real alpha, beta, norm_b, phi, phi_bar, rho, rho_bar, rho_max, theta; Real s, c; /* for Givens' rotations */ int iter, m, n; if ( ! b || ! x ) error(E_NULL,"lsqr"); if ( tol <= 0.0 ) tol = MACHEPS; m = b->dim; n = x->dim; u = v_get((u_int)m); v = v_get((u_int)n); w = v_get((u_int)n); tmp = v_get((u_int)n); norm_b = v_norm2(b); v_zero(x); beta = v_norm2(b); if ( beta == 0.0 ) return x; sv_mlt(1.0/beta,b,u); tracecatch((*AT)(A_params,u,v),"lsqr"); alpha = v_norm2(v); if ( alpha == 0.0 ) return x; sv_mlt(1.0/alpha,v,v); v_copy(v,w); phi_bar = beta; rho_bar = alpha; rho_max = 1.0; iter = 0; do { if ( ++iter > max_iter ) error(E_ITER,"lsqr"); tmp = v_resize(tmp,m); tracecatch((*A) (A_params,v,tmp),"lsqr"); v_mltadd(tmp,u,-alpha,u); beta = v_norm2(u); sv_mlt(1.0/beta,u,u); tmp = v_resize(tmp,n); tracecatch((*AT)(A_params,u,tmp),"lsqr"); v_mltadd(tmp,v,-beta,v); alpha = v_norm2(v); sv_mlt(1.0/alpha,v,v); rho = sqrt(rho_bar*rho_bar+beta*beta); if ( rho > rho_max ) rho_max = rho; c = rho_bar/rho; s = beta/rho; theta = s*alpha; rho_bar = -c*alpha; phi = c*phi_bar; phi_bar = s*phi_bar; /* update x & w */ if ( rho == 0.0 ) error(E_SING,"lsqr"); v_mltadd(x,w,phi/rho,x); v_mltadd(v,w,-theta/rho,w); } while ( fabs(phi_bar*alpha*c) > tol*norm_b/rho_max ); cg_num_iters = iter; V_FREE(tmp); V_FREE(u); V_FREE(v); V_FREE(w); return x; } /* sp_lsqr -- simple interface for SPMAT data structures */ VEC *sp_lsqr(A,b,tol,x) SPMAT *A; VEC *b, *x; double tol; { return lsqr(sp_mv_mlt,sp_vm_mlt,A,b,tol,x); } meschach-1.2b/lanczos.c100644 764 764 17065 5515156012 14514 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* File containing Lanczos type routines for finding eigenvalues of large, sparse, symmetic matrices */ #include #include #include "matrix.h" #include "sparse.h" static char rcsid[] = "$Id: lanczos.c,v 1.4 1994/01/13 05:28:24 des Exp $"; #ifdef ANSI_C extern VEC *trieig(VEC *,VEC *,MAT *); #else extern VEC *trieig(); #endif /* lanczos -- raw lanczos algorithm -- no re-orthogonalisation -- creates T matrix of size == m, but no larger than before beta_k == 0 -- uses passed routine to do matrix-vector multiplies */ void lanczos(A_fn,A_params,m,x0,a,b,beta2,Q) VEC *(*A_fn)(); /* VEC *(*A_fn)(void *A_params,VEC *in, VEC *out) */ void *A_params; int m; VEC *x0, *a, *b; Real *beta2; MAT *Q; { int j; VEC *v, *w, *tmp; Real alpha, beta; if ( ! A_fn || ! x0 || ! a || ! b ) error(E_NULL,"lanczos"); if ( m <= 0 ) error(E_BOUNDS,"lanczos"); if ( Q && ( Q->m < x0->dim || Q->n < m ) ) error(E_SIZES,"lanczos"); a = v_resize(a,(u_int)m); b = v_resize(b,(u_int)(m-1)); v = v_get(x0->dim); w = v_get(x0->dim); tmp = v_get(x0->dim); beta = 1.0; /* normalise x0 as w */ sv_mlt(1.0/v_norm2(x0),x0,w); (*A_fn)(A_params,w,v); for ( j = 0; j < m; j++ ) { /* store w in Q if Q not NULL */ if ( Q ) set_col(Q,j,w); alpha = in_prod(w,v); a->ve[j] = alpha; v_mltadd(v,w,-alpha,v); beta = v_norm2(v); if ( beta == 0.0 ) { v_resize(a,(u_int)j+1); v_resize(b,(u_int)j); *beta2 = 0.0; if ( Q ) Q = m_resize(Q,Q->m,j+1); return; } if ( j < m-1 ) b->ve[j] = beta; v_copy(w,tmp); sv_mlt(1/beta,v,w); sv_mlt(-beta,tmp,v); (*A_fn)(A_params,w,tmp); v_add(v,tmp,v); } *beta2 = beta; V_FREE(v); V_FREE(w); V_FREE(tmp); } extern double frexp(), ldexp(); /* product -- returns the product of a long list of numbers -- answer stored in mant (mantissa) and expt (exponent) */ static double product(a,offset,expt) VEC *a; double offset; int *expt; { Real mant, tmp_fctr; int i, tmp_expt; if ( ! a ) error(E_NULL,"product"); mant = 1.0; *expt = 0; if ( offset == 0.0 ) for ( i = 0; i < a->dim; i++ ) { mant *= frexp(a->ve[i],&tmp_expt); *expt += tmp_expt; if ( ! (i % 10) ) { mant = frexp(mant,&tmp_expt); *expt += tmp_expt; } } else for ( i = 0; i < a->dim; i++ ) { tmp_fctr = a->ve[i] - offset; tmp_fctr += (tmp_fctr > 0.0 ) ? -MACHEPS*offset : MACHEPS*offset; mant *= frexp(tmp_fctr,&tmp_expt); *expt += tmp_expt; if ( ! (i % 10) ) { mant = frexp(mant,&tmp_expt); *expt += tmp_expt; } } mant = frexp(mant,&tmp_expt); *expt += tmp_expt; return mant; } /* product2 -- returns the product of a long list of numbers -- answer stored in mant (mantissa) and expt (exponent) */ static double product2(a,k,expt) VEC *a; int k; /* entry of a to leave out */ int *expt; { Real mant, mu, tmp_fctr; int i, tmp_expt; if ( ! a ) error(E_NULL,"product2"); if ( k < 0 || k >= a->dim ) error(E_BOUNDS,"product2"); mant = 1.0; *expt = 0; mu = a->ve[k]; for ( i = 0; i < a->dim; i++ ) { if ( i == k ) continue; tmp_fctr = a->ve[i] - mu; tmp_fctr += ( tmp_fctr > 0.0 ) ? -MACHEPS*mu : MACHEPS*mu; mant *= frexp(tmp_fctr,&tmp_expt); *expt += tmp_expt; if ( ! (i % 10) ) { mant = frexp(mant,&tmp_expt); *expt += tmp_expt; } } mant = frexp(mant,&tmp_expt); *expt += tmp_expt; return mant; } /* dbl_cmp -- comparison function to pass to qsort() */ static int dbl_cmp(x,y) Real *x, *y; { Real tmp; tmp = *x - *y; return (tmp > 0 ? 1 : tmp < 0 ? -1: 0); } /* lanczos2 -- lanczos + error estimate for every e-val -- uses Cullum & Willoughby approach, Sparse Matrix Proc. 1978 -- returns multiple e-vals where multiple e-vals may not exist -- returns evals vector */ VEC *lanczos2(A_fn,A_params,m,x0,evals,err_est) VEC *(*A_fn)(); void *A_params; int m; VEC *x0; /* initial vector */ VEC *evals; /* eigenvalue vector */ VEC *err_est; /* error estimates of eigenvalues */ { VEC *a; static VEC *b=VNULL, *a2=VNULL, *b2=VNULL; Real beta, pb_mant, det_mant, det_mant1, det_mant2; int i, pb_expt, det_expt, det_expt1, det_expt2; if ( ! A_fn || ! x0 ) error(E_NULL,"lanczos2"); if ( m <= 0 ) error(E_RANGE,"lanczos2"); a = evals; a = v_resize(a,(u_int)m); b = v_resize(b,(u_int)(m-1)); MEM_STAT_REG(b,TYPE_VEC); lanczos(A_fn,A_params,m,x0,a,b,&beta,MNULL); /* printf("# beta =%g\n",beta); */ pb_mant = 0.0; if ( err_est ) { pb_mant = product(b,(double)0.0,&pb_expt); /* printf("# pb_mant = %g, pb_expt = %d\n",pb_mant, pb_expt); */ } /* printf("# diags =\n"); out_vec(a); */ /* printf("# off diags =\n"); out_vec(b); */ a2 = v_resize(a2,a->dim - 1); b2 = v_resize(b2,b->dim - 1); MEM_STAT_REG(a2,TYPE_VEC); MEM_STAT_REG(b2,TYPE_VEC); for ( i = 0; i < a2->dim - 1; i++ ) { a2->ve[i] = a->ve[i+1]; b2->ve[i] = b->ve[i+1]; } a2->ve[a2->dim-1] = a->ve[a2->dim]; trieig(a,b,MNULL); /* sort evals as a courtesy */ qsort((void *)(a->ve),(int)(a->dim),sizeof(Real),(int (*)())dbl_cmp); /* error estimates */ if ( err_est ) { err_est = v_resize(err_est,(u_int)m); trieig(a2,b2,MNULL); /* printf("# a =\n"); out_vec(a); */ /* printf("# a2 =\n"); out_vec(a2); */ for ( i = 0; i < a->dim; i++ ) { det_mant1 = product2(a,i,&det_expt1); det_mant2 = product(a2,(double)a->ve[i],&det_expt2); /* printf("# det_mant1=%g, det_expt1=%d\n", det_mant1,det_expt1); */ /* printf("# det_mant2=%g, det_expt2=%d\n", det_mant2,det_expt2); */ if ( det_mant1 == 0.0 ) { /* multiple e-val of T */ err_est->ve[i] = 0.0; continue; } else if ( det_mant2 == 0.0 ) { err_est->ve[i] = HUGE; continue; } if ( (det_expt1 + det_expt2) % 2 ) /* if odd... */ det_mant = sqrt(2.0*fabs(det_mant1*det_mant2)); else /* if even... */ det_mant = sqrt(fabs(det_mant1*det_mant2)); det_expt = (det_expt1+det_expt2)/2; err_est->ve[i] = fabs(beta* ldexp(pb_mant/det_mant,pb_expt-det_expt)); } } return a; } /* sp_lanczos -- version that uses sparse matrix data structure */ void sp_lanczos(A,m,x0,a,b,beta2,Q) SPMAT *A; int m; VEC *x0, *a, *b; Real *beta2; MAT *Q; { lanczos(sp_mv_mlt,A,m,x0,a,b,beta2,Q); } /* sp_lanczos2 -- version of lanczos2() that uses sparse matrix data structure */ VEC *sp_lanczos2(A,m,x0,evals,err_est) SPMAT *A; int m; VEC *x0; /* initial vector */ VEC *evals; /* eigenvalue vector */ VEC *err_est; /* error estimates of eigenvalues */ { return lanczos2(sp_mv_mlt,A,m,x0,evals,err_est); } meschach-1.2b/arnoldi.c100644 764 764 11354 5515160016 14465 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Arnoldi method for finding eigenvalues of large non-symmetric matrices */ #include #include #include "matrix.h" #include "matrix2.h" #include "sparse.h" static char rcsid[] = "$Id: arnoldi.c,v 1.3 1994/01/13 05:45:40 des Exp $"; /* arnoldi -- an implementation of the Arnoldi method */ MAT *arnoldi(A,A_param,x0,m,h_rem,Q,H) VEC *(*A)(); void *A_param; VEC *x0; int m; Real *h_rem; MAT *Q, *H; { static VEC *v=VNULL, *u=VNULL, *r=VNULL, *s=VNULL, *tmp=VNULL; int i; Real h_val; if ( ! A || ! Q || ! x0 ) error(E_NULL,"arnoldi"); if ( m <= 0 ) error(E_BOUNDS,"arnoldi"); if ( Q->n != x0->dim || Q->m != m ) error(E_SIZES,"arnoldi"); m_zero(Q); H = m_resize(H,m,m); m_zero(H); u = v_resize(u,x0->dim); v = v_resize(v,x0->dim); r = v_resize(r,m); s = v_resize(s,m); tmp = v_resize(tmp,x0->dim); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(v,TYPE_VEC); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(s,TYPE_VEC); MEM_STAT_REG(tmp,TYPE_VEC); sv_mlt(1.0/v_norm2(x0),x0,v); for ( i = 0; i < m; i++ ) { set_row(Q,i,v); u = (*A)(A_param,v,u); r = mv_mlt(Q,u,r); tmp = vm_mlt(Q,r,tmp); v_sub(u,tmp,u); h_val = v_norm2(u); /* if u == 0 then we have an exact subspace */ if ( h_val == 0.0 ) { *h_rem = h_val; return H; } /* iterative refinement -- ensures near orthogonality */ do { s = mv_mlt(Q,u,s); tmp = vm_mlt(Q,s,tmp); v_sub(u,tmp,u); v_add(r,s,r); } while ( v_norm2(s) > 0.1*(h_val = v_norm2(u)) ); /* now that u is nearly orthogonal to Q, update H */ set_col(H,i,r); if ( i == m-1 ) { *h_rem = h_val; continue; } /* H->me[i+1][i] = h_val; */ m_set_val(H,i+1,i,h_val); sv_mlt(1.0/h_val,u,v); } return H; } /* sp_arnoldi -- uses arnoldi() with an explicit representation of A */ MAT *sp_arnoldi(A,x0,m,h_rem,Q,H) SPMAT *A; VEC *x0; int m; Real *h_rem; MAT *Q, *H; { return arnoldi(sp_mv_mlt,A,x0,m,h_rem,Q,H); } /* gmres -- generalised minimum residual algorithm of Saad & Schultz SIAM J. Sci. Stat. Comp. v.7, pp.856--869 (1986) -- y is overwritten with the solution */ VEC *gmres(A,A_param,m,Q,R,b,tol,x) VEC *(*A)(); void *A_param; VEC *b, *x; int m; MAT *Q, *R; double tol; { static VEC *v=VNULL, *u=VNULL, *r=VNULL, *tmp=VNULL, *rhs=VNULL; static VEC *diag=VNULL, *beta=VNULL; int i; Real h_val, norm_b; if ( ! A || ! Q || ! b || ! R ) error(E_NULL,"gmres"); if ( m <= 0 ) error(E_BOUNDS,"gmres"); if ( Q->n != b->dim || Q->m != m ) error(E_SIZES,"gmres"); x = v_copy(b,x); m_zero(Q); R = m_resize(R,m+1,m); m_zero(R); u = v_resize(u,x->dim); v = v_resize(v,x->dim); tmp = v_resize(tmp,x->dim); rhs = v_resize(rhs,m+1); MEM_STAT_REG(u,TYPE_VEC); MEM_STAT_REG(v,TYPE_VEC); MEM_STAT_REG(r,TYPE_VEC); MEM_STAT_REG(tmp,TYPE_VEC); MEM_STAT_REG(rhs,TYPE_VEC); norm_b = v_norm2(x); if ( norm_b == 0.0 ) error(E_RANGE,"gmres"); sv_mlt(1.0/norm_b,x,v); for ( i = 0; i < m; i++ ) { set_row(Q,i,v); tracecatch(u = (*A)(A_param,v,u),"gmres"); r = mv_mlt(Q,u,r); tmp = vm_mlt(Q,r,tmp); v_sub(u,tmp,u); h_val = v_norm2(u); set_col(R,i,r); R->me[i+1][i] = h_val; sv_mlt(1.0/h_val,u,v); } /* use i x i submatrix of R */ R = m_resize(R,i+1,i); rhs = v_resize(rhs,i+1); v_zero(rhs); rhs->ve[0] = norm_b; tmp = v_resize(tmp,i); diag = v_resize(diag,i+1); beta = v_resize(beta,i+1); MEM_STAT_REG(beta,TYPE_VEC); MEM_STAT_REG(diag,TYPE_VEC); QRfactor(R,diag /* ,beta */); tmp = QRsolve(R,diag, /* beta, */ rhs,tmp); v_resize(tmp,m); vm_mlt(Q,tmp,x); return x; } meschach-1.2b/err.h100644 764 764 13112 5713176134 13634 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* err.h 28/09/1993 */ /* RCS id: $Id: err.h,v 1.2 1995/01/30 14:48:05 des Exp $ */ #ifndef ERRHEADER #define ERRHEADER #include #include "machine.h" /* Error recovery */ extern jmp_buf restart; /* max. # of error lists */ #define ERR_LIST_MAX_LEN 10 /* main error functions */ #ifndef ANSI_C extern int ev_err(); /* main error handler */ extern int set_err_flag(); /* for different ways of handling errors, returns old value */ extern int count_errs(); /* to avoid "too many errors" */ extern int err_list_attach(); /* for attaching a list of errors */ extern int err_is_list_attached(); /* checking if a list is attached */ extern int err_list_free(); /* freeing a list of errors */ #else /* ANSI_C */ extern int ev_err(char *,int,int,char *,int); /* main error handler */ extern int set_err_flag(int flag); /* for different ways of handling errors, returns old value */ extern int count_errs(int true_false); /* to avoid "too many errors" */ extern int err_list_attach(int list_num, int list_len, char **err_ptr,int warn); /* for attaching a list of errors */ extern int err_is_list_attached(int list_num); /* checking if a list is attached */ extern int err_list_free(int list_num); /* freeing a list of errors */ #endif /* error(E_TYPE,"myfunc") raises error type E_TYPE for function my_func() */ #define error(err_num,fn_name) ev_err(__FILE__,err_num,__LINE__,fn_name,0) /* warning(WARN_TYPE,"myfunc") raises warning type WARN_TYPE for function my_func() */ #define warning(err_num,fn_name) ev_err(__FILE__,err_num,__LINE__,fn_name,1) /* error flags */ #define EF_EXIT 0 /* exit on error */ #define EF_ABORT 1 /* abort (dump core) on error */ #define EF_JUMP 2 /* jump on error */ #define EF_SILENT 3 /* jump, but don't print message */ #define ERREXIT() set_err_flag(EF_EXIT) #define ERRABORT() set_err_flag(EF_ABORT) /* don't print message */ #define SILENTERR() if ( ! setjmp(restart) ) set_err_flag(EF_SILENT) /* return here on error */ #define ON_ERROR() if ( ! setjmp(restart) ) set_err_flag(EF_JUMP) /* error types */ #define E_UNKNOWN 0 #define E_SIZES 1 #define E_BOUNDS 2 #define E_MEM 3 #define E_SING 4 #define E_POSDEF 5 #define E_FORMAT 6 #define E_INPUT 7 #define E_NULL 8 #define E_SQUARE 9 #define E_RANGE 10 #define E_INSITU2 11 #define E_INSITU 12 #define E_ITER 13 #define E_CONV 14 #define E_START 15 #define E_SIGNAL 16 #define E_INTERN 17 #define E_EOF 18 #define E_SHARED_VECS 19 #define E_NEG 20 #define E_OVERWRITE 21 #define E_BREAKDOWN 22 /* warning types */ #define WARN_UNKNOWN 0 #define WARN_WRONG_TYPE 1 #define WARN_NO_MARK 2 #define WARN_RES_LESS_0 3 #define WARN_SHARED_VEC 4 /* error catching macros */ /* execute err_part if error errnum is raised while executing ok_part */ #define catch(errnum,ok_part,err_part) \ { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_SILENT); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ if ( (_err_num=setjmp(restart)) == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ else if ( _err_num == errnum ) \ { set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); \ err_part; } \ else { set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); \ error(_err_num,"catch"); \ } \ } /* execute err_part if any error raised while executing ok_part */ #define catchall(ok_part,err_part) \ { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_SILENT); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ if ( (_err_num=setjmp(restart)) == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ else \ { set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); \ err_part; } \ } /* print message if error raised while executing ok_part, then re-raise error to trace calls */ #define tracecatch(ok_part,function) \ { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_JUMP); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ if ( (_err_num=setjmp(restart)) == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ else \ { set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); \ error(_err_num,function); } \ } #endif /* ERRHEADER */ meschach-1.2b/meminfo.h100644 764 764 10064 5515156360 14500 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* meminfo.h 26/08/93 */ /* changed 11/12/93 */ #ifndef MEM_INFOH #define MEM_INFOH /* for hash table in mem_stat.c */ /* Note: the hash size should be a prime, or at very least odd */ #define MEM_HASHSIZE 509 #define MEM_HASHSIZE_FILE "meminfo.h" /* default: memory information is off */ /* set it to 1 if you want it all the time */ #define MEM_SWITCH_ON_DEF 0 /* available standard types */ #define TYPE_NULL (-1) #define TYPE_MAT 0 #define TYPE_BAND 1 #define TYPE_PERM 2 #define TYPE_VEC 3 #define TYPE_IVEC 4 #ifdef SPARSE #define TYPE_ITER 5 #define TYPE_SPROW 6 #define TYPE_SPMAT 7 #endif #ifdef COMPLEX #ifdef SPARSE #define TYPE_ZVEC 8 #define TYPE_ZMAT 9 #else #define TYPE_ZVEC 5 #define TYPE_ZMAT 6 #endif #endif /* structure for memory information */ typedef struct { long bytes; /* # of allocated bytes for each type (summary) */ int numvar; /* # of allocated variables for each type */ } MEM_ARRAY; #ifdef ANSI_C int mem_info_is_on(void); int mem_info_on(int sw); long mem_info_bytes(int type,int list); int mem_info_numvar(int type,int list); void mem_info_file(FILE * fp,int list); void mem_bytes_list(int type,int old_size,int new_size, int list); void mem_numvar_list(int type, int num, int list); int mem_stat_reg_list(void **var,int type,int list); int mem_stat_mark(int mark); int mem_stat_free_list(int mark,int list); int mem_stat_show_mark(void); void mem_stat_dump(FILE *fp,int list); int mem_attach_list(int list,int ntypes,char *type_names[], int (*free_funcs[])(), MEM_ARRAY info_sum[]); int mem_free_vars(int list); int mem_is_list_attached(int list); void mem_dump_list(FILE *fp,int list); int mem_stat_reg_vars(int list,int type,...); #else int mem_info_is_on(); int mem_info_on(); long mem_info_bytes(); int mem_info_numvar(); void mem_info_file(); void mem_bytes_list(); void mem_numvar_list(); int mem_stat_reg_list(); int mem_stat_mark(); int mem_stat_free_list(); int mem_stat_show_mark(); void mem_stat_dump(); int mem_attach_list(); int mem_free_vars(); int mem_is_list_attached(); void mem_dump_list(); int mem_stat_reg_vars(); #endif /* macros */ #define mem_info() mem_info_file(stdout,0) #define mem_stat_reg(var,type) mem_stat_reg_list((void **)var,type,0) #define MEM_STAT_REG(var,type) mem_stat_reg_list((void **)&(var),type,0) #define mem_stat_free(mark) mem_stat_free_list(mark,0) #define mem_bytes(type,old_size,new_size) \ mem_bytes_list(type,old_size,new_size,0) #define mem_numvar(type,num) mem_numvar_list(type,num,0) /* internal type */ typedef struct { char **type_names; /* array of names of types (strings) */ int (**free_funcs)(); /* array of functions for releasing types */ unsigned ntypes; /* max number of types */ MEM_ARRAY *info_sum; /* local array for keeping track of memory */ } MEM_CONNECT; /* max number of lists of types */ #define MEM_CONNECT_MAX_LISTS 5 #endif meschach-1.2b/machine.h100644 764 764 11100 5735556123 14447 0ustar lapeyrelapeyre/* machine.h. Generated automatically by configure. */ /* Any machine specific stuff goes here */ /* Add details necessary for your own installation here! */ /* RCS id: $Id: machine.h.in,v 1.3 1995/03/27 15:36:21 des Exp $ */ /* This is for use with "configure" -- if you are not using configure then use machine.van for the "vanilla" version of machine.h */ /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ #ifndef _MACHINE_H #define _MACHINE_H 1 #define const /* #undef MALLOCDECL */ #define NOT_SEGMENTED 1 #define HAVE_MEMORY_H 1 /* #undef HAVE_COMPLEX_H */ #define HAVE_MALLOC_H 1 #define STDC_HEADERS 1 #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 #define WORDS_BIGENDIAN 1 /* #undef U_INT_DEF */ #define VARARGS 1 #define HAVE_PROTOTYPES 1 /* #undef HAVE_PROTOTYPES_IN_STRUCT */ /* for inclusion into C++ files */ #ifdef __cplusplus #define ANSI_C 1 #ifndef HAVE_PROTOTYPES #define HAVE_PROTOTYPES 1 #endif #ifndef HAVE_PROTOTYPES_IN_STRUCT #define HAVE_PROTOTYPES_IN_STRUCT 1 #endif #endif /* __cplusplus */ /* example usage: VEC *PROTO(v_get,(int dim)); */ #ifdef HAVE_PROTOTYPES #define PROTO(name,args) name args #else #define PROTO(name,args) name() #endif /* HAVE_PROTOTYPES */ #ifdef HAVE_PROTOTYPES_IN_STRUCT /* PROTO_() is to be used instead of PROTO() in struct's and typedef's */ #define PROTO_(name,args) name args #else #define PROTO_(name,args) name() #endif /* HAVE_PROTOTYPES_IN_STRUCT */ /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 /* #undef REAL_FLT */ /* #undef REAL_DBL */ /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 1.19209e-07 #define D_MACHEPS 2.22045e-16 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 2147483647 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #else #ifndef HUGE #define HUGE HUGE_VAL #endif #endif #ifdef ANSI_C extern int isatty(int); #endif #endif meschach-1.2b/matrix.h100644 764 764 45440 5553631271 14361 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Type definitions for general purpose maths package */ #ifndef MATRIXH /* RCS id: $Id: matrix.h,v 1.18 1994/04/16 00:33:37 des Exp $ */ #define MATRIXH #include "machine.h" #include "err.h" #include "meminfo.h" /* unsigned integer type */ #ifndef U_INT_DEF typedef unsigned int u_int; #define U_INT_DEF #endif /* vector definition */ typedef struct { u_int dim, max_dim; Real *ve; } VEC; /* matrix definition */ typedef struct { u_int m, n; u_int max_m, max_n, max_size; Real **me,*base; /* base is base of alloc'd mem */ } MAT; /* band matrix definition */ typedef struct { MAT *mat; /* matrix */ int lb,ub; /* lower and upper bandwidth */ } BAND; /* permutation definition */ typedef struct { u_int size, max_size, *pe; } PERM; /* integer vector definition */ typedef struct { u_int dim, max_dim; int *ive; } IVEC; #ifndef MALLOCDECL #ifndef ANSI_C extern char *malloc(), *calloc(), *realloc(); #else extern void *malloc(size_t), *calloc(size_t,size_t), *realloc(void *,size_t); #endif #endif #ifndef ANSI_C extern void m_version(); #else void m_version( void ); #endif #ifndef ANSI_C /* allocate one object of given type */ #define NEW(type) ((type *)calloc(1,sizeof(type))) /* allocate num objects of given type */ #define NEW_A(num,type) ((type *)calloc((unsigned)(num),sizeof(type))) /* re-allocate arry to have num objects of the given type */ #define RENEW(var,num,type) \ ((var)=(type *)((var) ? \ realloc((char *)(var),(unsigned)(num)*sizeof(type)) : \ calloc((unsigned)(num),sizeof(type)))) #define MEMCOPY(from,to,n_items,type) \ MEM_COPY((char *)(from),(char *)(to),(unsigned)(n_items)*sizeof(type)) #else /* allocate one object of given type */ #define NEW(type) ((type *)calloc((size_t)1,(size_t)sizeof(type))) /* allocate num objects of given type */ #define NEW_A(num,type) ((type *)calloc((size_t)(num),(size_t)sizeof(type))) /* re-allocate arry to have num objects of the given type */ #define RENEW(var,num,type) \ ((var)=(type *)((var) ? \ realloc((char *)(var),(size_t)((num)*sizeof(type))) : \ calloc((size_t)(num),(size_t)sizeof(type)))) #define MEMCOPY(from,to,n_items,type) \ MEM_COPY((char *)(from),(char *)(to),(unsigned)(n_items)*sizeof(type)) #endif /* type independent min and max operations */ #ifndef max #define max(a,b) ((a) > (b) ? (a) : (b)) #endif #ifndef min #define min(a,b) ((a) > (b) ? (b) : (a)) #endif #undef TRUE #define TRUE 1 #undef FALSE #define FALSE 0 /* for input routines */ #define MAXLINE 81 /* Dynamic memory allocation */ /* Should use M_FREE/V_FREE/PX_FREE in programs instead of m/v/px_free() as this is considerably safer -- also provides a simple type check ! */ #ifndef ANSI_C extern VEC *v_get(), *v_resize(); extern MAT *m_get(), *m_resize(); extern PERM *px_get(), *px_resize(); extern IVEC *iv_get(), *iv_resize(); extern int m_free(),v_free(); extern int px_free(); extern int iv_free(); extern BAND *bd_get(), *bd_resize(); extern int bd_free(); #else /* get/resize vector to given dimension */ extern VEC *v_get(int), *v_resize(VEC *,int); /* get/resize matrix to be m x n */ extern MAT *m_get(int,int), *m_resize(MAT *,int,int); /* get/resize permutation to have the given size */ extern PERM *px_get(int), *px_resize(PERM *,int); /* get/resize an integer vector to given dimension */ extern IVEC *iv_get(int), *iv_resize(IVEC *,int); /* get/resize a band matrix to given dimension */ extern BAND *bd_get(int,int,int), *bd_resize(BAND *,int,int,int); /* free (de-allocate) (band) matrices, vectors, permutations and integer vectors */ extern int iv_free(IVEC *); extern m_free(MAT *),v_free(VEC *),px_free(PERM *); extern int bd_free(BAND *); #endif /* MACROS */ /* macros that also check types and sets pointers to NULL */ #define M_FREE(mat) ( m_free(mat), (mat)=(MAT *)NULL ) #define V_FREE(vec) ( v_free(vec), (vec)=(VEC *)NULL ) #define PX_FREE(px) ( px_free(px), (px)=(PERM *)NULL ) #define IV_FREE(iv) ( iv_free(iv), (iv)=(IVEC *)NULL ) #define MAXDIM 2001 /* Entry level access to data structures */ #ifdef DEBUG /* returns x[i] */ #define v_entry(x,i) (((i) < 0 || (i) >= (x)->dim) ? \ error(E_BOUNDS,"v_entry"), 0.0 : (x)->ve[i] ) /* x[i] <- val */ #define v_set_val(x,i,val) ((x)->ve[i] = ((i) < 0 || (i) >= (x)->dim) ? \ error(E_BOUNDS,"v_set_val"), 0.0 : (val)) /* x[i] <- x[i] + val */ #define v_add_val(x,i,val) ((x)->ve[i] += ((i) < 0 || (i) >= (x)->dim) ? \ error(E_BOUNDS,"v_add_val"), 0.0 : (val)) /* x[i] <- x[i] - val */ #define v_sub_val(x,i,val) ((x)->ve[i] -= ((i) < 0 || (i) >= (x)->dim) ? \ error(E_BOUNDS,"v_sub_val"), 0.0 : (val)) /* returns A[i][j] */ #define m_entry(A,i,j) (((i) < 0 || (i) >= (A)->m || \ (j) < 0 || (j) >= (A)->n) ? \ error(E_BOUNDS,"m_entry"), 0.0 : (A)->me[i][j] ) /* A[i][j] <- val */ #define m_set_val(A,i,j,val) ((A)->me[i][j] = ((i) < 0 || (i) >= (A)->m || \ (j) < 0 || (j) >= (A)->n) ? \ error(E_BOUNDS,"m_set_val"), 0.0 : (val) ) /* A[i][j] <- A[i][j] + val */ #define m_add_val(A,i,j,val) ((A)->me[i][j] += ((i) < 0 || (i) >= (A)->m || \ (j) < 0 || (j) >= (A)->n) ? \ error(E_BOUNDS,"m_add_val"), 0.0 : (val) ) /* A[i][j] <- A[i][j] - val */ #define m_sub_val(A,i,j,val) ((A)->me[i][j] -= ((i) < 0 || (i) >= (A)->m || \ (j) < 0 || (j) >= (A)->n) ? \ error(E_BOUNDS,"m_sub_val"), 0.0 : (val) ) #else /* returns x[i] */ #define v_entry(x,i) ((x)->ve[i]) /* x[i] <- val */ #define v_set_val(x,i,val) ((x)->ve[i] = (val)) /* x[i] <- x[i] + val */ #define v_add_val(x,i,val) ((x)->ve[i] += (val)) /* x[i] <- x[i] - val */ #define v_sub_val(x,i,val) ((x)->ve[i] -= (val)) /* returns A[i][j] */ #define m_entry(A,i,j) ((A)->me[i][j]) /* A[i][j] <- val */ #define m_set_val(A,i,j,val) ((A)->me[i][j] = (val) ) /* A[i][j] <- A[i][j] + val */ #define m_add_val(A,i,j,val) ((A)->me[i][j] += (val) ) /* A[i][j] <- A[i][j] - val */ #define m_sub_val(A,i,j,val) ((A)->me[i][j] -= (val) ) #endif /* I/O routines */ #ifndef ANSI_C extern void v_foutput(),m_foutput(),px_foutput(); extern void iv_foutput(); extern VEC *v_finput(); extern MAT *m_finput(); extern PERM *px_finput(); extern IVEC *iv_finput(); extern int fy_or_n(), fin_int(), yn_dflt(), skipjunk(); extern double fin_double(); #else /* print x on file fp */ void v_foutput(FILE *fp,VEC *x), /* print A on file fp */ m_foutput(FILE *fp,MAT *A), /* print px on file fp */ px_foutput(FILE *fp,PERM *px); /* print ix on file fp */ void iv_foutput(FILE *fp,IVEC *ix); /* Note: if out is NULL, then returned object is newly allocated; Also: if out is not NULL, then that size is assumed */ /* read in vector from fp */ VEC *v_finput(FILE *fp,VEC *out); /* read in matrix from fp */ MAT *m_finput(FILE *fp,MAT *out); /* read in permutation from fp */ PERM *px_finput(FILE *fp,PERM *out); /* read in int vector from fp */ IVEC *iv_finput(FILE *fp,IVEC *out); /* fy_or_n -- yes-or-no to question in string s -- question written to stderr, input from fp -- if fp is NOT a tty then return y_n_dflt */ int fy_or_n(FILE *fp,char *s); /* yn_dflt -- sets the value of y_n_dflt to val */ int yn_dflt(int val); /* fin_int -- return integer read from file/stream fp -- prompt s on stderr if fp is a tty -- check that x lies between low and high: re-prompt if fp is a tty, error exit otherwise -- ignore check if low > high */ int fin_int(FILE *fp,char *s,int low,int high); /* fin_double -- return double read from file/stream fp -- prompt s on stderr if fp is a tty -- check that x lies between low and high: re-prompt if fp is a tty, error exit otherwise -- ignore check if low > high */ double fin_double(FILE *fp,char *s,double low,double high); /* it skips white spaces and strings of the form #....\n Here .... is a comment string */ int skipjunk(FILE *fp); #endif /* MACROS */ /* macros to use stdout and stdin instead of explicit fp */ #define v_output(vec) v_foutput(stdout,vec) #define v_input(vec) v_finput(stdin,vec) #define m_output(mat) m_foutput(stdout,mat) #define m_input(mat) m_finput(stdin,mat) #define px_output(px) px_foutput(stdout,px) #define px_input(px) px_finput(stdin,px) #define iv_output(iv) iv_foutput(stdout,iv) #define iv_input(iv) iv_finput(stdin,iv) /* general purpose input routine; skips comments # ... \n */ #define finput(fp,prompt,fmt,var) \ ( ( isatty(fileno(fp)) ? fprintf(stderr,prompt) : skipjunk(fp) ), \ fscanf(fp,fmt,var) ) #define input(prompt,fmt,var) finput(stdin,prompt,fmt,var) #define fprompter(fp,prompt) \ ( isatty(fileno(fp)) ? fprintf(stderr,prompt) : skipjunk(fp) ) #define prompter(prompt) fprompter(stdin,prompt) #define y_or_n(s) fy_or_n(stdin,s) #define in_int(s,lo,hi) fin_int(stdin,s,lo,hi) #define in_double(s,lo,hi) fin_double(stdin,s,lo,hi) /* Copying routines */ #ifndef ANSI_C extern MAT *_m_copy(), *m_move(), *vm_move(); extern VEC *_v_copy(), *v_move(), *mv_move(); extern PERM *px_copy(); extern IVEC *iv_copy(), *iv_move(); extern BAND *bd_copy(); #else /* copy in to out starting at out[i0][j0] */ extern MAT *_m_copy(MAT *in,MAT *out,u_int i0,u_int j0), * m_move(MAT *in, int, int, int, int, MAT *out, int, int), *vm_move(VEC *in, int, MAT *out, int, int, int, int); /* copy in to out starting at out[i0] */ extern VEC *_v_copy(VEC *in,VEC *out,u_int i0), * v_move(VEC *in, int, int, VEC *out, int), *mv_move(MAT *in, int, int, int, int, VEC *out, int); extern PERM *px_copy(PERM *in,PERM *out); extern IVEC *iv_copy(IVEC *in,IVEC *out), *iv_move(IVEC *in, int, int, IVEC *out, int); extern BAND *bd_copy(BAND *in,BAND *out); #endif /* MACROS */ #define m_copy(in,out) _m_copy(in,out,0,0) #define v_copy(in,out) _v_copy(in,out,0) /* Initialisation routines -- to be zero, ones, random or identity */ #ifndef ANSI_C extern VEC *v_zero(), *v_rand(), *v_ones(); extern MAT *m_zero(), *m_ident(), *m_rand(), *m_ones(); extern PERM *px_ident(); extern IVEC *iv_zero(); #else extern VEC *v_zero(VEC *), *v_rand(VEC *), *v_ones(VEC *); extern MAT *m_zero(MAT *), *m_ident(MAT *), *m_rand(MAT *), *m_ones(MAT *); extern PERM *px_ident(PERM *); extern IVEC *iv_zero(IVEC *); #endif /* Basic vector operations */ #ifndef ANSI_C extern VEC *sv_mlt(), *mv_mlt(), *vm_mlt(), *v_add(), *v_sub(), *px_vec(), *pxinv_vec(), *v_mltadd(), *v_map(), *_v_map(), *v_lincomb(), *v_linlist(); extern double v_min(), v_max(), v_sum(); extern VEC *v_star(), *v_slash(), *v_sort(); extern double _in_prod(), __ip__(); extern void __mltadd__(), __add__(), __sub__(), __smlt__(), __zero__(); #else extern VEC *sv_mlt(double,VEC *,VEC *), /* out <- s.x */ *mv_mlt(MAT *,VEC *,VEC *), /* out <- A.x */ *vm_mlt(MAT *,VEC *,VEC *), /* out^T <- x^T.A */ *v_add(VEC *,VEC *,VEC *), /* out <- x + y */ *v_sub(VEC *,VEC *,VEC *), /* out <- x - y */ *px_vec(PERM *,VEC *,VEC *), /* out <- P.x */ *pxinv_vec(PERM *,VEC *,VEC *), /* out <- P^{-1}.x */ *v_mltadd(VEC *,VEC *,double,VEC *), /* out <- x + s.y */ #ifdef PROTOTYPES_IN_STRUCT *v_map(double (*f)(double),VEC *,VEC *), /* out[i] <- f(x[i]) */ *_v_map(double (*f)(void *,double),void *,VEC *,VEC *), #else *v_map(double (*f)(),VEC *,VEC *), /* out[i] <- f(x[i]) */ *_v_map(double (*f)(),void *,VEC *,VEC *), #endif *v_lincomb(int,VEC **,Real *,VEC *), /* out <- sum_i s[i].x[i] */ *v_linlist(VEC *out,VEC *v1,double a1,...); /* out <- s1.x1 + s2.x2 + ... */ /* returns min_j x[j] (== x[i]) */ extern double v_min(VEC *, int *), /* returns max_j x[j] (== x[i]) */ v_max(VEC *, int *), /* returns sum_i x[i] */ v_sum(VEC *); /* Hadamard product: out[i] <- x[i].y[i] */ extern VEC *v_star(VEC *, VEC *, VEC *), /* out[i] <- x[i] / y[i] */ *v_slash(VEC *, VEC *, VEC *), /* sorts x, and sets order so that sorted x[i] = x[order[i]] */ *v_sort(VEC *, PERM *); /* returns inner product starting at component i0 */ extern double _in_prod(VEC *x,VEC *y,u_int i0), /* returns sum_{i=0}^{len-1} x[i].y[i] */ __ip__(Real *,Real *,int); /* see v_mltadd(), v_add(), v_sub() and v_zero() */ extern void __mltadd__(Real *,Real *,double,int), __add__(Real *,Real *,Real *,int), __sub__(Real *,Real *,Real *,int), __smlt__(Real *,double,Real *,int), __zero__(Real *,int); #endif /* MACRO */ /* usual way of computing the inner product */ #define in_prod(a,b) _in_prod(a,b,0) /* Norms */ /* scaled vector norms -- scale == NULL implies unscaled */ #ifndef ANSI_C extern double _v_norm1(), _v_norm2(), _v_norm_inf(), m_norm1(), m_norm_inf(), m_norm_frob(); #else /* returns sum_i |x[i]/scale[i]| */ extern double _v_norm1(VEC *x,VEC *scale), /* returns (scaled) Euclidean norm */ _v_norm2(VEC *x,VEC *scale), /* returns max_i |x[i]/scale[i]| */ _v_norm_inf(VEC *x,VEC *scale); /* unscaled matrix norms */ extern double m_norm1(MAT *A), m_norm_inf(MAT *A), m_norm_frob(MAT *A); #endif /* MACROS */ /* unscaled vector norms */ #define v_norm1(x) _v_norm1(x,VNULL) #define v_norm2(x) _v_norm2(x,VNULL) #define v_norm_inf(x) _v_norm_inf(x,VNULL) /* Basic matrix operations */ #ifndef ANSI_C extern MAT *sm_mlt(), *m_mlt(), *mmtr_mlt(), *mtrm_mlt(), *m_add(), *m_sub(), *sub_mat(), *m_transp(), *ms_mltadd(); extern BAND *bd_transp(); extern MAT *px_rows(), *px_cols(), *swap_rows(), *swap_cols(), *_set_row(), *_set_col(); extern VEC *get_row(), *get_col(), *sub_vec(), *mv_mltadd(), *vm_mltadd(); #else extern MAT *sm_mlt(double s,MAT *A,MAT *out), /* out <- s.A */ *m_mlt(MAT *A,MAT *B,MAT *out), /* out <- A.B */ *mmtr_mlt(MAT *A,MAT *B,MAT *out), /* out <- A.B^T */ *mtrm_mlt(MAT *A,MAT *B,MAT *out), /* out <- A^T.B */ *m_add(MAT *A,MAT *B,MAT *out), /* out <- A + B */ *m_sub(MAT *A,MAT *B,MAT *out), /* out <- A - B */ *sub_mat(MAT *A,u_int,u_int,u_int,u_int,MAT *out), *m_transp(MAT *A,MAT *out), /* out <- A^T */ /* out <- A + s.B */ *ms_mltadd(MAT *A,MAT *B,double s,MAT *out); extern BAND *bd_transp(BAND *in, BAND *out); /* out <- A^T */ extern MAT *px_rows(PERM *px,MAT *A,MAT *out), /* out <- P.A */ *px_cols(PERM *px,MAT *A,MAT *out), /* out <- A.P^T */ *swap_rows(MAT *,int,int,int,int), *swap_cols(MAT *,int,int,int,int), /* A[i][j] <- out[j], j >= j0 */ *_set_col(MAT *A,u_int i,VEC *out,u_int j0), /* A[i][j] <- out[i], i >= i0 */ *_set_row(MAT *A,u_int j,VEC *out,u_int i0); extern VEC *get_row(MAT *,u_int,VEC *), *get_col(MAT *,u_int,VEC *), *sub_vec(VEC *,int,int,VEC *), /* out <- x + s.A.y */ *mv_mltadd(VEC *x,VEC *y,MAT *A,double s,VEC *out), /* out^T <- x^T + s.y^T.A */ *vm_mltadd(VEC *x,VEC *y,MAT *A,double s,VEC *out); #endif /* MACROS */ /* row i of A <- vec */ #define set_row(mat,row,vec) _set_row(mat,row,vec,0) /* col j of A <- vec */ #define set_col(mat,col,vec) _set_col(mat,col,vec,0) /* Basic permutation operations */ #ifndef ANSI_C extern PERM *px_mlt(), *px_inv(), *px_transp(); extern int px_sign(); #else extern PERM *px_mlt(PERM *px1,PERM *px2,PERM *out), /* out <- px1.px2 */ *px_inv(PERM *px,PERM *out), /* out <- px^{-1} */ /* swap px[i] and px[j] */ *px_transp(PERM *px,u_int i,u_int j); /* returns sign(px) = +1 if px product of even # transpositions -1 if ps product of odd # transpositions */ extern int px_sign(PERM *); #endif /* Basic integer vector operations */ #ifndef ANSI_C extern IVEC *iv_add(), *iv_sub(), *iv_sort(); #else extern IVEC *iv_add(IVEC *ix,IVEC *iy,IVEC *out), /* out <- ix + iy */ *iv_sub(IVEC *ix,IVEC *iy,IVEC *out), /* out <- ix - iy */ /* sorts ix & sets order so that sorted ix[i] = old ix[order[i]] */ *iv_sort(IVEC *ix, PERM *order); #endif /* miscellaneous functions */ #ifndef ANSI_C extern double square(), cube(), mrand(); extern void smrand(), mrandlist(); extern void m_dump(), px_dump(), v_dump(), iv_dump(); extern MAT *band2mat(); extern BAND *mat2band(); #else double square(double x), /* returns x^2 */ cube(double x), /* returns x^3 */ mrand(void); /* returns random # in [0,1) */ void smrand(int seed), /* seeds mrand() */ mrandlist(Real *x, int len); /* generates len random numbers */ void m_dump(FILE *fp,MAT *a), px_dump(FILE *,PERM *px), v_dump(FILE *fp,VEC *x), iv_dump(FILE *fp, IVEC *ix); MAT *band2mat(BAND *bA, MAT *A); BAND *mat2band(MAT *A, int lb,int ub, BAND *bA); #endif /* miscellaneous constants */ #define VNULL ((VEC *)NULL) #define MNULL ((MAT *)NULL) #define PNULL ((PERM *)NULL) #define IVNULL ((IVEC *)NULL) #define BDNULL ((BAND *)NULL) /* varying number of arguments */ #ifdef ANSI_C #include /* prototypes */ int v_get_vars(int dim,...); int iv_get_vars(int dim,...); int m_get_vars(int m,int n,...); int px_get_vars(int dim,...); int v_resize_vars(int new_dim,...); int iv_resize_vars(int new_dim,...); int m_resize_vars(int m,int n,...); int px_resize_vars(int new_dim,...); int v_free_vars(VEC **,...); int iv_free_vars(IVEC **,...); int px_free_vars(PERM **,...); int m_free_vars(MAT **,...); #elif VARARGS /* old varargs is used */ #include /* prototypes */ int v_get_vars(); int iv_get_vars(); int m_get_vars(); int px_get_vars(); int v_resize_vars(); int iv_resize_vars(); int m_resize_vars(); int px_resize_vars(); int v_free_vars(); int iv_free_vars(); int px_free_vars(); int m_free_vars(); #endif #endif meschach-1.2b/iter.h100644 764 764 15377 5537010714 14021 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* iter.h 14/09/93 */ /* Structures for iterative methods */ #ifndef ITERHH #define ITERHH /* RCS id: $Id: iter.h,v 1.2 1994/03/08 05:48:27 des Exp $ */ #include "sparse.h" /* basic structure for iterative methods */ /* type Fun_Ax for functions to get y = A*x */ #ifdef ANSI_C typedef VEC *(*Fun_Ax)(void *,VEC *,VEC *); #else typedef VEC *(*Fun_Ax)(); #endif /* type ITER */ typedef struct Iter_data { int shared_x; /* if TRUE then x is shared and it will not be free'd */ int shared_b; /* if TRUE then b is shared and it will not be free'd */ unsigned k; /* no. of direction (search) vectors; =0 - none */ int limit; /* upper bound on the no. of iter. steps */ int steps; /* no. of iter. steps done */ Real eps; /* accuracy required */ VEC *x; /* input: initial guess; output: approximate solution */ VEC *b; /* right hand side of the equation A*x = b */ Fun_Ax Ax; /* function computing y = A*x */ void *A_par; /* parameters for Ax */ Fun_Ax ATx; /* function computing y = A^T*x; T = transpose */ void *AT_par; /* parameters for ATx */ Fun_Ax Bx; /* function computing y = B*x; B - preconditioner */ void *B_par; /* parameters for Bx */ #ifdef ANSI_C #ifdef PROTOTYPES_IN_STRUCT void (*info)(struct Iter_data *, double, VEC *,VEC *); /* function giving some information for a user; nres - a norm of a residual res */ int (*stop_crit)(struct Iter_data *, double, VEC *,VEC *); /* stopping criterion: nres - a norm of res; res - residual; if returned value == TRUE then stop; if returned value == FALSE then continue; */ #else void (*info)(); int (*stop_crit)(); #endif /* PROTOTYPES_IN_STRUCT */ #else void (*info)(); /* function giving some information for a user */ int (*stop_crit)(); /* stopping criterion: if returned value == TRUE then stop; if returned value == FALSE then continue; */ #endif /* ANSI_C */ Real init_res; /* the norm of the initial residual */ } ITER; #define INULL (ITER *)NULL /* type Fun_info */ #ifdef ANSI_C typedef void (*Fun_info)(ITER *, double, VEC *,VEC *); #else typedef void (*Fun_info)(); #endif /* type Fun_stp_crt */ #ifdef ANSI_C typedef int (*Fun_stp_crt)(ITER *, double, VEC *,VEC *); #else typedef int (*Fun_stp_crt)(); #endif /* macros */ /* default values */ #define ITER_LIMIT_DEF 1000 #define ITER_EPS_DEF 1e-6 /* other macros */ /* set ip->Ax=fun and ip->A_par=fun_par */ #define iter_Ax(ip,fun,fun_par) \ (ip->Ax=(Fun_Ax)(fun),ip->A_par=(void *)(fun_par),0) #define iter_ATx(ip,fun,fun_par) \ (ip->ATx=(Fun_Ax)(fun),ip->AT_par=(void *)(fun_par),0) #define iter_Bx(ip,fun,fun_par) \ (ip->Bx=(Fun_Ax)(fun),ip->B_par=(void *)(fun_par),0) /* save free macro */ #define ITER_FREE(ip) (iter_free(ip), (ip)=(ITER *)NULL) /* prototypes from iter0.c */ #ifdef ANSI_C /* standard information */ void iter_std_info(ITER *ip,double nres,VEC *res,VEC *Bres); /* standard stopping criterion */ int iter_std_stop_crit(ITER *ip, double nres, VEC *res,VEC *Bres); /* get, resize and free ITER variable */ ITER *iter_get(int lenb, int lenx); ITER *iter_resize(ITER *ip,int lenb,int lenx); int iter_free(ITER *ip); void iter_dump(FILE *fp,ITER *ip); /* copy ip1 to ip2 copying also elements of x and b */ ITER *iter_copy(ITER *ip1, ITER *ip2); /* copy ip1 to ip2 without copying elements of x and b */ ITER *iter_copy2(ITER *ip1,ITER *ip2); /* functions for generating sparse matrices with random elements */ SPMAT *iter_gen_sym(int n, int nrow); SPMAT *iter_gen_nonsym(int m,int n,int nrow,double diag); SPMAT *iter_gen_nonsym_posdef(int n,int nrow); #else void iter_std_info(); int iter_std_stop_crit(); ITER *iter_get(); int iter_free(); ITER *iter_resize(); void iter_dump(); ITER *iter_copy(); ITER *iter_copy2(); SPMAT *iter_gen_sym(); SPMAT *iter_gen_nonsym(); SPMAT *iter_gen_nonsym_posdef(); #endif /* prototypes from iter.c */ /* different iterative procedures */ #ifdef ANSI_C VEC *iter_cg(ITER *ip); VEC *iter_cg1(ITER *ip); VEC *iter_spcg(SPMAT *A,SPMAT *LLT,VEC *b,double eps,VEC *x,int limit, int *steps); VEC *iter_cgs(ITER *ip,VEC *r0); VEC *iter_spcgs(SPMAT *A,SPMAT *B,VEC *b,VEC *r0,double eps,VEC *x, int limit, int *steps); VEC *iter_lsqr(ITER *ip); VEC *iter_splsqr(SPMAT *A,VEC *b,double tol,VEC *x, int limit,int *steps); VEC *iter_gmres(ITER *ip); VEC *iter_spgmres(SPMAT *A,SPMAT *B,VEC *b,double tol,VEC *x,int k, int limit, int *steps); MAT *iter_arnoldi_iref(ITER *ip,Real *h,MAT *Q,MAT *H); MAT *iter_arnoldi(ITER *ip,Real *h,MAT *Q,MAT *H); MAT *iter_sparnoldi(SPMAT *A,VEC *x0,int k,Real *h,MAT *Q,MAT *H); VEC *iter_mgcr(ITER *ip); VEC *iter_spmgcr(SPMAT *A,SPMAT *B,VEC *b,double tol,VEC *x,int k, int limit, int *steps); void iter_lanczos(ITER *ip,VEC *a,VEC *b,Real *beta2,MAT *Q); void iter_splanczos(SPMAT *A,int m,VEC *x0,VEC *a,VEC *b,Real *beta2, MAT *Q); VEC *iter_lanczos2(ITER *ip,VEC *evals,VEC *err_est); VEC *iter_splanczos2(SPMAT *A,int m,VEC *x0,VEC *evals,VEC *err_est); VEC *iter_cgne(ITER *ip); VEC *iter_spcgne(SPMAT *A,SPMAT *B,VEC *b,double eps,VEC *x, int limit,int *steps); #else VEC *iter_cg(); VEC *iter_cg1(); VEC *iter_spcg(); VEC *iter_cgs(); VEC *iter_spcgs(); VEC *iter_lsqr(); VEC *iter_splsqr(); VEC *iter_gmres(); VEC *iter_spgmres(); MAT *iter_arnoldi_iref(); MAT *iter_arnoldi(); MAT *iter_sparnoldi(); VEC *iter_mgcr(); VEC *iter_spmgcr(); void iter_lanczos(); void iter_splanczos(); VEC *iter_lanczos2(); VEC *iter_splanczos2(); VEC *iter_cgne(); VEC *iter_spcgne(); #endif #endif /* ITERHH */ meschach-1.2b/matlab.h100644 764 764 5704 5707754466 14311 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* matlab.h -- Header file for matlab.c, spmatlab.c and zmatlab.c for save/load formats */ #ifndef MATLAB_DEF #define MATLAB_DEF /* structure required by MATLAB */ typedef struct { long type; /* matrix type */ long m; /* # rows */ long n; /* # cols */ long imag; /* is complex? */ long namlen; /* length of variable name */ } matlab; /* macros for matrix storage type */ #define INTEL 0 /* for 80x87 format */ #define PC INTEL #define MOTOROLA 1 /* 6888x format */ #define SUN MOTOROLA #define APOLLO MOTOROLA #define MAC MOTOROLA #define VAX_D 2 #define VAX_G 3 #define COL_ORDER 0 #define ROW_ORDER 1 #define DOUBLE_PREC 0 /* double precision */ #define SINGLE_PREC 1 /* single precision */ #define INT_32 2 /* 32 bit integers (signed) */ #define INT_16 3 /* 16 bit integers (signed) */ #define INT_16u 4 /* 16 bit integers (unsigned) */ /* end of macros for matrix storage type */ #ifndef MACH_ID #define MACH_ID MOTOROLA #endif #define ORDER ROW_ORDER #if REAL == DOUBLE #define PRECISION DOUBLE_PREC #elif REAL == FLOAT #define PRECISION SINGLE_PREC #endif /* prototypes */ #ifdef ANSI_C MAT *m_save(FILE *,MAT *,char *); MAT *m_load(FILE *,char **); VEC *v_save(FILE *,VEC *,char *); double d_save(FILE *,double,char *); #else extern MAT *m_save(), *m_load(); extern VEC *v_save(); extern double d_save(); #endif /* complex variant */ #ifdef COMPLEX #include "zmatrix.h" #ifdef ANSI_C extern ZMAT *zm_save(FILE *fp,ZMAT *A,char *name); extern ZVEC *zv_save(FILE *fp,ZVEC *x,char *name); extern complex z_save(FILE *fp,complex z,char *name); extern ZMAT *zm_load(FILE *fp,char **name); #else extern ZMAT *zm_save(); extern ZVEC *zv_save(); extern complex z_save(); extern ZMAT *zm_load(); #endif #endif #endif meschach-1.2b/matrix2.h100644 764 764 20143 5515156236 14435 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Header file for ``matrix2.a'' library file */ #ifndef MATRIX2H #define MATRIX2H #include "matrix.h" /* Unless otherwise specified, factorisation routines overwrite the matrix that is being factorised */ #ifndef ANSI_C extern MAT *BKPfactor(), *CHfactor(), *LUfactor(), *QRfactor(), *QRCPfactor(), *LDLfactor(), *Hfactor(), *MCHfactor(), *m_inverse(); extern double LUcondest(), QRcondest(); extern MAT *makeQ(), *makeR(), *makeHQ(), *makeH(); extern MAT *LDLupdate(), *QRupdate(); extern VEC *BKPsolve(), *CHsolve(), *LUsolve(), *_Qsolve(), *QRsolve(), *LDLsolve(), *Usolve(), *Lsolve(), *Dsolve(), *LTsolve(), *UTsolve(), *LUTsolve(), *QRCPsolve(); extern BAND *bdLUfactor(), *bdLDLfactor(); extern VEC *bdLUsolve(), *bdLDLsolve(); extern VEC *hhvec(); extern VEC *hhtrvec(); extern MAT *hhtrrows(); extern MAT *hhtrcols(); extern void givens(); extern VEC *rot_vec(); /* in situ */ extern MAT *rot_rows(); /* in situ */ extern MAT *rot_cols(); /* in situ */ /* eigenvalue routines */ extern VEC *trieig(), *symmeig(); extern MAT *schur(); extern void schur_evals(); extern MAT *schur_vecs(); /* singular value decomposition */ extern VEC *bisvd(), *svd(); /* matrix powers and exponent */ MAT *_m_pow(); MAT *m_pow(); MAT *m_exp(), *_m_exp(); MAT *m_poly(); /* FFT */ void fft(); void ifft(); #else /* forms Bunch-Kaufman-Parlett factorisation for symmetric indefinite matrices */ extern MAT *BKPfactor(MAT *A,PERM *pivot,PERM *blocks), /* Cholesky factorisation of A (symmetric, positive definite) */ *CHfactor(MAT *A), /* LU factorisation of A (with partial pivoting) */ *LUfactor(MAT *A,PERM *pivot), /* QR factorisation of A; need dim(diag) >= # rows of A */ *QRfactor(MAT *A,VEC *diag), /* QR factorisation of A with column pivoting */ *QRCPfactor(MAT *A,VEC *diag,PERM *pivot), /* L.D.L^T factorisation of A */ *LDLfactor(MAT *A), /* Hessenberg factorisation of A -- for schur() */ *Hfactor(MAT *A,VEC *diag1,VEC *diag2), /* modified Cholesky factorisation of A; actually factors A+D, D diagonal with no diagonal entry in the factor < sqrt(tol) */ *MCHfactor(MAT *A,double tol), *m_inverse(MAT *A,MAT *out); /* returns condition estimate for A after LUfactor() */ extern double LUcondest(MAT *A,PERM *pivot), /* returns condition estimate for Q after QRfactor() */ QRcondest(MAT *A); /* Note: The make..() and ..update() routines assume that the factorisation has already been carried out */ /* Qout is the "Q" (orthongonal) matrix from QR factorisation */ extern MAT *makeQ(MAT *A,VEC *diag,MAT *Qout), /* Rout is the "R" (upper triangular) matrix from QR factorisation */ *makeR(MAT *A,MAT *Rout), /* Qout is orthogonal matrix in Hessenberg factorisation */ *makeHQ(MAT *A,VEC *diag1,VEC *diag2,MAT *Qout), /* Hout is the Hessenberg matrix in Hessenberg factorisation */ *makeH(MAT *A,MAT *Hout); /* updates L.D.L^T factorisation for A <- A + alpha.u.u^T */ extern MAT *LDLupdate(MAT *A,VEC *u,double alpha), /* updates QR factorisation for QR <- Q.(R+u.v^T) Note: we need explicit Q & R matrices, from makeQ() and makeR() */ *QRupdate(MAT *Q,MAT *R,VEC *u,VEC *v); /* Solve routines assume that the corresponding factorisation routine has already been applied to the matrix along with auxiliary objects (such as pivot permutations) These solve the system A.x = b, except for LUTsolve and QRTsolve which solve the transposed system A^T.x. = b. If x is NULL on entry, then it is created. */ extern VEC *BKPsolve(MAT *A,PERM *pivot,PERM *blocks,VEC *b,VEC *x), *CHsolve(MAT *A,VEC *b,VEC *x), *LDLsolve(MAT *A,VEC *b,VEC *x), *LUsolve(MAT *A,PERM *pivot,VEC *b,VEC *x), *_Qsolve(MAT *A,VEC *,VEC *,VEC *, VEC *), *QRsolve(MAT *A,VEC *,VEC *b,VEC *x), *QRTsolve(MAT *A,VEC *,VEC *b,VEC *x), /* Triangular equations solve routines; U for upper triangular, L for lower traingular, D for diagonal if diag_val == 0.0 use that values in the matrix */ *Usolve(MAT *A,VEC *b,VEC *x,double diag_val), *Lsolve(MAT *A,VEC *b,VEC *x,double diag_val), *Dsolve(MAT *A,VEC *b,VEC *x), *LTsolve(MAT *A,VEC *b,VEC *x,double diag_val), *UTsolve(MAT *A,VEC *b,VEC *x,double diag_val), *LUTsolve(MAT *A,PERM *,VEC *,VEC *), *QRCPsolve(MAT *QR,VEC *diag,PERM *pivot,VEC *b,VEC *x); extern BAND *bdLUfactor(BAND *A,PERM *pivot), *bdLDLfactor(BAND *A); extern VEC *bdLUsolve(BAND *A,PERM *pivot,VEC *b,VEC *x), *bdLDLsolve(BAND *A,VEC *b,VEC *x); extern VEC *hhvec(VEC *,u_int,Real *,VEC *,Real *); extern VEC *hhtrvec(VEC *,double,u_int,VEC *,VEC *); extern MAT *hhtrrows(MAT *,u_int,u_int,VEC *,double); extern MAT *hhtrcols(MAT *,u_int,u_int,VEC *,double); extern void givens(double,double,Real *,Real *); extern VEC *rot_vec(VEC *,u_int,u_int,double,double,VEC *); /* in situ */ extern MAT *rot_rows(MAT *,u_int,u_int,double,double,MAT *); /* in situ */ extern MAT *rot_cols(MAT *,u_int,u_int,double,double,MAT *); /* in situ */ /* eigenvalue routines */ /* compute eigenvalues of tridiagonal matrix with diagonal entries a[i], super & sub diagonal entries b[i]; eigenvectors stored in Q (if not NULL) */ extern VEC *trieig(VEC *a,VEC *b,MAT *Q), /* sets out to be vector of eigenvectors; eigenvectors stored in Q (if not NULL). A is unchanged */ *symmeig(MAT *A,MAT *Q,VEC *out); /* computes real Schur form = Q^T.A.Q */ extern MAT *schur(MAT *A,MAT *Q); /* computes real and imaginary parts of the eigenvalues of A after schur() */ extern void schur_evals(MAT *A,VEC *re_part,VEC *im_part); /* computes real and imaginary parts of the eigenvectors of A after schur() */ extern MAT *schur_vecs(MAT *T,MAT *Q,MAT *X_re,MAT *X_im); /* singular value decomposition */ /* computes singular values of bi-diagonal matrix with diagonal entries a[i] and superdiagonal entries b[i]; singular vectors stored in U and V (if not NULL) */ VEC *bisvd(VEC *a,VEC *b,MAT *U,MAT *V), /* sets out to be vector of singular values; singular vectors stored in U and V */ *svd(MAT *A,MAT *U,MAT *V,VEC *out); /* matrix powers and exponent */ MAT *_m_pow(MAT *,int,MAT *,MAT *); MAT *m_pow(MAT *,int, MAT *); MAT *m_exp(MAT *,double,MAT *); MAT *_m_exp(MAT *,double,MAT *,int *,int *); MAT *m_poly(MAT *,VEC *,MAT *); /* FFT */ void fft(VEC *,VEC *); void ifft(VEC *,VEC *); #endif #endif meschach-1.2b/oldnames.h100644 764 764 7415 5515156574 14645 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* macros for names used in versions 1.0 and 1.1 */ /* 8/11/93 */ #ifndef OLDNAMESH #define OLDNAMESH /* type IVEC */ #define get_ivec iv_get #define freeivec IV_FREE #define cp_ivec iv_copy #define fout_ivec iv_foutput #define out_ivec iv_output #define fin_ivec iv_finput #define in_ivec iv_input #define dump_ivec iv_dump /* type ZVEC */ #define get_zvec zv_get #define freezvec ZV_FREE #define cp_zvec zv_copy #define fout_zvec zv_foutput #define out_zvec zv_output #define fin_zvec zv_finput #define in_zvec zv_input #define zero_zvec zv_zero #define rand_zvec zv_rand #define dump_zvec zv_dump /* type ZMAT */ #define get_zmat zm_get #define freezmat ZM_FREE #define cp_zmat zm_copy #define fout_zmat zm_foutput #define out_zmat zm_output #define fin_zmat zm_finput #define in_zmat zm_input #define zero_zmat zm_zero #define rand_zmat zm_rand #define dump_zmat zm_dump /* types SPMAT */ #define sp_mat SPMAT #define sp_get_mat sp_get #define sp_free_mat sp_free #define sp_cp_mat sp_copy #define sp_cp_mat2 sp_copy2 #define sp_fout_mat sp_foutput #define sp_fout_mat2 sp_foutput2 #define sp_out_mat sp_output #define sp_out_mat2 sp_output2 #define sp_fin_mat sp_finput #define sp_in_mat sp_input #define sp_zero_mat sp_zero #define sp_dump_mat sp_dump /* type SPROW */ #define sp_row SPROW #define sp_get_idx sprow_idx #define row_xpd sprow_xpd #define sp_get_row sprow_get #define row_set_val sprow_set_val #define fout_row sprow_foutput #define _row_mltadd sprow_mltadd #define sp_row_copy sprow_copy #define sp_row_merge sprow_merge #define sp_row_ip sprow_ip #define sp_row_sqr sprow_sqr /* type MAT */ #define get_mat m_get #define freemat M_FREE #define cp_mat m_copy #define fout_mat m_foutput #define out_mat m_output #define fin_mat m_finput #define in_mat m_input #define zero_mat m_zero #define id_mat m_ident #define rand_mat m_rand #define ones_mat m_ones #define dump_mat m_dump /* type VEC */ #define get_vec v_get #define freevec V_FREE #define cp_vec v_copy #define fout_vec v_foutput #define out_vec v_output #define fin_vec v_finput #define in_vec v_input #define zero_vec v_zero #define rand_vec v_rand #define ones_vec v_ones #define dump_vec v_dump /* type PERM */ #define get_perm px_get #define freeperm PX_FREE #define cp_perm px_copy #define fout_perm px_foutput #define out_perm px_output #define fin_perm px_finput #define in_perm px_input #define id_perm px_ident #define px_id px_ident #define trans_px px_transp #define sign_px px_sign #define dump_perm px_dump #endif meschach-1.2b/sparse.h100644 764 764 14523 5515156465 14355 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Header for sparse matrix stuff. Basic sparse routines to be held in sparse.c */ /* RCS id: $Id: sparse.h,v 1.2 1994/01/13 05:33:36 des Exp $ */ #ifndef SPARSEH #define SPARSEH #include "matrix.h" /* basic sparse types */ typedef struct row_elt { int col, nxt_row, nxt_idx; Real val; } row_elt; typedef struct SPROW { int len, maxlen, diag; row_elt *elt; /* elt[maxlen] */ } SPROW; typedef struct SPMAT { int m, n, max_m, max_n; char flag_col, flag_diag; SPROW *row; /* row[max_m] */ int *start_row; /* start_row[max_n] */ int *start_idx; /* start_idx[max_n] */ } SPMAT; /* Note that the first allocated entry in column j is start_row[j]; This starts the chain down the columns using the nxt_row and nxt_idx fields of each entry in each row. */ typedef struct pair { int pos; Real val; } pair; typedef struct SPVEC { int dim, max_dim; pair *elt; /* elt[max_dim] */ } SPVEC; #define SMNULL ((SPMAT*)NULL) #define SVNULL ((SPVEC*)NULL) /* Macro for speedup */ #define sprow_idx2(r,c,hint) \ ( ( (hint) >= 0 && (hint) < (r)->len && \ (r)->elt[hint].col == (c)) ? (hint) : sprow_idx((r),(c)) ) /* memory functions */ #ifdef ANSI_C int sp_get_vars(int m,int n,int deg,...); int sp_resize_vars(int m,int n,...); int sp_free_vars(SPMAT **,...); #elif VARARGS int sp_get_vars(); int sp_resize_vars(); int sp_free_vars(); #endif /* Sparse Matrix Operations and Utilities */ #ifndef ANSI_C extern SPMAT *sp_get(), *sp_copy(), *sp_copy2(), *sp_zero(), *sp_resize(), *sp_compact(); extern double sp_get_val(), sp_set_val(); extern VEC *sp_mv_mlt(), *sp_vm_mlt(); extern int sp_free(); /* Access path operations */ extern SPMAT *sp_col_access(); extern SPMAT *sp_diag_access(); extern int chk_col_access(); /* Input/output operations */ extern SPMAT *sp_finput(); extern void sp_foutput(), sp_foutput2(); /* algebraic operations */ extern SPMAT *sp_smlt(), *sp_add(), *sp_sub(), *sp_mltadd(); /* sparse row operations */ extern SPROW *sprow_get(), *sprow_xpd(), *sprow_merge(), *sprow_mltadd(), *sprow_resize(), *sprow_copy(); extern SPROW *sprow_add(), *sprow_sub(), *sprow_smlt(); extern double sprow_set_val(); extern void sprow_foutput(); extern int sprow_idx(), sprow_free(); /* dump */ extern void sp_dump(), sprow_dump(); extern MAT *sp_m2dense(); #else SPMAT *sp_get(int,int,int), *sp_copy(SPMAT *), *sp_copy2(SPMAT *,SPMAT *), *sp_zero(SPMAT *), *sp_resize(SPMAT *,int,int), *sp_compact(SPMAT *,double); double sp_get_val(SPMAT *,int,int), sp_set_val(SPMAT *,int,int,double); VEC *sp_mv_mlt(SPMAT *,VEC *,VEC *), *sp_vm_mlt(SPMAT *,VEC *,VEC *); int sp_free(SPMAT *); /* Access path operations */ SPMAT *sp_col_access(SPMAT *); SPMAT *sp_diag_access(SPMAT *); int chk_col_access(SPMAT *); /* Input/output operations */ SPMAT *sp_finput(FILE *); void sp_foutput(FILE *,SPMAT *), sp_foutput2(FILE *,SPMAT *); /* algebraic operations */ SPMAT *sp_smlt(SPMAT *A,double alpha,SPMAT *B), *sp_add(SPMAT *A,SPMAT *B,SPMAT *C), *sp_sub(SPMAT *A,SPMAT *B,SPMAT *C), *sp_mltadd(SPMAT *A,SPMAT *B,double alpha,SPMAT *C); /* sparse row operations */ SPROW *sprow_get(int), *sprow_xpd(SPROW *r,int n,int type), *sprow_resize(SPROW *r,int n,int type), *sprow_merge(SPROW *,SPROW *,SPROW *,int type), *sprow_copy(SPROW *,SPROW *,SPROW *,int type), *sprow_mltadd(SPROW *,SPROW *,double,int,SPROW *,int type); SPROW *sprow_add(SPROW *r1,SPROW *r2, int j0,SPROW *r_out, int type), *sprow_sub(SPROW *r1,SPROW *r2, int j0,SPROW *r_out, int type), *sprow_smlt(SPROW *r1,double alpha, int j0,SPROW *r_out, int type); double sprow_set_val(SPROW *,int,double); int sprow_free(SPROW *); int sprow_idx(SPROW *,int); void sprow_foutput(FILE *,SPROW *); /* dump */ void sp_dump(FILE *fp, SPMAT *A); void sprow_dump(FILE *fp, SPROW *r); MAT *sp_m2dense(SPMAT *A,MAT *out); #endif /* MACROS */ #define sp_input() sp_finput(stdin) #define sp_output(A) sp_foutput(stdout,(A)) #define sp_output2(A) sp_foutput2(stdout,(A)) #define row_mltadd(r1,r2,alpha,out) sprow_mltadd(r1,r2,alpha,0,out) #define out_row(r) sprow_foutput(stdout,(r)) #define SP_FREE(A) ( sp_free((A)), (A)=(SPMAT *)NULL) /* utility for index computations -- ensures index returned >= 0 */ #define fixindex(idx) ((idx) == -1 ? (error(E_BOUNDS,"fixindex"),0) : \ (idx) < 0 ? -((idx)+2) : (idx)) /* NOT USED */ /* loop over the columns in a row */ /* #define loop_cols(r,e,code) \ do { int _r_idx; row_elt *e; SPROW *_t_row; \ _t_row = (r); e = &(_t_row->elt); \ for ( _r_idx = 0; _r_idx < _t_row->len; _r_idx++, e++ ) \ { code; } } while ( 0 ) */ /* loop over the rows in a column */ /* #define loop_cols(A,col,e,code) \ do { int _r_num, _r_idx, _c; SPROW *_r; row_elt *e; \ if ( ! (A)->flag_col ) sp_col_access((A)); \ col_num = (col); \ if ( col_num < 0 || col_num >= A->n ) \ error(E_BOUNDS,"loop_cols"); \ _r_num = (A)->start_row[_c]; _r_idx = (A)->start_idx[_c]; \ while ( _r_num >= 0 ) { \ _r = &((A)->row[_r_num]); \ _r_idx = sprow_idx2(_r,_c,_r_idx); \ if ( _r_idx < 0 ) continue; \ e = &(_r->elt[_r_idx]); code; \ _r_num = e->nxt_row; _r_idx = e->nxt_idx; \ } } while ( 0 ) */ #endif meschach-1.2b/sparse2.h100644 764 764 6130 5515156506 14406 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Sparse matrix factorise/solve header */ /* RCS id: $Id: sparse2.h,v 1.4 1994/01/13 05:33:46 des Exp $ */ #ifndef SPARSE2H #define SPARSE2H #include "sparse.h" #ifdef ANSI_C SPMAT *spCHfactor(SPMAT *), *spICHfactor(SPMAT *), *spCHsymb(SPMAT *); VEC *spCHsolve(SPMAT *,VEC *,VEC *); SPMAT *spLUfactor(SPMAT *,PERM *,double); SPMAT *spILUfactor(SPMAT *,double); VEC *spLUsolve(SPMAT *,PERM *,VEC *,VEC *), *spLUTsolve(SPMAT *,PERM *,VEC *,VEC *); SPMAT *spBKPfactor(SPMAT *, PERM *, PERM *, double); VEC *spBKPsolve(SPMAT *, PERM *, PERM *, VEC *, VEC *); VEC *pccg(VEC *(*A)(),void *A_par,VEC *(*M_inv)(),void *M_par,VEC *b, double tol,VEC *x); VEC *sp_pccg(SPMAT *,SPMAT *,VEC *,double,VEC *); VEC *cgs(VEC *(*A)(),void *A_par,VEC *b,VEC *r0,double tol,VEC *x); VEC *sp_cgs(SPMAT *,VEC *,VEC *,double,VEC *); VEC *lsqr(VEC *(*A)(),VEC *(*AT)(),void *A_par,VEC *b,double tol,VEC *x); VEC *sp_lsqr(SPMAT *,VEC *,double,VEC *); int cg_set_maxiter(int); void lanczos(VEC *(*A)(),void *A_par,int m,VEC *x0,VEC *a,VEC *b, Real *beta_m1,MAT *Q); void sp_lanczos(SPMAT *,int,VEC *,VEC *,VEC *,Real *,MAT *); VEC *lanczos2(VEC *(*A)(),void *A_par,int m,VEC *x0,VEC *evals, VEC *err_est); VEC *sp_lanczos2(SPMAT *,int,VEC *,VEC *,VEC *); extern void scan_to(SPMAT *,IVEC *,IVEC *,IVEC *,int); extern row_elt *chase_col(SPMAT *,int,int *,int *,int); extern row_elt *chase_past(SPMAT *,int,int *,int *,int); extern row_elt *bump_col(SPMAT *,int,int *,int *); #else extern SPMAT *spCHfactor(), *spICHfactor(), *spCHsymb(); extern VEC *spCHsolve(); extern SPMAT *spLUfactor(); extern SPMAT *spILUfactor(); extern VEC *spLUsolve(), *spLUTsolve(); extern SPMAT *spBKPfactor(); extern VEC *spBKPsolve(); extern VEC *pccg(), *sp_pccg(), *cgs(), *sp_cgs(), *lsqr(), *sp_lsqr(); extern int cg_set_maxiter(); void lanczos(), sp_lanczos(); VEC *lanczos2(), *sp_lanczos2(); extern void scan_to(); extern row_elt *chase_col(); extern row_elt *chase_past(); extern row_elt *bump_col(); #endif #endif meschach-1.2b/zmatrix.h100644 764 764 21116 5537011042 14533 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Main include file for zmeschach library -- complex vectors and matrices */ #ifndef ZMATRIXH #define ZMATRIXH #include "matrix.h" /* Type definitions for complex vectors and matrices */ /* complex definition */ typedef struct { Real re,im; } complex; /* complex vector definition */ typedef struct { u_int dim, max_dim; complex *ve; } ZVEC; /* complex matrix definition */ typedef struct { u_int m, n; u_int max_m, max_n, max_size; complex *base; /* base is base of alloc'd mem */ complex **me; } ZMAT; #define ZVNULL ((ZVEC *)NULL) #define ZMNULL ((ZMAT *)NULL) #define Z_CONJ 1 #define Z_NOCONJ 0 /* memory functions */ #ifdef ANSI_C int zv_get_vars(int dim,...); int zm_get_vars(int m,int n,...); int zv_resize_vars(int new_dim,...); int zm_resize_vars(int m,int n,...); int zv_free_vars(ZVEC **,...); int zm_free_vars(ZMAT **,...); #elif VARARGS int zv_get_vars(); int zm_get_vars(); int zv_resize_vars(); int zm_resize_vars(); int zv_free_vars(); int zm_free_vars(); #endif #ifdef ANSI_C extern ZMAT *_zm_copy(ZMAT *in,ZMAT *out,u_int i0,u_int j0); extern ZMAT * zm_move(ZMAT *, int, int, int, int, ZMAT *, int, int); extern ZMAT *zvm_move(ZVEC *, int, ZMAT *, int, int, int, int); extern ZVEC *_zv_copy(ZVEC *in,ZVEC *out,u_int i0); extern ZVEC * zv_move(ZVEC *, int, int, ZVEC *, int); extern ZVEC *zmv_move(ZMAT *, int, int, int, int, ZVEC *, int); extern complex z_finput(FILE *fp); extern ZMAT *zm_finput(FILE *fp,ZMAT *a); extern ZVEC *zv_finput(FILE *fp,ZVEC *x); extern ZMAT *zm_add(ZMAT *mat1,ZMAT *mat2,ZMAT *out); extern ZMAT *zm_sub(ZMAT *mat1,ZMAT *mat2,ZMAT *out); extern ZMAT *zm_mlt(ZMAT *A,ZMAT *B,ZMAT *OUT); extern ZMAT *zmma_mlt(ZMAT *A,ZMAT *B,ZMAT *OUT); extern ZMAT *zmam_mlt(ZMAT *A,ZMAT *B,ZMAT *OUT); extern ZVEC *zmv_mlt(ZMAT *A,ZVEC *b,ZVEC *out); extern ZMAT *zsm_mlt(complex scalar,ZMAT *matrix,ZMAT *out); extern ZVEC *zvm_mlt(ZMAT *A,ZVEC *b,ZVEC *out); extern ZMAT *zm_adjoint(ZMAT *in,ZMAT *out); extern ZMAT *zswap_rows(ZMAT *A,int i,int j,int lo,int hi); extern ZMAT *zswap_cols(ZMAT *A,int i,int j,int lo,int hi); extern ZMAT *mz_mltadd(ZMAT *A1,ZMAT *A2,complex s,ZMAT *out); extern ZVEC *zmv_mltadd(ZVEC *v1,ZVEC *v2,ZMAT *A,complex alpha,ZVEC *out); extern ZVEC *zvm_mltadd(ZVEC *v1,ZVEC *v2,ZMAT *A,complex alpha,ZVEC *out); extern ZVEC *zv_zero(ZVEC *x); extern ZMAT *zm_zero(ZMAT *A); extern ZMAT *zm_get(int m,int n); extern ZVEC *zv_get(int dim); extern ZMAT *zm_resize(ZMAT *A,int new_m,int new_n); extern complex _zin_prod(ZVEC *x,ZVEC *y,u_int i0,u_int flag); extern ZVEC *zv_resize(ZVEC *x,int new_dim); extern ZVEC *zv_mlt(complex scalar,ZVEC *vector,ZVEC *out); extern ZVEC *zv_add(ZVEC *vec1,ZVEC *vec2,ZVEC *out); extern ZVEC *zv_mltadd(ZVEC *v1,ZVEC *v2,complex scale,ZVEC *out); extern ZVEC *zv_sub(ZVEC *vec1,ZVEC *vec2,ZVEC *out); #ifdef PROTOTYPES_IN_STRUCT extern ZVEC *zv_map(complex (*f)(),ZVEC *x,ZVEC *out); extern ZVEC *_zv_map(complex (*f)(),void *params,ZVEC *x,ZVEC *out); #else extern ZVEC *zv_map(complex (*f)(complex),ZVEC *x,ZVEC *out); extern ZVEC *_zv_map(complex (*f)(void *,complex),void *params,ZVEC *x,ZVEC *out); #endif extern ZVEC *zv_lincomb(int n,ZVEC *v[],complex a[],ZVEC *out); extern ZVEC *zv_linlist(ZVEC *out,ZVEC *v1,complex a1,...); extern ZVEC *zv_star(ZVEC *x1, ZVEC *x2, ZVEC *out); extern ZVEC *zv_slash(ZVEC *x1, ZVEC *x2, ZVEC *out); extern int zm_free(ZMAT *mat); extern int zv_free(ZVEC *vec); extern ZVEC *zv_rand(ZVEC *x); extern ZMAT *zm_rand(ZMAT *A); extern ZVEC *zget_row(ZMAT *A, int i, ZVEC *out); extern ZVEC *zget_col(ZMAT *A, int j, ZVEC *out); extern ZMAT *zset_row(ZMAT *A, int i, ZVEC *in); extern ZMAT *zset_col(ZMAT *A, int j, ZVEC *in); extern ZVEC *px_zvec(PERM *pi, ZVEC *in, ZVEC *out); extern ZVEC *pxinv_zvec(PERM *pi, ZVEC *in, ZVEC *out); extern void __zconj__(complex zp[], int len); extern complex __zip__(complex zp1[],complex zp2[],int len,int flag); extern void __zmltadd__(complex zp1[],complex zp2[], complex s,int len,int flag); extern void __zmlt__(complex zp[],complex s,complex out[],int len); extern void __zadd__(complex zp1[],complex zp2[],complex out[],int len); extern void __zsub__(complex zp1[],complex zp2[],complex out[],int len); extern void __zzero__(complex zp[],int len); extern void z_foutput(FILE *fp,complex z); extern void zm_foutput(FILE *fp,ZMAT *a); extern void zv_foutput(FILE *fp,ZVEC *x); extern void zm_dump(FILE *fp,ZMAT *a); extern void zv_dump(FILE *fp,ZVEC *x); extern double _zv_norm1(ZVEC *x, VEC *scale); extern double _zv_norm2(ZVEC *x, VEC *scale); extern double _zv_norm_inf(ZVEC *x, VEC *scale); extern double zm_norm1(ZMAT *A); extern double zm_norm_inf(ZMAT *A); extern double zm_norm_frob(ZMAT *A); complex zmake(double real, double imag); double zabs(complex z); complex zadd(complex z1,complex z2); complex zsub(complex z1,complex z2); complex zmlt(complex z1,complex z2); complex zinv(complex z); complex zdiv(complex z1,complex z2); complex zsqrt(complex z); complex zexp(complex z); complex zlog(complex z); complex zconj(complex z); complex zneg(complex z); #else extern ZMAT *_zm_copy(); extern ZVEC *_zv_copy(); extern ZMAT *zm_finput(); extern ZVEC *zv_finput(); extern ZMAT *zm_add(); extern ZMAT *zm_sub(); extern ZMAT *zm_mlt(); extern ZMAT *zmma_mlt(); extern ZMAT *zmam_mlt(); extern ZVEC *zmv_mlt(); extern ZMAT *zsm_mlt(); extern ZVEC *zvm_mlt(); extern ZMAT *zm_adjoint(); extern ZMAT *zswap_rows(); extern ZMAT *zswap_cols(); extern ZMAT *mz_mltadd(); extern ZVEC *zmv_mltadd(); extern ZVEC *zvm_mltadd(); extern ZVEC *zv_zero(); extern ZMAT *zm_zero(); extern ZMAT *zm_get(); extern ZVEC *zv_get(); extern ZMAT *zm_resize(); extern ZVEC *zv_resize(); extern complex _zin_prod(); extern ZVEC *zv_mlt(); extern ZVEC *zv_add(); extern ZVEC *zv_mltadd(); extern ZVEC *zv_sub(); extern ZVEC *zv_map(); extern ZVEC *_zv_map(); extern ZVEC *zv_lincomb(); extern ZVEC *zv_linlist(); extern ZVEC *zv_star(); extern ZVEC *zv_slash(); extern ZVEC *px_zvec(); extern ZVEC *pxinv_zvec(); extern ZVEC *zv_rand(); extern ZMAT *zm_rand(); extern ZVEC *zget_row(); extern ZVEC *zget_col(); extern ZMAT *zset_row(); extern ZMAT *zset_col(); extern int zm_free(); extern int zv_free(); extern void __zconj__(); extern complex __zip__(); extern void __zmltadd__(); extern void __zmlt__(); extern void __zadd__(); extern void __zsub__(); extern void __zzero__(); extern void zm_foutput(); extern void zv_foutput(); extern void zm_dump(); extern void zv_dump(); extern double _zv_norm1(); extern double _zv_norm2(); extern double _zv_norm_inf(); extern double zm_norm1(); extern double zm_norm_inf(); extern double zm_norm_frob(); complex zmake(); double zabs(); complex zadd(); complex zsub(); complex zmlt(); complex zinv(); complex zdiv(); complex zsqrt(); complex zexp(); complex zlog(); complex zconj(); complex zneg(); #endif #define zv_copy(x,y) _zv_copy(x,y,0) #define zm_copy(A,B) _zm_copy(A,B,0,0) #define z_input() z_finput(stdin) #define zv_input(x) zv_finput(stdin,x) #define zm_input(A) zm_finput(stdin,A) #define z_output(z) z_foutput(stdout,z) #define zv_output(x) zv_foutput(stdout,x) #define zm_output(A) zm_foutput(stdout,A) #define ZV_FREE(x) ( zv_free(x), (x) = ZVNULL ) #define ZM_FREE(A) ( zm_free(A), (A) = ZMNULL ) #define zin_prod(x,y) _zin_prod(x,y,0,Z_CONJ) #define zv_norm1(x) _zv_norm1(x,VNULL) #define zv_norm2(x) _zv_norm2(x,VNULL) #define zv_norm_inf(x) _zv_norm_inf(x,VNULL) #endif meschach-1.2b/zmatrix2.h100644 764 764 10067 5515146401 14624 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* 2nd header file for Meschach's complex routines. This file contains declarations for complex factorisation/solve routines. */ #ifndef ZMATRIX2H #define ZMATRIX2H #include "zmatrix.h" #ifdef ANSI_C extern ZVEC *zUsolve(ZMAT *matrix, ZVEC *b, ZVEC *out, double diag); extern ZVEC *zLsolve(ZMAT *matrix, ZVEC *b, ZVEC *out, double diag); extern ZVEC *zUAsolve(ZMAT *U, ZVEC *b, ZVEC *out, double diag); extern ZVEC *zDsolve(ZMAT *A, ZVEC *b, ZVEC *x); extern ZVEC *zLAsolve(ZMAT *L, ZVEC *b, ZVEC *out, double diag); extern ZVEC *zhhvec(ZVEC *,int,Real *,ZVEC *,complex *); extern ZVEC *zhhtrvec(ZVEC *,double,int,ZVEC *,ZVEC *); extern ZMAT *zhhtrrows(ZMAT *,int,int,ZVEC *,double); extern ZMAT *zhhtrcols(ZMAT *,int,int,ZVEC *,double); extern ZMAT *zHfactor(ZMAT *,ZVEC *); extern ZMAT *zHQunpack(ZMAT *,ZVEC *,ZMAT *,ZMAT *); extern ZMAT *zQRfactor(ZMAT *A, ZVEC *diag); extern ZMAT *zQRCPfactor(ZMAT *A, ZVEC *diag, PERM *px); extern ZVEC *_zQsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x, ZVEC *tmp); extern ZMAT *zmakeQ(ZMAT *QR, ZVEC *diag, ZMAT *Qout); extern ZMAT *zmakeR(ZMAT *QR, ZMAT *Rout); extern ZVEC *zQRsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x); extern ZVEC *zQRAsolve(ZMAT *QR, ZVEC *diag, ZVEC *b, ZVEC *x); extern ZVEC *zQRCPsolve(ZMAT *QR,ZVEC *diag,PERM *pivot,ZVEC *b,ZVEC *x); extern ZVEC *zUmlt(ZMAT *U, ZVEC *x, ZVEC *out); extern ZVEC *zUAmlt(ZMAT *U, ZVEC *x, ZVEC *out); extern double zQRcondest(ZMAT *QR); extern ZVEC *zLsolve(ZMAT *, ZVEC *, ZVEC *, double); extern ZMAT *zset_col(ZMAT *, int, ZVEC *); extern ZMAT *zLUfactor(ZMAT *A, PERM *pivot); extern ZVEC *zLUsolve(ZMAT *A, PERM *pivot, ZVEC *b, ZVEC *x); extern ZVEC *zLUAsolve(ZMAT *LU, PERM *pivot, ZVEC *b, ZVEC *x); extern ZMAT *zm_inverse(ZMAT *A, ZMAT *out); extern double zLUcondest(ZMAT *LU, PERM *pivot); extern void zgivens(complex, complex, Real *, complex *); extern ZMAT *zrot_rows(ZMAT *A, int i, int k, double c, complex s, ZMAT *out); extern ZMAT *zrot_cols(ZMAT *A, int i, int k, double c, complex s, ZMAT *out); extern ZVEC *rot_zvec(ZVEC *x, int i, int k, double c, complex s, ZVEC *out); extern ZMAT *zschur(ZMAT *A,ZMAT *Q); /* extern ZMAT *schur_vecs(ZMAT *T,ZMAT *Q,X_re,X_im) */ #else extern ZVEC *zUsolve(), *zLsolve(), *zUAsolve(), *zDsolve(), *zLAsolve(); extern ZVEC *zhhvec(); extern ZVEC *zhhtrvec(); extern ZMAT *zhhtrrows(); extern ZMAT *zhhtrcols(); extern ZMAT *zHfactor(); extern ZMAT *zHQunpack(); extern ZMAT *zQRfactor(), *zQRCPfactor(); extern ZVEC *_zQsolve(); extern ZMAT *zmakeQ(), *zmakeR(); extern ZVEC *zQRsolve(), *zQRAsolve(), *zQRCPsolve(); extern ZVEC *zUmlt(), *zUAmlt(); extern double zQRcondest(); extern ZVEC *zLsolve(); extern ZMAT *zset_col(); extern ZMAT *zLUfactor(); extern ZVEC *zLUsolve(), *zLUAsolve(); extern ZMAT *zm_inverse(); extern double zLUcondest(); extern void zgivens(); extern ZMAT *zrot_rows(), *zrot_cols(); extern ZVEC *rot_zvec(); extern ZMAT *zschur(); /* extern ZMAT *schur_vecs(); */ #endif #endif meschach-1.2b/dmacheps.c100644 764 764 2572 5515157037 14614 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ #include double dclean(x) double x; { static double y; y = x; return y; /* prevents optimisation */ } main() { static double deps, deps1, dtmp; deps = 1.0; while ( dclean(1.0+deps) > 1.0 ) deps = 0.5*deps; printf("%g\n", 2.0*deps); } meschach-1.2b/extras.c100644 764 764 25257 5566521652 14367 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Memory port routines: MEM_COPY and MEM_ZERO */ /* For BSD 4.[23] environments: using bcopy() and bzero() */ #include "machine.h" #ifndef MEM_COPY void MEM_COPY(from,to,len) char *from, *to; int len; { int i; if ( from < to ) { for ( i = 0; i < len; i++ ) *to++ = *from++; } else { from += len; to += len; for ( i = 0; i < len; i++ ) *(--to) = *(--from); } } #endif #ifndef MEM_ZERO void MEM_ZERO(ptr,len) char *ptr; int len; { int i; for ( i = 0; i < len; i++ ) *(ptr++) = '\0'; } #endif /* This file contains versions of something approximating the well-known BLAS routines in C, suitable for Meschach (hence the `m'). These are "vanilla" implementations, at least with some consideration of the effects of caching and paging, and maybe some loop unrolling for register-rich machines */ /* Organisation of matrices: it is assumed that matrices are represented by Real **'s. To keep flexibility, there is also an "initial column" parameter j0, so that the actual elements used are A[0][j0], A[0][j0+1], ..., A[0][j0+n-1] A[1][j0], A[1][j0+1], ..., A[1][j0+n-1] .. .. ... .. A[m-1][j0], A[m-1][j0+1], ..., A[m-1][j0+n-1] */ static char rcsid[] = "$Id: extras.c,v 1.3 1994/01/13 05:45:36 des Exp $"; #include #define REGISTER_RICH 1 /* mblar-1 routines */ /* Mscale -- sets x <- alpha.x */ void Mscale(len,alpha,x) int len; double alpha; Real *x; { register int i; for ( i = 0; i < len; i++ ) x[i] *= alpha; } /* Mswap -- swaps x and y */ void Mswap(len,x,y) int len; Real *x, *y; { register int i; register Real tmp; for ( i = 0; i < len; i++ ) { tmp = x[i]; x[i] = y[i]; y[i] = tmp; } } /* Mcopy -- copies x to y */ void Mcopy(len,x,y) int len; Real *x, *y; { register int i; for ( i = 0; i < len; i++ ) y[i] = x[i]; } /* Maxpy -- y <- y + alpha.x */ void Maxpy(len,alpha,x,y) int len; double alpha; Real *x, *y; { register int i, len4; /**************************************** for ( i = 0; i < len; i++ ) y[i] += alpha*x[i]; ****************************************/ #ifdef REGISTER_RICH len4 = len / 4; len = len % 4; for ( i = 0; i < len4; i++ ) { y[4*i] += alpha*x[4*i]; y[4*i+1] += alpha*x[4*i+1]; y[4*i+2] += alpha*x[4*i+2]; y[4*i+3] += alpha*x[4*i+3]; } x += 4*len4; y += 4*len4; #endif for ( i = 0; i < len; i++ ) y[i] += alpha*x[i]; } /* Mdot -- returns x'.y */ double Mdot(len,x,y) int len; Real *x, *y; { register int i, len4; register Real sum; #ifndef REGISTER_RICH sum = 0.0; #endif #ifdef REGISTER_RICH register Real sum0, sum1, sum2, sum3; sum0 = sum1 = sum2 = sum3 = 0.0; len4 = len / 4; len = len % 4; for ( i = 0; i < len4; i++ ) { sum0 += x[4*i ]*y[4*i ]; sum1 += x[4*i+1]*y[4*i+1]; sum2 += x[4*i+2]*y[4*i+2]; sum3 += x[4*i+3]*y[4*i+3]; } sum = sum0 + sum1 + sum2 + sum3; x += 4*len4; y += 4*len4; #endif for ( i = 0; i < len; i++ ) sum += x[i]*y[i]; return sum; } #ifndef ABS #define ABS(x) ((x) >= 0 ? (x) : -(x)) #endif /* Mnorminf -- returns ||x||_inf */ double Mnorminf(len,x) int len; Real *x; { register int i; register Real tmp, max_val; max_val = 0.0; for ( i = 0; i < len; i++ ) { tmp = ABS(x[i]); if ( max_val < tmp ) max_val = tmp; } return max_val; } /* Mnorm1 -- returns ||x||_1 */ double Mnorm1(len,x) int len; Real *x; { register int i; register Real sum; sum = 0.0; for ( i = 0; i < len; i++ ) sum += ABS(x[i]); return sum; } /* Mnorm2 -- returns ||x||_2 */ double Mnorm2(len,x) int len; Real *x; { register int i; register Real norm, invnorm, sum, tmp; norm = Mnorminf(len,x); if ( norm == 0.0 ) return 0.0; invnorm = 1.0/norm; sum = 0.0; for ( i = 0; i < len; i++ ) { tmp = x[i]*invnorm; sum += tmp*tmp; } return sum/invnorm; } /* mblar-2 routines */ /* Mmv -- y <- alpha.A.x + beta.y */ void Mmv(m,n,alpha,A,j0,x,beta,y) int m, n, j0; double alpha, beta; Real **A, *x, *y; { register int i, j, m4, n4; register Real sum0, sum1, sum2, sum3, tmp0, tmp1, tmp2, tmp3; register Real *dp0, *dp1, *dp2, *dp3; /**************************************** for ( i = 0; i < m; i++ ) y[i] += alpha*Mdot(n,&(A[i][j0]),x); ****************************************/ m4 = n4 = 0; #ifdef REGISTER_RICH m4 = m / 4; m = m % 4; n4 = n / 4; n = n % 4; for ( i = 0; i < m4; i++ ) { sum0 = sum1 = sum2 = sum3 = 0.0; dp0 = &(A[4*i ][j0]); dp1 = &(A[4*i+1][j0]); dp2 = &(A[4*i+2][j0]); dp3 = &(A[4*i+3][j0]); for ( j = 0; j < n4; j++ ) { tmp0 = x[4*j ]; tmp1 = x[4*j+1]; tmp2 = x[4*j+2]; tmp3 = x[4*j+3]; sum0 = sum0 + dp0[j]*tmp0 + dp0[j+1]*tmp1 + dp0[j+2]*tmp2 + dp0[j+3]*tmp3; sum1 = sum1 + dp1[j]*tmp0 + dp1[j+1]*tmp1 + dp1[j+2]*tmp2 + dp1[j+3]*tmp3; sum2 = sum2 + dp2[j]*tmp0 + dp2[j+1]*tmp1 + dp2[j+2]*tmp2 + dp2[j+3]*tmp3; sum3 = sum3 + dp3[j]*tmp0 + dp3[j+1]*tmp2 + dp3[j+2]*tmp2 + dp3[j+3]*tmp3; } for ( j = 0; j < n; j++ ) { sum0 += dp0[4*n4+j]*x[4*n4+j]; sum1 += dp1[4*n4+j]*x[4*n4+j]; sum2 += dp2[4*n4+j]*x[4*n4+j]; sum3 += dp3[4*n4+j]*x[4*n4+j]; } y[4*i ] = beta*y[4*i ] + alpha*sum0; y[4*i+1] = beta*y[4*i+1] + alpha*sum1; y[4*i+2] = beta*y[4*i+2] + alpha*sum2; y[4*i+3] = beta*y[4*i+3] + alpha*sum3; } #endif for ( i = 0; i < m; i++ ) y[4*m4+i] = beta*y[i] + alpha*Mdot(4*n4+n,&(A[4*m4+i][j0]),x); } /* Mvm -- y <- alpha.A^T.x + beta.y */ void Mvm(m,n,alpha,A,j0,x,beta,y) int m, n, j0; double alpha, beta; Real **A, *x, *y; { register int i, j, m4, n2; register Real *Aref; register Real tmp; #ifdef REGISTER_RICH register Real *Aref0, *Aref1; register Real tmp0, tmp1; register Real yval0, yval1, yval2, yval3; #endif if ( beta != 1.0 ) Mscale(m,beta,y); /**************************************** for ( j = 0; j < n; j++ ) Maxpy(m,alpha*x[j],&(A[j][j0]),y); ****************************************/ m4 = n2 = 0; m4 = m / 4; m = m % 4; #ifdef REGISTER_RICH n2 = n / 2; n = n % 2; for ( j = 0; j < n2; j++ ) { tmp0 = alpha*x[2*j]; tmp1 = alpha*x[2*j+1]; Aref0 = &(A[2*j ][j0]); Aref1 = &(A[2*j+1][j0]); for ( i = 0; i < m4; i++ ) { yval0 = y[4*i ] + tmp0*Aref0[4*i ]; yval1 = y[4*i+1] + tmp0*Aref0[4*i+1]; yval2 = y[4*i+2] + tmp0*Aref0[4*i+2]; yval3 = y[4*i+3] + tmp0*Aref0[4*i+3]; y[4*i ] = yval0 + tmp1*Aref1[4*i ]; y[4*i+1] = yval1 + tmp1*Aref1[4*i+1]; y[4*i+2] = yval2 + tmp1*Aref1[4*i+2]; y[4*i+3] = yval3 + tmp1*Aref1[4*i+3]; } y += 4*m4; Aref0 += 4*m4; Aref1 += 4*m4; for ( i = 0; i < m; i++ ) y[i] += tmp0*Aref0[i] + tmp1*Aref1[i]; } #endif for ( j = 0; j < n; j++ ) { tmp = alpha*x[2*n2+j]; Aref = &(A[2*n2+j][j0]); for ( i = 0; i < m4; i++ ) { y[4*i ] += tmp*Aref[4*i ]; y[4*i+1] += tmp*Aref[4*i+1]; y[4*i+2] += tmp*Aref[4*i+2]; y[4*i+3] += tmp*Aref[4*i+3]; } y += 4*m4; Aref += 4*m4; for ( i = 0; i < m; i++ ) y[i] += tmp*Aref[i]; } } /* Mupdate -- A <- A + alpha.x.y^T */ void Mupdate(m,n,alpha,x,y,A,j0) int m, n, j0; double alpha; Real **A, *x, *y; { register int i, j, n4; register Real *Aref; register Real tmp; /**************************************** for ( i = 0; i < m; i++ ) Maxpy(n,alpha*x[i],y,&(A[i][j0])); ****************************************/ n4 = n / 4; n = n % 4; for ( i = 0; i < m; i++ ) { tmp = alpha*x[i]; Aref = &(A[i][j0]); for ( j = 0; j < n4; j++ ) { Aref[4*j ] += tmp*y[4*j ]; Aref[4*j+1] += tmp*y[4*j+1]; Aref[4*j+2] += tmp*y[4*j+2]; Aref[4*j+3] += tmp*y[4*j+3]; } Aref += 4*n4; y += 4*n4; for ( j = 0; j < n; j++ ) Aref[j] += tmp*y[j]; } } /* mblar-3 routines */ /* Mmm -- C <- C + alpha.A.B */ void Mmm(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) int m, n, p; /* C is m x n */ double alpha; Real **A, **B, **C; int Aj0, Bj0, Cj0; { register int i, j, k; /* register Real tmp, sum; */ /**************************************** for ( i = 0; i < m; i++ ) for ( k = 0; k < p; k++ ) Maxpy(n,alpha*A[i][Aj0+k],&(B[k][Bj0]),&(C[i][Cj0])); ****************************************/ for ( i = 0; i < m; i++ ) Mvm(p,n,alpha,B,Bj0,&(A[i][Aj0]),1.0,&(C[i][Cj0])); } /* Mmtrm -- C <- C + alpha.A^T.B */ void Mmtrm(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) int m, n, p; /* C is m x n */ double alpha; Real **A, **B, **C; int Aj0, Bj0, Cj0; { register int i, j, k; /**************************************** for ( i = 0; i < m; i++ ) for ( k = 0; k < p; k++ ) Maxpy(n,alpha*A[k][Aj0+i],&(B[k][Bj0]),&(C[i][Cj0])); ****************************************/ for ( k = 0; k < p; k++ ) Mupdate(m,n,alpha,&(A[k][Aj0]),&(B[k][Bj0]),C,Cj0); } /* Mmmtr -- C <- C + alpha.A.B^T */ void Mmmtr(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) int m, n, p; /* C is m x n */ double alpha; Real **A, **B, **C; int Aj0, Bj0, Cj0; { register int i, j, k; /**************************************** for ( i = 0; i < m; i++ ) for ( j = 0; j < n; j++ ) C[i][Cj0+j] += alpha*Mdot(p,&(A[i][Aj0]),&(B[j][Bj0])); ****************************************/ for ( i = 0; i < m; i++ ) Mmv(n,p,alpha,&(A[i][Aj0]),B,Bj0,&(C[i][Cj0])); } /* Mmtrmtr -- C <- C + alpha.A^T.B^T */ void Mmtrmtr(m,n,p,alpha,A,Aj0,B,Bj0,C,Cj0) int m, n, p; /* C is m x n */ double alpha; Real **A, **B, **C; int Aj0, Bj0, Cj0; { register int i, j, k; for ( i = 0; i < m; i++ ) for ( j = 0; j < n; j++ ) for ( k = 0; k < p; k++ ) C[i][Cj0+j] += A[i][Aj0+k]*B[k][Bj0+j]; } meschach-1.2b/fmacheps.c100644 764 764 2570 5515157236 14615 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ #include double fclean(x) double x; { static float y; y = x; return y; /* prevents optimisation */ } main() { static float feps, feps1, ftmp; feps = 1.0; while ( fclean(1.0+feps) > 1.0 ) feps = 0.5*feps; printf("%g\n", 2.0*feps); } meschach-1.2b/maxint.c100644 764 764 2351 5515156264 14324 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ main() { int i, old_i; i = 1; while ( i > 0 ) { old_i = i; i = (i << 1) | 1; } printf("%d\n", old_i); } meschach-1.2b/makefile.in100644 764 764 13412 5602131533 14772 0ustar lapeyrelapeyre# # Makefile for Meschach via autoconf # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: makefile.in,v 1.4 1994/03/14 01:24:06 des Exp $ # srcdir = @srcdir@ VPATH = @srcdir@ CC = @CC@ DEFS = @DEFS@ LIBS = @LIBS@ RANLIB = @RANLIB@ CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12b TAR = tar SHAR = stree -u ZIP = zip -r -l FLIST = FILELIST ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HBASE = err.h meminfo.h machine.h matrix.h HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ sparse2.h zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) # Different configurations # the dependencies **between** the parts are for dmake all: @PROGS@ part1 part2 part3 zpart1 zpart2 part2: part1 part3: part2 basic: part1 part2 sparse: part1 part2 part3 zpart2: zpart1 complex: part1 part2 zpart1 zpart2 $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1) $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2) $(RANLIB) meschach.a $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3) $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1) $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2) $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST) $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar list: /bin/rm -f $(FLIST) ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) MACHINES DOC \ |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ > $(FLIST) clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a realclean: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a /bin/rm -f torture sptort ztorture memtort itertort mfuntort iotort /bin/rm -f makefile machine.h config.status maxint macheps alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/README100644 764 764 43126 5550413323 13554 0ustar lapeyrelapeyre Meschach Library Version 1.2b David E. Stewart (david.stewart@anu.edu.au) and Zbigniew Leyk (zbigniew.leyk@anu.edu.au) School of Mathematical Sciences Australian National University Canberra ACT 0200 Australia [last revised: 6th April, 1994] 1. INTRODUCTION The Meschach Library is a numerical library of C routines for performing calculations on matrices and vectors. It is intended for solving systems of linear equations (dense and sparse), solve least squares problems, computing eigenvalues and eigenvectors, etc. We do not claim that it contains every useful algorithm in numerical linear algebra, but it does provide a basis on which more advanced algorithms can be built. The library is for people who know something about the C programming language, something of how to solve the numerical problem they are faced with but do not want to have the hassle of building all the necessary routines from the scratch. The library is not a loose collection of numerical routines but it comprises a coherent system. The current version is enhanced with many features comparing with previous versions. Since the memory requirements are nontrivial for large problems we have paid more attention to allocation/deallocation of memory. The source code is available to be perused, used and passed on without cost, while ensuring that the quality of the software is not compromised. The software is copyrighted; however, the copyright agreement follows in the footsteps of the Free Software Foundation in preventing abuse that occurs with totally public domain software. Detailed instructions for installing Meschach are contained below. Pronunciation: if in doubt, say "me-shark". This is close enough. Don't ask us "Why call it that?" Have a look at the quote at the front of the manual. 2. AVAILABILITY The authors make this code openly available to others, in the hope that it will prove to be a useful tool. We ask only that: * If you publish results obtained using Meschach, please consider acknowledging the source of the code. * If you discover any errors in the code, please promptly communicate them to the authors. We also suggest that you send email to the authors identifying yourself as a user of Meschach; this will enable the authors to notify you of any corrections/improvements in Meschach. 3. HOW TO GET IT There are several different forms in which you might receive Meschach. To provide a shorthand for describing collections of files, the Unix convention of putting alternative letters in [...] will be used. (So, fred[123] means the collection fred1, fred2 and fred3.) Meschach is available over Internet/AARnet via netlib, or at the anonymous ftp site thrain.anu.edu.au in the directory pub/meschach. There are five .shar files: meschach[01234].shar (which contain the library itself), meschach0.shar (which contains basic documentation and machine dependent files for a number of machines). Of the meschach[1234].shar files, only meschach[12].shar are needed for the basic Meschach library; the third .shar file contains the sparse matrix routines, and the the fourth contains the routines for complex numbers, vectors and matrices. There is also a README file that you should get from meschach0.shar. If you need the old iterative routines, the file oldmeschach.shar contains the files conjgrad.c, arnoldi.c and lanczos.c. To get the library from netlib, mail netlib@research.att.com send all from c/meschach There are a number of other netlib sites which mirror the main netlib sites. These include netlib@ornl.gov (Oak Ridge, TN, USA), netlib@nac.no (Oslo, Norway), ftp.cs.uow.edu.au (Wollongong, Australia; ftp only), netlib@nchc.edu.tw (Taiwan), elib.zib-berlin.de (Berlin, Germany; ftp only). (For anonymous ftp sites the directory containing the Meschach .shar files is pub/netlib/c/meschach or similar, possibly depending on the site.) Meschach is available in other forms on thrain.anu.edu.au by ftp in the directory pub/meschach. It is available as a .tar file (mesch12a.tar for version 1.2a), or as a collection of .shar files, or as a .zip file. The .tar and .zip versions each contain the entire contents of the Meschach library. There is a manual called "Meschach: Matrix Computations in C" which has been published by Centre for Mathematics and its Applications School of Mathematical Sciences Australian National University Canberra, ACT 0200 Australia and costs A$30 (about US$22) + postage/handling. You can order it by writing there or you can send email messages to one of us (david.stewart@anu.edu.au or zbigniew.leyk@anu.edu.au) and we can pass it on. If you don't have any money, as a stop gap you can get the **OLD** manual, although it is out of date, by anonymous ftp from thrain.anu.edu.au : /pub/meschach/version1.1b/bookdvi.tar [.Z or .gz] In addition, don't forget that the distribution includes a DOC directory which contains tutorial.txt and fnindex.txt which are respectively, the tutorial chapter (text version) and the function index (text version). 4. INSTALLATION a) On Unix machines To extract the files from the .shar files, put them all into a suitable directory and use sh .shar to expand the files. (Use one sh command per file; sh *.shar will not work in general.) For the .tar file, use tar xvf mesch12a.tar and for the .zip file use unzip mesch12a.zip On a Unix system you can use the configure script to set up the machine-dependent files. The script takes a number of options which are used for installing different subsets of the full Meschach. For the basic system, which requires only meschach[012].shar, use configure make basic make clean For including sparse operations, which requires meschach[0123].shar, use configure --with-sparse make sparse make clean For including complex operations, which requires meschach[0124].shar, use configure --with-complex make complex make clean For including everything, which requires meschach[01234].shar, use configure --with-all make all make clean To compile the complete library in single precision (with Real equivalent to float), add the --with-float option to configure, use configure --with-all --with-float make all make clean Some Unix-like systems may have some problems with this due to bugs or incompatibilities in various parts of the system. To check this use make torture and run torture. In this case use the machine-dependent files from the machines directory. (This is the case for RS/6000 machines, the -O switch results in failure of a routine in schur.c. Compiling without the -O switch results in correct results.) If you have problems using configure, or you use a non-Unix system, check the MACHINES directory (generated by meschach0.shar) for your machine, operating system and/or compiler. Save the machine dependent files makefile, machine.c and machine.h. Copy those files from the directory for your machine to the directory where the source code is. To link into a program prog.c, compile it using cc -o prog_name prog.c ....(source files).... meschach.a -lm This code has been mostly developed on the University of Queensland, Australia's Pyramid 9810 running BSD4.3. Initial development was on a Zilog Zeus Z8000 machine running Zeus, a Unix workalike operating system. Versions have also been successfully used on various Unix machines including Sun 3's, IBM RT's, SPARC's and an IBM RS/6000 running AIX. It has also been compiled on an IBM AT clone using Quick C. It has been designed to compile under either Kernighan and Richie, (Edition 1) C and under ANSI C. (And, indeed, it has been compiled in both ANSI C and non-ANSI C environments.) b) On non-Unix machines First look in the machines directory for your system type. If it is there, then copy the machine dependent files machine.h, makefile (and possibly machine.c) to the Meschach directory. If your machine type is not there, then you will need to either compile ``by hand'', or construct your own makefile and possibly machine.h as well. The machine-dependent files for various systems should be used as a starting point, and the ``vanilla'' version of machine.h should be used. Information on the machine-dependent files follows in the next three subsections. On an IBM PC clone, the source code would be on a floppy disk. Use xcopy a:* meschach to copy it to the meschach directory. Then ``cd meschach'', and then compile the source code. Different compilers on MSDOS machines will require different installation procedures. Check the directory meschach for the appropriate ``makefile'' for your compiler. If your compiler is not listed, then you should try compiling it ``by hand'', modifying the machine-dependent files as necessary. Worst come to worst, for a given C compiler, execute *.c on MS-DOS machines. For example, tcc *.c for Turbo C, and msc *.c for Microsoft C, or if you are using Quick C, qcl *.c and of course cc *.c for the standard Unix compiler. Once the object files have been generated, you will need to combine them into a library. Consult your local compiler's manual for details of how to do this. When compiling programs/routines that use Meschach, you will need to have access the the header files in the INCLUDE directory. The INCLUDE directory's contents can be copied to the directory where the programs/routines are compiled. The files in the DOC directory form a very brief form of documentation on the the library routines in Meschach. See the printed documentation for more comprehensive documentation of the Meschach routines. This can be obtained from the authors via email. The files and directories created by the machines.shar shell archive contain the files machine.c machine.h and makefile for a particular machine/operating system/compiler where they need to be different. Copy the files in the appropriate directory for your machine/operating system/compiler to the directory with the Meschach source before compiling. c) makefile This is setup by using the configure script on a Unix system, based on the makefile.in file. However, if you want to modify how the library is compiled, you are free to change the makefile. The most likely change that you would want to make to this file is to change the line CFLAGS = -O to suit your particular compiler. The code is intended to be compilable by both ANSI and non-ANSI compilers. To achieve this portability without sacrificing the ANSI function prototypes (which are very useful for avoiding problems with passing parameters) there is a token ANSI_C which must be #define'd in order to take full advantage of ANSI C. To do this you should do all compilations with #define ANSI_C 1 This can also be done at the compilation stage with a -DANSI_C flag. Again, you will have to use the -DANSI_C flag or its equivalent whenever you compile, or insert the line #define ANSI_C 1 in machine.h, to make full use of ANSI C with this matrix library. d) machine.h Like makefile this is normally set up by the configure script on Unix machines. However, for non-Unix systems, or if you need to set some things ``by hand'', change machine.h. There are a few quantities in here that should be modified to suit your particular compiler. Firstly, the macros MEM_COPY() and MEM_ZERO() need to be correctly defined here. The original library was compiled on BSD systems, and so it originally relied on bcopy() and bzero(). In machine.h you will find the definitions for using the standard ANSI C library routines: /*--------------------ANSI C--------------------*/ #include #include #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) Delete or comment out the alternative definitions and it should compile correctly. The source files containing memmove() and/or memset() are available by anonymous ftp from some ftp sites (try archie to discover them). The files are usually called memmove.c or memset.c. Some ftp sites which currently (Jan '94) have a version of these files are munnari.oz.au (in Australia), ftp.uu.net, gatekeeper.dec.com (USA), and unix.hensa.ac.uk (in the UK). The directory in which you will find memmove.c and memset.c typically looks like .../bsd-sources/lib/libc/... There are two further machine-dependent quantities that should be set. These are machine epsilon or the unit roundoff for double precision arithmetic, and the maximum value produced by the rand() routine, which is used in rand_vec() and rand_mat(). The current definitions of these are #define MACHEPS 2.2e-16 #define MAX_RAND 2.147483648e9 The value of MACHEPS should be correct for all IEEE standard double precision arithmetic. However, ANSI C's contains #define'd quantities DBL_EPSILON and RAND_MAX, so if you have an ANSI C compiler and headers, replace the above two lines of machine.h with #include /* for Real == float */ #define MACHEPS DBL_EPSILON #define MAX_RAND RAND_MAX The default value given for MAX_RAND is 2^31 , as the Pyramid 9810 and the SPARC 2's both have 32 bit words. There is a program macheps.c which is included in your source files which computes and prints out the value of MACHEPS for your machine. Some other macros control some aspects of Meschach. One of these is SEGMENTED which should be #define'd if you are working with a machine or compiler that does not allow large arrays to be allocated. For example, the most common memory models for MS-DOS compilers do not allow more than 64Kbyte to be allocated in one block. This limits square matrices to be no more than 9090 . Inserting #define SEGMENTED 1 into machine.h will mean that matrices are allocated a row at a time. 4. SAMPLE TESTS There are several programs for checking Meschach called torture (source: torture.c) for the dense routines, sptort (source: sptort.c) for the sparse routines, ztorture (source ztorture.c) for a complex version of torture, memtort (source memtort.c) for memory allocation/deallocation, itertort (source itertort.c) for iterative methods, mfuntort (source mfuntort.c) for computing powers of dense matrices, iotort (source iotort.c) for I/O routines. These can be compiled using make by "make torture", "make sptort", etc. The programs are part of meschach0.shar. 5. OTHER PROBLEMS Meschach is not a commercial package, so we do not guarantee that everything will be perfect or will install smoothly. Inevitably there will be unforeseen problems. If you come across any bugs or inconsistencies, please let us know. If you need to modify the results of the configure script, or need to construct your own machine.h and makefile's, please send them to us. A number of people sent us the machine dependent files for Meschach 1.1, but with the use of configure, and the new information needed for version 1.2, these machine dependent files don't have quite the right information. Hopefully, though, they are redundant. Non-Unix platforms at present require ``manual'' installation. Because of the variety of platforms (MS-DOS, Macintosh, VAX/VMS, Prime, Amiga, Atari, ....) this is left up to the users of these platforms. We hope that you can use the distibutable machine-dependent files as a starting point for this task. If you have programs or routines written using Meschach v.1.1x, you should put the statement #include "oldnames.h" at the beginning of your files. This is because a large number of the names of the routines have been changed (e.g. "get_vec()" has become "v_get()"). This will enable you to use the old names, although all of the error messages etc., will use the new names. Also note that the new iterative routines have a very different calling sequence. If you need the old iterative routines, they are in oldmeschach.shar. If you wish to let us know what you have done, etc., our email addresses are david.stewart@anu.edu.au zbigniew.leyk@anu.edu.au Good luck! ACKNOWLEDGMENTS Many people have helped in various ways with ideas and suggestions. Needless to say, the bugs are all ours! But these people should be thanked for their encouragement etc. These include a number of people at University of Queensland: Graeme Chandler, David De Wit, Martin Sharry, Michael Forbes, Phil Kilby, John Holt, Phil Pollett and Tony Watts. At the Australian National University: Mike Osborne, Steve Roberts, Margaret Kahn and Teresa Leyk. Karen George of the University of Canberra has been a source of both ideas and encouragement. Email has become significant part of work, and many people have pointed out bugs, inconsistencies and improvements to Meschach by email. These people include Ajay Shah of the University of Southern California, Dov Grobgeld of the Weizmann Institute, John Edstrom of the University of Calgary, Eric Grosse, one of the netlib organisers, Ole Saether of Oslo, Norway, Alfred Thiele and Pierre Asselin of Carnegie-Mellon Univeristy, Daniel Polani of the University of Mainz, Marian Slodicka of Slovakia, Kaifu Wu of Pomona, Hidetoshi Shimodaira of the University of Tokyo, Eng Siong of Edinburgh, Hirokawa Rui of the University of Tokyo, Marko Slyz of the University of Michigan, and Brook Milligan of the University of Texas. This list is only partial, and there are many others who have corresponded with us on details about Meschach and the like. Finally our thanks go to all those that have had to struggle with compilers and other things to get Meschach to work. meschach-1.2b/configure100755 764 764 64410 5537002370 14603 0ustar lapeyrelapeyre#!/bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated automatically using autoconf. # Copyright (C) 1991, 1992, 1993 Free Software Foundation, Inc. # 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 2, 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., 675 Mass Ave, Cambridge, MA 02139, USA. # Usage: configure [--srcdir=DIR] [--host=HOST] [--gas] [--nfp] [--no-create] # [--prefix=PREFIX] [--exec-prefix=PREFIX] [--with-PACKAGE] [TARGET] # Ignores all args except --srcdir, --prefix, --exec-prefix, --no-create, and # --with-PACKAGE unless this script has special code to handle it. for arg do # Handle --exec-prefix with a space before the argument. if test x$next_exec_prefix = xyes; then exec_prefix=$arg; next_exec_prefix= # Handle --host with a space before the argument. elif test x$next_host = xyes; then next_host= # Handle --prefix with a space before the argument. elif test x$next_prefix = xyes; then prefix=$arg; next_prefix= # Handle --srcdir with a space before the argument. elif test x$next_srcdir = xyes; then srcdir=$arg; next_srcdir= else case $arg in # For backward compatibility, also recognize exact --exec_prefix. -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* | --exe=* | --ex=* | --e=*) exec_prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e) next_exec_prefix=yes ;; -gas | --gas | --ga | --g) ;; -host=* | --host=* | --hos=* | --ho=* | --h=*) ;; -host | --host | --hos | --ho | --h) next_host=yes ;; -nfp | --nfp | --nf) ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre | --no-cr | --no-c | --no- | --no) no_create=1 ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=`echo $arg | sed 's/[-a-z_]*=//'` ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) next_prefix=yes ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*) srcdir=`echo $arg | sed 's/[-a-z_]*=//'` ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s) next_srcdir=yes ;; -with-* | --with-*) package=`echo $arg|sed 's/-*with-//'` # Delete all the valid chars; see if any are left. if test -n "`echo $package|sed 's/[-a-zA-Z0-9_]*//g'`"; then echo "configure: $package: invalid package name" >&2; exit 1 fi eval "with_`echo $package|sed s/-/_/g`=1" ;; -v | -verbose | --verbose | --verbos | --verbo | --verb | --ver | --ve | --v) verbose=yes ;; *) ;; esac fi done trap 'rm -f conftest* core; exit 1' 1 3 15 # Needed for some versions of `tr' so that character classes in `[]' work. if test "${LANG+set}" = "set" ; then LANG=C fi rm -f conftest* compile='${CC-cc} $CFLAGS $DEFS conftest.c -o conftest $LIBS >/dev/null 2>&1' # A filename unique to this package, relative to the directory that # configure is in, which we can look for to find out if srcdir is correct. unique_file=err.c # Find the source files, if location was not specified. if test -z "$srcdir"; then srcdirdefaulted=yes # Try the directory containing this script, then `..'. prog=$0 confdir=`echo $prog|sed 's%/[^/][^/]*$%%'` test "X$confdir" = "X$prog" && confdir=. srcdir=$confdir if test ! -r $srcdir/$unique_file; then srcdir=.. fi fi if test ! -r $srcdir/$unique_file; then if test x$srcdirdefaulted = xyes; then echo "configure: Can not find sources in \`${confdir}' or \`..'." 1>&2 else echo "configure: Can not find sources in \`${srcdir}'." 1>&2 fi exit 1 fi # Preserve a srcdir of `.' to avoid automounter screwups with pwd. # But we can't avoid them for `..', to make subdirectories work. case $srcdir in .|/*|~*) ;; *) srcdir=`cd $srcdir; pwd` ;; # Make relative path absolute. esac PROGS="" if test -z "$CC"; then # Extract the first word of `acc', so it can be a program name with args. set dummy acc; word=$2 echo checking for $word IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" for dir in $PATH; do test -z "$dir" && dir=. if test -f $dir/$word; then CC="acc" break fi done IFS="$saveifs" fi test -z "$CC" && CC="""" test -n "$CC" -a -n "$verbose" && echo " setting CC to $CC" if test -z "$CC"; then # Extract the first word of `cc', so it can be a program name with args. set dummy cc; word=$2 echo checking for $word IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" for dir in $PATH; do test -z "$dir" && dir=. if test -f $dir/$word; then CC="cc" break fi done IFS="$saveifs" fi test -z "$CC" && CC="gcc" test -n "$CC" -a -n "$verbose" && echo " setting CC to $CC" echo checking how to run the C preprocessor if test -z "$CPP"; then CPP='${CC-cc} -E' cat > conftest.c < EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then : else CPP=/lib/cpp fi rm -f conftest* fi echo checking for AIX cat > conftest.c < conftest.out 2>&1" if egrep "yes" conftest.out >/dev/null 2>&1; then { test -n "$verbose" && \ echo ' defining' _ALL_SOURCE DEFS="$DEFS -D_ALL_SOURCE=1" SEDDEFS="${SEDDEFS}\${SEDdA}_ALL_SOURCE\${SEDdB}_ALL_SOURCE\${SEDdC}1\${SEDdD} \${SEDuA}_ALL_SOURCE\${SEDuB}_ALL_SOURCE\${SEDuC}1\${SEDuD} \${SEDeA}_ALL_SOURCE\${SEDeB}_ALL_SOURCE\${SEDeC}1\${SEDeD} " } fi rm -f conftest* echo checking for minix/config.h cat > conftest.c < EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then MINIX=1 fi rm -f conftest* # The Minix shell can't assign to the same variable on the same line! if test -n "$MINIX"; then { test -n "$verbose" && \ echo ' defining' _POSIX_SOURCE DEFS="$DEFS -D_POSIX_SOURCE=1" SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_SOURCE\${SEDdB}_POSIX_SOURCE\${SEDdC}1\${SEDdD} \${SEDuA}_POSIX_SOURCE\${SEDuB}_POSIX_SOURCE\${SEDuC}1\${SEDuD} \${SEDeA}_POSIX_SOURCE\${SEDeB}_POSIX_SOURCE\${SEDeC}1\${SEDeD} " } { test -n "$verbose" && \ echo ' defining' _POSIX_1_SOURCE to be '2' DEFS="$DEFS -D_POSIX_1_SOURCE=2" SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_1_SOURCE\${SEDdB}_POSIX_1_SOURCE\${SEDdC}2\${SEDdD} \${SEDuA}_POSIX_1_SOURCE\${SEDuB}_POSIX_1_SOURCE\${SEDuC}2\${SEDuD} \${SEDeA}_POSIX_1_SOURCE\${SEDeB}_POSIX_1_SOURCE\${SEDeC}2\${SEDeD} " } { test -n "$verbose" && \ echo ' defining' _MINIX DEFS="$DEFS -D_MINIX=1" SEDDEFS="${SEDDEFS}\${SEDdA}_MINIX\${SEDdB}_MINIX\${SEDdC}1\${SEDdD} \${SEDuA}_MINIX\${SEDuB}_MINIX\${SEDuC}1\${SEDuD} \${SEDeA}_MINIX\${SEDeB}_MINIX\${SEDeC}1\${SEDeD} " } fi echo checking for POSIXized ISC if test -d /etc/conf/kconfig.d && grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1 then ISC=1 # If later tests want to check for ISC. { test -n "$verbose" && \ echo ' defining' _POSIX_SOURCE DEFS="$DEFS -D_POSIX_SOURCE=1" SEDDEFS="${SEDDEFS}\${SEDdA}_POSIX_SOURCE\${SEDdB}_POSIX_SOURCE\${SEDdC}1\${SEDdD} \${SEDuA}_POSIX_SOURCE\${SEDuB}_POSIX_SOURCE\${SEDuC}1\${SEDuD} \${SEDeA}_POSIX_SOURCE\${SEDeB}_POSIX_SOURCE\${SEDeC}1\${SEDeD} " } if test -n "$GCC"; then CC="$CC -posix" else CC="$CC -Xp" fi fi if test -z "$RANLIB"; then # Extract the first word of `ranlib', so it can be a program name with args. set dummy ranlib; word=$2 echo checking for $word IFS="${IFS= }"; saveifs="$IFS"; IFS="${IFS}:" for dir in $PATH; do test -z "$dir" && dir=. if test -f $dir/$word; then RANLIB="ranlib" break fi done IFS="$saveifs" fi test -z "$RANLIB" && RANLIB=":" test -n "$RANLIB" -a -n "$verbose" && echo " setting RANLIB to $RANLIB" for hdr in memory.h do trhdr=HAVE_`echo $hdr | tr '[a-z]./' '[A-Z]__'` echo checking for ${hdr} cat > conftest.c < EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then { test -n "$verbose" && \ echo ' defining' ${trhdr} DEFS="$DEFS -D${trhdr}=1" SEDDEFS="${SEDDEFS}\${SEDdA}${trhdr}\${SEDdB}${trhdr}\${SEDdC}1\${SEDdD} \${SEDuA}${trhdr}\${SEDuB}${trhdr}\${SEDuC}1\${SEDuD} \${SEDeA}${trhdr}\${SEDeB}${trhdr}\${SEDeC}1\${SEDeD} " } fi rm -f conftest* done echo checking for ANSI C header files cat > conftest.c < #include #include #include EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. echo '#include ' > conftest.c eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" if egrep "memchr" conftest.out >/dev/null 2>&1; then # SGI's /bin/cc from Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. cat > conftest.c < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') #define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #define XOR(e,f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } EOF eval $compile if test -s conftest && (./conftest; exit) 2>/dev/null; then { test -n "$verbose" && \ echo ' defining' STDC_HEADERS DEFS="$DEFS -DSTDC_HEADERS=1" SEDDEFS="${SEDDEFS}\${SEDdA}STDC_HEADERS\${SEDdB}STDC_HEADERS\${SEDdC}1\${SEDdD} \${SEDuA}STDC_HEADERS\${SEDuB}STDC_HEADERS\${SEDuC}1\${SEDuD} \${SEDeA}STDC_HEADERS\${SEDeB}STDC_HEADERS\${SEDeC}1\${SEDeD} " } fi rm -f conftest* fi rm -f conftest* fi rm -f conftest* echo checking for complex.h cat > conftest.c < EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then { test -n "$verbose" && \ echo ' defining' HAVE_COMPLEX_H DEFS="$DEFS -DHAVE_COMPLEX_H=1" SEDDEFS="${SEDDEFS}\${SEDdA}HAVE_COMPLEX_H\${SEDdB}HAVE_COMPLEX_H\${SEDdC}1\${SEDdD} \${SEDuA}HAVE_COMPLEX_H\${SEDuB}HAVE_COMPLEX_H\${SEDuC}1\${SEDuD} \${SEDeA}HAVE_COMPLEX_H\${SEDeB}HAVE_COMPLEX_H\${SEDeC}1\${SEDeD} " } fi rm -f conftest* echo checking for malloc.h cat > conftest.c < EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then { test -n "$verbose" && \ echo ' defining' HAVE_MALLOC_H DEFS="$DEFS -DHAVE_MALLOC_H=1" SEDDEFS="${SEDDEFS}\${SEDdA}HAVE_MALLOC_H\${SEDdB}HAVE_MALLOC_H\${SEDdC}1\${SEDdD} \${SEDuA}HAVE_MALLOC_H\${SEDuB}HAVE_MALLOC_H\${SEDuC}1\${SEDuD} \${SEDeA}HAVE_MALLOC_H\${SEDeB}HAVE_MALLOC_H\${SEDeC}1\${SEDeD} " } fi rm -f conftest* echo checking for varargs.h cat > conftest.c < EOF err=`eval "($CPP \$DEFS conftest.c >/dev/null) 2>&1"` if test -z "$err"; then { test -n "$verbose" && \ echo ' defining' VARARGS DEFS="$DEFS -DVARARGS=1" SEDDEFS="${SEDDEFS}\${SEDdA}VARARGS\${SEDdB}VARARGS\${SEDdC}1\${SEDdD} \${SEDuA}VARARGS\${SEDuB}VARARGS\${SEDuC}1\${SEDuD} \${SEDeA}VARARGS\${SEDeB}VARARGS\${SEDeC}1\${SEDeD} " } fi rm -f conftest* { test -n "$verbose" && \ echo ' defining' NOT_SEGMENTED DEFS="$DEFS -DNOT_SEGMENTED=1" SEDDEFS="${SEDDEFS}\${SEDdA}NOT_SEGMENTED\${SEDdB}NOT_SEGMENTED\${SEDdC}1\${SEDdD} \${SEDuA}NOT_SEGMENTED\${SEDuB}NOT_SEGMENTED\${SEDuC}1\${SEDuD} \${SEDeA}NOT_SEGMENTED\${SEDeB}NOT_SEGMENTED\${SEDeC}1\${SEDeD} " } echo checking for size_t in sys/types.h echo '#include ' > conftest.c eval "$CPP \$DEFS conftest.c > conftest.out 2>&1" if egrep "size_t" conftest.out >/dev/null 2>&1; then : else { test -n "$verbose" && \ echo ' defining' size_t to be 'unsigned' DEFS="$DEFS -Dsize_t=unsigned" SEDDEFS="${SEDDEFS}\${SEDdA}size_t\${SEDdB}size_t\${SEDdC}unsigned\${SEDdD} \${SEDuA}size_t\${SEDuB}size_t\${SEDuC}unsigned\${SEDuD} \${SEDeA}size_t\${SEDeB}size_t\${SEDeC}unsigned\${SEDeD} " } fi rm -f conftest* prog='/* Ultrix mips cc rejects this. */ typedef int charset[2]; const charset x; /* SunOS 4.1.1 cc rejects this. */ char const *const *ccp; char **p; /* AIX XL C 1.02.0.0 rejects this. It does not let you subtract one const X* pointer from another in an arm of an if-expression whose if-part is not a constant expression */ const char *g = "string"; p = &g + (g ? g-g : 0); /* HPUX 7.0 cc rejects these. */ ++ccp; p = (char**) ccp; ccp = (char const *const *) p; { /* SCO 3.2v4 cc rejects this. */ char *t; char const *s = 0 ? (char *) 0 : (char const *) 0; *t++ = 0; } { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ int x[] = {25,17}; const int *foo = &x[0]; ++foo; } { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ typedef const int *iptr; iptr p = 0; ++p; } { /* AIX XL C 1.02.0.0 rejects this saying "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ struct s { int j; const int *ap[3]; }; struct s *b; b->j = 5; }' echo checking for working const cat > conftest.c < conftest.c </dev/null; then : else { test -n "$verbose" && \ echo ' defining' WORDS_BIGENDIAN DEFS="$DEFS -DWORDS_BIGENDIAN=1" SEDDEFS="${SEDDEFS}\${SEDdA}WORDS_BIGENDIAN\${SEDdB}WORDS_BIGENDIAN\${SEDdC}1\${SEDdD} \${SEDuA}WORDS_BIGENDIAN\${SEDuB}WORDS_BIGENDIAN\${SEDuC}1\${SEDuD} \${SEDeA}WORDS_BIGENDIAN\${SEDeB}WORDS_BIGENDIAN\${SEDeC}1\${SEDeD} " } fi rm -f conftest* # check whether --with-complex was given if test -n "$with_complex"; then { test -n "$verbose" && \ echo ' defining' COMPLEX DEFS="$DEFS -DCOMPLEX=1" SEDDEFS="${SEDDEFS}\${SEDdA}COMPLEX\${SEDdB}COMPLEX\${SEDdC}1\${SEDdD} \${SEDuA}COMPLEX\${SEDuB}COMPLEX\${SEDuC}1\${SEDuD} \${SEDeA}COMPLEX\${SEDeB}COMPLEX\${SEDeC}1\${SEDeD} " } fi # check whether --with-sparse was given if test -n "$with_sparse"; then { test -n "$verbose" && \ echo ' defining' SPARSE DEFS="$DEFS -DSPARSE=1" SEDDEFS="${SEDDEFS}\${SEDdA}SPARSE\${SEDdB}SPARSE\${SEDdC}1\${SEDdD} \${SEDuA}SPARSE\${SEDuB}SPARSE\${SEDuC}1\${SEDuD} \${SEDeA}SPARSE\${SEDeB}SPARSE\${SEDeC}1\${SEDeD} " } fi # check whether --with-all was given if test -n "$with_all"; then { test -n "$verbose" && \ echo ' defining' COMPLEX DEFS="$DEFS -DCOMPLEX=1" SEDDEFS="${SEDDEFS}\${SEDdA}COMPLEX\${SEDdB}COMPLEX\${SEDdC}1\${SEDdD} \${SEDuA}COMPLEX\${SEDuB}COMPLEX\${SEDuC}1\${SEDuD} \${SEDeA}COMPLEX\${SEDeB}COMPLEX\${SEDeC}1\${SEDeD} " } fi # check whether --with-all was given if test -n "$with_all"; then { test -n "$verbose" && \ echo ' defining' SPARSE DEFS="$DEFS -DSPARSE=1" SEDDEFS="${SEDDEFS}\${SEDdA}SPARSE\${SEDdB}SPARSE\${SEDdC}1\${SEDdD} \${SEDuA}SPARSE\${SEDuB}SPARSE\${SEDuC}1\${SEDuD} \${SEDeA}SPARSE\${SEDeB}SPARSE\${SEDeC}1\${SEDeD} " } fi # check whether --with-unroll was given if test -n "$with_unroll"; then { test -n "$verbose" && \ echo ' defining' VUNROLL DEFS="$DEFS -DVUNROLL=1" SEDDEFS="${SEDDEFS}\${SEDdA}VUNROLL\${SEDdB}VUNROLL\${SEDdC}1\${SEDdD} \${SEDuA}VUNROLL\${SEDuB}VUNROLL\${SEDuC}1\${SEDuD} \${SEDeA}VUNROLL\${SEDeB}VUNROLL\${SEDeC}1\${SEDeD} " } fi # check whether --with-munroll was given if test -n "$with_munroll"; then { test -n "$verbose" && \ echo ' defining' MUNROLL DEFS="$DEFS -DMUNROLL=1" SEDDEFS="${SEDDEFS}\${SEDdA}MUNROLL\${SEDdB}MUNROLL\${SEDdC}1\${SEDdD} \${SEDuA}MUNROLL\${SEDuB}MUNROLL\${SEDuC}1\${SEDuD} \${SEDeA}MUNROLL\${SEDeB}MUNROLL\${SEDeC}1\${SEDeD} " } fi # check whether --with-segmem was given if test -n "$with_segmem"; then { test -n "$verbose" && \ echo ' defining' SEGMENTED DEFS="$DEFS -DSEGMENTED=1" SEDDEFS="${SEDDEFS}\${SEDdA}SEGMENTED\${SEDdB}SEGMENTED\${SEDdC}1\${SEDdD} \${SEDuA}SEGMENTED\${SEDuB}SEGMENTED\${SEDuC}1\${SEDuD} \${SEDeA}SEGMENTED\${SEDeB}SEGMENTED\${SEDeC}1\${SEDeD} " } fi # check whether --with-float was given if test -n "$with_float"; then { test -n "$verbose" && \ echo ' defining' REAL_FLT DEFS="$DEFS -DREAL_FLT=1" SEDDEFS="${SEDDEFS}\${SEDdA}REAL_FLT\${SEDdB}REAL_FLT\${SEDdC}1\${SEDdD} \${SEDuA}REAL_FLT\${SEDuB}REAL_FLT\${SEDuC}1\${SEDuD} \${SEDeA}REAL_FLT\${SEDeB}REAL_FLT\${SEDeC}1\${SEDeD} " } fi # check whether --with-double was given if test -n "$with_double"; then { test -n "$verbose" && \ echo ' defining' REAL_DBL DEFS="$DEFS -DREAL_DBL=1" SEDDEFS="${SEDDEFS}\${SEDdA}REAL_DBL\${SEDdB}REAL_DBL\${SEDdC}1\${SEDdD} \${SEDuA}REAL_DBL\${SEDuB}REAL_DBL\${SEDuC}1\${SEDuD} \${SEDeA}REAL_DBL\${SEDeB}REAL_DBL\${SEDeC}1\${SEDeD} " } fi LIBS="$LIBS -lm" echo checking for u_int cat > conftest.c < #ifdef __STDC__ #include #endif int main() { exit(0); } int t() { u_int i; i = 1; } EOF if eval $compile; then { test -n "$verbose" && \ echo ' defining' U_INT_DEF DEFS="$DEFS -DU_INT_DEF=1" SEDDEFS="${SEDDEFS}\${SEDdA}U_INT_DEF\${SEDdB}U_INT_DEF\${SEDdC}1\${SEDdD} \${SEDuA}U_INT_DEF\${SEDuB}U_INT_DEF\${SEDuC}1\${SEDuD} \${SEDeA}U_INT_DEF\${SEDeB}U_INT_DEF\${SEDeC}1\${SEDeD} " } fi rm -f conftest* echo 'computing machine epsilon(s)' echo $CC -o macheps dmacheps.c $CC -o macheps dmacheps.c { test -n "$verbose" && \ echo ' defining' D_MACHEPS to be '`macheps`' DEFS="$DEFS -DD_MACHEPS=`macheps`" SEDDEFS="${SEDDEFS}\${SEDdA}D_MACHEPS\${SEDdB}D_MACHEPS\${SEDdC}`macheps`\${SEDdD} \${SEDuA}D_MACHEPS\${SEDuB}D_MACHEPS\${SEDuC}`macheps`\${SEDuD} \${SEDeA}D_MACHEPS\${SEDeB}D_MACHEPS\${SEDeC}`macheps`\${SEDeD} " } echo $CC -o macheps fmacheps.c $CC -o macheps fmacheps.c { test -n "$verbose" && \ echo ' defining' F_MACHEPS to be '`macheps`' DEFS="$DEFS -DF_MACHEPS=`macheps`" SEDDEFS="${SEDDEFS}\${SEDdA}F_MACHEPS\${SEDdB}F_MACHEPS\${SEDdC}`macheps`\${SEDdD} \${SEDuA}F_MACHEPS\${SEDuB}F_MACHEPS\${SEDuC}`macheps`\${SEDuD} \${SEDeA}F_MACHEPS\${SEDeB}F_MACHEPS\${SEDeC}`macheps`\${SEDeD} " } echo computing M_MAX_INT echo $CC -o maxint maxint.c $CC -o maxint maxint.c { test -n "$verbose" && \ echo ' defining' M_MAX_INT to be '`maxint`' DEFS="$DEFS -DM_MAX_INT=`maxint`" SEDDEFS="${SEDDEFS}\${SEDdA}M_MAX_INT\${SEDdB}M_MAX_INT\${SEDdC}`maxint`\${SEDdD} \${SEDuA}M_MAX_INT\${SEDuB}M_MAX_INT\${SEDuC}`maxint`\${SEDuD} \${SEDeA}M_MAX_INT\${SEDeB}M_MAX_INT\${SEDeC}`maxint`\${SEDeD} " } echo checking char '\\0' vs. float zeros cat > conftest.c < conftest.out 2>&1" if egrep "yes" conftest.out >/dev/null 2>&1; then { test -n "$verbose" && \ echo ' defining' CHAR0ISDBL0 DEFS="$DEFS -DCHAR0ISDBL0=1" SEDDEFS="${SEDDEFS}\${SEDdA}CHAR0ISDBL0\${SEDdB}CHAR0ISDBL0\${SEDdC}1\${SEDdD} \${SEDuA}CHAR0ISDBL0\${SEDuB}CHAR0ISDBL0\${SEDuC}1\${SEDuD} \${SEDeA}CHAR0ISDBL0\${SEDeB}CHAR0ISDBL0\${SEDeC}1\${SEDeD} " } fi rm -f conftest* for func in bcopy bzero do trfunc=HAVE_`echo $func | tr '[a-z]' '[A-Z]'` echo checking for ${func} cat > conftest.c < int main() { exit(0); } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_${func}) || defined (__stub___${func}) choke me #else /* Override any gcc2 internal prototype to avoid an error. */ extern char ${func}(); ${func}(); #endif } EOF if eval $compile; then { test -n "$verbose" && \ echo ' defining' ${trfunc} DEFS="$DEFS -D${trfunc}=1" SEDDEFS="${SEDDEFS}\${SEDdA}${trfunc}\${SEDdB}${trfunc}\${SEDdC}1\${SEDdD} \${SEDuA}${trfunc}\${SEDuB}${trfunc}\${SEDuC}1\${SEDuD} \${SEDeA}${trfunc}\${SEDeB}${trfunc}\${SEDeC}1\${SEDeD} " } fi rm -f conftest* done echo checking for function prototypes cat > conftest.c < config.status </dev/null | sed 1q`: # # $0 $* for arg do case "\$arg" in -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) exec /bin/sh $0 $* ;; *) echo "Usage: config.status --recheck" 2>&1; exit 1 ;; esac done trap 'rm -f makefile machine.h conftest*; exit 1' 1 3 15 PROGS='$PROGS' CC='$CC' CPP='$CPP' RANLIB='$RANLIB' LIBS='$LIBS' srcdir='$srcdir' prefix='$prefix' exec_prefix='$exec_prefix' prsub='$prsub' EOF cat >> config.status <<\EOF top_srcdir=$srcdir # Allow make-time overrides of the generated file list. test -n "$gen_files" || gen_files="makefile" for file in .. $gen_files; do if [ "x$file" != "x.." ]; then srcdir=$top_srcdir # Remove last slash and all that follows it. Not all systems have dirname. dir=`echo $file|sed 's%/[^/][^/]*$%%'` if test "$dir" != "$file"; then test "$top_srcdir" != . && srcdir=$top_srcdir/$dir test ! -d $dir && mkdir $dir fi echo creating $file rm -f $file echo "# Generated automatically from `echo $file|sed 's|.*/||'`.in by configure." > $file sed -e " $prsub s%@PROGS@%$PROGS%g s%@CC@%$CC%g s%@CPP@%$CPP%g s%@RANLIB@%$RANLIB%g s%@LIBS@%$LIBS%g s%@srcdir@%$srcdir%g s%@DEFS@%-DHAVE_CONFIG_H%" $top_srcdir/${file}.in >> $file fi; done test -n "$gen_config" || gen_config=machine.h echo creating $gen_config # These sed commands are put into SEDDEFS when defining a macro. # They are broken into pieces to make the sed script easier to manage. # They are passed to sed as "A NAME B NAME C VALUE D", where NAME # is the cpp macro being defined and VALUE is the value it is being given. # Each defining turns into a single global substitution command. # # SEDd sets the value in "#define NAME VALUE" lines. SEDdA='s@^\([ ]*\)#\([ ]*define[ ][ ]*\)' SEDdB='\([ ][ ]*\)[^ ]*@\1#\2' SEDdC='\3' SEDdD='@g' # SEDu turns "#undef NAME" with trailing blanks into "#define NAME VALUE". SEDuA='s@^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' SEDuB='\([ ]\)@\1#\2define\3' SEDuC=' ' SEDuD='\4@g' # SEDe turns "#undef NAME" without trailing blanks into "#define NAME VALUE". SEDeA='s@^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' SEDeB='$@\1#\2define\3' SEDeC=' ' SEDeD='@g' rm -f conftest.sed EOF # Turn off quoting long enough to insert the sed commands. rm -f conftest.sh cat > conftest.sh < conftest.s1 # Like head -20. sed 1,${maxshlines}d conftest.sh > conftest.s2 # Like tail +21. # Write a limited-size here document to append to conftest.sed. echo 'cat >> conftest.sed <> config.status cat conftest.s1 >> config.status echo 'CONFEOF' >> config.status rm -f conftest.s1 conftest.sh mv conftest.s2 conftest.sh done rm -f conftest.sh # Now back to your regularly scheduled config.status. cat >> config.status <<\EOF # This sed command replaces #undef's with comments. This is necessary, for # example, in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it in # machine.h. cat >> conftest.sed <<\CONFEOF s,^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*,/* & */, CONFEOF rm -f conftest.h # Break up the sed commands because old seds have small limits. maxsedlines=20 cp $top_srcdir/$gen_config.in conftest.h1 while : do lines=`grep -c . conftest.sed` if test -z "$lines" || test "$lines" -eq 0; then break; fi rm -f conftest.s1 conftest.s2 conftest.h2 sed ${maxsedlines}q conftest.sed > conftest.s1 # Like head -20. sed 1,${maxsedlines}d conftest.sed > conftest.s2 # Like tail +21. sed -f conftest.s1 < conftest.h1 > conftest.h2 rm -f conftest.s1 conftest.h1 conftest.sed mv conftest.h2 conftest.h1 mv conftest.s2 conftest.sed done rm -f conftest.sed conftest.h echo "/* $gen_config. Generated automatically by configure. */" > conftest.h cat conftest.h1 >> conftest.h rm -f conftest.h1 if cmp -s $gen_config conftest.h 2>/dev/null; then # The file exists and we would not be changing it. rm -f conftest.h else rm -f $gen_config mv conftest.h $gen_config fi exit 0 EOF chmod +x config.status test -n "$no_create" || ./config.status echo "Extensions to basic version: use configure --with-opt1 --with-opt2" echo " Option:" echo " --with-complex incorporate complex functions" echo " --with-sparse incorporate sparse matrix functions" echo " --with-all both of the above" echo " --with-unroll unroll low level loops on vectors" echo " --with-munroll unroll low level loops on matrices" echo " --with-float single precision" echo " --with-double double precision (default)" echo "Re-run configure with these options if you want them" # configure.in copyright (C) Brook Milligan and David Stewart, 1993 meschach-1.2b/configure.in100644 764 764 6720 5537010054 15163 0ustar lapeyrelapeyrednl Meschach autoconf script dnl Copyright (C) Brook Milligan and David Stewart, 1993 dnl $Id: configure.in,v 1.3 1994/03/08 05:41:32 des Exp $ dnl dnl Brook Milligan's prototype check dnl Check if $(CC) supports prototypes define(LOCAL_HAVE_PROTOTYPES, [AC_COMPILE_CHECK([function prototypes], , [extern int test (int i, double x);], AC_DEFINE(HAVE_PROTOTYPES))])dnl dnl dnl Brook Milligan's compiler check dnl Check for the sun ansi c compiler, acc define(LOCAL_PROG_ACC, [AC_BEFORE([$0], [AC_PROG_CPP])AC_PROVIDE([$0])dnl AC_PROGRAM_CHECK(CC, acc, acc, "")])dnl dnl David Stewart's modified compiler check define(LOCAL_PROG_CC, [AC_BEFORE([$0], [AC_PROG_CPP])AC_PROVIDE([$0])dnl AC_PROGRAM_CHECK(CC, acc, acc, cc)])dnl dnl dnl dnl dnl ---------------------------------------------------------------------- dnl Start of configure.in proper dnl ---------------------------------------------------------------------- AC_INIT(err.c) AC_CONFIG_HEADER(machine.h) PROGS="" AC_SUBST(PROGS)dnl LOCAL_PROG_ACC AC_PROGRAM_CHECK(CC, cc, cc, gcc) dnl AC_PROG_CC AC_PROG_CPP AC_AIX AC_MINIX AC_ISC_POSIX dnl dnl Brook Milligan's prototype check dnl Check if $(CC) supports prototypes in function declarations and structures define(LOCAL_HAVE_PROTOTYPES, [AC_COMPILE_CHECK([function prototypes], , [extern int test (int i, double x);], AC_DEFINE(HAVE_PROTOTYPES)) AC_COMPILE_CHECK([function prototypes in structures], , [struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);};], AC_DEFINE(HAVE_PROTOTYPES_IN_STRUCT))])dnl dnl AC_PROG_RANLIB AC_HAVE_HEADERS(memory.h) AC_STDC_HEADERS AC_HEADER_CHECK(complex.h, AC_DEFINE(HAVE_COMPLEX_H),) AC_HEADER_CHECK(malloc.h, AC_DEFINE(HAVE_MALLOC_H),) AC_HEADER_CHECK(varargs.h, AC_DEFINE(VARARGS),) AC_DEFINE(NOT_SEGMENTED) AC_SIZE_T AC_CONST AC_WORDS_BIGENDIAN AC_WITH(complex, AC_DEFINE(COMPLEX)) AC_WITH(sparse, AC_DEFINE(SPARSE)) AC_WITH(all, AC_DEFINE(COMPLEX)) AC_WITH(all, AC_DEFINE(SPARSE)) AC_WITH(unroll, AC_DEFINE(VUNROLL)) AC_WITH(munroll, AC_DEFINE(MUNROLL)) AC_WITH(segmem, AC_DEFINE(SEGMENTED)) AC_WITH(float, AC_DEFINE(REAL_FLT)) AC_WITH(double, AC_DEFINE(REAL_DBL)) LIBS="$LIBS -lm" AC_COMPILE_CHECK([u_int],[#include #ifdef __STDC__ #include #endif],[u_int i; i = 1;],AC_DEFINE(U_INT_DEF)) echo 'computing machine epsilon(s)' echo $CC -o macheps dmacheps.c $CC -o macheps dmacheps.c AC_DEFINE_UNQUOTED(D_MACHEPS,`macheps`) echo $CC -o macheps fmacheps.c $CC -o macheps fmacheps.c AC_DEFINE_UNQUOTED(F_MACHEPS,`macheps`) echo computing M_MAX_INT echo $CC -o maxint maxint.c $CC -o maxint maxint.c AC_DEFINE_UNQUOTED(M_MAX_INT,`maxint`) echo checking char '\\0' vs. float zeros AC_PROGRAM_EGREP(yes,[main() { char *cp = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; double *dp; dp = (double *)cp; if ( *dp == 0.0 ) printf("yes\n"); } ],AC_DEFINE(CHAR0ISDBL0)) AC_HAVE_FUNCS(bcopy bzero) LOCAL_HAVE_PROTOTYPES AC_OUTPUT(makefile) echo "Extensions to basic version: use configure --with-opt1 --with-opt2" echo " Option:" echo " --with-complex incorporate complex functions" echo " --with-sparse incorporate sparse matrix functions" echo " --with-all both of the above" echo " --with-unroll unroll low level loops on vectors" echo " --with-munroll unroll low level loops on matrices" echo " --with-float single precision" echo " --with-double double precision (default)" echo "Re-run configure with these options if you want them" # configure.in copyright (C) Brook Milligan and David Stewart, 1993 meschach-1.2b/machine.h.in100644 764 764 10605 5735555705 15072 0ustar lapeyrelapeyre/* Any machine specific stuff goes here */ /* Add details necessary for your own installation here! */ /* RCS id: $Id: machine.h.in,v 1.3 1995/03/27 15:36:21 des Exp $ */ /* This is for use with "configure" -- if you are not using configure then use machine.van for the "vanilla" version of machine.h */ /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ #ifndef _MACHINE_H #define _MACHINE_H 1 #undef const #undef MALLOCDECL #undef NOT_SEGMENTED #undef HAVE_MEMORY_H #undef HAVE_COMPLEX_H #undef HAVE_MALLOC_H #undef STDC_HEADERS #undef HAVE_BCOPY #undef HAVE_BZERO #undef CHAR0ISDBL0 #undef WORDS_BIGENDIAN #undef U_INT_DEF #undef VARARGS #undef HAVE_PROTOTYPES #undef HAVE_PROTOTYPES_IN_STRUCT /* for inclusion into C++ files */ #ifdef __cplusplus #define ANSI_C 1 #ifndef HAVE_PROTOTYPES #define HAVE_PROTOTYPES 1 #endif #ifndef HAVE_PROTOTYPES_IN_STRUCT #define HAVE_PROTOTYPES_IN_STRUCT 1 #endif #endif /* __cplusplus */ /* example usage: VEC *PROTO(v_get,(int dim)); */ #ifdef HAVE_PROTOTYPES #define PROTO(name,args) name args #else #define PROTO(name,args) name() #endif /* HAVE_PROTOTYPES */ #ifdef HAVE_PROTOTYPES_IN_STRUCT /* PROTO_() is to be used instead of PROTO() in struct's and typedef's */ #define PROTO_(name,args) name args #else #define PROTO_(name,args) name() #endif /* HAVE_PROTOTYPES_IN_STRUCT */ /* for basic or larger versions */ #undef COMPLEX #undef SPARSE /* for loop unrolling */ #undef VUNROLL #undef MUNROLL /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 #undef REAL_FLT #undef REAL_DBL /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #undef F_MACHEPS #undef D_MACHEPS #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif #undef M_MACHEPS /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #undef M_MAX_INT #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #else #ifndef HUGE #define HUGE HUGE_VAL #endif #endif #ifdef ANSI_C extern int isatty(int); #endif #endif meschach-1.2b/copyright100644 764 764 2144 5515161030 14576 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ meschach-1.2b/tutorial.c100644 764 764 17127 5566571645 14730 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* tutorial.c 10/12/1993 */ /* routines from Chapter 1 of Meschach */ static char rcsid[] = "$Id: tutorial.c,v 1.3 1994/01/16 22:53:09 des Exp $"; #include #include "matrix.h" /* rk4 -- 4th order Runge--Kutta method */ double rk4(f,t,x,h) double t, h; VEC *(*f)(), *x; { static VEC *v1=VNULL, *v2=VNULL, *v3=VNULL, *v4=VNULL; static VEC *temp=VNULL; /* do not work with NULL initial vector */ if ( x == VNULL ) error(E_NULL,"rk4"); /* ensure that v1, ..., v4, temp are of the correct size */ v1 = v_resize(v1,x->dim); v2 = v_resize(v2,x->dim); v3 = v_resize(v3,x->dim); v4 = v_resize(v4,x->dim); temp = v_resize(temp,x->dim); /* register workspace variables */ MEM_STAT_REG(v1,TYPE_VEC); MEM_STAT_REG(v2,TYPE_VEC); MEM_STAT_REG(v3,TYPE_VEC); MEM_STAT_REG(v4,TYPE_VEC); MEM_STAT_REG(temp,TYPE_VEC); /* end of memory allocation */ (*f)(t,x,v1); /* most compilers allow: "f(t,x,v1);" */ v_mltadd(x,v1,0.5*h,temp); /* temp = x+.5*h*v1 */ (*f)(t+0.5*h,temp,v2); v_mltadd(x,v2,0.5*h,temp); /* temp = x+.5*h*v2 */ (*f)(t+0.5*h,temp,v3); v_mltadd(x,v3,h,temp); /* temp = x+h*v3 */ (*f)(t+h,temp,v4); /* now add: v1+2*v2+2*v3+v4 */ v_copy(v1,temp); /* temp = v1 */ v_mltadd(temp,v2,2.0,temp); /* temp = v1+2*v2 */ v_mltadd(temp,v3,2.0,temp); /* temp = v1+2*v2+2*v3 */ v_add(temp,v4,temp); /* temp = v1+2*v2+2*v3+v4 */ /* adjust x */ v_mltadd(x,temp,h/6.0,x); /* x = x+(h/6)*temp */ return t+h; /* return the new time */ } /* rk4 -- 4th order Runge-Kutta method */ /* another variant */ double rk4_var(f,t,x,h) double t, h; VEC *(*f)(), *x; { static VEC *v1, *v2, *v3, *v4, *temp; /* do not work with NULL initial vector */ if ( x == VNULL ) error(E_NULL,"rk4"); /* ensure that v1, ..., v4, temp are of the correct size */ v_resize_vars(x->dim, &v1, &v2, &v3, &v4, &temp, NULL); /* register workspace variables */ mem_stat_reg_vars(0, TYPE_VEC, &v1, &v2, &v3, &v4, &temp, NULL); /* end of memory allocation */ (*f)(t,x,v1); v_mltadd(x,v1,0.5*h,temp); (*f)(t+0.5*h,temp,v2); v_mltadd(x,v2,0.5*h,temp); (*f)(t+0.5*h,temp,v3); v_mltadd(x,v3,h,temp); (*f)(t+h,temp,v4); /* now add: temp = v1+2*v2+2*v3+v4 */ v_linlist(temp, v1, 1.0, v2, 2.0, v3, 2.0, v4, 1.0, VNULL); /* adjust x */ v_mltadd(x,temp,h/6.0,x); /* x = x+(h/6)*temp */ return t+h; /* return the new time */ } /* f -- right-hand side of ODE solver */ VEC *f(t,x,out) VEC *x, *out; double t; { if ( x == VNULL || out == VNULL ) error(E_NULL,"f"); if ( x->dim != 2 || out->dim != 2 ) error(E_SIZES,"f"); out->ve[0] = x->ve[1]; out->ve[1] = - x->ve[0]; return out; } void tutor_rk4() { VEC *x; VEC *f(); double h, t, t_fin; double rk4(); input("Input initial time: ","%lf",&t); input("Input final time: ", "%lf",&t_fin); x = v_get(2); /* this is the size needed by f() */ prompter("Input initial state:\n"); x = v_input(VNULL); input("Input step size: ", "%lf",&h); printf("# At time %g, the state is\n",t); v_output(x); while (t < t_fin) { /* you can use t = rk4_var(f,t,x,min(h,t_fin-t)); */ t = rk4(f,t,x,min(h,t_fin-t)); /* new t is returned */ printf("# At time %g, the state is\n",t); v_output(x); } } #include "matrix2.h" void tutor_ls() { MAT *A, *QR; VEC *b, *x, *diag; /* read in A matrix */ printf("Input A matrix:\n"); A = m_input(MNULL); /* A has whatever size is input */ if ( A->m < A->n ) { printf("Need m >= n to obtain least squares fit\n"); exit(0); } printf("# A =\n"); m_output(A); diag = v_get(A->m); /* QR is to be the QR factorisation of A */ QR = m_copy(A,MNULL); QRfactor(QR,diag); /* read in b vector */ printf("Input b vector:\n"); b = v_get(A->m); b = v_input(b); printf("# b =\n"); v_output(b); /* solve for x */ x = QRsolve(QR,diag,b,VNULL); printf("Vector of best fit parameters is\n"); v_output(x); /* ... and work out norm of errors... */ printf("||A*x-b|| = %g\n", v_norm2(v_sub(mv_mlt(A,x,VNULL),b,VNULL))); } #include "iter.h" #define N 50 #define VEC2MAT(v,m) vm_move((v),0,(m),0,0,N,N); #define PI 3.141592653589793116 #define index(i,j) (N*((i)-1)+(j)-1) /* right hand side function (for generating b) */ double f1(x,y) double x,y; { /* return 2.0*PI*PI*sin(PI*x)*sin(PI*y); */ return exp(x*y); } /* discrete laplacian */ SPMAT *laplacian(A) SPMAT *A; { Real h; int i,j; if (!A) A = sp_get(N*N,N*N,5); for ( i = 1; i <= N; i++ ) for ( j = 1; j <= N; j++ ) { if ( i < N ) sp_set_val(A,index(i,j),index(i+1,j),-1.0); if ( i > 1 ) sp_set_val(A,index(i,j),index(i-1,j),-1.0); if ( j < N ) sp_set_val(A,index(i,j),index(i,j+1),-1.0); if ( j > 1 ) sp_set_val(A,index(i,j),index(i,j-1),-1.0); sp_set_val(A,index(i,j),index(i,j),4.0); } return A; } /* generating right hand side */ VEC *rhs_lap(b) VEC *b; { Real h,h2,x,y; int i,j; if (!b) b = v_get(N*N); h = 1.0/(N+1); /* for a unit square */ h2 = h*h; x = 0.0; for ( i = 1; i <= N; i++ ) { x += h; y = 0.0; for ( j = 1; j <= N; j++ ) { y += h; b->ve[index(i,j)] = h2*f1(x,y); } } return b; } void tut_lap() { SPMAT *A, *LLT; VEC *b, *out, *x; MAT *B; int num_steps; FILE *fp; A = sp_get(N*N,N*N,5); b = v_get(N*N); laplacian(A); LLT = sp_copy(A); spICHfactor(LLT); out = v_get(A->m); x = v_get(A->m); rhs_lap(b); /* new rhs */ iter_spcg(A,LLT,b,1e-6,out,1000,&num_steps); printf("Number of iterations = %d\n",num_steps); /* save b as a MATLAB matrix */ fp = fopen("laplace.mat","w"); /* b will be saved in laplace.mat */ if (fp == NULL) { printf("Cannot open %s\n","laplace.mat"); exit(1); } /* b must be transformed to a matrix */ B = m_get(N,N); VEC2MAT(out,B); m_save(fp,B,"sol"); /* sol is an internal name in MATLAB */ } void main() { int i; input("Choose the problem (1=Runge-Kutta, 2=least squares,3=laplace): ", "%d",&i); switch (i) { case 1: tutor_rk4(); break; case 2: tutor_ls(); break; case 3: tut_lap(); break; default: printf(" Wrong value of i (only 1, 2 or 3)\n\n"); break; } } meschach-1.2b/tutadv.c100644 764 764 10634 5566572220 14356 0ustar lapeyrelapeyre /* routines from the section 8 of tutorial.txt */ #include "matrix.h" #define M3D_LIST 3 /* list number */ #define TYPE_MAT3D 0 /* the number of a type */ /* type for 3 dimensional matrices */ typedef struct { int l,m,n; /* actual dimensions */ int max_l, max_m, max_n; /* maximal dimensions */ Real ***me; /* pointer to matrix elements */ /* we do not consider segmented memory */ Real *base, **me2d; /* me and me2d are additional pointers to base */ } MAT3D; /* function for creating a variable of MAT3D type */ MAT3D *m3d_get(l,m,n) int l,m,n; { MAT3D *mat; int i,j,k; /* check if arguments are positive */ if (l <= 0 || m <= 0 || n <= 0) error(E_NEG,"m3d_get"); /* new structure */ if ((mat = NEW(MAT3D)) == (MAT3D *)NULL) error(E_MEM,"m3d_get"); else if (mem_info_is_on()) { /* record how many bytes is allocated */ mem_bytes_list(TYPE_MAT3D,0,sizeof(MAT3D),M3D_LIST); /* record a new allocated variable */ mem_numvar_list(TYPE_MAT3D,1,M3D_LIST); } mat->l = mat->max_l = l; mat->m = mat->max_m = m; mat->n = mat->max_n = n; /* allocate memory for 3D array */ if ((mat->base = NEW_A(l*m*n,Real)) == (Real *)NULL) error(E_MEM,"m3d_get"); else if (mem_info_is_on()) mem_bytes_list(TYPE_MAT3D,0,l*m*n*sizeof(Real),M3D_LIST); /* allocate memory for 2D pointers */ if ((mat->me2d = NEW_A(l*m,Real *)) == (Real **)NULL) error(E_MEM,"m3d_get"); else if (mem_info_is_on()) mem_bytes_list(TYPE_MAT3D,0,l*m*sizeof(Real *),M3D_LIST); /* allocate memory for 1D pointers */ if ((mat->me = NEW_A(l,Real **)) == (Real ***)NULL) error(E_MEM,"m3d_get"); else if (mem_info_is_on()) mem_bytes_list(TYPE_MAT3D,0,l*sizeof(Real **),M3D_LIST); /* pointers to 2D matrices */ for (i=0,k=0; i < l; i++) for (j=0; j < m; j++) mat->me2d[k++] = &mat->base[(i*m+j)*n]; /* pointers to rows */ for (i=0; i < l; i++) mat->me[i] = &mat->me2d[i*m]; return mat; } /* deallocate a variable of type MAT3D */ int m3d_free(mat) MAT3D *mat; { /* do not try to deallocate the NULL pointer */ if (mat == (MAT3D *)NULL) return -1; /* first deallocate base */ if (mat->base != (Real *)NULL) { if (mem_info_is_on()) /* record how many bytes is deallocated */ mem_bytes_list(TYPE_MAT3D,mat->max_l*mat->max_m*mat->max_n*sizeof(Real), 0,M3D_LIST); free((char *)mat->base); } /* deallocate array of 2D pointers */ if (mat->me2d != (Real **)NULL) { if (mem_info_is_on()) /* record how many bytes is deallocated */ mem_bytes_list(TYPE_MAT3D,mat->max_l*mat->max_m*sizeof(Real *), 0,M3D_LIST); free((char *)mat->me2d); } /* deallocate array of 1D pointers */ if (mat->me != (Real ***)NULL) { if (mem_info_is_on()) /* record how many bytes is deallocated */ mem_bytes_list(TYPE_MAT3D,mat->max_l*sizeof(Real **),0,M3D_LIST); free((char *)mat->me); } /* deallocate MAT3D structure */ if (mem_info_is_on()) { mem_bytes_list(TYPE_MAT3D,sizeof(MAT3D),0,M3D_LIST); mem_numvar_list(TYPE_MAT3D,-1,M3D_LIST); } free((char *)mat); return 0; } /*=============================================*/ char *m3d_names[] = { "MAT3D" }; #define M3D_NUM (sizeof(m3d_names)/sizeof(*m3d_names)) int (*m3d_free_funcs[M3D_NUM])() = { m3d_free }; static MEM_ARRAY m3d_sum[M3D_NUM]; /* test routing for allocating/deallocating static variables */ void test_stat(k) int k; { static MAT3D *work; if (!work) { work = m3d_get(10,10,10); mem_stat_reg_list((void **)&work,TYPE_MAT3D,M3D_LIST); work->me[9][9][9] = -3.14; } if (k == 9) printf(" work[9][9][9] = %g\n",work->me[9][9][9]); } void main() { MAT3D *M; int i,j,k; mem_info_on(TRUE); /* can be the first command */ mem_attach_list(M3D_LIST,M3D_NUM,m3d_names,m3d_free_funcs,m3d_sum); M = m3d_get(3,4,5); mem_info_file(stdout,M3D_LIST); /* make use of M->me[i][j][k], where i,j,k are non-negative and i < 3, j < 4, k < 5 */ mem_stat_mark(1); for (i=0; i < 3; i++) for (j=0; j < 4; j++) for (k=0; k < 5; k++) { test_stat(i+j+k); M->me[i][j][k] = i+j+k; } mem_stat_free_list(1,M3D_LIST); mem_info_file(stdout,M3D_LIST); printf(" M[%d][%d][%d] = %g\n",2,3,4,M->me[2][3][4]); mem_stat_mark(2); test_stat(9); mem_stat_free_list(2,M3D_LIST); m3d_free(M); /* if M is not necessary */ mem_info_file(stdout,M3D_LIST); } meschach-1.2b/rk4.dat100644 764 764 215 5515160357 14025 0ustar lapeyrelapeyre# No. of a problem 1 # Initial time 0 # Final time 1 # Solution is x(t) = (cos(t),-sin(t)) # x(0) = Vector: dim: 2 1 0 # Step size 0.1 meschach-1.2b/ls.dat100644 764 764 615 5515160357 13747 0ustar lapeyrelapeyre# No. of a problem 2 # A = Matrix: 5 by 3 row 0: 3 -1 2 row 1: 2 -1 1.2 row 2: 2.5 1 -1.5 row 3: 3 1 1 row 4: -1 1 -2.2 # b = Vector: dim: 5 5 3 2 4 6 meschach-1.2b/makefile100644 764 764 13707 5745533467 14420 0ustar lapeyrelapeyre# Generated automatically from makefile.in by configure. # # Makefile for Meschach via autoconf # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: makefile.in,v 1.4 1994/03/14 01:24:06 des Exp $ # srcdir = . VPATH = . CC = acc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = ranlib CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12b TAR = tar SHAR = stree -u ZIP = zip -r -l FLIST = FILELIST ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HBASE = err.h meminfo.h machine.h matrix.h HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ sparse2.h zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) # Different configurations # the dependencies **between** the parts are for dmake all: part1 part2 part3 zpart1 zpart2 part2: part1 part3: part2 basic: part1 part2 sparse: part1 part2 part3 zpart2: zpart1 complex: part1 part2 zpart1 zpart2 $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1) $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2) $(RANLIB) meschach.a $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3) $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1) $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2) $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST) $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar list: /bin/rm -f $(FLIST) ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) MACHINES DOC \ > $(FLIST) # ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ # `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ # $(HLIST) $(OTHERS) MACHINES DOC \ # |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ # $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ # > $(FLIST) clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a realclean: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a /bin/rm -f torture sptort ztorture memtort itertort mfuntort iotort /bin/rm -f makefile machine.h config.status maxint macheps alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/FILELIST100644 764 764 15047 5745534364 14052 0ustar lapeyrelapeyre-rw-r--r-- 1 des 0 Apr 20 14:41 FILELIST -rw-r--r-- 1 des 18006 Apr 5 1994 README -rw-r--r-- 1 des 4844 Jan 12 1994 arnoldi.c -rw-r--r-- 1 des 14461 Dec 12 13:50 bdfactor.c -rw-r--r-- 1 des 8450 Dec 12 13:44 bkpfacto.c -rw-r--r-- 1 des 5022 Dec 12 13:45 chfactor.c -rwxr-xr-x 1 des 26888 Mar 7 1994 configure -rw-r--r-- 1 des 3536 Mar 7 1994 configure.in -rw-r--r-- 1 des 8250 Jan 12 1994 conjgrad.c -rw-r--r-- 1 des 5530 Jan 12 1994 copy.c -rw-r--r-- 1 des 1124 Jan 12 1994 copyright -rw-r--r-- 1 des 1402 Jan 12 1994 dmacheps.c -rw-r--r-- 1 des 9896 Jan 30 08:49 err.c -rw-r--r-- 1 des 5706 Jan 30 08:49 err.h -rw-r--r-- 1 des 10927 May 18 1994 extras.c -rw-r--r-- 1 des 3892 Dec 12 13:49 fft.c -rw-r--r-- 1 des 1400 Jan 12 1994 fmacheps.c -rw-r--r-- 1 des 3691 Mar 27 09:42 givens.c -rw-r--r-- 1 des 4063 Mar 27 09:45 hessen.c -rw-r--r-- 1 des 4735 Dec 12 13:47 hsehldr.c -rw-r--r-- 1 des 5889 Jan 12 1994 init.c -rw-r--r-- 1 des 3396 Jan 13 1994 iotort.c -rw-r--r-- 1 des 6911 Mar 7 1994 iter.h -rw-r--r-- 1 des 8822 Apr 7 11:32 iter0.c -rw-r--r-- 1 des 31057 Apr 7 11:34 iternsym.c -rw-r--r-- 1 des 14016 Apr 7 11:33 itersym.c -rw-r--r-- 1 des 16178 Dec 12 14:02 itertort.c -rw-r--r-- 1 des 9800 Jan 12 1994 ivecop.c -rw-r--r-- 1 des 7733 Jan 12 1994 lanczos.c -rw-r--r-- 1 des 397 Jan 12 1994 ls.dat -rw-r--r-- 1 des 6884 Apr 20 14:24 lufactor.c -rw-r--r-- 1 des 3669 Jan 24 1994 machine.c -rw-r--r-- 1 des 4672 Mar 27 09:40 machine.h -rw-r--r-- 1 des 4485 Mar 27 09:37 machine.h.in -rw-r--r-- 1 des 6087 Apr 20 14:34 makefile -rw-r--r-- 1 des 5898 Jun 22 1994 makefile.in -rw-r--r-- 1 des 5253 Feb 14 14:13 matlab.c -rw-r--r-- 1 des 3012 Jan 20 09:39 matlab.h -rw-r--r-- 1 des 12080 Mar 27 09:44 matop.c -rw-r--r-- 1 des 19232 Apr 15 1994 matrix.h -rw-r--r-- 1 des 8291 Jan 12 1994 matrix2.h -rw-r--r-- 1 des 13409 Jan 12 1994 matrixio.c -rw-r--r-- 1 des 1257 Jan 12 1994 maxint.c -rw-r--r-- 1 des 9155 Jan 12 1994 meminfo.c -rw-r--r-- 1 des 4148 Jan 12 1994 meminfo.h -rw-r--r-- 1 des 19918 Apr 4 1994 memory.c -rw-r--r-- 1 des 8644 Jan 12 1994 memstat.c -rw-r--r-- 1 des 17345 Jan 13 1994 memtort.c -rw-r--r-- 1 des 9213 Dec 12 13:50 mfunc.c -rw-r--r-- 1 des 4533 Jan 13 1994 mfuntort.c -rw-r--r-- 1 des 4187 Dec 12 13:49 norm.c -rw-r--r-- 1 des 3853 Jan 12 1994 oldnames.h -rw-r--r-- 1 des 4226 Jan 12 1994 otherio.c -rw-r--r-- 1 des 7497 Mar 23 1994 pxop.c -rw-r--r-- 1 des 13381 Dec 12 13:47 qrfactor.c -rw-r--r-- 1 des 141 Jan 12 1994 rk4.dat -rw-r--r-- 1 des 18439 Dec 12 13:45 schur.c -rw-r--r-- 1 des 6819 Dec 12 13:48 solve.c -rw-r--r-- 1 des 23765 Mar 7 1994 sparse.c -rw-r--r-- 1 des 6483 Jan 12 1994 sparse.h -rw-r--r-- 1 des 3160 Jan 12 1994 sparse2.h -rw-r--r-- 1 des 8225 Jan 12 1994 sparseio.c -rw-r--r-- 1 des 35564 Dec 12 13:52 spbkp.c -rw-r--r-- 1 des 15873 Dec 12 13:52 spchfctr.c -rw-r--r-- 1 des 10808 Dec 12 13:51 splufctr.c -rw-r--r-- 1 des 17667 Jan 12 1994 sprow.c -rw-r--r-- 1 des 7368 Dec 12 13:53 spswap.c -rw-r--r-- 1 des 11286 Feb 28 1994 sptort.c -rw-r--r-- 1 des 4533 Jan 12 1994 submat.c -rw-r--r-- 1 des 9917 Dec 12 13:46 svd.c -rw-r--r-- 1 des 6000 Mar 27 09:46 symmeig.c -rw-r--r-- 1 des 28116 Dec 12 14:01 torture.c -rw-r--r-- 1 des 4508 May 19 1994 tutadv.c -rw-r--r-- 1 des 7767 May 19 1994 tutorial.c -rw-r--r-- 1 des 3441 Dec 12 13:48 update.c -rw-r--r-- 1 des 13430 Mar 7 1994 vecop.c -rw-r--r-- 1 des 2562 Mar 23 1994 version.c -rw-r--r-- 1 des 5204 Jan 12 1994 zcopy.c -rw-r--r-- 1 des 4556 Apr 7 11:27 zfunc.c -rw-r--r-- 1 des 4893 Mar 27 09:47 zgivens.c -rw-r--r-- 1 des 3971 Mar 27 09:48 zhessen.c -rw-r--r-- 1 des 5532 Dec 12 13:59 zhsehldr.c -rw-r--r-- 1 des 6892 Dec 12 13:57 zlufctr.c -rw-r--r-- 1 des 4255 Dec 12 13:56 zmachine.c -rw-r--r-- 1 des 10649 Jan 12 1994 zmatio.c -rw-r--r-- 1 des 6152 Feb 14 14:13 zmatlab.c -rw-r--r-- 1 des 15306 Mar 27 09:49 zmatop.c -rw-r--r-- 1 des 8782 Mar 7 1994 zmatrix.h -rw-r--r-- 1 des 4151 Jan 12 1994 zmatrix2.h -rw-r--r-- 1 des 15277 Jun 22 1994 zmemory.c -rw-r--r-- 1 des 4624 Dec 12 13:57 znorm.c -rw-r--r-- 1 des 13780 Dec 12 13:57 zqrfctr.c -rw-r--r-- 1 des 11222 Apr 7 11:29 zschur.c -rw-r--r-- 1 des 7573 Dec 12 13:58 zsolve.c -rw-r--r-- 1 des 20049 Dec 12 14:01 ztorture.c -rw-r--r-- 1 des 11225 Mar 7 1994 zvecop.c DOC: total 62 -rw------- 1 des 17186 Jan 13 1994 fnindex.txt -rw------- 1 des 45980 Jan 13 1994 tutorial.txt MACHINES: total 6 drwxr-xr-x 2 des 512 Feb 7 09:37 Cray drwxr-xr-x 2 des 512 Mar 29 14:12 GCC drwxr-xr-x 2 des 512 Mar 29 14:12 Linux drwxr-xr-x 2 des 512 Mar 29 14:12 RS6000 drwxr-xr-x 2 des 512 Feb 7 09:37 SGI drwxr-xr-x 2 des 512 Mar 29 14:12 SPARC MACHINES/Cray: total 15 -rw------- 1 des 4645 Oct 27 11:18 machine.h -rw------- 1 des 6053 Oct 27 11:22 makefile -rw------- 1 des 1951 Oct 27 11:18 patch.1 -rw------- 1 des 687 Oct 27 11:18 patch.2 -rw------- 1 des 298 Oct 27 11:18 patch.3 MACHINES/GCC: total 10 -rw------- 1 des 3775 Jan 13 1994 machine.h -rw------- 1 des 5192 Mar 27 09:06 makefile MACHINES/Linux: total 10 -rw------- 1 des 3820 Mar 2 1994 machine.h -rw------- 1 des 5604 Mar 27 09:05 makefile MACHINES/RS6000: total 16 -rw------- 1 des 6129 Jan 24 1994 machine.c -rw------- 1 des 3502 Jan 13 1994 machine.h -rw------- 1 des 5663 Mar 27 09:06 makefile MACHINES/SGI: total 11 -rw------- 1 des 4635 Oct 27 08:31 machine.h -rw------- 1 des 5938 Oct 27 08:55 makefile MACHINES/SPARC: total 10 -rw------- 1 des 3524 Jan 13 1994 machine.h -rw------- 1 des 5195 Mar 27 09:05 makefile meschach-1.2b/torture.c100644 764 764 66724 5673126003 14557 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains a series of tests for the Meschach matrix library, parts 1 and 2 */ static char rcsid[] = "$Id: torture.c,v 1.6 1994/08/25 15:22:11 des Exp $"; #include #include "matrix2.h" #include #include "matlab.h" #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg); static char *test_err_list[] = { "unknown error", /* 0 */ "testing error messages", /* 1 */ "unexpected end-of-file" /* 2 */ }; #define MAX_TEST_ERR (sizeof(test_err_list)/sizeof(char *)) /* extern int malloc_chain_check(); */ /* #define MEMCHK() if ( malloc_chain_check(0) ) \ { printf("Error in malloc chain: \"%s\", line %d\n", \ __FILE__, __LINE__); exit(0); } */ #define MEMCHK() /* cmp_perm -- returns 1 if pi1 == pi2, 0 otherwise */ int cmp_perm(pi1, pi2) PERM *pi1, *pi2; { int i; if ( ! pi1 || ! pi2 ) error(E_NULL,"cmp_perm"); if ( pi1->size != pi2->size ) return 0; for ( i = 0; i < pi1->size; i++ ) if ( pi1->pe[i] != pi2->pe[i] ) return 0; return 1; } /* px_rand -- generates sort-of random permutation */ PERM *px_rand(pi) PERM *pi; { int i, j, k; if ( ! pi ) error(E_NULL,"px_rand"); for ( i = 0; i < 3*pi->size; i++ ) { j = (rand() >> 8) % pi->size; k = (rand() >> 8) % pi->size; px_transp(pi,j,k); } return pi; } #define SAVE_FILE "asx5213a.mat" #define MATLAB_NAME "alpha" char name[81] = MATLAB_NAME; int main(argc, argv) int argc; char *argv[]; { VEC *x = VNULL, *y = VNULL, *z = VNULL, *u = VNULL, *v = VNULL, *w = VNULL; VEC *diag = VNULL, *beta = VNULL; PERM *pi1 = PNULL, *pi2 = PNULL, *pi3 = PNULL, *pivot = PNULL, *blocks = PNULL; MAT *A = MNULL, *B = MNULL, *C = MNULL, *D = MNULL, *Q = MNULL, *U = MNULL; BAND *bA, *bB, *bC; Real cond_est, s1, s2, s3; int i, j, seed; FILE *fp; char *cp; mem_info_on(TRUE); setbuf(stdout,(char *)NULL); seed = 1111; if ( argc > 2 ) { printf("usage: %s [seed]\n",argv[0]); exit(0); } else if ( argc == 2 ) sscanf(argv[1], "%d", &seed); /* set seed for rand() */ smrand(seed); mem_stat_mark(1); /* print version information */ m_version(); printf("# grep \"^Error\" the output for a listing of errors\n"); printf("# Don't panic if you see \"Error\" appearing; \n"); printf("# Also check the reported size of error\n"); printf("# This program uses randomly generated problems and therefore\n"); printf("# may occasionally produce ill-conditioned problems\n"); printf("# Therefore check the size of the error compared with MACHEPS\n"); printf("# If the error is within 1000*MACHEPS then don't worry\n"); printf("# If you get an error of size 0.1 or larger there is \n"); printf("# probably a bug in the code or the compilation procedure\n\n"); printf("# seed = %d\n",seed); printf("# Check: MACHEPS = %g\n",MACHEPS); /* allocate, initialise, copy and resize operations */ /* VEC */ notice("vector initialise, copy & resize"); x = v_get(12); y = v_get(15); z = v_get(12); v_rand(x); v_rand(y); z = v_copy(x,z); if ( v_norm2(v_sub(x,z,z)) >= MACHEPS ) errmesg("VEC copy"); v_copy(x,y); x = v_resize(x,10); y = v_resize(y,10); if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("VEC copy/resize"); x = v_resize(x,15); y = v_resize(y,15); if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("VEC resize"); /* MAT */ notice("matrix initialise, copy & resize"); A = m_get(8,5); B = m_get(3,9); C = m_get(8,5); m_rand(A); m_rand(B); C = m_copy(A,C); if ( m_norm_inf(m_sub(A,C,C)) >= MACHEPS ) errmesg("MAT copy"); m_copy(A,B); A = m_resize(A,3,5); B = m_resize(B,3,5); if ( m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) errmesg("MAT copy/resize"); A = m_resize(A,10,10); B = m_resize(B,10,10); if ( m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) errmesg("MAT resize"); MEMCHK(); /* PERM */ notice("permutation initialise, inverting & permuting vectors"); pi1 = px_get(15); pi2 = px_get(12); px_rand(pi1); v_rand(x); px_vec(pi1,x,z); y = v_resize(y,x->dim); pxinv_vec(pi1,z,y); if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("PERMute vector"); pi2 = px_inv(pi1,pi2); pi3 = px_mlt(pi1,pi2,PNULL); for ( i = 0; i < pi3->size; i++ ) if ( pi3->pe[i] != i ) errmesg("PERM inverse/multiply"); /* testing catch() etc */ notice("error handling routines"); catch(E_NULL, catchall(v_add(VNULL,VNULL,VNULL); errmesg("tracecatch() failure"), printf("# tracecatch() caught error\n"); error(E_NULL,"main")); errmesg("catch() failure"), printf("# catch() caught E_NULL error\n")); /* testing attaching a new error list (error list 2) */ notice("attaching error lists"); printf("# IT IS NOT A REAL WARNING ... \n"); err_list_attach(2,MAX_TEST_ERR,test_err_list,TRUE); if (!err_is_list_attached(2)) errmesg("attaching the error list 2"); ev_err(__FILE__,1,__LINE__,"main",2); err_list_free(2); if (err_is_list_attached(2)) errmesg("detaching the error list 2"); /* testing inner products and v_mltadd() etc */ notice("inner products and linear combinations"); u = v_get(x->dim); v_rand(u); v_rand(x); v_resize(y,x->dim); v_rand(y); v_mltadd(y,x,-in_prod(x,y)/in_prod(x,x),z); if ( fabs(in_prod(x,z)) >= MACHEPS*x->dim ) errmesg("v_mltadd()/in_prod()"); s1 = -in_prod(x,y)/(v_norm2(x)*v_norm2(x)); sv_mlt(s1,x,u); v_add(y,u,u); if ( v_norm2(v_sub(u,z,u)) >= MACHEPS*x->dim ) errmesg("sv_mlt()/v_norm2()"); #ifdef ANSI_C v_linlist(u,x,s1,y,1.0,VNULL); if ( v_norm2(v_sub(u,z,u)) >= MACHEPS*x->dim ) errmesg("v_linlist()"); #endif #ifdef VARARGS v_linlist(u,x,s1,y,1.0,VNULL); if ( v_norm2(v_sub(u,z,u)) >= MACHEPS*x->dim ) errmesg("v_linlist()"); #endif MEMCHK(); /* vector norms */ notice("vector norms"); x = v_resize(x,12); v_rand(x); for ( i = 0; i < x->dim; i++ ) if ( v_entry(x,i) >= 0.5 ) v_set_val(x,i,1.0); else v_set_val(x,i,-1.0); s1 = v_norm1(x); s2 = v_norm2(x); s3 = v_norm_inf(x); if ( fabs(s1 - x->dim) >= MACHEPS*x->dim || fabs(s2 - sqrt((Real)(x->dim))) >= MACHEPS*x->dim || fabs(s3 - 1.0) >= MACHEPS ) errmesg("v_norm1/2/_inf()"); /* test matrix multiply etc */ notice("matrix multiply and invert"); A = m_resize(A,10,10); B = m_resize(B,10,10); m_rand(A); m_inverse(A,B); m_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,m_entry(C,i,i)-1.0); if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("m_inverse()/m_mlt()"); MEMCHK(); /* ... and transposes */ notice("transposes and transpose-multiplies"); m_transp(A,A); /* can do square matrices in situ */ mtrm_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,m_entry(C,i,i)-1.0); if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("m_transp()/mtrm_mlt()"); m_transp(A,A); m_transp(B,B); mmtr_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,m_entry(C,i,i)-1.0); if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("m_transp()/mmtr_mlt()"); sm_mlt(3.71,B,B); mmtr_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,m_entry(C,i,i)-3.71); if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("sm_mlt()/mmtr_mlt()"); m_transp(B,B); sm_mlt(1.0/3.71,B,B); MEMCHK(); /* ... and matrix-vector multiplies */ notice("matrix-vector multiplies"); x = v_resize(x,A->n); y = v_resize(y,A->m); z = v_resize(z,A->m); u = v_resize(u,A->n); v_rand(x); v_rand(y); mv_mlt(A,x,z); s1 = in_prod(y,z); vm_mlt(A,y,u); s2 = in_prod(u,x); if ( fabs(s1 - s2) >= (MACHEPS*x->dim)*x->dim ) errmesg("mv_mlt()/vm_mlt()"); mv_mlt(B,z,u); if ( v_norm2(v_sub(u,x,u)) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("mv_mlt()/m_inverse()"); MEMCHK(); /* get/set row/col */ notice("getting and setting rows and cols"); x = v_resize(x,A->n); y = v_resize(y,B->m); x = get_row(A,3,x); y = get_col(B,3,y); if ( fabs(in_prod(x,y) - 1.0) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("get_row()/get_col()"); sv_mlt(-1.0,x,x); sv_mlt(-1.0,y,y); set_row(A,3,x); set_col(B,3,y); m_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,m_entry(C,i,i)-1.0); if ( m_norm_inf(C) >= MACHEPS*m_norm_inf(A)*m_norm_inf(B)*5 ) errmesg("set_row()/set_col()"); MEMCHK(); /* matrix norms */ notice("matrix norms"); A = m_resize(A,11,15); m_rand(A); s1 = m_norm_inf(A); B = m_transp(A,B); s2 = m_norm1(B); if ( fabs(s1 - s2) >= MACHEPS*A->m ) errmesg("m_norm1()/m_norm_inf()"); C = mtrm_mlt(A,A,C); s1 = 0.0; for ( i = 0; i < C->m && i < C->n; i++ ) s1 += m_entry(C,i,i); if ( fabs(sqrt(s1) - m_norm_frob(A)) >= MACHEPS*A->m*A->n ) errmesg("m_norm_frob"); MEMCHK(); /* permuting rows and columns */ notice("permuting rows & cols"); A = m_resize(A,11,15); B = m_resize(B,11,15); pi1 = px_resize(pi1,A->m); px_rand(pi1); x = v_resize(x,A->n); y = mv_mlt(A,x,y); px_rows(pi1,A,B); px_vec(pi1,y,z); mv_mlt(B,x,u); if ( v_norm2(v_sub(z,u,u)) >= MACHEPS*A->m ) errmesg("px_rows()"); pi1 = px_resize(pi1,A->n); px_rand(pi1); px_cols(pi1,A,B); pxinv_vec(pi1,x,z); mv_mlt(B,z,u); if ( v_norm2(v_sub(y,u,u)) >= MACHEPS*A->n ) errmesg("px_cols()"); MEMCHK(); /* MATLAB save/load */ notice("MATLAB save/load"); A = m_resize(A,12,11); if ( (fp=fopen(SAVE_FILE,"w")) == (FILE *)NULL ) printf("Cannot perform MATLAB save/load test\n"); else { m_rand(A); m_save(fp, A, name); fclose(fp); if ( (fp=fopen(SAVE_FILE,"r")) == (FILE *)NULL ) printf("Cannot open save file \"%s\"\n",SAVE_FILE); else { M_FREE(B); B = m_load(fp,&cp); if ( strcmp(name,cp) || m_norm1(m_sub(A,B,B)) >= MACHEPS*A->m ) errmesg("mload()/m_save()"); } } MEMCHK(); /* Now, onto matrix factorisations */ A = m_resize(A,10,10); B = m_resize(B,A->m,A->n); m_copy(A,B); x = v_resize(x,A->n); y = v_resize(y,A->m); z = v_resize(z,A->n); u = v_resize(u,A->m); v_rand(x); mv_mlt(B,x,y); z = v_copy(x,z); notice("LU factor/solve"); pivot = px_get(A->m); LUfactor(A,pivot); tracecatch(LUsolve(A,pivot,y,x),"main"); tracecatch(cond_est = LUcondest(A,pivot),"main"); printf("# cond(A) approx= %g\n", cond_est); if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est) { errmesg("LUfactor()/LUsolve()"); printf("# LU solution error = %g [cf MACHEPS = %g]\n", v_norm2(v_sub(x,z,u)), MACHEPS); } v_copy(y,x); tracecatch(LUsolve(A,pivot,x,x),"main"); tracecatch(cond_est = LUcondest(A,pivot),"main"); if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est) { errmesg("LUfactor()/LUsolve()"); printf("# LU solution error = %g [cf MACHEPS = %g]\n", v_norm2(v_sub(x,z,u)), MACHEPS); } vm_mlt(B,z,y); v_copy(y,x); tracecatch(LUTsolve(A,pivot,x,x),"main"); if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est) { errmesg("LUfactor()/LUTsolve()"); printf("# LU solution error = %g [cf MACHEPS = %g]\n", v_norm2(v_sub(x,z,u)), MACHEPS); } MEMCHK(); /* QR factorisation */ m_copy(B,A); mv_mlt(B,z,y); notice("QR factor/solve:"); diag = v_get(A->m); beta = v_get(A->m); QRfactor(A,diag); QRsolve(A,diag,y,x); if ( v_norm2(v_sub(x,z,u)) >= MACHEPS*v_norm2(x)*cond_est ) { errmesg("QRfactor()/QRsolve()"); printf("# QR solution error = %g [cf MACHEPS = %g]\n", v_norm2(v_sub(x,z,u)), MACHEPS); } Q = m_get(A->m,A->m); makeQ(A,diag,Q); makeR(A,A); m_mlt(Q,A,C); m_sub(B,C,C); if ( m_norm1(C) >= MACHEPS*m_norm1(Q)*m_norm1(B) ) { errmesg("QRfactor()/makeQ()/makeR()"); printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", m_norm1(C), MACHEPS); } MEMCHK(); /* now try with a non-square matrix */ A = m_resize(A,15,7); m_rand(A); B = m_copy(A,B); diag = v_resize(diag,A->n); beta = v_resize(beta,A->n); x = v_resize(x,A->n); y = v_resize(y,A->m); v_rand(y); QRfactor(A,diag); x = QRsolve(A,diag,y,x); /* z is the residual vector */ mv_mlt(B,x,z); v_sub(z,y,z); /* check B^T.z = 0 */ vm_mlt(B,z,u); if ( v_norm2(u) >= MACHEPS*m_norm1(B)*v_norm2(y) ) { errmesg("QRfactor()/QRsolve()"); printf("# QR solution error = %g [cf MACHEPS = %g]\n", v_norm2(u), MACHEPS); } Q = m_resize(Q,A->m,A->m); makeQ(A,diag,Q); makeR(A,A); m_mlt(Q,A,C); m_sub(B,C,C); if ( m_norm1(C) >= MACHEPS*m_norm1(Q)*m_norm1(B) ) { errmesg("QRfactor()/makeQ()/makeR()"); printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", m_norm1(C), MACHEPS); } D = m_get(A->m,Q->m); mtrm_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q) ) { errmesg("QRfactor()/makeQ()/makeR()"); printf("# QR orthogonality error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } MEMCHK(); /* QRCP factorisation */ m_copy(B,A); notice("QR factor/solve with column pivoting"); pivot = px_resize(pivot,A->n); QRCPfactor(A,diag,pivot); z = v_resize(z,A->n); QRCPsolve(A,diag,pivot,y,z); /* pxinv_vec(pivot,z,x); */ /* now compute residual (z) vector */ mv_mlt(B,x,z); v_sub(z,y,z); /* check B^T.z = 0 */ vm_mlt(B,z,u); if ( v_norm2(u) >= MACHEPS*m_norm1(B)*v_norm2(y) ) { errmesg("QRCPfactor()/QRsolve()"); printf("# QR solution error = %g [cf MACHEPS = %g]\n", v_norm2(u), MACHEPS); } Q = m_resize(Q,A->m,A->m); makeQ(A,diag,Q); makeR(A,A); m_mlt(Q,A,C); M_FREE(D); D = m_get(B->m,B->n); px_cols(pivot,C,D); m_sub(B,D,D); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm1(B) ) { errmesg("QRCPfactor()/makeQ()/makeR()"); printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } MEMCHK(); /* Cholesky and LDL^T factorisation */ /* Use these for normal equations approach */ notice("Cholesky factor/solve"); mtrm_mlt(B,B,A); CHfactor(A); u = v_resize(u,B->n); vm_mlt(B,y,u); z = v_resize(z,B->n); CHsolve(A,u,z); v_sub(x,z,z); if ( v_norm2(z) >= MACHEPS*v_norm2(x)*100 ) { errmesg("CHfactor()/CHsolve()"); printf("# Cholesky solution error = %g [cf MACHEPS = %g]\n", v_norm2(z), MACHEPS); } /* modified Cholesky factorisation should be identical with Cholesky factorisation provided the matrix is "sufficiently positive definite */ mtrm_mlt(B,B,C); MCHfactor(C,MACHEPS); m_sub(A,C,C); if ( m_norm1(C) >= MACHEPS*m_norm1(A) ) { errmesg("MCHfactor()"); printf("# Modified Cholesky error = %g [cf MACHEPS = %g]\n", m_norm1(C), MACHEPS); } /* now test the LDL^T factorisation -- using a negative def. matrix */ mtrm_mlt(B,B,A); sm_mlt(-1.0,A,A); m_copy(A,C); LDLfactor(A); LDLsolve(A,u,z); w = v_get(A->m); mv_mlt(C,z,w); v_sub(w,u,w); if ( v_norm2(w) >= MACHEPS*v_norm2(u)*m_norm1(C) ) { errmesg("LDLfactor()/LDLsolve()"); printf("# LDL^T residual = %g [cf MACHEPS = %g]\n", v_norm2(w), MACHEPS); } v_add(x,z,z); if ( v_norm2(z) >= MACHEPS*v_norm2(x)*100 ) { errmesg("LDLfactor()/LDLsolve()"); printf("# LDL^T solution error = %g [cf MACHEPS = %g]\n", v_norm2(z), MACHEPS); } MEMCHK(); /* and now the Bunch-Kaufman-Parlett method */ /* set up D to be an indefinite diagonal matrix */ notice("Bunch-Kaufman-Parlett factor/solve"); D = m_resize(D,B->m,B->m); m_zero(D); w = v_resize(w,B->m); v_rand(w); for ( i = 0; i < w->dim; i++ ) if ( v_entry(w,i) >= 0.5 ) m_set_val(D,i,i,1.0); else m_set_val(D,i,i,-1.0); /* set A <- B^T.D.B */ C = m_resize(C,B->n,B->n); C = mtrm_mlt(B,D,C); A = m_mlt(C,B,A); C = m_resize(C,B->n,B->n); C = m_copy(A,C); /* ... and use BKPfactor() */ blocks = px_get(A->m); pivot = px_resize(pivot,A->m); x = v_resize(x,A->m); y = v_resize(y,A->m); z = v_resize(z,A->m); v_rand(x); mv_mlt(A,x,y); BKPfactor(A,pivot,blocks); printf("# BKP pivot =\n"); px_output(pivot); printf("# BKP blocks =\n"); px_output(blocks); BKPsolve(A,pivot,blocks,y,z); /* compute & check residual */ mv_mlt(C,z,w); v_sub(w,y,w); if ( v_norm2(w) >= MACHEPS*m_norm1(C)*v_norm2(z) ) { errmesg("BKPfactor()/BKPsolve()"); printf("# BKP residual size = %g [cf MACHEPS = %g]\n", v_norm2(w), MACHEPS); } /* check update routines */ /* check LDLupdate() first */ notice("update L.D.L^T routine"); A = mtrm_mlt(B,B,A); m_resize(C,A->m,A->n); C = m_copy(A,C); LDLfactor(A); s1 = 3.7; w = v_resize(w,A->m); v_rand(w); for ( i = 0; i < C->m; i++ ) for ( j = 0; j < C->n; j++ ) m_set_val(C,i,j,m_entry(C,i,j)+s1*v_entry(w,i)*v_entry(w,j)); LDLfactor(C); LDLupdate(A,w,s1); /* zero out strictly upper triangular parts of A and C */ for ( i = 0; i < A->m; i++ ) for ( j = i+1; j < A->n; j++ ) { m_set_val(A,i,j,0.0); m_set_val(C,i,j,0.0); } if ( m_norm1(m_sub(A,C,C)) >= sqrt(MACHEPS)*m_norm1(A) ) { errmesg("LDLupdate()"); printf("# LDL update matrix error = %g [cf MACHEPS = %g]\n", m_norm1(C), MACHEPS); } /* BAND MATRICES */ #define COL 40 #define UDIAG 5 #define LDIAG 2 smrand(101); bA = bd_get(LDIAG,UDIAG,COL); bB = bd_get(LDIAG,UDIAG,COL); bC = bd_get(LDIAG,UDIAG,COL); A = m_resize(A,COL,COL); B = m_resize(B,COL,COL); pivot = px_resize(pivot,COL); x = v_resize(x,COL); w = v_resize(w,COL); z = v_resize(z,COL); m_rand(A); /* generate band matrix */ mat2band(A,LDIAG,UDIAG,bA); band2mat(bA,A); /* now A is banded */ bB = bd_copy(bA,bB); v_rand(x); mv_mlt(A,x,w); /* test of bd_mv_mlt */ notice("bd_mv_mlt"); bd_mv_mlt(bA,x,z); v_sub(z,w,z); if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { errmesg("incorrect vector (bd_mv_mlt)"); printf(" ||exact vector. - computed vector.|| = %g [MACHEPS = %g]\n", v_norm2(z),MACHEPS); } z = v_copy(w,z); notice("band LU factorization"); bdLUfactor(bA,pivot); /* pivot will be changed */ bdLUsolve(bA,pivot,z,z); v_sub(x,z,z); if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { errmesg("incorrect solution (band LU factorization)"); printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", v_norm2(z),MACHEPS); } /* solve transpose system */ notice("band LU factorization for transpose system"); m_transp(A,B); mv_mlt(B,x,w); bd_copy(bB,bA); bd_transp(bA,bA); /* transposition in situ */ bd_transp(bA,bB); bd_transp(bB,bB); bdLUfactor(bB,pivot); bdLUsolve(bB,pivot,w,z); v_sub(x,z,z); if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { errmesg("incorrect solution (band transposed LU factorization)"); printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", v_norm2(z),MACHEPS); } /* Cholesky factorization */ notice("band Choleski LDL' factorization"); m_add(A,B,A); /* symmetric matrix */ for (i=0; i < COL; i++) /* positive definite */ A->me[i][i] += 2*LDIAG; mat2band(A,LDIAG,LDIAG,bA); band2mat(bA,A); /* corresponding matrix A */ v_rand(x); mv_mlt(A,x,w); z = v_copy(w,z); bdLDLfactor(bA); z = bdLDLsolve(bA,z,z); v_sub(x,z,z); if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { errmesg("incorrect solution (band LDL' factorization)"); printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", v_norm2(z),MACHEPS); } /* new bandwidths */ m_rand(A); bA = bd_resize(bA,UDIAG,LDIAG,COL); bB = bd_resize(bB,UDIAG,LDIAG,COL); mat2band(A,UDIAG,LDIAG,bA); band2mat(bA,A); bd_copy(bA,bB); mv_mlt(A,x,w); notice("band LU factorization (resized)"); bdLUfactor(bA,pivot); /* pivot will be changed */ bdLUsolve(bA,pivot,w,z); v_sub(x,z,z); if (v_norm2(z) > v_norm2(x)*sqrt(MACHEPS)) { errmesg("incorrect solution (band LU factorization)"); printf(" ||exact sol. - computed sol.|| = %g [MACHEPS = %g]\n", v_norm2(z),MACHEPS); } /* testing transposition */ notice("band matrix transposition"); m_zero(bA->mat); bd_copy(bB,bA); m_zero(bB->mat); bd_copy(bA,bB); bd_transp(bB,bB); bd_transp(bB,bB); m_zero(bC->mat); bd_copy(bB,bC); m_sub(bA->mat,bC->mat,bC->mat); if (m_norm_inf(bC->mat) > MACHEPS*bC->mat->n) { errmesg("band transposition"); printf(" difference ||A - (A')'|| = %g\n",m_norm_inf(bC->mat)); } bd_free(bA); bd_free(bB); bd_free(bC); MEMCHK(); /* now check QRupdate() routine */ notice("update QR routine"); B = m_resize(B,15,7); A = m_resize(A,B->m,B->n); m_copy(B,A); diag = v_resize(diag,A->n); beta = v_resize(beta,A->n); QRfactor(A,diag); Q = m_resize(Q,A->m,A->m); makeQ(A,diag,Q); makeR(A,A); m_resize(C,A->m,A->n); w = v_resize(w,A->m); v = v_resize(v,A->n); u = v_resize(u,A->m); v_rand(w); v_rand(v); vm_mlt(Q,w,u); QRupdate(Q,A,u,v); m_mlt(Q,A,C); for ( i = 0; i < B->m; i++ ) for ( j = 0; j < B->n; j++ ) m_set_val(B,i,j,m_entry(B,i,j)+v_entry(w,i)*v_entry(v,j)); m_sub(B,C,C); if ( m_norm1(C) >= MACHEPS*m_norm1(A)*m_norm1(Q)*2 ) { errmesg("QRupdate()"); printf("# Reconstruction error in QR update = %g [cf MACHEPS = %g]\n", m_norm1(C), MACHEPS); } m_resize(D,Q->m,Q->n); mtrm_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( m_norm1(D) >= 10*MACHEPS*m_norm1(Q)*m_norm_inf(Q) ) { errmesg("QRupdate()"); printf("# QR update orthogonality error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } /* Now check eigenvalue/SVD routines */ notice("eigenvalue and SVD routines"); A = m_resize(A,11,11); B = m_resize(B,A->m,A->n); C = m_resize(C,A->m,A->n); D = m_resize(D,A->m,A->n); Q = m_resize(Q,A->m,A->n); m_rand(A); /* A <- A + A^T for symmetric case */ m_add(A,m_transp(A,C),A); u = v_resize(u,A->m); u = symmeig(A,Q,u); m_zero(B); for ( i = 0; i < B->m; i++ ) m_set_val(B,i,i,v_entry(u,i)); m_mlt(Q,B,C); mmtr_mlt(C,Q,D); m_sub(A,D,D); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*v_norm_inf(u)*3 ) { errmesg("symmeig()"); printf("# Reconstruction error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } mtrm_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*3 ) { errmesg("symmeig()"); printf("# symmeig() orthogonality error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } MEMCHK(); /* now test (real) Schur decomposition */ /* m_copy(A,B); */ M_FREE(A); A = m_get(11,11); m_rand(A); B = m_copy(A,B); MEMCHK(); B = schur(B,Q); MEMCHK(); m_mlt(Q,B,C); mmtr_mlt(C,Q,D); MEMCHK(); m_sub(A,D,D); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*m_norm1(B)*5 ) { errmesg("schur()"); printf("# Schur reconstruction error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } /* orthogonality check */ mmtr_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*10 ) { errmesg("schur()"); printf("# Schur orthogonality error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } MEMCHK(); /* now test SVD */ A = m_resize(A,11,7); m_rand(A); U = m_get(A->n,A->n); Q = m_resize(Q,A->m,A->m); u = v_resize(u,max(A->m,A->n)); svd(A,Q,U,u); /* check reconstruction of A */ D = m_resize(D,A->m,A->n); C = m_resize(C,A->m,A->n); m_zero(D); for ( i = 0; i < min(A->m,A->n); i++ ) m_set_val(D,i,i,v_entry(u,i)); mtrm_mlt(Q,D,C); m_mlt(C,U,D); m_sub(A,D,D); if ( m_norm1(D) >= MACHEPS*m_norm1(U)*m_norm_inf(Q)*m_norm1(A) ) { errmesg("svd()"); printf("# SVD reconstruction error = %g [cf MACHEPS = %g]\n", m_norm1(D), MACHEPS); } /* check orthogonality of Q and U */ D = m_resize(D,Q->n,Q->n); mtrm_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( m_norm1(D) >= MACHEPS*m_norm1(Q)*m_norm_inf(Q)*5 ) { errmesg("svd()"); printf("# SVD orthognality error (Q) = %g [cf MACHEPS = %g\n", m_norm1(D), MACHEPS); } D = m_resize(D,U->n,U->n); mtrm_mlt(U,U,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( m_norm1(D) >= MACHEPS*m_norm1(U)*m_norm_inf(U)*5 ) { errmesg("svd()"); printf("# SVD orthognality error (U) = %g [cf MACHEPS = %g\n", m_norm1(D), MACHEPS); } for ( i = 0; i < u->dim; i++ ) if ( v_entry(u,i) < 0 || (i < u->dim-1 && v_entry(u,i+1) > v_entry(u,i)) ) break; if ( i < u->dim ) { errmesg("svd()"); printf("# SVD sorting error\n"); } /* test of long vectors */ notice("Long vectors"); x = v_resize(x,100000); y = v_resize(y,100000); z = v_resize(z,100000); v_rand(x); v_rand(y); v_mltadd(x,y,3.0,z); sv_mlt(1.0/3.0,z,z); v_mltadd(z,x,-1.0/3.0,z); v_sub(z,y,x); if (v_norm2(x) >= MACHEPS*(x->dim)) { errmesg("long vectors"); printf(" norm = %g\n",v_norm2(x)); } mem_stat_free(1); MEMCHK(); /************************************************** VEC *x, *y, *z, *u, *v, *w; VEC *diag, *beta; PERM *pi1, *pi2, *pi3, *pivot, *blocks; MAT *A, *B, *C, *D, *Q, *U; **************************************************/ V_FREE(x); V_FREE(y); V_FREE(z); V_FREE(u); V_FREE(v); V_FREE(w); V_FREE(diag); V_FREE(beta); PX_FREE(pi1); PX_FREE(pi2); PX_FREE(pi3); PX_FREE(pivot); PX_FREE(blocks); M_FREE(A); M_FREE(B); M_FREE(C); M_FREE(D); M_FREE(Q); M_FREE(U); MEMCHK(); printf("# Finished torture test\n"); mem_info(); return 0; } meschach-1.2b/sptort.c100644 764 764 26026 5534476273 14412 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains tests for the sparse matrix part of Meschach */ #include #include #include "matrix2.h" #include "sparse2.h" #include "iter.h" #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg); /* for iterative methods */ #if REAL == DOUBLE #define EPS 1e-7 #elif REAL == FLOAT #define EPS 1e-3 #endif int chk_col_access(A) SPMAT *A; { int i, j, nxt_idx, nxt_row, scan_cnt, total_cnt; SPROW *r; row_elt *e; if ( ! A ) error(E_NULL,"chk_col_access"); if ( ! A->flag_col ) return FALSE; /* scan down each column, counting the number of entries met */ scan_cnt = 0; for ( j = 0; j < A->n; j++ ) { i = -1; nxt_idx = A->start_idx[j]; nxt_row = A->start_row[j]; while ( nxt_row >= 0 && nxt_idx >= 0 && nxt_row > i ) { i = nxt_row; r = &(A->row[i]); e = &(r->elt[nxt_idx]); nxt_idx = e->nxt_idx; nxt_row = e->nxt_row; scan_cnt++; } } total_cnt = 0; for ( i = 0; i < A->m; i++ ) total_cnt += A->row[i].len; if ( total_cnt != scan_cnt ) return FALSE; else return TRUE; } void main(argc, argv) int argc; char *argv[]; { VEC *x, *y, *z, *u, *v; Real s1, s2; PERM *pivot; SPMAT *A, *B, *C; SPMAT *B1, *C1; SPROW *r; int i, j, k, deg, seed, m, m_old, n, n_old; mem_info_on(TRUE); setbuf(stdout, (char *)NULL); /* get seed if in argument list */ if ( argc == 1 ) seed = 1111; else if ( argc == 2 && sscanf(argv[1],"%d",&seed) == 1 ) ; else { printf("usage: %s [seed]\n", argv[0]); exit(0); } srand(seed); /* set up two random sparse matrices */ m = 120; n = 100; deg = 8; notice("allocating sparse matrices"); A = sp_get(m,n,deg); B = sp_get(m,n,deg); notice("setting and getting matrix entries"); for ( k = 0; k < m*deg; k++ ) { i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(A,i,j,rand()/((Real)MAX_RAND)); i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(B,i,j,rand()/((Real)MAX_RAND)); } for ( k = 0; k < 10; k++ ) { s1 = rand()/((Real)MAX_RAND); i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(A,i,j,s1); s2 = sp_get_val(A,i,j); if ( fabs(s1 - s2) >= MACHEPS ) break; } if ( k < 10 ) errmesg("sp_set_val()/sp_get_val()"); /* test copy routines */ notice("copy routines"); x = v_get(n); y = v_get(m); z = v_get(m); /* first copy routine */ C = sp_copy(A); for ( k = 0; k < 100; k++ ) { v_rand(x); sp_mv_mlt(A,x,y); sp_mv_mlt(C,x,z); if ( v_norm_inf(v_sub(y,z,z)) >= MACHEPS*deg*m ) break; } if ( k < 100 ) { errmesg("sp_copy()/sp_mv_mlt()"); printf("# Error in A.x (inf norm) = %g [cf MACHEPS = %g]\n", v_norm_inf(z), MACHEPS); } /* second copy routine -- note that A & B have different sparsity patterns */ mem_stat_mark(1); sp_copy2(A,B); mem_stat_free(1); for ( k = 0; k < 10; k++ ) { v_rand(x); sp_mv_mlt(A,x,y); sp_mv_mlt(B,x,z); if ( v_norm_inf(v_sub(y,z,z)) >= MACHEPS*deg*m ) break; } if ( k < 10 ) { errmesg("sp_copy2()/sp_mv_mlt()"); printf("# Error in A.x (inf norm) = %g [cf MACHEPS = %g]\n", v_norm_inf(z), MACHEPS); } /* now check compacting routine */ notice("compacting routine"); sp_compact(B,0.0); for ( k = 0; k < 10; k++ ) { v_rand(x); sp_mv_mlt(A,x,y); sp_mv_mlt(B,x,z); if ( v_norm_inf(v_sub(y,z,z)) >= MACHEPS*deg*m ) break; } if ( k < 10 ) { errmesg("sp_compact()"); printf("# Error in A.x (inf norm) = %g [cf MACHEPS = %g]\n", v_norm_inf(z), MACHEPS); } for ( i = 0; i < B->m; i++ ) { r = &(B->row[i]); for ( j = 0; j < r->len; j++ ) if ( r->elt[j].val == 0.0 ) break; } if ( i < B->m ) { errmesg("sp_compact()"); printf("# Zero entry in compacted matrix\n"); } /* check column access paths */ notice("resizing and access paths"); m_old = A->m-1; n_old = A->n-1; A = sp_resize(A,A->m+10,A->n+10); for ( k = 0 ; k < 20; k++ ) { i = m_old + ((rand() >> 8) % 10); j = n_old + ((rand() >> 8) % 10); s1 = rand()/((Real)MAX_RAND); sp_set_val(A,i,j,s1); if ( fabs(s1 - sp_get_val(A,i,j)) >= MACHEPS ) break; } if ( k < 20 ) errmesg("sp_resize()"); sp_col_access(A); if ( ! chk_col_access(A) ) { errmesg("sp_col_access()"); } sp_diag_access(A); for ( i = 0; i < A->m; i++ ) { r = &(A->row[i]); if ( r->diag != sprow_idx(r,i) ) break; } if ( i < A->m ) { errmesg("sp_diag_access()"); } /* test both sp_mv_mlt() and sp_vm_mlt() */ x = v_resize(x,B->n); y = v_resize(y,B->m); u = v_get(B->m); v = v_get(B->n); for ( k = 0; k < 10; k++ ) { v_rand(x); v_rand(y); sp_mv_mlt(B,x,u); sp_vm_mlt(B,y,v); if ( fabs(in_prod(x,v) - in_prod(y,u)) >= MACHEPS*v_norm2(x)*v_norm2(u)*5 ) break; } if ( k < 10 ) { errmesg("sp_mv_mlt()/sp_vm_mlt()"); printf("# Error in inner products = %g [cf MACHEPS = %g]\n", fabs(in_prod(x,v) - in_prod(y,u)), MACHEPS); } SP_FREE(A); SP_FREE(B); SP_FREE(C); /* now test Cholesky and LU factorise and solve */ notice("sparse Cholesky factorise/solve"); A = iter_gen_sym(120,8); B = sp_copy(A); spCHfactor(A); x = v_resize(x,A->m); y = v_resize(y,A->m); v_rand(x); sp_mv_mlt(B,x,y); z = v_resize(z,A->m); spCHsolve(A,y,z); v = v_resize(v,A->m); sp_mv_mlt(B,z,v); /* compute residual */ v_sub(y,v,v); if ( v_norm2(v) >= MACHEPS*v_norm2(y)*10 ) { errmesg("spCHfactor()/spCHsolve()"); printf("# Sparse Cholesky residual = %g [cf MACHEPS = %g]\n", v_norm2(v), MACHEPS); } /* compute error in solution */ v_sub(x,z,z); if ( v_norm2(z) > MACHEPS*v_norm2(x)*10 ) { errmesg("spCHfactor()/spCHsolve()"); printf("# Solution error = %g [cf MACHEPS = %g]\n", v_norm2(z), MACHEPS); } /* now test symbolic and incomplete factorisation */ SP_FREE(A); A = sp_copy(B); mem_stat_mark(2); spCHsymb(A); mem_stat_mark(2); spICHfactor(A); spCHsolve(A,y,z); v = v_resize(v,A->m); sp_mv_mlt(B,z,v); /* compute residual */ v_sub(y,v,v); if ( v_norm2(v) >= MACHEPS*v_norm2(y)*5 ) { errmesg("spCHsymb()/spICHfactor()"); printf("# Sparse Cholesky residual = %g [cf MACHEPS = %g]\n", v_norm2(v), MACHEPS); } /* compute error in solution */ v_sub(x,z,z); if ( v_norm2(z) > MACHEPS*v_norm2(x)*10 ) { errmesg("spCHsymb()/spICHfactor()"); printf("# Solution error = %g [cf MACHEPS = %g]\n", v_norm2(z), MACHEPS); } /* now test sparse LU factorisation */ notice("sparse LU factorise/solve"); SP_FREE(A); SP_FREE(B); A = iter_gen_nonsym(100,100,8,1.0); B = sp_copy(A); x = v_resize(x,A->n); z = v_resize(z,A->n); y = v_resize(y,A->m); v = v_resize(v,A->m); v_rand(x); sp_mv_mlt(B,x,y); pivot = px_get(A->m); mem_stat_mark(3); spLUfactor(A,pivot,0.1); spLUsolve(A,pivot,y,z); mem_stat_free(3); sp_mv_mlt(B,z,v); /* compute residual */ v_sub(y,v,v); if ( v_norm2(v) >= MACHEPS*v_norm2(y)*A->m ) { errmesg("spLUfactor()/spLUsolve()"); printf("# Sparse LU residual = %g [cf MACHEPS = %g]\n", v_norm2(v), MACHEPS); } /* compute error in solution */ v_sub(x,z,z); if ( v_norm2(z) > MACHEPS*v_norm2(x)*100*A->m ) { errmesg("spLUfactor()/spLUsolve()"); printf("# Sparse LU solution error = %g [cf MACHEPS = %g]\n", v_norm2(z), MACHEPS); } /* now check spLUTsolve */ mem_stat_mark(4); sp_vm_mlt(B,x,y); spLUTsolve(A,pivot,y,z); sp_vm_mlt(B,z,v); mem_stat_free(4); /* compute residual */ v_sub(y,v,v); if ( v_norm2(v) >= MACHEPS*v_norm2(y)*A->m ) { errmesg("spLUTsolve()"); printf("# Sparse LU residual = %g [cf MACHEPS = %g]\n", v_norm2(v), MACHEPS); } /* compute error in solution */ v_sub(x,z,z); if ( v_norm2(z) > MACHEPS*v_norm2(x)*100*A->m ) { errmesg("spLUTsolve()"); printf("# Sparse LU solution error = %g [cf MACHEPS = %g]\n", v_norm2(z), MACHEPS); } /* algebraic operations */ notice("addition,subtraction and multiplying by a number"); SP_FREE(A); SP_FREE(B); m = 120; n = 120; deg = 5; A = sp_get(m,n,deg); B = sp_get(m,n,deg); C = sp_get(m,n,deg); C1 = sp_get(m,n,deg); for ( k = 0; k < m*deg; k++ ) { i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(A,i,j,rand()/((Real)MAX_RAND)); i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(B,i,j,rand()/((Real)MAX_RAND)); } s1 = mrand(); B1 = sp_copy(B); mem_stat_mark(1); sp_smlt(B,s1,C); sp_add(A,C,C1); sp_sub(C1,A,C); sp_smlt(C,-1.0/s1,C); sp_add(C,B1,C); s2 = 0.0; for (k=0; k < C->m; k++) { r = &(C->row[k]); for (j=0; j < r->len; j++) { if (s2 < fabs(r->elt[j].val)) s2 = fabs(r->elt[j].val); } } if (s2 > MACHEPS*A->m) { errmesg("add, sub, mlt sparse matrices (args not in situ)\n"); printf(" difference = %g [MACEPS = %g]\n",s2,MACHEPS); } sp_mltadd(A,B1,s1,C1); sp_sub(C1,A,A); sp_smlt(A,1.0/s1,C1); sp_sub(C1,B1,C1); mem_stat_free(1); s2 = 0.0; for (k=0; k < C1->m; k++) { r = &(C1->row[k]); for (j=0; j < r->len; j++) { if (s2 < fabs(r->elt[j].val)) s2 = fabs(r->elt[j].val); } } if (s2 > MACHEPS*A->m) { errmesg("add, sub, mlt sparse matrices (args not in situ)\n"); printf(" difference = %g [MACEPS = %g]\n",s2,MACHEPS); } V_FREE(x); V_FREE(y); V_FREE(z); V_FREE(u); V_FREE(v); PX_FREE(pivot); SP_FREE(A); SP_FREE(B); SP_FREE(C); SP_FREE(B1); SP_FREE(C1); printf("# Done testing (%s)\n",argv[0]); mem_info(); } meschach-1.2b/ztorture.c100644 764 764 47121 5673126017 14744 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains a series of tests for the Meschach matrix library, complex routines */ static char rcsid[] = "$Id: $"; #include #include "zmatrix2.h" #include #include "matlab.h" #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg); /* extern int malloc_chain_check(); */ /* #define MEMCHK() if ( malloc_chain_check(0) ) \ { printf("Error in malloc chain: \"%s\", line %d\n", \ __FILE__, __LINE__); exit(0); } */ #define MEMCHK() /* cmp_perm -- returns 1 if pi1 == pi2, 0 otherwise */ int cmp_perm(pi1, pi2) PERM *pi1, *pi2; { int i; if ( ! pi1 || ! pi2 ) error(E_NULL,"cmp_perm"); if ( pi1->size != pi2->size ) return 0; for ( i = 0; i < pi1->size; i++ ) if ( pi1->pe[i] != pi2->pe[i] ) return 0; return 1; } /* px_rand -- generates sort-of random permutation */ PERM *px_rand(pi) PERM *pi; { int i, j, k; if ( ! pi ) error(E_NULL,"px_rand"); for ( i = 0; i < 3*pi->size; i++ ) { j = (rand() >> 8) % pi->size; k = (rand() >> 8) % pi->size; px_transp(pi,j,k); } return pi; } #define SAVE_FILE "asx5213a.mat" #define MATLAB_NAME "alpha" char name[81] = MATLAB_NAME; void main(argc, argv) int argc; char *argv[]; { ZVEC *x = ZVNULL, *y = ZVNULL, *z = ZVNULL, *u = ZVNULL; ZVEC *diag = ZVNULL; PERM *pi1 = PNULL, *pi2 = PNULL, *pivot = PNULL; ZMAT *A = ZMNULL, *B = ZMNULL, *C = ZMNULL, *D = ZMNULL, *Q = ZMNULL; complex ONE; complex z1, z2, z3; Real cond_est, s1, s2, s3; int i, seed; FILE *fp; char *cp; mem_info_on(TRUE); setbuf(stdout,(char *)NULL); seed = 1111; if ( argc > 2 ) { printf("usage: %s [seed]\n",argv[0]); exit(0); } else if ( argc == 2 ) sscanf(argv[1], "%d", &seed); /* set seed for rand() */ smrand(seed); /* print out version information */ m_version(); printf("# Meschach Complex numbers & vectors torture test\n\n"); printf("# grep \"^Error\" the output for a listing of errors\n"); printf("# Don't panic if you see \"Error\" appearing; \n"); printf("# Also check the reported size of error\n"); printf("# This program uses randomly generated problems and therefore\n"); printf("# may occasionally produce ill-conditioned problems\n"); printf("# Therefore check the size of the error compared with MACHEPS\n"); printf("# If the error is within 1000*MACHEPS then don't worry\n"); printf("# If you get an error of size 0.1 or larger there is \n"); printf("# probably a bug in the code or the compilation procedure\n\n"); printf("# seed = %d\n",seed); printf("\n"); mem_stat_mark(1); notice("complex arithmetic & special functions"); ONE = zmake(1.0,0.0); printf("# ONE = "); z_output(ONE); z1.re = mrand(); z1.im = mrand(); z2.re = mrand(); z2.im = mrand(); z3 = zadd(z1,z2); if ( fabs(z1.re+z2.re-z3.re) + fabs(z1.im+z2.im-z3.im) > 10*MACHEPS ) errmesg("zadd"); z3 = zsub(z1,z2); if ( fabs(z1.re-z2.re-z3.re) + fabs(z1.im-z2.im-z3.im) > 10*MACHEPS ) errmesg("zadd"); z3 = zmlt(z1,z2); if ( fabs(z1.re*z2.re - z1.im*z2.im - z3.re) + fabs(z1.im*z2.re + z1.re*z2.im - z3.im) > 10*MACHEPS ) errmesg("zmlt"); s1 = zabs(z1); if ( fabs(s1*s1 - (z1.re*z1.re+z1.im*z1.im)) > 10*MACHEPS ) errmesg("zabs"); if ( zabs(zsub(z1,zmlt(z2,zdiv(z1,z2)))) > 10*MACHEPS || zabs(zsub(ONE,zdiv(z1,zmlt(z2,zdiv(z1,z2))))) > 10*MACHEPS ) errmesg("zdiv"); z3 = zsqrt(z1); if ( zabs(zsub(z1,zmlt(z3,z3))) > 10*MACHEPS ) errmesg("zsqrt"); if ( zabs(zsub(z1,zlog(zexp(z1)))) > 10*MACHEPS ) errmesg("zexp/zlog"); printf("# Check: MACHEPS = %g\n",MACHEPS); /* allocate, initialise, copy and resize operations */ /* ZVEC */ notice("vector initialise, copy & resize"); x = zv_get(12); y = zv_get(15); z = zv_get(12); zv_rand(x); zv_rand(y); z = zv_copy(x,z); if ( zv_norm2(zv_sub(x,z,z)) >= MACHEPS ) errmesg("ZVEC copy"); zv_copy(x,y); x = zv_resize(x,10); y = zv_resize(y,10); if ( zv_norm2(zv_sub(x,y,z)) >= MACHEPS ) errmesg("ZVEC copy/resize"); x = zv_resize(x,15); y = zv_resize(y,15); if ( zv_norm2(zv_sub(x,y,z)) >= MACHEPS ) errmesg("VZEC resize"); /* ZMAT */ notice("matrix initialise, copy & resize"); A = zm_get(8,5); B = zm_get(3,9); C = zm_get(8,5); zm_rand(A); zm_rand(B); C = zm_copy(A,C); if ( zm_norm_inf(zm_sub(A,C,C)) >= MACHEPS ) errmesg("ZMAT copy"); zm_copy(A,B); A = zm_resize(A,3,5); B = zm_resize(B,3,5); if ( zm_norm_inf(zm_sub(A,B,C)) >= MACHEPS ) errmesg("ZMAT copy/resize"); A = zm_resize(A,10,10); B = zm_resize(B,10,10); if ( zm_norm_inf(zm_sub(A,B,C)) >= MACHEPS ) errmesg("ZMAT resize"); MEMCHK(); /* PERM */ notice("permutation initialise, inverting & permuting vectors"); pi1 = px_get(15); pi2 = px_get(12); px_rand(pi1); zv_rand(x); px_zvec(pi1,x,z); y = zv_resize(y,x->dim); pxinv_zvec(pi1,z,y); if ( zv_norm2(zv_sub(x,y,z)) >= MACHEPS ) errmesg("PERMute vector"); /* testing catch() etc */ notice("error handling routines"); catch(E_NULL, catchall(zv_add(ZVNULL,ZVNULL,ZVNULL); errmesg("tracecatch() failure"), printf("# tracecatch() caught error\n"); error(E_NULL,"main")); errmesg("catch() failure"), printf("# catch() caught E_NULL error\n")); /* testing inner products and v_mltadd() etc */ notice("inner products and linear combinations"); u = zv_get(x->dim); zv_rand(u); zv_rand(x); zv_resize(y,x->dim); zv_rand(y); zv_mltadd(y,x,zneg(zdiv(zin_prod(x,y),zin_prod(x,x))),z); if ( zabs(zin_prod(x,z)) >= 5*MACHEPS*x->dim ) { errmesg("zv_mltadd()/zin_prod()"); printf("# error norm = %g\n", zabs(zin_prod(x,z))); } z1 = zneg(zdiv(zin_prod(x,y),zmake(zv_norm2(x)*zv_norm2(x),0.0))); zv_mlt(z1,x,u); zv_add(y,u,u); if ( zv_norm2(zv_sub(u,z,u)) >= MACHEPS*x->dim ) { errmesg("zv_mlt()/zv_norm2()"); printf("# error norm = %g\n", zv_norm2(u)); } #ifdef ANSI_C zv_linlist(u,x,z1,y,ONE,VNULL); if ( zv_norm2(zv_sub(u,z,u)) >= MACHEPS*x->dim ) errmesg("zv_linlist()"); #endif #ifdef VARARGS zv_linlist(u,x,z1,y,ONE,VNULL); if ( zv_norm2(zv_sub(u,z,u)) >= MACHEPS*x->dim ) errmesg("zv_linlist()"); #endif MEMCHK(); /* vector norms */ notice("vector norms"); x = zv_resize(x,12); zv_rand(x); for ( i = 0; i < x->dim; i++ ) if ( zabs(v_entry(x,i)) >= 0.7 ) v_set_val(x,i,ONE); else v_set_val(x,i,zneg(ONE)); s1 = zv_norm1(x); s2 = zv_norm2(x); s3 = zv_norm_inf(x); if ( fabs(s1 - x->dim) >= MACHEPS*x->dim || fabs(s2 - sqrt((double)(x->dim))) >= MACHEPS*x->dim || fabs(s3 - 1.0) >= MACHEPS ) errmesg("zv_norm1/2/_inf()"); /* test matrix multiply etc */ notice("matrix multiply and invert"); A = zm_resize(A,10,10); B = zm_resize(B,10,10); zm_rand(A); zm_inverse(A,B); zm_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("zm_inverse()/zm_mlt()"); MEMCHK(); /* ... and adjoints */ notice("adjoints and adjoint-multiplies"); zm_adjoint(A,A); /* can do square matrices in situ */ zmam_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("zm_adjoint()/zmam_mlt()"); zm_adjoint(A,A); zm_adjoint(B,B); zmma_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("zm_adjoint()/zmma_mlt()"); zsm_mlt(zmake(3.71,2.753),B,B); zmma_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,zsub(m_entry(C,i,i),zmake(3.71,-2.753))); if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("szm_mlt()/zmma_mlt()"); zm_adjoint(B,B); zsm_mlt(zdiv(ONE,zmake(3.71,-2.753)),B,B); MEMCHK(); /* ... and matrix-vector multiplies */ notice("matrix-vector multiplies"); x = zv_resize(x,A->n); y = zv_resize(y,A->m); z = zv_resize(z,A->m); u = zv_resize(u,A->n); zv_rand(x); zv_rand(y); zmv_mlt(A,x,z); z1 = zin_prod(y,z); zvm_mlt(A,y,u); z2 = zin_prod(u,x); if ( zabs(zsub(z1,z2)) >= (MACHEPS*x->dim)*x->dim ) { errmesg("zmv_mlt()/zvm_mlt()"); printf("# difference between inner products is %g\n", zabs(zsub(z1,z2))); } zmv_mlt(B,z,u); if ( zv_norm2(zv_sub(u,x,u)) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("zmv_mlt()/zvm_mlt()"); MEMCHK(); /* get/set row/col */ notice("getting and setting rows and cols"); x = zv_resize(x,A->n); y = zv_resize(y,B->m); x = zget_row(A,3,x); y = zget_col(B,3,y); if ( zabs(zsub(_zin_prod(x,y,0,Z_NOCONJ),ONE)) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("zget_row()/zget_col()"); zv_mlt(zmake(-1.0,0.0),x,x); zv_mlt(zmake(-1.0,0.0),y,y); zset_row(A,3,x); zset_col(B,3,y); zm_mlt(A,B,C); for ( i = 0; i < C->m; i++ ) m_set_val(C,i,i,zsub(m_entry(C,i,i),ONE)); if ( zm_norm_inf(C) >= MACHEPS*zm_norm_inf(A)*zm_norm_inf(B)*5 ) errmesg("zset_row()/zset_col()"); MEMCHK(); /* matrix norms */ notice("matrix norms"); A = zm_resize(A,11,15); zm_rand(A); s1 = zm_norm_inf(A); B = zm_adjoint(A,B); s2 = zm_norm1(B); if ( fabs(s1 - s2) >= MACHEPS*A->m ) errmesg("zm_norm1()/zm_norm_inf()"); C = zmam_mlt(A,A,C); z1.re = z1.im = 0.0; for ( i = 0; i < C->m && i < C->n; i++ ) z1 = zadd(z1,m_entry(C,i,i)); if ( fabs(sqrt(z1.re) - zm_norm_frob(A)) >= MACHEPS*A->m*A->n ) errmesg("zm_norm_frob"); MEMCHK(); /* permuting rows and columns */ /****************************** notice("permuting rows & cols"); A = zm_resize(A,11,15); B = zm_resize(B,11,15); pi1 = px_resize(pi1,A->m); px_rand(pi1); x = zv_resize(x,A->n); y = zmv_mlt(A,x,y); px_rows(pi1,A,B); px_zvec(pi1,y,z); zmv_mlt(B,x,u); if ( zv_norm2(zv_sub(z,u,u)) >= MACHEPS*A->m ) errmesg("px_rows()"); pi1 = px_resize(pi1,A->n); px_rand(pi1); px_cols(pi1,A,B); pxinv_zvec(pi1,x,z); zmv_mlt(B,z,u); if ( zv_norm2(zv_sub(y,u,u)) >= MACHEPS*A->n ) errmesg("px_cols()"); ******************************/ MEMCHK(); /* MATLAB save/load */ notice("MATLAB save/load"); A = zm_resize(A,12,11); if ( (fp=fopen(SAVE_FILE,"w")) == (FILE *)NULL ) printf("Cannot perform MATLAB save/load test\n"); else { zm_rand(A); zm_save(fp, A, name); fclose(fp); if ( (fp=fopen(SAVE_FILE,"r")) == (FILE *)NULL ) printf("Cannot open save file \"%s\"\n",SAVE_FILE); else { ZM_FREE(B); B = zm_load(fp,&cp); if ( strcmp(name,cp) || zm_norm1(zm_sub(A,B,C)) >= MACHEPS*A->m ) { errmesg("zm_load()/zm_save()"); printf("# orig. name = %s, restored name = %s\n", name, cp); printf("# orig. A =\n"); zm_output(A); printf("# restored A =\n"); zm_output(B); } } } MEMCHK(); /* Now, onto matrix factorisations */ A = zm_resize(A,10,10); B = zm_resize(B,A->m,A->n); zm_copy(A,B); x = zv_resize(x,A->n); y = zv_resize(y,A->m); z = zv_resize(z,A->n); u = zv_resize(u,A->m); zv_rand(x); zmv_mlt(B,x,y); z = zv_copy(x,z); notice("LU factor/solve"); pivot = px_get(A->m); zLUfactor(A,pivot); tracecatch(zLUsolve(A,pivot,y,x),"main"); tracecatch(cond_est = zLUcondest(A,pivot),"main"); printf("# cond(A) approx= %g\n", cond_est); if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est) { errmesg("zLUfactor()/zLUsolve()"); printf("# LU solution error = %g [cf MACHEPS = %g]\n", zv_norm2(zv_sub(x,z,u)), MACHEPS); } zv_copy(y,x); tracecatch(zLUsolve(A,pivot,x,x),"main"); tracecatch(cond_est = zLUcondest(A,pivot),"main"); if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est) { errmesg("zLUfactor()/zLUsolve()"); printf("# LU solution error = %g [cf MACHEPS = %g]\n", zv_norm2(zv_sub(x,z,u)), MACHEPS); } zvm_mlt(B,z,y); zv_copy(y,x); tracecatch(zLUAsolve(A,pivot,x,x),"main"); if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est) { errmesg("zLUfactor()/zLUAsolve()"); printf("# LU solution error = %g [cf MACHEPS = %g]\n", zv_norm2(zv_sub(x,z,u)), MACHEPS); } MEMCHK(); /* QR factorisation */ zm_copy(B,A); zmv_mlt(B,z,y); notice("QR factor/solve:"); diag = zv_get(A->m); zQRfactor(A,diag); zQRsolve(A,diag,y,x); if ( zv_norm2(zv_sub(x,z,u)) >= MACHEPS*zv_norm2(x)*cond_est ) { errmesg("zQRfactor()/zQRsolve()"); printf("# QR solution error = %g [cf MACHEPS = %g]\n", zv_norm2(zv_sub(x,z,u)), MACHEPS); } printf("# QR cond(A) approx= %g\n", zQRcondest(A)); Q = zm_get(A->m,A->m); zmakeQ(A,diag,Q); zmakeR(A,A); zm_mlt(Q,A,C); zm_sub(B,C,C); if ( zm_norm1(C) >= MACHEPS*zm_norm1(Q)*zm_norm1(B) ) { errmesg("zQRfactor()/zmakeQ()/zmakeR()"); printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", zm_norm1(C), MACHEPS); } MEMCHK(); /* now try with a non-square matrix */ A = zm_resize(A,15,7); zm_rand(A); B = zm_copy(A,B); diag = zv_resize(diag,A->n); x = zv_resize(x,A->n); y = zv_resize(y,A->m); zv_rand(y); zQRfactor(A,diag); x = zQRsolve(A,diag,y,x); /* z is the residual vector */ zmv_mlt(B,x,z); zv_sub(z,y,z); /* check B*.z = 0 */ zvm_mlt(B,z,u); if ( zv_norm2(u) >= 100*MACHEPS*zm_norm1(B)*zv_norm2(y) ) { errmesg("zQRfactor()/zQRsolve()"); printf("# QR solution error = %g [cf MACHEPS = %g]\n", zv_norm2(u), MACHEPS); } Q = zm_resize(Q,A->m,A->m); zmakeQ(A,diag,Q); zmakeR(A,A); zm_mlt(Q,A,C); zm_sub(B,C,C); if ( zm_norm1(C) >= MACHEPS*zm_norm1(Q)*zm_norm1(B) ) { errmesg("zQRfactor()/zmakeQ()/zmakeR()"); printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", zm_norm1(C), MACHEPS); } D = zm_get(A->m,Q->m); zmam_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,zsub(m_entry(D,i,i),ONE)); if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q) ) { errmesg("QRfactor()/makeQ()/makeR()"); printf("# QR orthogonality error = %g [cf MACHEPS = %g]\n", zm_norm1(D), MACHEPS); } MEMCHK(); /* QRCP factorisation */ zm_copy(B,A); notice("QR factor/solve with column pivoting"); pivot = px_resize(pivot,A->n); zQRCPfactor(A,diag,pivot); z = zv_resize(z,A->n); zQRCPsolve(A,diag,pivot,y,z); /* pxinv_zvec(pivot,z,x); */ /* now compute residual (z) vector */ zmv_mlt(B,x,z); zv_sub(z,y,z); /* check B^T.z = 0 */ zvm_mlt(B,z,u); if ( zv_norm2(u) >= MACHEPS*zm_norm1(B)*zv_norm2(y) ) { errmesg("QRCPfactor()/QRsolve()"); printf("# QR solution error = %g [cf MACHEPS = %g]\n", zv_norm2(u), MACHEPS); } Q = zm_resize(Q,A->m,A->m); zmakeQ(A,diag,Q); zmakeR(A,A); zm_mlt(Q,A,C); ZM_FREE(D); D = zm_get(B->m,B->n); /****************************** px_cols(pivot,C,D); zm_sub(B,D,D); if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm1(B) ) { errmesg("QRCPfactor()/makeQ()/makeR()"); printf("# QR reconstruction error = %g [cf MACHEPS = %g]\n", zm_norm1(D), MACHEPS); } ******************************/ /* Now check eigenvalue/SVD routines */ notice("complex Schur routines"); A = zm_resize(A,11,11); B = zm_resize(B,A->m,A->n); C = zm_resize(C,A->m,A->n); D = zm_resize(D,A->m,A->n); Q = zm_resize(Q,A->m,A->n); MEMCHK(); /* now test complex Schur decomposition */ /* zm_copy(A,B); */ ZM_FREE(A); A = zm_get(11,11); zm_rand(A); B = zm_copy(A,B); MEMCHK(); B = zschur(B,Q); MEMCHK(); zm_mlt(Q,B,C); zmma_mlt(C,Q,D); MEMCHK(); zm_sub(A,D,D); if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q)*zm_norm1(B)*5 ) { errmesg("zschur()"); printf("# Schur reconstruction error = %g [cf MACHEPS = %g]\n", zm_norm1(D), MACHEPS); } /* orthogonality check */ zmma_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,zsub(m_entry(D,i,i),ONE)); if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q)*10 ) { errmesg("zschur()"); printf("# Schur orthogonality error = %g [cf MACHEPS = %g]\n", zm_norm1(D), MACHEPS); } MEMCHK(); /* now test SVD */ /****************************** A = zm_resize(A,11,7); zm_rand(A); U = zm_get(A->n,A->n); Q = zm_resize(Q,A->m,A->m); u = zv_resize(u,max(A->m,A->n)); svd(A,Q,U,u); ******************************/ /* check reconstruction of A */ /****************************** D = zm_resize(D,A->m,A->n); C = zm_resize(C,A->m,A->n); zm_zero(D); for ( i = 0; i < min(A->m,A->n); i++ ) zm_set_val(D,i,i,v_entry(u,i)); zmam_mlt(Q,D,C); zm_mlt(C,U,D); zm_sub(A,D,D); if ( zm_norm1(D) >= MACHEPS*zm_norm1(U)*zm_norm_inf(Q)*zm_norm1(A) ) { errmesg("svd()"); printf("# SVD reconstruction error = %g [cf MACHEPS = %g]\n", zm_norm1(D), MACHEPS); } ******************************/ /* check orthogonality of Q and U */ /****************************** D = zm_resize(D,Q->n,Q->n); zmam_mlt(Q,Q,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( zm_norm1(D) >= MACHEPS*zm_norm1(Q)*zm_norm_inf(Q)*5 ) { errmesg("svd()"); printf("# SVD orthognality error (Q) = %g [cf MACHEPS = %g\n", zm_norm1(D), MACHEPS); } D = zm_resize(D,U->n,U->n); zmam_mlt(U,U,D); for ( i = 0; i < D->m; i++ ) m_set_val(D,i,i,m_entry(D,i,i)-1.0); if ( zm_norm1(D) >= MACHEPS*zm_norm1(U)*zm_norm_inf(U)*5 ) { errmesg("svd()"); printf("# SVD orthognality error (U) = %g [cf MACHEPS = %g\n", zm_norm1(D), MACHEPS); } for ( i = 0; i < u->dim; i++ ) if ( v_entry(u,i) < 0 || (i < u->dim-1 && v_entry(u,i+1) > v_entry(u,i)) ) break; if ( i < u->dim ) { errmesg("svd()"); printf("# SVD sorting error\n"); } ******************************/ ZV_FREE(x); ZV_FREE(y); ZV_FREE(z); ZV_FREE(u); ZV_FREE(diag); PX_FREE(pi1); PX_FREE(pi2); PX_FREE(pivot); ZM_FREE(A); ZM_FREE(B); ZM_FREE(C); ZM_FREE(D); ZM_FREE(Q); mem_stat_free(1); MEMCHK(); printf("# Finished torture test for complex numbers/vectors/matrices\n"); mem_info(); } meschach-1.2b/memtort.c100644 764 764 41701 5515365565 14543 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* Tests for mem_info.c functions */ static char rcsid[] = "$Id: $"; #include #include #include "matrix2.h" #include "sparse2.h" #include "zmatrix2.h" #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg) /* new types list */ extern MEM_CONNECT mem_connect[MEM_CONNECT_MAX_LISTS]; /* the number of a new list */ #define FOO_LIST 1 /* numbers of types */ #define TYPE_FOO_1 1 #define TYPE_FOO_2 2 typedef struct { int dim; int fix_dim; Real (*a)[10]; } FOO_1; typedef struct { int dim; int fix_dim; Real (*a)[2]; } FOO_2; FOO_1 *foo_1_get(dim) int dim; { FOO_1 *f; if ((f = (FOO_1 *)malloc(sizeof(FOO_1))) == NULL) error(E_MEM,"foo_1_get"); else if (mem_info_is_on()) { mem_bytes_list(TYPE_FOO_1,0,sizeof(FOO_1),FOO_LIST); mem_numvar_list(TYPE_FOO_1,1,FOO_LIST); } f->dim = dim; f->fix_dim = 10; if ((f->a = (Real (*)[10])malloc(dim*sizeof(Real [10]))) == NULL) error(E_MEM,"foo_1_get"); else if (mem_info_is_on()) mem_bytes_list(TYPE_FOO_1,0,dim*sizeof(Real [10]),FOO_LIST); return f; } FOO_2 *foo_2_get(dim) int dim; { FOO_2 *f; if ((f = (FOO_2 *)malloc(sizeof(FOO_2))) == NULL) error(E_MEM,"foo_2_get"); else if (mem_info_is_on()) { mem_bytes_list(TYPE_FOO_2,0,sizeof(FOO_2),FOO_LIST); mem_numvar_list(TYPE_FOO_2,1,FOO_LIST); } f->dim = dim; f->fix_dim = 2; if ((f->a = (Real (*)[2])malloc(dim*sizeof(Real [2]))) == NULL) error(E_MEM,"foo_2_get"); else if (mem_info_is_on()) mem_bytes_list(TYPE_FOO_2,0,dim*sizeof(Real [2]),FOO_LIST); return f; } int foo_1_free(f) FOO_1 *f; { if ( f != NULL) { if (mem_info_is_on()) { mem_bytes_list(TYPE_FOO_1,sizeof(FOO_1)+ f->dim*sizeof(Real [10]),0,FOO_LIST); mem_numvar_list(TYPE_FOO_1,-1,FOO_LIST); } free(f->a); free(f); } return 0; } int foo_2_free(f) FOO_2 *f; { if ( f != NULL) { if (mem_info_is_on()) { mem_bytes_list(TYPE_FOO_2,sizeof(FOO_2)+ f->dim*sizeof(Real [2]),0,FOO_LIST); mem_numvar_list(TYPE_FOO_2,-1,FOO_LIST); } free(f->a); free(f); } return 0; } char *foo_type_name[] = { "nothing", "FOO_1", "FOO_2" }; #define FOO_NUM_TYPES (sizeof(foo_type_name)/sizeof(*foo_type_name)) int (*foo_free_func[FOO_NUM_TYPES])() = { NULL, foo_1_free, foo_2_free }; static MEM_ARRAY foo_info_sum[FOO_NUM_TYPES]; /* px_rand -- generates sort-of random permutation */ PERM *px_rand(pi) PERM *pi; { int i, j, k; if ( ! pi ) error(E_NULL,"px_rand"); for ( i = 0; i < 3*pi->size; i++ ) { j = (rand() >> 8) % pi->size; k = (rand() >> 8) % pi->size; px_transp(pi,j,k); } return pi; } #ifdef SPARSE SPMAT *gen_non_symm(m,n) int m, n; { SPMAT *A; static PERM *px = PNULL; int i, j, k, k_max; Real s1; A = sp_get(m,n,8); px = px_resize(px,n); MEM_STAT_REG(px,TYPE_PERM); for ( i = 0; i < A->m; i++ ) { k_max = 1 + ((rand() >> 8) % 10); for ( k = 0; k < k_max; k++ ) { j = (rand() >> 8) % A->n; s1 = rand()/((double)MAX_RAND); sp_set_val(A,i,j,s1); } } /* to make it likely that A is nonsingular, use pivot... */ for ( i = 0; i < 2*A->n; i++ ) { j = (rand() >> 8) % A->n; k = (rand() >> 8) % A->n; px_transp(px,j,k); } for ( i = 0; i < A->n; i++ ) sp_set_val(A,i,px->pe[i],1.0); return A; } #endif void stat_test1(par) int par; { static MAT *AT = MNULL; static VEC *xt1 = VNULL, *yt1 = VNULL; static VEC *xt2 = VNULL, *yt2 = VNULL; static VEC *xt3 = VNULL, *yt3 = VNULL; static VEC *xt4 = VNULL, *yt4 = VNULL; AT = m_resize(AT,10,10); xt1 = v_resize(xt1,10); yt1 = v_resize(yt1,10); xt2 = v_resize(xt2,10); yt2 = v_resize(yt2,10); xt3 = v_resize(xt3,10); yt3 = v_resize(yt3,10); xt4 = v_resize(xt4,10); yt4 = v_resize(yt4,10); MEM_STAT_REG(AT,TYPE_MAT); #ifdef ANSI_C mem_stat_reg_vars(0,TYPE_VEC,&xt1,&xt2,&xt3,&xt4,&yt1, &yt2,&yt3,&yt4,NULL); #else #ifdef VARARGS mem_stat_reg_vars(0,TYPE_VEC,&xt1,&xt2,&xt3,&xt4,&yt1, &yt2,&yt3,&yt4,NULL); #else MEM_STAT_REG(xt1,TYPE_VEC); MEM_STAT_REG(yt1,TYPE_VEC); MEM_STAT_REG(xt2,TYPE_VEC); MEM_STAT_REG(yt2,TYPE_VEC); MEM_STAT_REG(xt3,TYPE_VEC); MEM_STAT_REG(yt3,TYPE_VEC); MEM_STAT_REG(xt4,TYPE_VEC); MEM_STAT_REG(yt4,TYPE_VEC); #endif #endif v_rand(xt1); m_rand(AT); mv_mlt(AT,xt1,yt1); } void stat_test2(par) int par; { static PERM *px = PNULL; static IVEC *ixt = IVNULL, *iyt = IVNULL; px = px_resize(px,10); ixt = iv_resize(ixt,10); iyt = iv_resize(iyt,10); MEM_STAT_REG(px,TYPE_PERM); MEM_STAT_REG(ixt,TYPE_IVEC); MEM_STAT_REG(iyt,TYPE_IVEC); px_rand(px); px_inv(px,px); } #ifdef SPARSE void stat_test3(par) int par; { static SPMAT *AT = (SPMAT *)NULL; static VEC *xt = VNULL, *yt = VNULL; static SPROW *r = (SPROW *) NULL; if (AT == (SPMAT *)NULL) AT = gen_non_symm(100,100); else AT = sp_resize(AT,100,100); xt = v_resize(xt,100); yt = v_resize(yt,100); if (r == NULL) r = sprow_get(100); MEM_STAT_REG(AT,TYPE_SPMAT); MEM_STAT_REG(xt,TYPE_VEC); MEM_STAT_REG(yt,TYPE_VEC); MEM_STAT_REG(r,TYPE_SPROW); v_rand(xt); sp_mv_mlt(AT,xt,yt); } #endif #ifdef COMPLEX void stat_test4(par) int par; { static ZMAT *AT = ZMNULL; static ZVEC *xt = ZVNULL, *yt = ZVNULL; AT = zm_resize(AT,10,10); xt = zv_resize(xt,10); yt = zv_resize(yt,10); MEM_STAT_REG(AT,TYPE_ZMAT); MEM_STAT_REG(xt,TYPE_ZVEC); MEM_STAT_REG(yt,TYPE_ZVEC); zv_rand(xt); zm_rand(AT); zmv_mlt(AT,xt,yt); } #endif void main(argc, argv) int argc; char *argv[]; { VEC *x = VNULL, *y = VNULL, *z = VNULL; PERM *pi1 = PNULL, *pi2 = PNULL, *pi3 = PNULL; MAT *A = MNULL, *B = MNULL, *C = MNULL; #ifdef SPARSE SPMAT *sA, *sB; SPROW *r; #endif IVEC *ix = IVNULL, *iy = IVNULL, *iz = IVNULL; int m,n,i,j,deg,k; Real s1,s2; #ifdef COMPLEX ZVEC *zx = ZVNULL, *zy = ZVNULL, *zz = ZVNULL; ZMAT *zA = ZMNULL, *zB = ZMNULL, *zC = ZMNULL; complex ONE; #endif /* variables for testing attaching new lists of types */ FOO_1 *foo_1; FOO_2 *foo_2; mem_info_on(TRUE); #if defined(ANSI_C) || defined(VARARGS) notice("vector initialize, copy & resize"); n = v_get_vars(15,&x,&y,&z,(VEC **)NULL); if (n != 3) { errmesg("v_get_vars"); printf(" n = %d (should be 3)\n",n); } v_rand(x); v_rand(y); z = v_copy(x,z); if ( v_norm2(v_sub(x,z,z)) >= MACHEPS ) errmesg("v_get_vars"); v_copy(x,y); n = v_resize_vars(10,&x,&y,&z,NULL); if ( n != 3 || v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("VEC copy/resize"); n = v_resize_vars(20,&x,&y,&z,NULL); if ( n != 3 || v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("VEC resize"); n = v_free_vars(&x,&y,&z,NULL); if (n != 3) errmesg("v_free_vars"); /* IVEC */ notice("int vector initialise, copy & resize"); n = iv_get_vars(15,&ix,&iy,&iz,NULL); if (n != 3) { errmesg("iv_get_vars"); printf(" n = %d (should be 3)\n",n); } for (i=0; i < ix->dim; i++) { ix->ive[i] = 2*i-1; iy->ive[i] = 3*i+2; } iz = iv_add(ix,iy,iz); for (i=0; i < ix->dim; i++) if ( iz->ive[i] != 5*i+1) errmesg("iv_get_vars"); n = iv_resize_vars(10,&ix,&iy,&iz,NULL); if ( n != 3) errmesg("IVEC copy/resize"); iv_add(ix,iy,iz); for (i=0; i < ix->dim; i++) if (iz->ive[i] != 5*i+1) errmesg("IVEC copy/resize"); n = iv_resize_vars(20,&ix,&iy,&iz,NULL); if ( n != 3 ) errmesg("IVEC resize"); iv_add(ix,iy,iz); for (i=0; i < 10; i++) if (iz->ive[i] != 5*i+1) errmesg("IVEC copy/resize"); n = iv_free_vars(&ix,&iy,&iz,NULL); if (n != 3) errmesg("iv_free_vars"); /* MAT */ notice("matrix initialise, copy & resize"); n = m_get_vars(10,10,&A,&B,&C,NULL); if (n != 3) { errmesg("m_get_vars"); printf(" n = %d (should be 3)\n",n); } m_rand(A); m_rand(B); C = m_copy(A,C); if ( m_norm_inf(m_sub(A,C,C)) >= MACHEPS ) errmesg("MAT copy"); m_copy(A,B); n = m_resize_vars(5,5,&A,&B,&C,NULL); if ( n != 3 || m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) errmesg("MAT copy/resize"); n = m_resize_vars(20,20,&A,&B,NULL); if ( m_norm_inf(m_sub(A,B,C)) >= MACHEPS ) errmesg("MAT resize"); k = m_free_vars(&A,&B,&C,NULL); if ( k != 3 ) errmesg("MAT free"); /* PERM */ notice("permutation initialise, inverting & permuting vectors"); n = px_get_vars(15,&pi1,&pi2,&pi3,NULL); if (n != 3) { errmesg("px_get_vars"); printf(" n = %d (should be 3)\n",n); } v_get_vars(15,&x,&y,&z,NULL); px_rand(pi1); v_rand(x); px_vec(pi1,x,z); y = v_resize(y,x->dim); pxinv_vec(pi1,z,y); if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("PERMute vector"); pi2 = px_inv(pi1,pi2); pi3 = px_mlt(pi1,pi2,pi3); for ( i = 0; i < pi3->size; i++ ) if ( pi3->pe[i] != i ) errmesg("PERM inverse/multiply"); px_resize_vars(20,&pi1,&pi2,&pi3,NULL); v_resize_vars(20,&x,&y,&z,NULL); px_rand(pi1); v_rand(x); px_vec(pi1,x,z); pxinv_vec(pi1,z,y); if ( v_norm2(v_sub(x,y,z)) >= MACHEPS ) errmesg("PERMute vector"); pi2 = px_inv(pi1,pi2); pi3 = px_mlt(pi1,pi2,pi3); for ( i = 0; i < pi3->size; i++ ) if ( pi3->pe[i] != i ) errmesg("PERM inverse/multiply"); n = px_free_vars(&pi1,&pi2,&pi3,NULL); if ( n != 3 ) errmesg("PERM px_free_vars"); #ifdef SPARSE /* set up two random sparse matrices */ m = 120; n = 100; deg = 5; notice("allocating sparse matrices"); k = sp_get_vars(m,n,deg,&sA,&sB,NULL); if (k != 2) { errmesg("sp_get_vars"); printf(" n = %d (should be 2)\n",k); } notice("setting and getting matrix entries"); for ( k = 0; k < m*deg; k++ ) { i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(sA,i,j,rand()/((Real)MAX_RAND)); i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(sB,i,j,rand()/((Real)MAX_RAND)); } for ( k = 0; k < 10; k++ ) { s1 = rand()/((Real)MAX_RAND); i = (rand() >> 8) % m; j = (rand() >> 8) % n; sp_set_val(sA,i,j,s1); s2 = sp_get_val(sA,i,j); if ( fabs(s1 - s2) >= MACHEPS ) { printf(" s1 = %g, s2 = %g, |s1 - s2| = %g\n", s1,s2,fabs(s1-s2)); break; } } if ( k < 10 ) errmesg("sp_set_val()/sp_get_val()"); /* check column access paths */ notice("resizing and access paths"); k = sp_resize_vars(sA->m+10,sA->n+10,&sA,&sB,NULL); if (k != 2) { errmesg("sp_get_vars"); printf(" n = %d (should be 2)\n",k); } for ( k = 0 ; k < 20; k++ ) { i = sA->m - 1 - ((rand() >> 8) % 10); j = sA->n - 1 - ((rand() >> 8) % 10); s1 = rand()/((Real)MAX_RAND); sp_set_val(sA,i,j,s1); if ( fabs(s1 - sp_get_val(sA,i,j)) >= MACHEPS ) break; } if ( k < 20 ) errmesg("sp_resize()"); sp_col_access(sA); if ( ! chk_col_access(sA) ) { errmesg("sp_col_access()"); } sp_diag_access(sA); for ( i = 0; i < sA->m; i++ ) { r = &(sA->row[i]); if ( r->diag != sprow_idx(r,i) ) break; } if ( i < sA->m ) { errmesg("sp_diag_access()"); } k = sp_free_vars(&sA,&sB,NULL); if (k != 2) errmesg("sp_free_vars"); #endif /* SPARSE */ #ifdef COMPLEX /* complex stuff */ ONE = zmake(1.0,0.0); printf("# ONE = "); z_output(ONE); printf("# Check: MACHEPS = %g\n",MACHEPS); /* allocate, initialise, copy and resize operations */ /* ZVEC */ notice("vector initialise, copy & resize"); zv_get_vars(12,&zx,&zy,&zz,NULL); zv_rand(zx); zv_rand(zy); zz = zv_copy(zx,zz); if ( zv_norm2(zv_sub(zx,zz,zz)) >= MACHEPS ) errmesg("ZVEC copy"); zv_copy(zx,zy); zv_resize_vars(10,&zx,&zy,NULL); if ( zv_norm2(zv_sub(zx,zy,zz)) >= MACHEPS ) errmesg("ZVEC copy/resize"); zv_resize_vars(20,&zx,&zy,NULL); if ( zv_norm2(zv_sub(zx,zy,zz)) >= MACHEPS ) errmesg("VZEC resize"); zv_free_vars(&zx,&zy,&zz,NULL); /* ZMAT */ notice("matrix initialise, copy & resize"); zm_get_vars(8,5,&zA,&zB,&zC,NULL); zm_rand(zA); zm_rand(zB); zC = zm_copy(zA,zC); if ( zm_norm_inf(zm_sub(zA,zC,zC)) >= MACHEPS ) errmesg("ZMAT copy"); zm_copy(zA,zB); zm_resize_vars(3,5,&zA,&zB,&zC,NULL); if ( zm_norm_inf(zm_sub(zA,zB,zC)) >= MACHEPS ) errmesg("ZMAT copy/resize"); zm_resize_vars(20,20,&zA,&zB,&zC,NULL); if ( zm_norm_inf(zm_sub(zA,zB,zC)) >= MACHEPS ) errmesg("ZMAT resize"); zm_free_vars(&zA,&zB,&zC,NULL); #endif /* COMPLEX */ #endif /* if defined(ANSI_C) || defined(VARARGS) */ printf("# test of mem_info_bytes and mem_info_numvar\n"); printf(" TYPE VEC: %ld bytes allocated, %d variables allocated\n", mem_info_bytes(TYPE_VEC,0),mem_info_numvar(TYPE_VEC,0)); notice("static memory test"); mem_info_on(TRUE); mem_stat_mark(1); for (i=0; i < 100; i++) stat_test1(i); mem_stat_free(1); mem_stat_mark(1); for (i=0; i < 100; i++) { stat_test1(i); #ifdef COMPLEX stat_test4(i); #endif } mem_stat_mark(2); for (i=0; i < 100; i++) stat_test2(i); mem_stat_mark(3); #ifdef SPARSE for (i=0; i < 100; i++) stat_test3(i); #endif mem_info(); mem_dump_list(stdout,0); mem_stat_free(1); mem_stat_free(3); mem_stat_mark(4); for (i=0; i < 100; i++) { stat_test1(i); #ifdef COMPLEX stat_test4(i); #endif } mem_stat_dump(stdout,0); if (mem_stat_show_mark() != 4) { errmesg("not 4 in mem_stat_show_mark()"); } mem_stat_free(2); mem_stat_free(4); if (mem_stat_show_mark() != 0) { errmesg("not 0 in mem_stat_show_mark()"); } /* add new list of types */ mem_attach_list(FOO_LIST,FOO_NUM_TYPES,foo_type_name, foo_free_func,foo_info_sum); if (!mem_is_list_attached(FOO_LIST)) errmesg("list FOO_LIST is not attached"); mem_dump_list(stdout,FOO_LIST); foo_1 = foo_1_get(6); foo_2 = foo_2_get(3); for (i=0; i < foo_1->dim; i++) for (j=0; j < foo_1->fix_dim; j++) foo_1->a[i][j] = i+j; for (i=0; i < foo_2->dim; i++) for (j=0; j < foo_2->fix_dim; j++) foo_2->a[i][j] = i+j; printf(" foo_1->a[%d][%d] = %g\n",5,9,foo_1->a[5][9]); printf(" foo_2->a[%d][%d] = %g\n",2,1,foo_2->a[2][1]); mem_stat_mark(5); mem_stat_reg_list((void **)&foo_1,TYPE_FOO_1,FOO_LIST); mem_stat_reg_list((void **)&foo_2,TYPE_FOO_2,FOO_LIST); mem_stat_dump(stdout,FOO_LIST); mem_info_file(stdout,FOO_LIST); mem_stat_free_list(5,FOO_LIST); mem_stat_dump(stdout,FOO_LIST); if ( foo_1 != NULL ) errmesg(" foo_1 is not released"); if ( foo_2 != NULL ) errmesg(" foo_2 is not released"); mem_dump_list(stdout,FOO_LIST); mem_info_file(stdout,FOO_LIST); mem_free_vars(FOO_LIST); if ( mem_is_list_attached(FOO_LIST) ) errmesg("list FOO_LIST is not detached"); mem_info(); #if REAL == FLOAT printf("# SINGLE PRECISION was used\n"); #elif REAL == DOUBLE printf("# DOUBLE PRECISION was used\n"); #endif #define ANSI_OR_VAR #ifndef ANSI_C #ifndef VARARGS #undef ANSI_OR_VAR #endif #endif #ifdef ANSI_OR_VAR printf("# you should get: \n"); #if (REAL == FLOAT) printf("# type VEC: 276 bytes allocated, 3 variables allocated\n"); #elif (REAL == DOUBLE) printf("# type VEC: 516 bytes allocated, 3 variables allocated\n"); #endif printf("# and other types are zeros\n"); #endif /*#if defined(ANSI_C) || defined(VARAGS) */ printf("# Finished memory torture test\n"); return; } meschach-1.2b/itertort.c100644 764 764 37462 5673126121 14725 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* iter_tort.c 16/09/93 */ /* This file contains tests for the iterative part of Meschach */ #include #include "matrix2.h" #include "sparse2.h" #include "iter.h" #include #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg); /* for iterative methods */ #if REAL == DOUBLE #define EPS 1e-7 #define KK 20 #elif REAL == FLOAT #define EPS 1e-5 #define KK 8 #endif #define ANON 513 #define ASYM ANON static VEC *ex_sol = VNULL; /* new iter information */ void iter_mod_info(ip,nres,res,Bres) ITER *ip; double nres; VEC *res, *Bres; { static VEC *tmp; if (ip->b == VNULL) return; tmp = v_resize(tmp,ip->b->dim); MEM_STAT_REG(tmp,TYPE_VEC); if (nres >= 0.0) { printf(" %d. residual = %g\n",ip->steps,nres); } else printf(" %d. residual = %g (WARNING !!! should be >= 0) \n", ip->steps,nres); if (ex_sol != VNULL) printf(" ||u_ex - u_approx||_2 = %g\n", v_norm2(v_sub(ip->x,ex_sol,tmp))); } /* out = A^T*A*x */ VEC *norm_equ(A,x,out) SPMAT *A; VEC *x, *out; { static VEC * tmp; tmp = v_resize(tmp,x->dim); MEM_STAT_REG(tmp,TYPE_VEC); sp_mv_mlt(A,x,tmp); sp_vm_mlt(A,tmp,out); return out; } /* make symmetric preconditioner for nonsymmetric matrix A; B = 0.5*(A+A^T) and then B is factorized using incomplete Choleski factorization */ SPMAT *gen_sym_precond(A) SPMAT *A; { SPMAT *B; SPROW *row; int i,j,k; Real val; B = sp_get(A->m,A->n,A->row[0].maxlen); for (i=0; i < A->m; i++) { row = &(A->row[i]); for (j = 0; j < row->len; j++) { k = row->elt[j].col; if (i != k) { val = 0.5*(sp_get_val(A,i,k) + sp_get_val(A,k,i)); sp_set_val(B,i,k,val); sp_set_val(B,k,i,val); } else { /* i == k */ val = sp_get_val(A,i,i); sp_set_val(B,i,i,val); } } } spICHfactor(B); return B; } /* Dv_mlt -- diagonal by vector multiply; the diagonal matrix is represented by a vector d */ VEC *Dv_mlt(d, x, out) VEC *d, *x, *out; { int i; if ( ! d || ! x ) error(E_NULL,"Dv_mlt"); if ( d->dim != x->dim ) error(E_SIZES,"Dv_mlt"); out = v_resize(out,x->dim); for ( i = 0; i < x->dim; i++ ) out->ve[i] = d->ve[i]*x->ve[i]; return out; } /************************************************/ void main(argc, argv) int argc; char *argv[]; { VEC *x, *y, *z, *u, *v, *xn, *yn; SPMAT *A = NULL, *B = NULL; SPMAT *An = NULL, *Bn = NULL; int i, k, kk, j; ITER *ips, *ips1, *ipns, *ipns1; MAT *Q, *H, *Q1, *H1; VEC vt, vt1; Real hh; mem_info_on(TRUE); notice("allocating sparse matrices"); printf(" dim of A = %dx%d\n",ASYM,ASYM); A = iter_gen_sym(ASYM,8); B = sp_copy(A); spICHfactor(B); u = v_get(A->n); x = v_get(A->n); y = v_get(A->n); v = v_get(A->n); v_rand(x); sp_mv_mlt(A,x,y); ex_sol = x; notice(" initialize ITER variables"); /* ips for symmetric matrices with precondition */ ips = iter_get(A->m,A->n); /* printf(" ips:\n"); iter_dump(stdout,ips); */ ips->limit = 500; ips->eps = EPS; iter_Ax(ips,sp_mv_mlt,A); iter_Bx(ips,spCHsolve,B); ips->b = v_copy(y,ips->b); v_rand(ips->x); /* test of iter_resize */ ips = iter_resize(ips,2*A->m,2*A->n); ips = iter_resize(ips,A->m,A->n); /* printf(" ips:\n"); iter_dump(stdout,ips); */ /* ips1 for symmetric matrices without precondition */ ips1 = iter_get(0,0); /* printf(" ips1:\n"); iter_dump(stdout,ips1); */ ITER_FREE(ips1); ips1 = iter_copy2(ips,ips1); iter_Bx(ips1,NULL,NULL); ips1->b = ips->b; ips1->shared_b = TRUE; /* printf(" ips1:\n"); iter_dump(stdout,ips1); */ /* ipns for nonsymetric matrices with precondition */ ipns = iter_copy(ips,INULL); ipns->k = KK; ipns->limit = 500; ipns->info = NULL; An = iter_gen_nonsym_posdef(ANON,8); Bn = gen_sym_precond(An); xn = v_get(An->n); yn = v_get(An->n); v_rand(xn); sp_mv_mlt(An,xn,yn); ipns->b = v_copy(yn,ipns->b); iter_Ax(ipns, sp_mv_mlt,An); iter_ATx(ipns, sp_vm_mlt,An); iter_Bx(ipns, spCHsolve,Bn); /* printf(" ipns:\n"); iter_dump(stdout,ipns); */ /* ipns1 for nonsymmetric matrices without precondition */ ipns1 = iter_copy2(ipns,INULL); ipns1->b = ipns->b; ipns1->shared_b = TRUE; iter_Bx(ipns1,NULL,NULL); /* printf(" ipns1:\n"); iter_dump(stdout,ipns1); */ /******* CG ********/ notice(" CG method without preconditioning"); ips1->info = NULL; mem_stat_mark(1); iter_cg(ips1); k = ips1->steps; z = ips1->x; printf(" cg: no. of iter.steps = %d\n",k); v_sub(z,x,u); printf(" (cg:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); notice(" CG method with ICH preconditioning"); ips->info = NULL; v_zero(ips->x); iter_cg(ips); k = ips->steps; printf(" cg: no. of iter.steps = %d\n",k); v_sub(ips->x,x,u); printf(" (cg:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); V_FREE(v); if ((v = iter_spcg(A,B,y,EPS,VNULL,1000,&k)) == VNULL) errmesg("CG method with precond.: NULL solution"); v_sub(ips->x,v,u); if (v_norm2(u) >= EPS) { errmesg("CG method with precond.: different solutions"); printf(" diff. = %g\n",v_norm2(u)); } mem_stat_free(1); printf(" spcg: # of iter. steps = %d\n",k); v_sub(v,x,u); printf(" (spcg:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); /*** CG FOR NORMAL EQUATION *****/ notice("CGNE method with ICH preconditioning (nonsymmetric case)"); /* ipns->info = iter_std_info; */ ipns->info = NULL; v_zero(ipns->x); mem_stat_mark(1); iter_cgne(ipns); k = ipns->steps; z = ipns->x; printf(" cgne: no. of iter.steps = %d\n",k); v_sub(z,xn,u); printf(" (cgne:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); notice("CGNE method without preconditioning (nonsymmetric case)"); v_rand(u); u = iter_spcgne(An,NULL,yn,EPS,u,1000,&k); mem_stat_free(1); printf(" spcgne: no. of iter.steps = %d\n",k); v_sub(u,xn,u); printf(" (spcgne:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); /*** CGS *****/ notice("CGS method with ICH preconditioning (nonsymmetric case)"); v_zero(ipns->x); /* new init guess == 0 */ mem_stat_mark(1); ipns->info = NULL; v_rand(u); iter_cgs(ipns,u); k = ipns->steps; z = ipns->x; printf(" cgs: no. of iter.steps = %d\n",k); v_sub(z,xn,u); printf(" (cgs:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); notice("CGS method without preconditioning (nonsymmetric case)"); v_rand(u); v_rand(v); v = iter_spcgs(An,NULL,yn,u,EPS,v,1000,&k); mem_stat_free(1); printf(" cgs: no. of iter.steps = %d\n",k); v_sub(v,xn,u); printf(" (cgs:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(u),EPS); /*** LSQR ***/ notice("LSQR method (without preconditioning)"); v_rand(u); v_free(ipns1->x); ipns1->x = u; ipns1->shared_x = TRUE; ipns1->info = NULL; mem_stat_mark(2); z = iter_lsqr(ipns1); v_sub(xn,z,v); k = ipns1->steps; printf(" lsqr: # of iter. steps = %d\n",k); printf(" (lsqr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(v),EPS); v_rand(u); u = iter_splsqr(An,yn,EPS,u,1000,&k); mem_stat_free(2); v_sub(xn,u,v); printf(" splsqr: # of iter. steps = %d\n",k); printf(" (splsqr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(v),EPS); /***** GMRES ********/ notice("GMRES method with ICH preconditioning (nonsymmetric case)"); v_zero(ipns->x); /* ipns->info = iter_std_info; */ ipns->info = NULL; mem_stat_mark(2); z = iter_gmres(ipns); v_sub(xn,z,v); k = ipns->steps; printf(" gmres: # of iter. steps = %d\n",k); printf(" (gmres:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(v),EPS); notice("GMRES method without preconditioning (nonsymmetric case)"); V_FREE(v); v = iter_spgmres(An,NULL,yn,EPS,VNULL,10,1004,&k); mem_stat_free(2); v_sub(xn,v,v); printf(" spgmres: # of iter. steps = %d\n",k); printf(" (spgmres:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(v),EPS); /**** MGCR *****/ notice("MGCR method with ICH preconditioning (nonsymmetric case)"); v_zero(ipns->x); mem_stat_mark(2); z = iter_mgcr(ipns); v_sub(xn,z,v); k = ipns->steps; printf(" mgcr: # of iter. steps = %d\n",k); printf(" (mgcr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(v),EPS); notice("MGCR method without preconditioning (nonsymmetric case)"); V_FREE(v); v = iter_spmgcr(An,NULL,yn,EPS,VNULL,10,1004,&k); mem_stat_free(2); v_sub(xn,v,v); printf(" spmgcr: # of iter. steps = %d\n",k); printf(" (spmgcr:) ||u_ex - u_approx||_2 = %g [EPS = %g]\n", v_norm2(v),EPS); /***** ARNOLDI METHOD ********/ notice("arnoldi method"); kk = ipns1->k = KK; Q = m_get(kk,x->dim); Q1 = m_get(kk,x->dim); H = m_get(kk,kk); v_rand(u); ipns1->x = u; ipns1->shared_x = TRUE; mem_stat_mark(3); iter_arnoldi_iref(ipns1,&hh,Q,H); mem_stat_free(3); /* check the equality: Q*A*Q^T = H; */ vt.dim = vt.max_dim = x->dim; vt1.dim = vt1.max_dim = x->dim; for (j=0; j < kk; j++) { vt.ve = Q->me[j]; vt1.ve = Q1->me[j]; sp_mv_mlt(An,&vt,&vt1); } H1 = m_get(kk,kk); mmtr_mlt(Q,Q1,H1); m_sub(H,H1,H1); if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (arnoldi_iref) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /* check Q*Q^T = I */ mmtr_mlt(Q,Q,H1); for (j=0; j < kk; j++) H1->me[j][j] -= 1.0; if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (arnoldi_iref) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); ipns1->x = u; ipns1->shared_x = TRUE; mem_stat_mark(3); iter_arnoldi(ipns1,&hh,Q,H); mem_stat_free(3); /* check the equality: Q*A*Q^T = H; */ vt.dim = vt.max_dim = x->dim; vt1.dim = vt1.max_dim = x->dim; for (j=0; j < kk; j++) { vt.ve = Q->me[j]; vt1.ve = Q1->me[j]; sp_mv_mlt(An,&vt,&vt1); } mmtr_mlt(Q,Q1,H1); m_sub(H,H1,H1); if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (arnoldi) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /* check Q*Q^T = I */ mmtr_mlt(Q,Q,H1); for (j=0; j < kk; j++) H1->me[j][j] -= 1.0; if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (arnoldi) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); v_rand(u); mem_stat_mark(3); iter_sparnoldi(An,u,kk,&hh,Q,H); mem_stat_free(3); /* check the equality: Q*A*Q^T = H; */ vt.dim = vt.max_dim = x->dim; vt1.dim = vt1.max_dim = x->dim; for (j=0; j < kk; j++) { vt.ve = Q->me[j]; vt1.ve = Q1->me[j]; sp_mv_mlt(An,&vt,&vt1); } mmtr_mlt(Q,Q1,H1); m_sub(H,H1,H1); if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (sparnoldi) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /* check Q*Q^T = I */ mmtr_mlt(Q,Q,H1); for (j=0; j < kk; j++) H1->me[j][j] -= 1.0; if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (sparnoldi) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /****** LANCZOS METHOD ******/ notice("lanczos method"); kk = ipns1->k; Q = m_resize(Q,kk,x->dim); Q1 = m_resize(Q1,kk,x->dim); H = m_resize(H,kk,kk); ips1->k = kk; v_rand(u); v_free(ips1->x); ips1->x = u; ips1->shared_x = TRUE; mem_stat_mark(3); iter_lanczos(ips1,x,y,&hh,Q); mem_stat_free(3); /* check the equality: Q*A*Q^T = H; */ vt.dim = vt1.dim = Q->n; vt.max_dim = vt1.max_dim = Q->max_n; Q1 = m_resize(Q1,Q->m,Q->n); for (j=0; j < Q->m; j++) { vt.ve = Q->me[j]; vt1.ve = Q1->me[j]; sp_mv_mlt(A,&vt,&vt1); } H1 = m_resize(H1,Q->m,Q->m); H = m_resize(H,Q->m,Q->m); mmtr_mlt(Q,Q1,H1); m_zero(H); for (j=0; j < Q->m-1; j++) { H->me[j][j] = x->ve[j]; H->me[j][j+1] = H->me[j+1][j] = y->ve[j]; } H->me[Q->m-1][Q->m-1] = x->ve[Q->m-1]; m_sub(H,H1,H1); if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (lanczos) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /* check Q*Q^T = I */ mmtr_mlt(Q,Q,H1); for (j=0; j < Q->m; j++) H1->me[j][j] -= 1.0; if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (lanczos) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); mem_stat_mark(3); v_rand(u); iter_splanczos(A,kk,u,x,y,&hh,Q); mem_stat_free(3); /* check the equality: Q*A*Q^T = H; */ vt.dim = vt1.dim = Q->n; vt.max_dim = vt1.max_dim = Q->max_n; Q1 = m_resize(Q1,Q->m,Q->n); for (j=0; j < Q->m; j++) { vt.ve = Q->me[j]; vt1.ve = Q1->me[j]; sp_mv_mlt(A,&vt,&vt1); } H1 = m_resize(H1,Q->m,Q->m); H = m_resize(H,Q->m,Q->m); mmtr_mlt(Q,Q1,H1); for (j=0; j < Q->m-1; j++) { H->me[j][j] = x->ve[j]; H->me[j][j+1] = H->me[j+1][j] = y->ve[j]; } H->me[Q->m-1][Q->m-1] = x->ve[Q->m-1]; m_sub(H,H1,H1); if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (splanczos) ||Q*A*Q^T - H|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /* check Q*Q^T = I */ mmtr_mlt(Q,Q,H1); for (j=0; j < Q->m; j++) H1->me[j][j] -= 1.0; if (m_norm_inf(H1) > MACHEPS*x->dim) printf(" (splanczos) ||Q*Q^T - I|| = %g [cf. MACHEPS = %g]\n", m_norm_inf(H1),MACHEPS); /***** LANCZOS2 ****/ notice("lanczos2 method"); kk = 50; /* # of dir. vectors */ ips1->k = kk; v_rand(u); ips1->x = u; ips1->shared_x = TRUE; for ( i = 0; i < xn->dim; i++ ) xn->ve[i] = i; iter_Ax(ips1,Dv_mlt,xn); mem_stat_mark(3); iter_lanczos2(ips1,y,v); mem_stat_free(3); printf("# Number of steps of Lanczos algorithm = %d\n", kk); printf("# Exact eigenvalues are 0, 1, 2, ..., %d\n",ANON-1); printf("# Extreme eigenvalues should be accurate; \n"); printf("# interior values usually are not.\n"); printf("# approx e-vals =\n"); v_output(y); printf("# Error in estimate of bottom e-vec (Lanczos) = %g\n", fabs(v->ve[0])); mem_stat_mark(3); v_rand(u); iter_splanczos2(A,kk,u,y,v); mem_stat_free(3); /***** FINISHING *******/ notice("release ITER variables"); M_FREE(Q); M_FREE(Q1); M_FREE(H); M_FREE(H1); ITER_FREE(ipns); ITER_FREE(ips); ITER_FREE(ipns1); ITER_FREE(ips1); SP_FREE(A); SP_FREE(B); SP_FREE(An); SP_FREE(Bn); V_FREE(x); V_FREE(y); V_FREE(u); V_FREE(v); V_FREE(xn); V_FREE(yn); printf("# Done testing (%s)\n",argv[0]); mem_info(); } meschach-1.2b/mfuntort.c100644 764 764 10665 5515370214 14722 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* mfuntort.c, 10/11/93 */ static char rcsid[] = "$Id: mfuntort.c,v 1.2 1994/01/14 01:08:06 des Exp $"; #include #include #include "matrix.h" #include "matrix2.h" #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg); #define DIM 10 void main() { MAT *A, *B, *C, *OUTA, *OUTB, *TMP; MAT *exp_A_expected, *exp_A; VEC *x, *b; double c, eps = 1e-10; int i, j, q_out, j_out; mem_info_on(TRUE); A = m_get(DIM,DIM); B = m_get(DIM,DIM); C = m_get(DIM,DIM); OUTA = m_get(DIM,DIM); OUTB = m_get(DIM,DIM); TMP = m_get(DIM,DIM); x = v_get(DIM); b = v_get(6); notice("exponent of a matrix"); m_ident(A); mem_stat_mark(1); _m_exp(A,eps,OUTA,&q_out,&j_out); printf("# q_out = %d, j_out = %d\n",q_out,j_out); m_exp(A,eps,OUTA); sm_mlt(exp(1.0),A,A); m_sub(OUTA,A,TMP); printf("# ||exp(I) - e*I|| = %g\n",m_norm_inf(TMP)); m_rand(A); m_transp(A,TMP); m_add(A,TMP,A); B = m_copy(A,B); m_exp(A,eps,OUTA); symmeig(B,OUTB,x); m_zero(TMP); for (i=0; i < x->dim; i++) TMP->me[i][i] = exp(x->ve[i]); m_mlt(OUTB,TMP,C); mmtr_mlt(C,OUTB,TMP); m_sub(TMP,OUTA,TMP); printf("# ||exp(A) - Q*exp(lambda)*Q^T|| = %g\n",m_norm_inf(TMP)); notice("polynomial of a matrix"); m_rand(A); m_transp(A,TMP); m_add(A,TMP,A); B = m_copy(A,B); v_rand(b); m_poly(A,b,OUTA); symmeig(B,OUTB,x); m_zero(TMP); for (i=0; i < x->dim; i++) { c = b->ve[b->dim-1]; for (j=b->dim-2; j >= 0; j--) c = c*x->ve[i] + b->ve[j]; TMP->me[i][i] = c; } m_mlt(OUTB,TMP,C); mmtr_mlt(C,OUTB,TMP); m_sub(TMP,OUTA,TMP); printf("# ||poly(A) - Q*poly(lambda)*Q^T|| = %g\n",m_norm_inf(TMP)); mem_stat_free(1); /* Brook Milligan's test */ M_FREE(A); M_FREE(B); M_FREE(C); notice("exponent of a nonsymmetric matrix"); A = m_get (2, 2); A -> me [0][0] = 1.0; A -> me [0][1] = 1.0; A -> me [1][0] = 4.0; A -> me [1][1] = 1.0; exp_A_expected = m_get(2, 2); exp_A_expected -> me [0][0] = exp (3.0) / 2.0 + exp (-1.0) / 2.0; exp_A_expected -> me [0][1] = exp (3.0) / 4.0 - exp (-1.0) / 4.0; exp_A_expected -> me [1][0] = exp (3.0) - exp (-1.0); exp_A_expected -> me [1][1] = exp (3.0) / 2.0 + exp (-1.0) / 2.0; printf ("A:\n"); for (i = 0; i < 2; i++) { for (j = 0; j < 2; j++) printf (" %15.8e", A -> me [i][j]); printf ("\n"); } printf ("\nexp(A) (expected):\n"); for (i = 0; i < 2; i++) { for (j = 0; j < 2; j++) printf (" %15.8e", exp_A_expected -> me [i][j]); printf ("\n"); } mem_stat_mark(3); exp_A = m_exp (A, 1e-16,NULL); mem_stat_free(3); printf ("\nexp(A):\n"); for (i = 0; i < 2; i++) { for (j = 0; j < 2; j++) printf (" %15.8e", exp_A -> me [i][j]); printf ("\n"); } printf ("\nexp(A) - exp(A) (expected):\n"); for (i = 0; i < 2; i++) { for (j = 0; j < 2; j++) printf (" %15.8e", exp_A -> me [i][j] - exp_A_expected -> me [i][j]); printf ("\n"); } M_FREE(A); M_FREE(B); M_FREE(C); M_FREE(exp_A); M_FREE(exp_A_expected); M_FREE(OUTA); M_FREE(OUTB); M_FREE(TMP); V_FREE(b); V_FREE(x); mem_info(); } meschach-1.2b/iotort.c100644 764 764 6504 5515365565 14356 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Steward & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* iotort.c 10/11/93 */ /* test of I/O functions */ static char rcsid[] = "$Id: $"; #include "sparse.h" #include "zmatrix.h" #define errmesg(mesg) printf("Error: %s error: line %d\n",mesg,__LINE__) #define notice(mesg) printf("# Testing %s...\n",mesg); void main() { VEC *x; MAT *A; PERM *pivot; IVEC *ix; SPMAT *spA; ZVEC *zx; ZMAT *ZA; char yes; int i; FILE *fp; mem_info_on(TRUE); if ((fp = fopen("iotort.dat","w")) == NULL) { printf(" !!! Cannot open file %s for writing\n\n","iotort.dat"); exit(1); } x = v_get(10); A = m_get(3,3); zx = zv_get(10); ZA = zm_get(3,3); pivot = px_get(10); ix = iv_get(10); spA = sp_get(3,3,2); v_rand(x); m_rand(A); zv_rand(zx); zm_rand(ZA); px_ident(pivot); for (i=0; i < 10; i++) ix->ive[i] = i+1; for (i=0; i < spA->m; i++) { sp_set_val(spA,i,i,1.0); if (i > 0) sp_set_val(spA,i-1,i,-1.0); } notice(" VEC output"); v_foutput(fp,x); notice(" MAT output"); m_foutput(fp,A); notice(" ZVEC output"); zv_foutput(fp,zx); notice(" ZMAT output"); zm_foutput(fp,ZA); notice(" PERM output"); px_foutput(fp,pivot); notice(" IVEC output"); iv_foutput(fp,ix); notice(" SPMAT output"); sp_foutput(fp,spA); fprintf(fp,"Y"); fclose(fp); printf("\nENTER SOME VALUES:\n\n"); if ((fp = fopen("iotort.dat","r")) == NULL) { printf(" !!! Cannot open file %s for reading\n\n","iotort.dat"); exit(1); } notice(" VEC input/output"); x = v_finput(fp,x); v_output(x); notice(" MAT input/output"); A = m_finput(fp,A); m_output(A); notice(" ZVEC input/output"); zx = zv_finput(fp,zx); zv_output(zx); notice(" ZMAT input/output"); ZA = zm_finput(fp,ZA); zm_output(ZA); notice(" PERM input/output"); pivot = px_finput(fp,pivot); px_output(pivot); notice(" IVEC input/output"); ix = iv_finput(fp,ix); iv_output(ix); notice(" SPMAT input/output"); SP_FREE(spA); spA = sp_finput(fp); sp_output(spA); notice(" general input"); finput(fp," finish the test? ","%c",&yes); if (yes == 'y' || yes == 'Y' ) printf(" YES\n"); else printf(" NO\n"); fclose(fp); mem_info(); } meschach-1.2b/MACHINES/ 40755 764 764 0 5715706741 13754 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/GCC/ 40755 764 764 0 5736337444 14353 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/GCC/makefile100600 764 764 12110 5735552160 16144 0ustar lapeyrelapeyre# # # Makefile for Meschach for GNU cc # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: $ # srcdir = . VPATH = . CC = gcc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = ranlib CFLAGS = -O6 .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12a TAR = tar SHAR = stree -u ZIP = zip -r -l ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HLIST = err.h iter.h machine.h matlab.h matrix.h matrix2.h \ meminfo.h oldnames.h sparse.h sparse2.h \ zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile # Different configurations all: part1 part2 part3 zpart1 zpart2 basic: part1 part2 sparse: part1 part2 part3 complex: part1 part2 zpart1 zpart2 HBASE = err.h meminfo.h machine.h matrix.h $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1); $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2); $(RANLIB) $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3); $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1); $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2); $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST); $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/MACHINES/GCC/machine.h100600 764 764 7277 5515410160 16210 0ustar lapeyrelapeyre/* machine.h. Generated automatically by configure. */ /* Any machine specific stuff goes here */ /* Add details necessary for your own installation here! */ /* This is for use with "configure" -- if you are not using configure then use machine.van for the "vanilla" version of machine.h */ /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ #define ANSI_C 1 #define NOT_SEGMENTED 1 /* #undef HAVE_COMPLEX_H */ #define HAVE_MALLOC_H 1 #define STDC_HEADERS #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 #define WORDS_BIGENDIAN 1 /* #undef U_INT_DEF */ /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ /* #undef HAVE_PROTOTYPES */ #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 /* #undef REAL_FLT */ #define REAL_DBL 1 /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 1.19209e-07 #define D_MACHEPS 2.22045e-16 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 2147483647 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #endif #ifdef ANSI_C extern int isatty(int); #endif meschach-1.2b/MACHINES/RS6000/ 40755 764 764 0 5736337445 14612 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/RS6000/machine.c100600 764 764 13761 5521047064 16462 0ustar lapeyrelapeyre /************************************************************************** ** ** Copyright (C) 1993 David E. Stewart & Zbigniew Leyk, all rights reserved. ** ** Meschach Library ** ** This Meschach Library is provided "as is" without any express ** or implied warranty of any kind with respect to this software. ** In particular the authors shall not be liable for any direct, ** indirect, special, incidental or consequential damages arising ** in any way from use of the software. ** ** Everyone is granted permission to copy, modify and redistribute this ** Meschach Library, provided: ** 1. All copies contain this copyright notice. ** 2. All modified copies shall carry a notice stating who ** made the last modification and the date of such modification. ** 3. No charge is made for this software or works derived from it. ** This clause shall not be construed as constraining other software ** distributed on the same medium as this software, nor is a ** distribution fee considered a charge. ** ***************************************************************************/ /* This file contains basic routines which are used by the functions in matrix.a etc. These are the routines that should be modified in order to take full advantage of specialised architectures (pipelining, vector processors etc). */ static char *rcsid = "$Header: /usr/local/home/des/meschach/meschach/RCS/machine.c,v 1.3 1991/08/29 06:42:11 des Exp $"; #include "machine.h" /* __ip__ -- inner product */ double __ip__(dp1,dp2,len) register double *dp1, *dp2; int len; { register int len4; register int i; register double sum0, sum1, sum2, sum3; sum0 = sum1 = sum2 = sum3 = 0.0; len4 = len / 4; len = len % 4; for ( i = 0; i < len4; i++ ) { sum0 += dp1[4*i]*dp2[4*i]; sum1 += dp1[4*i+1]*dp2[4*i+1]; sum2 += dp1[4*i+2]*dp2[4*i+2]; sum3 += dp1[4*i+3]*dp2[4*i+3]; } sum0 += sum1 + sum2 + sum3; dp1 += 4*len4; dp2 += 4*len4; for ( i = 0; i < len; i++ ) sum0 += (*dp1++)*(*dp2++); return sum0; } /* __mltadd__ -- scalar multiply and add c.f. v_mltadd() */ void __mltadd__(dp1,dp2,s,len) register double *dp1, *dp2, s; register int len; { register int i, len4; len4 = len / 4; len = len % 4; for ( i = 0; i < len4; i++ ) { dp1[4*i] += s*dp2[4*i]; dp1[4*i+1] += s*dp2[4*i+1]; dp1[4*i+2] += s*dp2[4*i+2]; dp1[4*i+3] += s*dp2[4*i+3]; } dp1 += 4*len4; dp2 += 4*len4; for ( i = 0; i < len; i++ ) (*dp1++) += s*(*dp2++); } /* __smlt__ scalar multiply array c.f. sv_mlt() */ void __smlt__(dp,s,out,len) register double *dp, s, *out; register int len; { register int i; for ( i = 0; i < len; i++ ) (*out++) = s*(*dp++); } /* __add__ -- add arrays c.f. v_add() */ void __add__(dp1,dp2,out,len) register double *dp1, *dp2, *out; register int len; { register int i; for ( i = 0; i < len; i++ ) (*out++) = (*dp1++) + (*dp2++); } /* __sub__ -- subtract arrays c.f. v_sub() */ void __sub__(dp1,dp2,out,len) register double *dp1, *dp2, *out; register int len; { register int i; for ( i = 0; i < len; i++ ) (*out++) = (*dp1++) - (*dp2++); } /* __zero__ -- zeros an array of double precision numbers */ void __zero__(dp,len) register double *dp; register int len; { /* if a double precision zero is equivalent to a string of nulls */ MEM_ZERO((char *)dp,len*sizeof(double)); /* else, need to zero the array entry by entry */ /************************************************* while ( len-- ) *dp++ = 0.0; *************************************************/ } /*********************************************************************** ****** Faster versions ******** ***********************************************************************/ /* __ip4__ -- compute 4 inner products in one go */ void __ip4__(v0,v1,v2,v3,w,out,len) double *v0, *v1, *v2, *v3, *w; double out[4]; int len; { register int i, len2; register double sum00, sum10, sum20, sum30, w_val0; register double sum01, sum11, sum21, sum31, w_val1; len2 = len / 2; len = len % 2; sum00 = sum10 = sum20 = sum30 = 0.0; sum01 = sum11 = sum21 = sum31 = 0.0; for ( i = 0; i < len2; i++ ) { w_val0 = w[2*i]; w_val1 = w[2*i+1]; sum00 += v0[2*i] *w_val0; sum01 += v0[2*i+1]*w_val1; sum10 += v1[2*i] *w_val0; sum11 += v1[2*i+1]*w_val1; sum20 += v2[2*i] *w_val0; sum21 += v2[2*i+1]*w_val1; sum30 += v3[2*i] *w_val0; sum31 += v3[2*i+1]*w_val1; } w += 2*len2; v0 += 2*len2; v1 += 2*len2; v2 += 2*len2; v3 += 2*len2; for ( i = 0; i < len; i++ ) { w_val0 = w[i]; sum00 += v0[i]*w_val0; sum10 += v1[i]*w_val0; sum20 += v2[i]*w_val0; sum30 += v3[i]*w_val0; } out[0] = sum00 + sum01; out[1] = sum10 + sum11; out[2] = sum20 + sum21; out[3] = sum30 + sum31; } /* __lc4__ -- linear combinations: w <- w+a[0]*v0+ ... + a[3]*v3 */ void __lc4__(v0,v1,v2,v3,w,a,len) double *v0, *v1, *v2, *v3, *w; double a[4]; int len; { register int i, len2; register double a0, a1, a2, a3, tmp0, tmp1; len2 = len / 2; len = len % 2; a0 = a[0]; a1 = a[1]; a2 = a[2]; a3 = a[3]; for ( i = 0; i < len2; i++ ) { tmp0 = w[2*i] + a0*v0[2*i]; tmp1 = w[2*i+1] + a0*v0[2*i+1]; tmp0 += a1*v1[2*i]; tmp1 += a1*v1[2*i+1]; tmp0 += a2*v2[2*i]; tmp1 += a2*v2[2*i+1]; tmp0 += a3*v3[2*i]; tmp1 += a3*v3[2*i+1]; w[2*i] = tmp0; w[2*i+1] = tmp1; } w += 2*len2; v0 += 2*len2; v1 += 2*len2; v2 += 2*len2; v3 += 2*len2; for ( i = 0; i < len; i++ ) w[i] += a0*v0[i] + a1*v1[i] + a2*v2[i] + a3*v3[i]; } /* __ma4__ -- multiply and add with 4 vectors: vi <- vi + ai*w */ void __ma4__(v0,v1,v2,v3,w,a,len) double *v0, *v1, *v2, *v3, *w; double a[4]; int len; { register int i; register double a0, a1, a2, a3, w0, w1, w2, w3; a0 = a[0]; a1 = a[1]; a2 = a[2]; a3 = a[3]; for ( i = 0; i < len; i++ ) { w0 = w[i]; v0[i] += a0*w0; v1[i] += a1*w0; v2[i] += a2*w0; v3[i] += a3*w0; } } meschach-1.2b/MACHINES/RS6000/machine.h100600 764 764 6656 5515410160 16446 0ustar lapeyrelapeyre /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ #define ANSI_C 1 /* #undef MALLOCDECL */ #define NOT_SEGMENTED 1 /* #undef HAVE_COMPLEX_H */ #define HAVE_MALLOC_H 1 #define STDC_HEADERS 1 #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 #define WORDS_BIGENDIAN 1 #define U_INT_DEF 1 /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ #define HAVE_PROTOTYPES 1 #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 /* #undef REAL_FLT */ /* #undef REAL_DBL */ /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 1.19209e-07 #define D_MACHEPS 2.22045e-16 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 2147483647 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #endif #ifdef ANSI_C extern int isatty(int); #endif meschach-1.2b/MACHINES/RS6000/makefile100600 764 764 13037 5735552213 16412 0ustar lapeyrelapeyre# Generated automatically from makefile.in by configure. # # Makefile for Meschach via autoconf # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: $ # srcdir = . VPATH = . CC = cc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = ranlib CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12a TAR = tar SHAR = stree -u ZIP = zip -r -l FLIST = FILELIST ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HBASE = err.h meminfo.h machine.h matrix.h HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ sparse2.h zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) # Different configurations all: part1 part2 part3 zpart1 zpart2 basic: part1 part2 sparse: part1 part2 part3 complex: part1 part2 zpart1 zpart2 $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1); $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2); $(RANLIB) meschach.a schur.o: schur.c $(HBASE) matrix2.h cc -c $(DEFS) schur.c $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3); $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1); $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2); $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST); $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar list: /bin/rm -f $(FLIST) ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) MACHINES DOC \ |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ > $(FLIST) clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/MACHINES/SPARC/ 40755 764 764 0 5736337445 14630 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/SPARC/machine.h100600 764 764 6704 5515410161 16457 0ustar lapeyrelapeyre /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ #define const /* #undef MALLOCDECL */ #define NOT_SEGMENTED 1 /* #undef HAVE_COMPLEX_H */ #define HAVE_MALLOC_H 1 /* #undef STDC_HEADERS */ #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 #define WORDS_BIGENDIAN 1 /* #undef U_INT_DEF */ #define VARARGS 1 /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ /* #undef HAVE_PROTOTYPES */ #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 /* #undef REAL_FLT */ #define REAL_DBL 1 /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 1.19209e-07 #define D_MACHEPS 2.22045e-16 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 2147483647 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #endif #ifdef ANSI_C extern int isatty(int); #endif meschach-1.2b/MACHINES/SPARC/makefile100600 764 764 12113 5735552052 16423 0ustar lapeyrelapeyre# # # Makefile for Meschach for SUN SPARC cc # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: $ # srcdir = . VPATH = . CC = cc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = ranlib CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12a TAR = tar SHAR = stree -u ZIP = zip -r -l ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HLIST = err.h iter.h machine.h matlab.h matrix.h matrix2.h \ meminfo.h oldnames.h sparse.h sparse2.h \ zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile # Different configurations all: part1 part2 part3 zpart1 zpart2 basic: part1 part2 sparse: part1 part2 part3 complex: part1 part2 zpart1 zpart2 HBASE = err.h meminfo.h machine.h matrix.h $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1); $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2); $(RANLIB) $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3); $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1); $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2); $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST); $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/MACHINES/Linux/ 40755 764 764 0 5736337445 15057 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/Linux/makefile100600 764 764 12744 5735552123 16663 0ustar lapeyrelapeyre# Generated automatically from makefile.in by configure. # # Makefile for Meschach via autoconf # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: $ # srcdir = . VPATH = . CC = cc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = ranlib CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12a TAR = tar SHAR = stree -u ZIP = zip -r -l FLIST = FILELIST ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HBASE = err.h meminfo.h machine.h matrix.h HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ sparse2.h zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) # Different configurations all: part1 part2 part3 zpart1 zpart2 basic: part1 part2 sparse: part1 part2 part3 complex: part1 part2 zpart1 zpart2 $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1); $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2); $(RANLIB) meschach.a $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3); $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1); $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2); $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST); $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar list: /bin/rm -f $(FLIST) ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) MACHINES DOC \ |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ > $(FLIST) clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/MACHINES/Linux/machine.h100600 764 764 7354 5535214311 16711 0ustar lapeyrelapeyre/* machine.h. Generated automatically by configure. */ /* Any machine specific stuff goes here */ /* Add details necessary for your own installation here! */ /* This is for use with "configure" -- if you are not using configure then use machine.van for the "vanilla" version of machine.h */ /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ /* #undef const */ /* #undef MALLOCDECL */ #define NOT_SEGMENTED 1 /* #undef HAVE_COMPLEX_H */ #define HAVE_MALLOC_H 1 #define STDC_HEADERS 1 #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 /* #undef WORDS_BIGENDIAN */ #define U_INT_DEF 1 #define VARARGS 1 /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ #define HAVE_PROTOTYPES 1 #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 /* #undef REAL_FLT */ /* #undef REAL_DBL */ /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 1.19209e-07 #define D_MACHEPS 2.22045e-16 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 2147483647 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #endif #ifdef ANSI_C extern int isatty(int); #endif meschach-1.2b/MACHINES/SGI/ 40755 764 764 0 5715711710 14366 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/SGI/machine.h100600 764 764 11033 5653725661 16261 0ustar lapeyrelapeyre/* machine.h. Generated automatically by configure. */ /* Any machine specific stuff goes here */ /* Add details necessary for your own installation here! */ /* RCS id: $Id: machine.h.in,v 1.2 1994/03/13 23:07:30 des Exp $ */ /* This is for use with "configure" -- if you are not using configure then use machine.van for the "vanilla" version of machine.h */ /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ /* #undef const */ /* #undef MALLOCDECL */ #define NOT_SEGMENTED 1 #define HAVE_MEMORY_H 1 /* #undef HAVE_COMPLEX_H */ #define HAVE_MALLOC_H 1 #define STDC_HEADERS 1 #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 #define WORDS_BIGENDIAN 1 /*#undef U_INT_DEF */ #define U_INT_DEF #define VARARGS 1 #define HAVE_PROTOTYPES 1 /* #undef HAVE_PROTOTYPES_IN_STRUCT */ /* for inclusion into C++ files */ #ifdef __cplusplus #define ANSI_C 1 #ifndef HAVE_PROTOTYPES #define HAVE_PROTOTYPES 1 #endif #ifndef HAVE_PROTOTYPES_IN_STRUCT #define HAVE_PROTOTYPES_IN_STRUCT 1 #endif #endif /* __cplusplus */ /* example usage: VEC *PROTO(v_get,(int dim)); */ #ifdef HAVE_PROTOTYPES #define PROTO(name,args) name args #else #define PROTO(name,args) name() #endif /* HAVE_PROTOTYPES */ #ifdef HAVE_PROTOTYPES_IN_STRUCT /* PROTO_() is to be used instead of PROTO() in struct's and typedef's */ #define PROTO_(name,args) name args #else #define PROTO_(name,args) name() #endif /* HAVE_PROTOTYPES_IN_STRUCT */ /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 #define REAL_FLT 1 /* #undef REAL_DBL */ /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 1.19209e-07 #define D_MACHEPS 2.22045e-16 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 2147483647 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #else #undef HUGE #define HUGE HUGE_VAL #endif #ifdef ANSI_C extern int isatty(int); #endif meschach-1.2b/MACHINES/SGI/makefile100600 764 764 13462 5653730504 16204 0ustar lapeyrelapeyre# Generated automatically from makefile.in by configure. # # Makefile for Meschach via autoconf # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: makefile.in,v 1.4 1994/03/14 01:24:06 des Exp $ # srcdir = . VPATH = . CC = cc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = ranlib CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12b TAR = tar SHAR = stree -u ZIP = zip -r -l FLIST = FILELIST ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HBASE = err.h meminfo.h machine.h matrix.h HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ sparse2.h zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) # Different configurations # the dependencies **between** the parts are for dmake all: part1 part2 part3 zpart1 zpart2 part2: part1 part3: part2 basic: part1 part2 sparse: part1 part2 part3 zpart2: zpart1 complex: part1 part2 zpart1 zpart2 $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1) $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2) $(RANLIB) meschach.a $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3) $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1) $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2) $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST) $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar list: /bin/rm -f $(FLIST) ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) MACHINES DOC \ |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ > $(FLIST) clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a realclean: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a /bin/rm -f torture sptort ztorture memtort itertort mfuntort iotort /bin/rm -f makefile machine.h config.status maxint macheps alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) meschach-1.2b/MACHINES/Cray/ 40755 764 764 0 5715711721 14644 5ustar lapeyrelapeyremeschach-1.2b/MACHINES/Cray/machine.h100600 764 764 11045 5653751300 16525 0ustar lapeyrelapeyre/* machine.h. Generated automatically by configure. */ /* Any machine specific stuff goes here */ /* Add details necessary for your own installation here! */ /* RCS id: $Id: machine.h.in,v 1.2 1994/03/13 23:07:30 des Exp $ */ /* This is for use with "configure" -- if you are not using configure then use machine.van for the "vanilla" version of machine.h */ /* Note special macros: ANSI_C (ANSI C syntax) SEGMENTED (segmented memory machine e.g. MS-DOS) MALLOCDECL (declared if malloc() etc have been declared) */ #include #define const /* #undef MALLOCDECL */ #define NOT_SEGMENTED 1 #define HAVE_MEMORY_H 1 #define HAVE_COMPLEX_H 1 #define HAVE_MALLOC_H 1 #define STDC_HEADERS 1 #define HAVE_BCOPY 1 #define HAVE_BZERO 1 #define CHAR0ISDBL0 1 #define WORDS_BIGENDIAN 1 /* #undef U_INT_DEF */ #define VARARGS 1 #define HAVE_PROTOTYPES 1 /* #undef HAVE_PROTOTYPES_IN_STRUCT */ /* for inclusion into C++ files */ #ifdef __cplusplus #define ANSI_C 1 #ifndef HAVE_PROTOTYPES #define HAVE_PROTOTYPES 1 #endif #ifndef HAVE_PROTOTYPES_IN_STRUCT #define HAVE_PROTOTYPES_IN_STRUCT 1 #endif #endif /* __cplusplus */ /* example usage: VEC *PROTO(v_get,(int dim)); */ #ifdef HAVE_PROTOTYPES #define PROTO(name,args) name args #else #define PROTO(name,args) name() #endif /* HAVE_PROTOTYPES */ #ifdef HAVE_PROTOTYPES_IN_STRUCT /* PROTO_() is to be used instead of PROTO() in struct's and typedef's */ #define PROTO_(name,args) name args #else #define PROTO_(name,args) name() #endif /* HAVE_PROTOTYPES_IN_STRUCT */ /* for basic or larger versions */ #define COMPLEX 1 #define SPARSE 1 /* for loop unrolling */ /* #undef VUNROLL */ /* #undef MUNROLL */ /* for segmented memory */ #ifndef NOT_SEGMENTED #define SEGMENTED #endif /* if the system has malloc.h */ #ifdef HAVE_MALLOC_H #define MALLOCDECL 1 #include #endif /* any compiler should have this header */ /* if not, change it */ #include /* Check for ANSI C memmove and memset */ #ifdef STDC_HEADERS /* standard copy & zero functions */ #define MEM_COPY(from,to,size) memmove((to),(from),(size)) #define MEM_ZERO(where,size) memset((where),'\0',(size)) #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* standard headers */ #ifdef ANSI_C #include #include #include #include #endif /* if have bcopy & bzero and no alternatives yet known, use them */ #ifdef HAVE_BCOPY #ifndef MEM_COPY /* nonstandard copy function */ #define MEM_COPY(from,to,size) bcopy((char *)(from),(char *)(to),(int)(size)) #endif #endif #ifdef HAVE_BZERO #ifndef MEM_ZERO /* nonstandard zero function */ #define MEM_ZERO(where,size) bzero((char *)(where),(int)(size)) #endif #endif /* if the system has complex.h */ #ifdef HAVE_COMPLEX_H #include #endif /* If prototypes are available & ANSI_C not yet defined, then define it, but don't include any header files as the proper ANSI C headers aren't here */ #ifdef HAVE_PROTOTYPES #ifndef ANSI_C #define ANSI_C 1 #endif #endif /* floating point precision */ /* you can choose single, double or long double (if available) precision */ #define FLOAT 1 #define DOUBLE 2 #define LONG_DOUBLE 3 #define REAL_FLT 1 /* #undef REAL_DBL */ /* if nothing is defined, choose double precision */ #ifndef REAL_DBL #ifndef REAL_FLT #define REAL_DBL 1 #endif #endif /* single precision */ #ifdef REAL_FLT #define Real float #define LongReal float #define REAL FLOAT #define LONGREAL FLOAT #endif /* double precision */ #ifdef REAL_DBL #define Real double #define LongReal double #define REAL DOUBLE #define LONGREAL DOUBLE #endif /* machine epsilon or unit roundoff error */ /* This is correct on most IEEE Real precision systems */ #ifdef DBL_EPSILON #if REAL == DOUBLE #define MACHEPS DBL_EPSILON #elif REAL == FLOAT #define MACHEPS FLT_EPSILON #elif REAL == LONGDOUBLE #define MACHEPS LDBL_EPSILON #endif #endif #define F_MACHEPS 7.10543e-15 #define D_MACHEPS 7.10543e-15 #ifndef MACHEPS #if REAL == DOUBLE #define MACHEPS D_MACHEPS #elif REAL == FLOAT #define MACHEPS F_MACHEPS #elif REAL == LONGDOUBLE #define MACHEPS D_MACHEPS #endif #endif /* #undef M_MACHEPS */ /******************** #ifdef DBL_EPSILON #define MACHEPS DBL_EPSILON #endif #ifdef M_MACHEPS #ifndef MACHEPS #define MACHEPS M_MACHEPS #endif #endif ********************/ #define M_MAX_INT 9223372036854775807 #ifdef M_MAX_INT #ifndef MAX_RAND #define MAX_RAND ((double)(M_MAX_INT)) #endif #endif /* for non-ANSI systems */ #ifndef HUGE_VAL #define HUGE_VAL HUGE #else /* #undef HUGE */ #define HUGE HUGE_VAL #endif #ifdef ANSI_C extern int isatty(int); #endif meschach-1.2b/MACHINES/Cray/makefile100600 764 764 13645 5653751726 16474 0ustar lapeyrelapeyre# Generated automatically from makefile.in by configure. # # Makefile for Meschach via autoconf # # Copyright (C) David Stewart & Zbigniew Leyk 1993 # # $Id: makefile.in,v 1.4 1994/03/14 01:24:06 des Exp $ # srcdir = . VPATH = . CC = cc DEFS = -DHAVE_CONFIG_H LIBS = -lm RANLIB = : CFLAGS = -O .c.o: $(CC) -c $(CFLAGS) $(DEFS) $< SHELL = /bin/sh MES_PAK = mesch12b TAR = tar SHAR = stree -u ZIP = zip -r -l FLIST = FILELIST ############################### LIST1 = copy.o err.o matrixio.o memory.o vecop.o matop.o pxop.o \ submat.o init.o otherio.o machine.o matlab.o ivecop.o version.o \ meminfo.o memstat.o LIST2 = lufactor.o bkpfacto.o chfactor.o qrfactor.o solve.o hsehldr.o \ givens.o update.o norm.o hessen.o symmeig.o schur.o svd.o fft.o \ mfunc.o bdfactor.o LIST3 = sparse.o sprow.o sparseio.o spchfctr.o splufctr.o \ spbkp.o spswap.o iter0.o itersym.o iternsym.o ZLIST1 = zmachine.o zcopy.o zmatio.o zmemory.o zvecop.o zmatop.o znorm.o \ zfunc.o ZLIST2 = zlufctr.o zsolve.o zmatlab.o zhsehldr.o zqrfctr.o \ zgivens.o zhessen.o zschur.o # they are no longer supported # if you use them add oldpart to all and sparse OLDLIST = conjgrad.o lanczos.o arnoldi.o ALL_LISTS = $(LIST1) $(LIST2) $(LIST3) $(ZLIST1) $(ZLIST2) $(OLDLIST) HBASE = err.h meminfo.h machine.h matrix.h HLIST = $(HBASE) iter.h matlab.h matrix2.h oldnames.h sparse.h \ sparse2.h zmatrix.h zmatrix2.h TORTURE = torture.o sptort.o ztorture.o memtort.o itertort.o \ mfuntort.o iotort.o OTHERS = dmacheps.c extras.c fmacheps.c maxint.c makefile.in \ README configure configure.in machine.h.in copyright \ tutorial.c tutadv.c rk4.dat ls.dat makefile $(FLIST) # Different configurations # the dependencies **between** the parts are for dmake all: part1 part2 part3 zpart1 zpart2 ar_create part2: part1 part3: part2 basic: part1 part2 sparse: part1 part2 part3 zpart2: zpart1 complex: part1 part2 zpart1 zpart2 $(LIST1): $(HBASE) part1: $(LIST1) ar ru meschach.a $(LIST1) $(RANLIB) meschach.a $(LIST2): $(HBASE) matrix2.h part2: $(LIST2) ar ru meschach.a $(LIST2) $(RANLIB) meschach.a $(LIST3): $(HBASE) sparse.h sparse2.h part3: $(LIST3) ar ru meschach.a $(LIST3) $(RANLIB) meschach.a $(ZLIST1): $(HBASDE) zmatrix.h zpart1: $(ZLIST1) ar ru meschach.a $(ZLIST1) $(RANLIB) meschach.a $(ZLIST2): $(HBASE) zmatrix.h zmatrix2.h zpart2: $(ZLIST2) ar ru meschach.a $(ZLIST2) $(RANLIB) meschach.a $(OLDLIST): $(HBASE) sparse.h sparse2.h oldpart: $(OLDLIST) ar ru meschach.a $(OLDLIST) $(RANLIB) meschach.a ####################################### tar: - /bin/rm -f $(MES_PAK).tar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(TAR) cvf $(MES_PAK).tar \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC # use this only for PC machines msdos-zip: - /bin/rm -f $(MES_PAK).zip chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(ZIP) $(MES_PAK).zip \ `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC fullshar: - /bin/rm -f $(MES_PAK).shar; chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ MACHINES DOC > $(MES_PAK).shar shar: - /bin/rm -f meschach1.shar meschach2.shar meschach3.shar \ meschach4.shar oldmeschach.shar meschach0.shar chmod 644 `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ $(OTHERS) $(HLIST) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` chmod 755 configure $(MAKE) list $(SHAR) `echo $(LIST1) | sed -e 's/\.o/.c/g'` > meschach1.shar $(SHAR) `echo $(LIST2) | sed -e 's/\.o/.c/g'` > meschach2.shar $(SHAR) `echo $(LIST3) | sed -e 's/\.o/.c/g'` > meschach3.shar $(SHAR) `echo $(ZLIST1) | sed -e 's/\.o/.c/g'` \ `echo $(ZLIST2) | sed -e 's/\.o/.c/g'` > meschach4.shar $(SHAR) `echo $(OLDLIST) | sed -e 's/\.o/.c/g'` > oldmeschach.shar $(SHAR) $(OTHERS) `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) DOC MACHINES > meschach0.shar list: /bin/rm -f $(FLIST) ls -lR `echo $(ALL_LISTS) | sed -e 's/\.o/.c/g'` \ `echo $(TORTURE) | sed -e 's/\.o/.c/g'` \ $(HLIST) $(OTHERS) MACHINES DOC \ |awk '/^$$/ {print};/^[-d]/ {printf("%s %s %10d %s %s %s %s\n", \ $$1,$$2,$$5,$$6,$$7,$$8,$$9)}; /^[^-d]/ {print}' \ > $(FLIST) clean: /bin/rm -f *.o core asx5213a.mat iotort.dat cleanup: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a realclean: /bin/rm -f *.o core asx5213a.mat iotort.dat *.a /bin/rm -f torture sptort ztorture memtort itertort mfuntort iotort /bin/rm -f makefile machine.h config.status maxint macheps alltorture: torture sptort ztorture memtort itertort mfuntort iotort torture:torture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o torture torture.o \ meschach.a $(LIBS) sptort:sptort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o sptort sptort.o \ meschach.a $(LIBS) memtort: memtort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o memtort memtort.o \ meschach.a $(LIBS) ztorture:ztorture.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o ztorture ztorture.o \ meschach.a $(LIBS) itertort: itertort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o itertort itertort.o \ meschach.a $(LIBS) iotort: iotort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o iotort iotort.o \ meschach.a $(LIBS) mfuntort: mfuntort.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o mfuntort mfuntort.o \ meschach.a $(LIBS) tstmove: tstmove.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstmove tstmove.o \ meschach.a $(LIBS) tstpxvec: tstpxvec.o meschach.a $(CC) $(CFLAGS) $(DEFS) -o tstpxvec tstpxvec.o \ meschach.a $(LIBS) ar_create: rm meschach.a ar ruv meschach.a $(LIST1) $(LIST2) $(LIST3) \ $(ZLIST1) $(ZLIST2) $(OLDLIST) meschach-1.2b/MACHINES/Cray/patch.1100600 764 764 3637 5653751300 16121 0ustar lapeyrelapeyre*** err.h Thu Jan 13 16:38:12 1994 --- err.h.orig Wed Oct 26 17:56:36 1994 *************** *** 129,135 **** { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_SILENT); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ ! if ( (_err_num=setjmp(restart)) == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ --- 129,136 ---- { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_SILENT); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ ! _err_num=setjmp(restart); \ ! if ( _err_num == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ *************** *** 149,155 **** { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_SILENT); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ ! if ( (_err_num=setjmp(restart)) == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ --- 150,157 ---- { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_SILENT); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ ! _err_num=setjmp(restart); \ ! if ( _err_num == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ *************** *** 166,172 **** { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_JUMP); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ ! if ( (_err_num=setjmp(restart)) == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ --- 168,175 ---- { jmp_buf _save; int _err_num, _old_flag; \ _old_flag = set_err_flag(EF_JUMP); \ MEM_COPY(restart,_save,sizeof(jmp_buf)); \ ! _err_num=setjmp(restart) ;\ ! if ( _err_num == 0 ) \ { ok_part; \ set_err_flag(_old_flag); \ MEM_COPY(_save,restart,sizeof(jmp_buf)); } \ meschach-1.2b/MACHINES/Cray/patch.2100600 764 764 1257 5653751302 16120 0ustar lapeyrelapeyre*** iter0.c Mon Jun 20 15:22:36 1994 --- iter0.c.orig Fri Oct 28 01:49:19 1994 *************** *** 103,111 **** if (lenx > 0) ip->x = v_get(lenx); else ip->x = (VEC *)NULL; ! ip->Ax = ip->A_par = NULL; ! ip->ATx = ip->AT_par = NULL; ! ip->Bx = ip->B_par = NULL; ip->info = iter_std_info; ip->stop_crit = iter_std_stop_crit; ip->init_res = 0.0; --- 103,111 ---- if (lenx > 0) ip->x = v_get(lenx); else ip->x = (VEC *)NULL; ! ip->Ax = NULL; ip->A_par = NULL; ! ip->ATx = NULL; ip->AT_par = NULL; ! ip->Bx = NULL; ip->B_par = NULL; ip->info = iter_std_info; ip->stop_crit = iter_std_stop_crit; ip->init_res = 0.0; meschach-1.2b/MACHINES/Cray/patch.3100600 764 764 452 5653751303 16076 0ustar lapeyrelapeyre*** zmatrix.h Tue Mar 8 15:50:26 1994 --- zmatrix.h.orig Fri Oct 28 01:52:48 1994 *************** *** 34,39 **** --- 34,41 ---- /* Type definitions for complex vectors and matrices */ + #undef complex + #define complex Complex /* complex definition */ typedef struct { meschach-1.2b/DOC/ 40755 764 764 0 5715711667 13175 5ustar lapeyrelapeyremeschach-1.2b/DOC/fnindex.txt100600 764 764 41442 5515367377 15506 0ustar lapeyrelapeyre FUNCTION INDEX ============== In the descriptions below, matrices are represented by capital letters, vectors by lower case letters and scalars by alpha. Function Description band2mat() Convert band matrix to dense matrix bd_free() Deallocate (destroy) band matrix bd_get() Allocate and initialise band matrix bd_transp() Transpose band matrix bd_resize() Resize band matrix bdLDLfactor() Band LDL^T factorisation bdLDLsolve() Solve Ax=b using band LDL^T factors bdLUfactor() Band LU factorisation bdLUsolve() Solve Ax=b using band LU factors bisvd() SVD of bi-diagonal matrix BKPfactor() Bunch-Kaufman-Parlett factorisation BKPsolve() Bunch-Kaufman-Parlett solver catch() Catch a raised error (macro) catchall() Catch any raised error (macro) catch_FPE() Catch floating point error (sets flag) CHfactor() Dense Cholesky factorisation CHsolve() Cholesky solver d_save() Save real in MATLAB format Dsolve() Solve Dx=y , D diagonal ERRABORT() Abort on error (sets flag, macro) ERREXIT() Exit on error (sets flag, macro) error() Raise an error (macro, see ev_err()) err_list_attach() Attach new list of errors err_list_free() Discard list of errors err_is_list_attached() Checks for an error list ev_err() Raise an error (function) fft() Computes Fast Fourier Transform finput() Input a simple data item from a stream fprompter() Print prompt to stderr get_col() Extract a column from a matrix get_row() Extract a row from a matrix givens() Compute Givens parameters hhtrcols() Compute AP^T where P is a Householder matrix hhtrrows() Compute PA where P is a Householder matrix hhtrvec() Compute Px where P is a Householder matrix hhvec() Compute parameters for a Householder matrix ifft() Computes inverse FFT in_prod() Inner product of vectors input() Input a simple data item from stdin (macro) iter_arnoldi() Arnoldi iterative method iter_arnoldi_iref() Arnoldi iterative method with refinement iter_ATx() Set A^T in ITER structure iter_Ax() Set A in ITER structure iter_Bx() Set preconditioner in ITER structure iter_cg() Conjugate gradients iterative method iter_cgne() Conjugate gradients for normal equations iter_cgs() CGS iterative method iter_copy() Copy ITER data structures iter_copy2() Shallow copy of ITER data structures iter_dump() Dump ITER data structure to a stream iter_free() Free (deallocate) ITER structure iter_get() Allocate ITER structure iter_gmres() GMRES iterative method iter_lanczos() Lanczos iterative method iter_lanczos2() Lanczos method with Cullum and Willoughby extensions iter_lsqr() LSQR iterative method iter_mgcr() MGCR iterative method iter_resize() Resize vectors in an ITER data structure iter_spcg() Sparse matrix CG method iter_spcgne() Sparse matrix CG method for normal equations iter_spcgs() Sparse matrix CGS method iter_spgmres() Sparse matrix GMRES method iter_splsqr() Sparse matrix LSQR method iter_spmgcr() Sparse matrix MGCR method iv_add() Add integer vectors iv_copy() Copy integer vector iv_dump() Dump integer vector to a stream iv_finput() Input integer vector from a stream iv_foutput() Output integer vector to a stream IV_FREE() Free (deallocate) an integer vector (macro) iv_free() Free (deallocate) integer vector (function) iv_free_vars() Free a list of integer vectors iv_get() Allocate and initialise an integer vector iv_get_vars() Allocate list of integer vectors iv_input() Input integer vector from stdin (macro) iv_output() Output integer vector to stdout (macro) iv_resize() Resize an integer vector iv_resize_vars() Resize a list of integer vectors iv_sub() Subtract integer vectors LDLfactor() LDL^T factorisation LDLsolve() LDL^T solver LDLupdate() Update LDL^T factorisation Lsolve() Solve Lx=y , L lower triangular LTsolve() Solve L^Tx=y , L lower triangular LUcondest() Estimate a condition number using LU factors LUfactor() Compute LU factors with implicit scaled partial pivoting LUsolve() Solve Ax=b using LU factors LUTsolve() Solve A^Tx=b usng LU factors m_add() Add matrices makeQ() Form Q matrix for QR factorisation makeR() Form R matrix for QR factorisation mat2band() Extract band matrix from dense matrix MCHfactor() Modified Cholesky factorisation (actually factors A+D, D diagonal, instead of A) m_copy() Copy dense matrix m_dump() Dump matrix data structure to a stream mem_attach_list() Adds a new family of types mem_bytes() Notify change in memory usage (macro) mem_bytes_list() Notify change in memory usage mem_free_list() Frees a family of types mem_info_bytes() Number of bytes used by a type mem_info_numvar() Number of structures of a type mem_info_file() Print memory info to a stream mem_info_is_on() Is memory data being accumulated? mem_info_on() Turns memory info system on/off mem_is_list_attached() Is list of types attached? mem_numvar() Notify change in number of structures allocated (macro) mem_numvar_list() Notify change in number of structures allocated mem_stat_dump() Prints information on registered workspace mem_stat_free() Frees (deallocates) static workspace mem_stat_mark() Sets mark for workspace MEM_STAT_REG() Register static workspace (macro) mem_stat_show_mark() Current workspace group m_exp() Computes matrix exponential m_finput() Input matrix from a stream m_foutput() Output matrix to a stream M_FREE() Free (deallocate) a matrix (macro) m_free() Free (deallocate) matrix (function) m_free_vars() Free a list of matrices m_get() Allocate and initialise a matrix m_get_vars() Allocate list of matrices m_ident() Sets matrix to identity matrix m_input() Input matrix from stdin (macro) m_inverse() Invert matrix m_load() Load matrix in MATLAB format m_mlt() Multiplies matrices mmtr_mlt() Computes AB^T m_norm1() Computes ||A||_1 of a matrix m_norm_frob() Computes the Frobenius norm of a matrix m_norm_inf() Computes ||A||_inf of a matrix m_ones() Set matrix to all 1's m_output() Output matrix to stdout (macro) m_poly() Computes a matrix polynomial m_pow() Computes integer power of a matrix mrand() Generates pseudo-random real number m_rand() Randomise entries of a matrix mrandlist() Generates array of pseudo-random numbers m_resize() Resize matrix m_resize_vars() Resize a list of matrices m_save() Save matrix in MATLAB format m_sub() Subtract matrices m_transp() Transpose matrix mtrm_mlt() Computes A^TB mv_mlt() Computes Ax mv_mltadd() Computes y <- Ax+y m_zero() Zero a matrix ON_ERROR() Error handler (macro) prompter() Print prompt message to stdout px_cols() Permute the columns of a matrix px_copy() Copy permutation px_dump() Dump permutation data structure to a stream px_finput() Input permutation from a stream px_foutput() Output permutation to a stream PX_FREE() Free (deallocate) a permutation (macro) px_free() Free (deallocate) permutation (function) px_free_vars() Free a list of permutations px_get() Allocate and initialise a permutation px_get_vars() Allocate a list of permutations px_ident() Sets permutation to identity px_input() Input permutation from stdin (macro) px_inv() Invert permutation pxinv_vec() Computes P^Tx where P is a permutation matrix pxinv_zvec() Computes P^Tx where P is a permutation matrix (complex) px_mlt() Multiply permutations px_output() Output permutation to stdout (macro) px_resize() Resize a permutation px_resize_vars() Resize a list of permutations px_rows() Permute the rows of a matrix px_sign() Returns the sign of the permutation px_transp() Transpose a pair of entries px_vec() Computes Px where P is a permutation matrix px_zvec() Computes Px where P is a permutation matrix (complex) QRCPfactor() QR factorisation with column pivoting QRfactor() QR factorisation QRsolve() Solve Ax=b using QR factorisation QRTsolve() Solve A^Tx=b using QR factorisation QRupdate() Update explicit QR factors rot_cols() Apply Givens rotation to the columns of a matrix rot_rows() Apply Givens rotation to the rows of a matrix rot_vec() Apply Givens rotation to a vector rot_zvec() Apply complex Givens rotation to a vector schur() Compute real Schur form schur_evals() Compute eigenvalues from the real Schur form schur_vecs() Compute eigenvectors from the real Schur form set_col() Set the column of a matrix to a given vector set_err_flag() Control behaviour of ev_err() set_row() Set the row of a matrix to a given vector sm_mlt() Scalar-matrix multiplication smrand() Set seed for mrand() spBKPfactor() Sparse symmetric indefinite factorsiation spBKPsolve() Sparse symmetric indefinite solver spCHfactor() Sparse Cholesky factorisation spCHsolve() Sparse Cholesky solver spCHsymb() Symbolic sparse Cholesky factorisation (no floating point operations) sp_col_access() Sets up column access paths for a sparse matrix sp_compact() Eliminates zero entries in a sparse matrix sp_copy() Copies a sparse matrix sp_copy2() Copies a sparse matrix into another sp_diag_access() Sets up diagonal access paths for a sparse matrix sp_dump() Dump sparse matrix data structure to a stream sp_finput() Input sparse matrix from a stream sp_foutput() Output a sparse matrix to a stream sp_free() Free (deallocate) a sparse matrix sp_get() Allocate and initialise a sparse matrix sp_get_val() Get the (i,j) entry of a sparse matrix spICHfactor() Sparse incomplete Cholesky factorisation sp_input() Input a sparse matrix form stdin spLUfactor() Sparse LU factorisation using partial pivoting spLUsolve() Solves Ax=b using sparse LU factors spLUTsolve() Solves A^Tx=b using sparse LU factors sp_mv_mlt() Computes Ax for sparse A sp_output() Outputs a sparse matrix to a stream (macro) sp_resize() Resize a sparse matrix sprow_add() Adds a pair of sparse rows sprow_foutput() Output sparse row to a stream sprow_get() Allocate and initialise a sparse row sprow_get_idx() Get location of an entry in a sparse row sprow_merge() Merge two sparse rows sprow_mltadd() Sparse row vector multiply-and-add sprow_set_val() Set an entry in a sparse row sprow_smlt() Multiplies a sparse row by a scalar sprow_sub() Subtracts a sparse row from another sprow_xpd() Expand a sparse row sp_set_val() Set the (i,j) entry of a sparse matrix sp_vm_mlt() Compute x^TA for sparse A sp_zero() Zero (but do not remove) all entries of a sparse matrix svd() Compute the SVD of a matrix sv_mlt() Scalar-vector multiply symmeig() Compute eigenvalues/vectors of a symmetric matrix tracecatch() Catch and re-raise errors (macro) trieig() Compute eigenvalues/vectors of a symmetric tridiagonal matrix Usolve() Solve Ux=b where U is upper triangular UTsolve() Solve U^Tx=b where U is upper triangular v_add() Add vectors v_conv() Convolution product of vectors v_copy() Copy vector v_dump() Dump vector data structure to a stream v_finput() Input vector from a stream v_foutput() Output vector to a stream V_FREE() Free (deallocate) a vector (macro) v_free() Free (deallocate) vector (function) v_free_vars() Free a list of vectors v_get() Allocate and initialise a vector v_get_vars() Allocate list of vectors v_input() Input vector from stdin (macro) v_lincomb() Compute sum of a_i x_i for an array of vectors v_linlist() Compute sum of a_i x_i for a list of vectors v_map() Apply function componentwise to a vector v_max() Computes max vector entry and index v_min() Computes min vector entry and index v_mltadd() Computes y <- alpha*x+y for vectors x , y vm_mlt() Computes x^TA vm_mltadd() Computes y^T <- y^T+x^TA v_norm1() Computes ||x||_1 for a vector v_norm2() Computes ||x||_2 (the Euclidean norm) of a vector v_norm_inf() Computes ||x||_inf for a vector v_ones() Set vector to all 1's v_output() Output vector to stdout (macro) v_pconv() Periodic convolution of two vectors v_rand() Randomise entries of a vector v_resize() Resize a vector v_resize_vars() Resize a list of vectors v_save() Save a vector in MATLAB format v_slash() Computes componentwise ratio of vectors v_sort() Sorts vector components v_star() Componentwise vector product v_sub() Subtract two vectors v_sum() Sum of components of a vector v_zero() Zero a vector zabs() Complex absolute value (modulus) zadd() Add complex numbers zconj() Conjugate complex number zdiv() Divide complex numbers zexp() Complex exponential z_finput() Read complex number from file or stream z_foutput() Prints complex number to file or stream zgivens() Compute complex Givens' rotation zhhtrcols() Apply Householder transformation: PA (complex) zhhtrrows() Apply Householder transformation: AP (complex) zhhtrvec() Apply Householder transformation: Px (complex) zhhvec() Compute Householder transformation zin_prod() Complex inner product z_input() Read complex number from stdin zinv() Computes 1/z (complex) zLAsolve() Solve L^*x=b , L complex lower triangular zlog() Complex logarithm zLsolve() Solve Lx=b , L complex lower triangular zLUAsolve() Solve A^*x=b using complex LU factorisation (A^* - adjoint of A, A is complex) zLUcondest() Complex LU condition estimate zLUfactor() Complex LU factorisation zLUsolve() Solve Ax=b using complex LU factorisation zm_add() Add complex matrices zm_adjoint() Computes adjoint of complex matrix zmake() Construct complex number from real and imaginary parts zmakeQ() Construct Q matrix for complex QR zmakeR() Construct R matrix for complex QR zmam_mlt() Computes A^*B (complex) zm_dump() Dump complex matrix to stream zm_finput() Input complex matrix from stream ZM_FREE() Free (deallocate) complex matrix (macro) zm_free() Free (deallocate) complex matrix (function) zm_free_vars() Free a list of complex matrices zm_get() Allocate complex matrix zm_get_vars() Allocate a list of complex matrices zm_input() Input complex matrix from stdin zm_inverse() Compute inverse of complex matrix zm_load() Load complex matrix in MATLAB format zmlt() Multiply complex numbers zmma_mlt() Computes AB^* (complex) zm_mlt() Multiply complex matrices zm_norm1() Complex matrix 1-norm zm_norm_frob() Complex matrix Frobenius norm zm_norm_inf() Complex matrix infinity-norm zm_rand() Randomise complex matrix zm_resize() Resize complex matrix zm_resize_vars() Resize a list of complex matrices zm_save() Save complex matrix in MATLAB format zm_sub() Subtract complex matrices zmv_mlt() Complex matrix-vector multiply zmv_mltadd() Complex matrix-vector multiply and add zm_zero() Zero complex matrix zneg() Computes -z (complex) z_output() Print complex number to stdout zQRCPfactor() Complex QR factorisation with column pivoting zQRCPsolve() Solve Ax = b using complex QR factorisation zQRfactor() Complex QR factorisation zQRAsolve() Solve A^*x = b using complex QR factorisation zQRsolve() Solve Ax = b using complex QR factorisation zrot_cols() Complex Givens' rotation of columns zrot_rows() Complex Givens' rotation of rows z_save() Save complex number in MATLAB format zschur() Complex Schur factorisation zset_col() Set column of complex matrix zset_row() Set row of complex matrix zsm_mlt() Complex scalar-matrix product zsqrt() Square root z (complex) zsub() Subtract complex numbers zUAsolve() Solve U^*x=b , U complex upper triangular zUsolve() Solve Ux=b , U complex upper triangular zv_add() Add complex vectors zv_copy() Copy complex vector zv_dump() Dump complex vector to a stream zv_finput() Input complex vector from a stream ZV_FREE() Free (deallocate) complex vector (macro) zv_free() Free (deallocate) complex vector (function) zv_free_vars() Free a list of complex vectors zv_get() Allocate complex vector zv_get_vars() Allocate a list of complex vectors zv_input() Input complex vector from a stdin zv_lincomb() Compute sum of a_i x_i for an array of vectors zv_linlist() Compute sum of a_i x_i for a list of vectors zv_map() Apply function componentwise to a complex vector zv_mlt() Complex scalar-vector product zv_mltadd() Complex scalar-vector multiply and add zvm_mlt() Computes A^*x (complex) zvm_mltadd() Computes A^*x+y (complex) zv_norm1() Complex vector 1-norm vnorm1() zv_norm2() Complex vector 2-norm (Euclidean norm) zv_norm_inf() Complex vector infinity- (or supremum) norm zv_rand() Randomise complex vector zv_resize() Resize complex vector zv_resize_vars() Resize a list of complex vectors zv_save() Save complex vector in MATLAB format zv_slash() Componentwise ratio of complex vectors zv_star() Componentwise product of complex vectors zv_sub() Subtract complex vectors zv_sum() Sum of components of a complex vector zv_zero() Zero complex vector Low level routines Function Description __add__() Add arrays __ip__() Inner product of arrays MEM_COPY() Copy memory (macro) MEM_ZERO() Zero memory (macro) __mltadd__() Forms x+ alpha*y for arrays __smlt__() Scalar-vector multiplication for arrays __sub__() Subtract an array from another __zadd__() Add complex arrays __zconj__() Conjugate complex array __zero__() Zero an array __zip__() Complex inner product of arrays __zmlt__() Complex array scalar product __zmltadd__() Complex array saxpy __zsub__() Subtract complex arrays __zzero__() Zero a complex array meschach-1.2b/DOC/tutorial.txt100600 764 764 131634 5515367400 15724 0ustar lapeyrelapeyre MESCHACH VERSION 1.2A --------------------- TUTORIAL ======== In this manual the basic data structures are introduced, and some of the more basic operations are illustrated. Then some examples of how to use the data structures and procedures to solve some simple problems are given. The first example program is a simple 4th order Runge-Kutta solver for ordinary differential equations. The second is a general least squares equation solver for over-determined equations. The third example illustrates how to solve a problem involving sparse matrices. These examples illustrate the use of matrices, matrix factorisations and solving systems of linear equations. The examples described in this manual are implemented in tutorial.c. While the description of each aspect of the system is brief and far from comprehensive, the aim is to show the different aspects of how to set up programs and routines and how these work in practice, which includes I/O and error-handling issues. 1. THE DATA STRUCTURES AND SOME BASIC OPERATIONS The three main data structures are those describing vectors, matrices and permutations. These have been used to create data structures for simplex tableaus for linear programming, and used with data structures for sparse matrices etc. To use the system reliably, you should always use pointers to these data structures and use library routines to do all the necessary initialisation. In fact, for the operations that involve memory management (creation, destruction and resizing), it is essential that you use the routines provided. For example, to create a matrix A of size 34 , a vector x of dimension 10, and a permutation p of size 10, use the following code: #include "matrix.h" .............. main() { MAT *A; VEC *x; PERM *p; .......... A = m_get(3,4); x = v_get(10); p = px_get(10); .......... } This initialises these data structures to have the given size. The matrix A and the vector x are initially all zero, while p is initially the identity permutation. They can be disposed of by calling M_FREE(A), V_FREE(x) and PX_FREE(p) respectively if you need to re-use the memory for something else. The elements of each data structure can be accessed directly using the members (or fields) of the corresponding structures. For example the (i,j) component of A is accessed by A->me[i][j], x_i by x->ve[i] and p_i by p->pe[i]. Their sizes are also directly accessible: A->m and A->n are the number of rows and columns of A respectively, x->dim is the dimension of x , and size of p is p->size. Note that the indexes are zero relative just as they are in ordinary C, so that the index i in x->ve[i] can range from 0 to x->dim -1 . Thus the total number of entries of a vector is exactly x->dim. While this alone is sufficient to allow a programmer to do any desired operation with vectors and matrices it is neither convenient for the programmer, nor efficient use of the CPU. A whole library has been implemented to reduce the burden on the programmer in implementing algorithms with vectors and matrices. For instance, to copy a vector from x to y it is sufficient to write y = v_copy(x,VNULL). The VNULL is the NULL vector, and usually tells the routine called to create a vector for output. Thus, the v_copy function will create a vector which has the same size as x and all the components are equal to those of x. If y has already been created then you can write y = v_copy(x,y); in general, writing ``v_copy(x,y);'' is not enough! If y is NULL, then it is created (to have the correct size, i.e. the same size as x), and if it is the wrong size, then it is resized to have the correct size (i.e. same size as x). Note that for all the following functions, the output value is returned, even if you have a non-NULL value as the output argument. This is the standard across the entire library. Addition, subtraction and scalar multiples of vectors can be computed by calls to library routines: v_add(x,y,out), v_sub(x,y,out), sv_mlt(s,x,out) where x and y are input vectors (with data type VEC *), out is the output vector (same data type) and s is a double precision number (data type double). There is also a special combination routine, which computes out=v_1+s,v_2 in a single routine: v_mltadd(v1,v2,s,out). This is not only extremely useful, it is also more efficient than using the scalar-vector multiply and vector addition routines separately. Inner products can be computed directly: in_prod(x,y) returns the inner product of x and y. Note that extended precision evaluation is not guaranteed. The standard installation options uses double precision operations throughout the library. Equivalent operations can be performed on matrices: m_add(A,B,C) which returns C=A+B , and sm_mlt(s,A,C) which returns C=sA . The data types of A, B and C are all MAT *, while that of s is type double as before. The matrix NULL is called MNULL. Multiplying matrices and vectors can be done by a single function call: mv_mlt(A,x,out) returns out=A*x while vm_mlt(A,x,out) returns out=A^T*x , or equivalently, out^T=x^T*A . Note that there is no distinction between row and column vectors unlike certain interactive environments such as MATLAB or MATCALC. Permutations are also an essential part of the package. Vectors can be permuted by using px_vec(p,x,p_x), rows and columns of matrices can be permuted by using px_rows(p,A,p_A), px_cols(p,A,A_p), and permutations can be multiplied using px_mlt(p1,p2,p1_p2) and inverted using px_inv(p,p_inv). The NULL permutation is called PXNULL. There are also utility routines to initialise or re-initialise these data structures: v_zero(x), m_zero(A), m_ident(A) (which sets A=I of the correct size), v_rand(x), m_rand(A) which sets the entries of x and A respectively to be randomly and uniformly selected between zero and one, and px_ident(p) which sets p to be an identity permutation. Input and output are accomplished by library routines v_input(x), m_input(A), and px_input(p). If a null object is passed to any of these input routines, all data will be obtained from the input file, which is stdin. If input is taken from a keyboard then the user will be prompted for all the data items needed; if input is taken from a file, then the input will have to be of the same format as that produced by the output routines, which are: v_output(x), m_output(A) and px_output(p). This output is both human and machine readable! If you wish to send the data to a file other than the standard output device stdout, or receive input from a file or device other than the standard input device stdin, take the appropriate routine above, use the ``foutpout'' suffix instead of just ``output'', and add a file pointer as the first argument. For example, to send a matrix A to a file called ``fred'', use the following: #include "matrix.h" ............. main() { FILE *fp; MAT *A; ............. fp = fopen("fred","w"); m_foutput(fp,A); ............. } These input routines allow for the presence of comments in the data. A comment in the input starts with a ``hash'' character ``#'', and continues to the end of the line. For example, the following is valid input for a 3-dimensional vector: # The initial vector must not be zero # x = Vector: dim: 3 -7 0 3 For general input/output which conforms to this format, allowing comments in the input files, use the input() and finput() macros. These are used to print out a prompt message if stdin is a terminal (or ``tty'' in Unix jargon), and to skip over any comments if input is from a non-interactive device. An example of the usage of these macros is: input("Input number of steps: ","%d",&steps); fp = stdin; finput(fp,"Input number of steps: ","%d",&steps); fp = fopen("fred","r"); finput(fp,"Input number of steps: ","%d",&steps); The "%d" is one of the format specifiers which are used in fscanf(); the last argument is the pointer to the variable (unless the variable is a string) just as for scanf() and fscanf(). The first two macro calls read input from stdin, the last from the file fred. If, in the first two calls, stdin is a keyboard (a ``tty'' in Unix jargon) then the prompt string "Input number of steps: " is printed out on the terminal. The second part of the library contains routines for various factorisation methods. To use it put #include "matrix2.h" at the beginning of your program. It contains factorisation and solution routines for LU, Cholesky and QR-factorisation methods, as well as update routines for Cholesky and QR factorisations. Supporting these are a number of Householder transformation and Givens' rotation routines. Also there is a routine for generating the Q matrix for a QR-factorisation, if it is needed explicitly, as it often is. There are routines for band factorisation and solution for LU and LDL^T factorisations. For using complex numbers, vectors and matrices include #include "zmatrix.h" for using the basic routines, and #include "zmatrix2.h" for the complex matrix factorisation routines. The zmatrix2.h file includes matrix.h and zmatrix.h so you don't need these files included together. For using the sparse matrix routines in the library you need to put #include "sparse.h" or, if you use any sparse factorisation routines, #include "sparse2.h" at the beginning of your file. The routines contained in the library include routines for creating, destroying, initialising and updating sparse matrices, and also routines for sparse matrix-dense vector multiplication, sparse LU factorisation and sparse Cholesky factorisation. For using the iterative routines you need to use #include "iter.h" This includes the sparse.h and matrix.h file. There are also routines for applying iterative methods such as pre-conditioned conjugate gradient methods to sparse matrices. And if you use the standard maths library (sin(), cos(), tan(), exp(), log(), sqrt(), acos() etc.) don't forget to include the standard mathematics header: #include This file is not automatically included by any of the Meschach header files. 2. HOW TO MANAGE MEMORY Unlike many other numerical libraries, Meschach allows you to allocate, deallocate and resize the vectors, matrices and permutations that you are using. To gain maximum benefit from this it is sometimes necessary to think a little about where memory is allocated and deallocated. There are two reasons for this. Memory allocation, deallocation and resizing takes a significant amount of time compared with (say) vector operations, so it should not be done too frequently. Allocating memory but not deallocating it means that it cannot be used by any other data structure. Data structures that are no longer needed should be explicitly deallocated, or kept as static variables for later use. Unlike other interpreted systems (such as Lisp) there is no implicit ``garbage collection'' of no-longer-used memory. There are three main strategies that are recommended for deciding how to allocate, deallocate and resize objects. These are ``no deallocation'' which is really only useful for demonstration programs, ``allocate and deallocate'' which minimises overall memory requirements at the expense of speed, and ``resize on demand'' which is useful for routines that are called repeatedly. A new technique for static workspace arrays is to ``register workspace variables''. 2.1 NO DEALLOCATION This is the strategy of allocating but never deallocating data structures. This is only useful for demonstration programs run with small to medium size data structures. For example, there could be a line QR = m_copy(A,MNULL); /* allocate memory for QR */ to allocate the memory, but without the call M_FREE(QR); in it. This can be acceptable if QR = m_copy(A,MNULL) is only executed once, and so the allocated memory never needs to be explicitly deallocated. This would not be acceptable if QR = m_copy(A,MNULL) occurred inside a for loop. If this were so, then memory would be ``lost'' as far as the program is concerned until there was insufficient space for allocating the next matrix for QR. The next subsection shows how to avoid this. 2.2 ALLOCATE AND DEALLOCATE This is the most straightforward way of ensuring that memory is not lost. With the example of allocating QR it would work like this: for ( ... ; ... ; ... ) { QR = m_copy(A,MNULL); /* allocate memory for QR */ /* could have been allocated by m_get() */ /* use QR */ ...... ...... /* no longer need QR for this cycle */ M_FREE(QR); /* deallocate QR so memory can be reused */ } The allocate and deallocate statements could also have come at the beginning and end of a function or procedure, so that when the function returns, all the memory that the function has allocated has been deallocated. This is most suitable for functions or sections of code that are called repeatedly but involve fairly extensive calculations (at least a matrix-matrix multiply, or solving a system of equations). 2.3 RESIZE ON DEMAND This technique reduces the time involved in memory allocation for code that is repeatedly called or used, especially where the same size matrix or vector is needed. For example, the vectors v1, v2, etc. in the Runge-Kutta routine rk4() are allocated according to this strategy: rk4(...,x,...) { static VEC *v1=VNULL, *v2=VNULL, *v3=VNULL, *v4=VNULL, *temp=VNULL; ....... v1 = v_resize(v1,x->dim); v2 = v_resize(v2,x->dim); v3 = v_resize(v3,x->dim); v4 = v_resize(v4,x->dim); temp = v_resize(temp,x->dim); ....... } The intention is that the rk4() routine is called repeatedly with the same size x vector. It then doesn't make as much sense to allocate v1, v2 etc. whenever the function is called. Instead, v_resize() only performs memory allocation if the memory already allocated to v1, v2 etc. is smaller than x->dim. The vectors v1, v2 etc. are declared to be static to ensure that their values are not lost between function calls. Variables that are declared static are set to NULL or zero by default. So the declaration of v1, v2, etc., could be static VEC *v1, *v2, *v3, *v4, *temp; This strategy of resizing static workspace variables is not so useful if the object being allocated is extremely large. The previous ``allocate and deallocate'' strategy is much more efficient for memory in those circumstances. However, the following section shows how to get the best of both worlds. 2.4 REGISTRATION OF WORKSPACE From version 1.2 onwards, workspace variables can be registered so that the memory they reference can be freed up on demand. To do this, the function containing the static workspace variables has to include calls to MEM_STAT_REG(var,type) where var is a pointer to a Meschach data type (such as VEC or MAT). This call should be placed after the call to the appropriate resize function. The type parameter should be a TYPE_... macro where the ``...'' is the name of a Meschach type such as VEC or MAT. For example, rk4(...,x,...) { static VEC *v1, *v2, *v3, *v4, *temp; ....... v1 = v_resize(v1,x->dim); MEM_STAT_REG(v1,TYPE_VEC); v2 = v_resize(v2,x->dim); MEM_STAT_REG(v2,TYPE_VEC); ...... } Normally, these registered workspace variables remain allocated. However, to implement the ``deallocate on exit'' approach, use the following code: ...... mem_stat_mark(1); rk4(...,x,...) mem_stat_free(1); ...... To keep the workspace vectors allocated for the duration of a loop, but then deallocated, use ...... mem_stat_mark(1); for (i = 0; i < N; i++ ) rk4(...,x,...); mem_stat_free(1); ...... The number used in the mem_stat_mark() and mem_stat_free() calls is the workspace group number. The call mem_stat_mark(1) designates 1 as the current workspace group number; the call mem_stat_free(1) deallocates (and sets to NULL) all static workspace variables registered as belonging to workspace group 1. 3. SIMPLE VECTOR OPERATIONS: AN RK4 ROUTINE The main purpose of this example is to show how to deal with vectors and to compute linear combinations. The problem here is to implement the standard 4th order Runge-Kutta method for the ODE x'=f(t,x), x(t_0)=x_0 for x(t_i), i=1,2,3, where t_i=t_0+i*h and h is the step size. The formulae for the 4th order Runge-Kutta method are: x_i+1 = x_i+ h/6*(v_1+2*v_2+2*v_3+v_4), where v_1 = f(t_i,x_i) v_2 = f(t_i+h, x_i+h*v_1) v_3 = f(t_i+h, x_i+h*v_2) v_4 = f(t_i+h, x_i+h*v_3) where the v_i are vectors. The procedure for implementing this method (rk4()) will be passed (a pointer to) the function f. The implementation of f could, in this system, create a vector to hold the return value each time it is called. However, such a scheme is memory intensive and the calls to the memory allocation functions could easily dominate the time performed doing numerical computations. So, the implementation of f will also be passed an already allocated vector to be filled in with the appropriate values. The procedure rk4() will also be passed the current time t, the step size h, and the current value for x. The time after the step will be returned by rk4(). The code that does this follows. #include "matrix.h" /* rk4 - 4th order Runge-Kutta method */ double rk4(f,t,x,h) double t, h; VEC *(*f)(), *x; { static VEC *v1=VNULL, *v2=VNULL, *v3=VNULL, *v4=VNULL; static VEC *temp=VNULL; /* do not work with NULL initial vector */ if ( x == VNULL ) error(E_NULL,"rk4"); /* ensure that v1, ..., v4, temp are of the correct size */ v1 = v_resize(v1,x->dim); v2 = v_resize(v2,x->dim); v3 = v_resize(v3,x->dim); v4 = v_resize(v4,x->dim); temp = v_resize(temp,x->dim); /* register workspace variables */ MEM_STAT_REG(v1,TYPE_VEC); MEM_STAT_REG(v2,TYPE_VEC); MEM_STAT_REG(v3,TYPE_VEC); MEM_STAT_REG(v4,TYPE_VEC); MEM_STAT_REG(temp,TYPE_VEC); /* end of memory allocation */ (*f)(t,x,v1); /* most compilers allow: f(t,x,v1); */ v_mltadd(x,v1,0.5*h,temp); /* temp = x+.5*h*v1 */ (*f)(t+0.5*h,temp,v2); v_mltadd(x,v2,0.5*h,temp); /* temp = x+.5*h*v2 */ (*f)(t+0.5*h,temp,v3); v_mltadd(x,v3,h,temp); /* temp = x+h*v3 */ (*f)(t+h,temp,v4); /* now add: v1+2*v2+2*v3+v4 */ v_copy(v1,temp); /* temp = v1 */ v_mltadd(temp,v2,2.0,temp); /* temp = v1+2*v2 */ v_mltadd(temp,v3,2.0,temp); /* temp = v1+2*v2+2*v3 */ v_add(temp,v4,temp); /* temp = v1+2*v2+2*v3+v4 */ /* adjust x */ v_mltadd(x,temp,h/6.0,x); /* x = x+(h/6)*temp */ return t+h; /* return the new time */ } Note that the last parameter of f() is where the output is placed. Often this can be NULL in which case the appropriate data structure is allocated and initialised. Note also that this routine can be used for problems of arbitrary size, and the dimension of the problem is determined directly from the data given. The vectors v_1,...,v_4 are created to have the correct size in the lines .... v1 = v_resize(v1,x->dim); v2 = v_resize(v2,x->dim); .... Here v_resize(v,dim) resizes the VEC structure v to hold a vector of length dim. If v is initially NULL, then this creates a new vector of dimension dim, just as v_get(dim) would do. For the above piece of code to work correctly, v1, v2 etc., must be initialised to be NULL vectors. This is done by the declaration static VEC *v1=VNULL, *v2=VNULL, *v3=VNULL, *v4=VNULL; or static VEC *v1, *v2, *v3, *v4; The operations of vector addition and scalar addition are really the only vector operations that need to be performed in rk4. Vector addition is done by v_add(v1,v2,out), where out=v1+v2, and scalar multiplication by sv_mlt(scale,v,out), where out=scale*v. These can be combined into a single operation v_mltadd(v1,v2,scale,out), where out=v1+scale*v2. As many operations in numerical mathematics involve accumulating scalar multiples, this is an extremely useful operation, as we can see above. For example: v_mltadd(x,v1,0.5*h,temp); /* temp = x+0.5*h*v1 */ We also need a number of ``utility'' operations. For example v_copy(in, out) copies the vector in to out. There is also v_zero(v) to zero a vector v. Here is an implementation of the function f for simple harmonic motion: /* f - right-hand side of ODE solver */ VEC *f(t,x,out) VEC *x, *out; double t; { if ( x == VNULL || out == VNULL ) error(E_NULL,"f"); if ( x->dim != 2 || out->dim != 2 ) error(E_SIZES,"f"); out->ve[0] = x->ve[1]; out->ve[1] = - x->ve[0]; return out; } As can be seen, most of this code is error checking code, which, of course, makes the routine safer but a little slower. For a procedure like f() it is probably not necessary, although then the main program would have to perform checking to ensure that the vectors involved have the correct size etc. The ith component of a vector x is x->ve[i], and indexing is zero-relative (i.e., the ``first'' component is component 0). The ODE described above is for simple harmonic motion: x_0'=x_1 , x_1'=-x_0 , or equivalently, x_0''+ x_0 = 0 . Here is the main program: #include #include "matrix.h" main() { VEC *x; VEC *f(); double h, t, t_fin; double rk4(); input("Input initial time: ", "%lf", &t); input("Input final time: ", "%lf", &t_fin); x = v_get(2); /* this is the size needed by f() */ prompter("Input initial state:\n"); x = v_input(VNULL); input("Input step size: ", "%lf", &h); printf("# At time %g, the state is\n",t); v_output(x); while ( t < t_fin ) { t = rk4(f,t,x,min(h,t_fin-t)); /* new t is returned */ printf("# At time %g, the state is\n",t); v_output(x); t += h; } } The initial values are entered as a vector by v_input(). If v_input() is passed a vector, then this vector will be used to store the input, and this vector has the size that x had on entry to v_input(). The original values of x are also used as a prompt on input from a tty. If a NULL is passed to v_input() then v_input() will return a vector of whatever size the user inputs. So, to ensure that only a two-dimensional vector is used for the initial conditions (which is what f() is expecting) we use x = v_get(2); x = v_input(x); To compile the program under Unix, if it is in a file tutorial.c: cc -o tutorial tutorial.c meschach.a or, if you have an ANSI compiler, cc -DANSI_C -o tutorial tutorial.c meschach.a Here is a sample session with the above program: tutorial Input initial time: 0 Input final time: 1 Input initial state: Vector: dim: 2 entry 0: -1 entry 1: b entry 0: old -1 new: 1 entry 1: old 0 new: 0 Input step size: 0.1 At time 0, the state is Vector: dim: 2 1 0 At time 0.1, the state is Vector: dim: 2 0.995004167 -0.0998333333 ................. At time 1, the state is Vector: dim: 2 0.540302967 -0.841470478 By way of comparison, the state at t=1 for the true solution is x_0(1)=0.5403023058 , x_1(1)=-0.8414709848 . The ``b'' that is typed in entering the x vector allows the user to alter previously entered components. In this case once this is done, the user is prompted with the old values when entering the new values. The user can also type in ``f'' for skipping over the vector's components, which are then unchanged. If an incorrectly sized initial value vector x is given, the error handler comes into action: Input initial time: 0 Input final time: 1 Input initial state: Vector: dim: 3 entry 0: 3 entry 1: 2 entry 2: -1 Input step size: 0.1 At time 0, the state is Vector: dim: 3 3 2 -1 "tutorial.c", line 79: sizes of objects don't match in function f() Sorry, aborting program The error handler prints out the error message giving the source code file and line number as well as the function name where the error was raised. The relevant section of f() in file tutorial.c is: if ( x->dim != 2 || out->dim != 2 ) error(E_SIZES,"f"); /* line 79 */ The standard routines in this system perform error checking of this type, and also checking for undefined results such as division by zero in the routines for solving systems of linear equations. There are also error messages for incorrectly formatted input and end-of-file conditions. To round off the discussion of this program, note that we have seen interactive input of vectors. If the input file or stream is not a tty (e.g., a file, a pipeline or a device) then it expects the input to have the same form as the output for each of the data structures. Each of the input routines (v_input(), m_input(), px_input()) skips over ``comments'' in the input data, as do the macros input() and finput(). Anything from a `#' to the end of the line (or EOF) is considered to be a comment. For example, the initial value problem could be set up in a file ivp.dat as: # Initial time 0 # Final time 1 # Solution is x(t) = (cos(t),-sin(t)) # x(0) = Vector: dim: 2 1 0 # Step size 0.1 The output of the above program with the above input (from a file) gives essentially the same output as shown above, except that no prompts are sent to the screen. 4. USING ROUTINES FOR LISTS OF ARGUMENTS Some of the most common routines have variants that take a variable number of arguments. These are the routines .._get_vars(), .._resize_vars() and .._free_vars(). These correspond to the the basic routines .._get(), .._resize() and .._free() respectively. Also there is the mem_stat_reg_vars() routine which registers a list of static workspace variables. This corresponds to mem_stat_reg_list() for a single variable. Here is an example of how to use these functions. This example also uses the routine v_linlist() to compute a linear combination of vectors. Note that the code is much more compact, but don't forget that these ``..._vars()'' routines usually need the address-of operator ``&'' and NULL termination of the arguments to work correctly. #include "matrix.h" /* rk4 - 4th order Runge-Kutta method */ double rk4(f,t,x,h) double t, h; VEC *(*f)(), *x; { static VEC *v1, *v2, *v3, *v4, *temp; /* do not work with NULL initial vector */ if ( x == VNULL ) error(E_NULL,"rk4"); /* ensure that v1, ..., v4, temp are of the correct size */ v_resize_vars(x->dim, &v1, &v2, &v3, &v4, &temp, NULL); /* register workspace variables */ mem_stat_reg_vars(0, TYPE_VEC, &v1, &v2, &v3, &v4, &temp, NULL); /* end of memory allocation */ (*f)(t,x,v1); v_mltadd(x,v1,0.5*h,temp); (*f)(t+0.5*h,temp,v2); v_mltadd(x,v2,0.5*h,temp); (*f)(t+0.5*h,temp,v3); v_mltadd(x,v3,h,temp); (*f)(t+h,temp,v4); /* now add: temp = v1+2*v2+2*v3+v4 */ v_linlist(temp, v1, 1.0, v2, 2.0, v3, 2.0, v4, 1.0, VNULL); /* adjust x */ v_mltadd(x,temp,h/6.0,x); /* x = x+(h/6)*temp */ return t+h; /* return the new time */ } 5. A LEAST SQUARES PROBLEM Here we need to use matrices and matrix factorisations (in particular, a QR factorisation) in order to find the best linear least squares solution to some data. Thus in order to solve the (approximate) equations A*x = b, where A is an m x n matrix (m > n) we really need to solve the optimisation problem min_x ||Ax-b||^2. If we write A=QR where Q is an orthogonal m x m matrix and R is an upper triangular m x n matrix then (we use 2-norm) ||A*x-b||^2 = ||R*x-Q^T*b||^2 = || R_1*x - Q_1^T*b||^2 + ||Q_2^T*b||^2 where R_1 is an n x n upper triangular matrix. If A has full rank then R_1 will be an invertible matrix, and the best least squares solution of A*x=b is x= R_1^{-1}*Q_1^T*b . These calculations can be be done quite easily as there is a QRfactor() function available with the system. QRfactor() is declared to have the prototype MAT *QRfactor(MAT *A, VEC *diag); The matrix A is overwritten with the factorisation of A ``in compact form''; that is, while the upper triangular part of A is indeed the R matrix described above, the Q matrix is stored as a collection of Householder vectors in the strictly lower triangular part of A and in the diag vector. The QRsolve() function knows and uses this compact form and solves Q*R*x=b with the call QRsolve(A,diag,b,x), which also returns x. Here is the code to obtain the matrix A, perform the QR factorisation, obtain the data vector b, solve for x, and determine what the norm of the errors ( ||Ax-b||_2 ) is. #include "matrix2.h" main() { MAT *A, *QR; VEC *b, *x, *diag; /* read in A matrix */ printf("Input A matrix:"); A = m_input(MNULL); /* A has whatever size is input */ if ( A->m < A->n ) { printf("Need m >= n to obtain least squares fit"); exit(0); } printf("# A ="); m_output(A); diag = v_get(A->m); /* QR is to be the QR factorisation of A */ QR = m_copy(A,MNULL); QRfactor(QR,diag); /* read in b vector */ printf("Input b vector:"); b = v_get(A->m); b = v_input(b); printf("# b ="); v_output(b); /* solve for x */ x = QRsolve(QR,diag,b,VNULL); printf("Vector of best fit parameters is"); v_output(x); /* ... and work out norm of errors... */ printf("||A*x-b|| = %g\n", v_norm2(v_sub(mv_mlt(A,x,VNULL),b,VNULL))); } Note that as well as the usual memory allocation functions like m_get(), the I/O functions like m_input() and m_output(), and the factorise-and-solve functions QRfactor() and QRsolve(), there are also functions for matrix-vector multiplication: mv_mlt(MAT *A, VEC *x, VEC *out) and also vector-matrix multiplication (with the vector on the left): vm_mlt(MAT *A, VEC *x, VEC *out), with out=x^T A. There are also functions to perform matrix arithmetic - matrix addition m_add(), matrix-scalar multiplication sm_mlt(), matrix-matrix multiplication m_mlt(). Several different sorts of matrix factorisation are supported: LU factorisation (also known as Gaussian elimination) with partial pivoting, by LUfactor() and LUsolve(). Other factorisation methods include Cholesky factorisation CHfactor() and CHsolve(), and QR factorisation with column pivoting QRCPfactor(). Pivoting involve permutations which have their own PERM data structure. Permutations can be created by px_get(), read and written by px_input() and px_output(), multiplied by px_mlt(), inverted by px_inv() and applied to vectors by px_vec(). The above program can be put into a file leastsq.c and compiled under Unix using cc -o leastsq leastsq.c meschach.a -lm A sample session using leastsq follows: Input A matrix: Matrix: rows cols:5 3 row 0: entry (0,0): 3 entry (0,1): -1 entry (0,2): 2 Continue: row 1: entry (1,0): 2 entry (1,1): -1 entry (1,2): 1 Continue: n row 1: entry (1,0): old 2 new: 2 entry (1,1): old -1 new: -1 entry (1,2): old 1 new: 1.2 Continue: row 2: entry (2,0): old 0 new: 2.5 .... .... (Data entry) .... # A = Matrix: 5 by 3 row 0: 3 -1 2 row 1: 2 -1 1.2 row 2: 2.5 1 -1.5 row 3: 3 1 1 row 4: -1 1 -2.2 Input b vector: entry 0: old 0 new: 5 entry 1: old 0 new: 3 entry 2: old 0 new: 2 entry 3: old 0 new: 4 entry 4: old 0 new: 6 # b = Vector: dim: 5 5 3 2 4 6 Vector of best fit parameters is Vector: dim: 3 1.47241555 -0.402817858 -1.14411815 ||A*x-b|| = 6.78938 The Q matrix can be obtained explicitly by the routine makeQ(). The Q matrix can then be used to obtain an orthogonal basis for the range of A . An orthogonal basis for the null space of A can be obtained by finding the QR-factorisation of A^T . 6. A SPARSE MATRIX EXAMPLE To illustrate the sparse matrix routines, consider the problem of solving Poisson's equation on a square using finite differences, and incomplete Cholesky factorisation. The actual equations to solve are u_{i,j+1} + u_{i,j-1} + u_{i+1,j} + u_{i-1,j} - 4*u_{i,j} = h^2*f(x_i,y_j), for i,j=1,...,N where u_{0,j} = u_{i,0} = u_{N+1,j} = u_{i,N+1} = 0 for i,j=1,...,N and h is the common distance between grid points. The first task is to set up the matrix describing this system of linear equations. The next is to set up the right-hand side. The third is to form the incomplete Cholesky factorisation of this matrix, and finally to use the sparse matrix conjugate gradient routine with the incomplete Cholesky factorisation as preconditioner. Setting up the matrix and right-hand side can be done by the following code: #define N 100 #define index(i,j) (N*((i)-1)+(j)-1) ...... A = sp_get(N*N,N*N,5); b = v_get(N*N); h = 1.0/(N+1); /* for a unit square */ ...... for ( i = 1; i <= N; i++ ) for ( j = 1; j <= N; j++ ) { if ( i < N ) sp_set_val(A,index(i,j),index(i+1,j),-1.0); if ( i > 1 ) sp_set_val(A,index(i,j),index(i-1,j),-1.0); if ( j < N ) sp_set_val(A,index(i,j),index(i,j+1),-1.0); if ( j > 1 ) sp_set_val(A,index(i,j),index(i,j-1),-1.0); sp_set_val(A,index(i,j),index(i,j),4.0); b->ve[index(i,j)] = -h*h*f(h*i,h*j); } Once the matrix and right-hand side are set up, the next task is to compute the sparse incomplete Cholesky factorisation of A. This must be done in a different matrix, so A must be copied. LLT = sp_copy(A); spICHfactor(LLT); Now when that is done, the remainder is easy: out = v_get(A->m); ...... iter_spcg(A,LLT,b,1e-6,out,1000,&num_steps); printf("Number of iterations = %d\n",num_steps); ...... and the output can be used in whatever way desired. For graphical output of the results, the solution vector can be copied into a square matrix, which is then saved in MATLAB format using m_save(), and graphical output can be produced by MATLAB. 7. HOW DO I ....? For the convenience of the user, here a number of common tasks that people need to perform frequently, and how to perform the computations using Meschach. 7.1 .... SOLVE A SYSTEM OF LINEAR EQUATIONS ? If you wish to solve Ax=b for x given A and b (without destroying A), then the following code will do this: VEC *x, *b; MAT *A, *LU; PERM *pivot; ...... LU = m_get(A->m,A->n); LU = m_copy(A,LU); pivot = px_get(A->m); LUfactor(LU,pivot); /* set values of b here */ x = LUsolve(LU,pivot,b,VNULL); 7.2 .... SOLVE A LEAST-SQUARES PROBLEM ? To minimise ||Ax-b||_2^2 = sum_i ((Ax)_i-b_i)^2, the most reliable method is based on the QR-factorisation. The following code performs this calculation assuming that A is m x n with m > n : MAT *A, *QR; VEC *diag, *b, *x; ...... QR = m_get(A->m,A->n); QR = m_copy(A,QR); diag = v_get(A->n); QRfactor(QR,diag); /* set values of b here */ x = QRsolve(QR,diag,b,x); 7.3 .... FIND ALL THE EIGENVALUES (AND EIGENVECTORS) OF A GENERAL MATRIX ? The best method is based on the Schur decomposition. For symmetric matrices, the eigenvalues and eigenvectors can be computed by a single call to symmeig(). For non-symmetric matrices, the situation is more complex and the problem of finding eigenvalues and eigenvectors can become quite ill-conditioned. Provided the problem is not too ill-conditioned, the following code should give accurate results: /* A is the matrix whose eigenvalues and eigenvectors are sought */ MAT *A, *T, *Q, *X_re, *X_im; VEC *evals_re, *evals_im; ...... Q = m_get(A->m,A->n); T = m_copy(A,MNULL); /* compute Schur form: A = Q*T*Q^T */ schur(T,Q); /* extract eigenvalues */ evals_re = v_get(A->m); evals_im = v_get(A->m); schur_evals(T,evals_re,evals_im); /* Q not needed for eiegenvalues */ X_re = m_get(A->m,A->n); X_im = m_get(A->m,A->n); schur_vecs(T,Q,X_re,X_im); /* k'th eigenvector is k'th column of (X_re + i*X_im) */ 7.4 .... SOLVE A LARGE, SPARSE, POSITIVE DEFINITE SYSTEM OF EQUATIONS ? An example of a large, sparse, positive definite matrix is the matrix obtained from a finite-difference approximation of the Laplacian operator. If an explicit representation of such a matrix is available, then the following code is suggested as a reasonable way of computing solutions: /* A*x == b is the system to be solved */ SPMAT *A, *LLT; VEC *x, *b; int num_steps; ...... /* set up A and b */ ...... x = m_get(A->m); LLT = sp_copy(A); /* preconditioning using the incomplete Cholesky factorisation */ spICHfactor(LLT); /* now use pre-conditioned conjugate gradients */ x = iter_spcg(A,LLT,b,1e-7,x,1000,&num_steps); /* solution computed to give a relative residual of 10^-7 */ If explicitly storing such a matrix takes up too much memory, then if you can write a routine to perform the calculation of A*x for any given x , the following code may be more suitable (if slower): VEC *mult_routine(user_def,x,out) void *user_def; VEC *x, *out; { /* compute out = A*x */ ...... return out; } main() { ITER *ip; VEC *x, *b; ...... b = v_get(BIG_DIM); /* right-hand side */ x = v_get(BIG_DIM); /* solution */ /* set up b */ ...... ip = iter_get(b->dim, x->dim); ip->b = v_copy(b,ip->b); ip->info = NULL; /* if you don't want information about solution process */ v_zero(ip->x); /* initial guess is zero */ iter_Ax(ip,mult_routine,user_def); iter_cg(ip); printf("# Solution is:\n"); v_output(ip->x); ...... ITER_FREE(ip); /* destroy ip */ } The user_def argument is for a pointer to a user-defined structure (possibly NULL, if you don't need this) so that you can write a common function for handling a large number of different circumstances. 8. MORE ADVANCED TOPICS Read this if you are interested in using Meschach library as a base for applications. As an example we show how to implement a new type for 3 dimensional matrices and incorporate this new type into the Meschach system. Usually this part of Meschach is transparent to a user. But a more advanced user can take advantage of these routines. We do not describe the routines in detail here, but we want to give a rather broad picture of what can be done. By the system we mainly mean the system of delivering information on the number of bytes of allocated memory and routines for deallocating static variables by mem_stat_... routines. First we introduce a concept of a list of types. By a list of types we mean a set of different types with corresponding routines for creating these types, destroying and resizing them. Each type list has a number. The list 0 is a list of standard Meschach types such as MAT or VEC. Other lists can be defined by a user or a application (based on Meschach). The user can attach his/her own list to the system by the routine mem_attach_list(). Sometimes it is worth checking if a list number is already used by another application. It can be done by mem_is_list_attached(ls_num), which returns TRUE if the number ls_num is used. And such a list can be removed from the system by mem_free_list(ls_num) if necessary. We describe arguments required by mem_attach_list(). The prototype of this function is as follow int mem_attach_list(int ls_num, int ntypes, char *type_names[], int (*free_funcs[])(), MEM_ARRAY sum[]); where the structure MEM_ARRAY has two members: "bytes" of type long and "numvar" of type int. The frst argument is the list number. Note that you cannot overwrite another list. To do this remove first the old list (by mem_free_list()) or choose another number. The next argument is the number of types which are on the list. This number cannot be changed during running a program. The third argument is an array containing the names of types (these are character strings). The fourth one is an array of functions deallocating variables of the corresponding type. And the last argument is the local array where information about the number of bytes of allocated/deallocated memory (member bytes) and the number of allocated variables (member numvar) are gathered. The functions which send information to this array are mem_bytes_list() and mem_numvar_list(). Example: The routines described here are in the file tutadv.c. Firstly we define some macros and a type for 3 dimensional matrices. #include "matrix.h" #define M3D_LIST 3 /* list number */ #define TYPE_MAT3D 0 /* the number of a type */ /* type for 3 dimensional matrices */ typedef struct { int l,m,n; /* actual dimensions */ int max_l, max_m, max_n; /* maximal dimensions */ Real ***me; /* pointer to matrix elements */ /* we do not consider segmented memory */ Real *base, **me2d; /* me and me2d are additional pointers to base */ } MAT3D; Now we need two routines: one for allocating memory for 3 dimensional matrices and the other for deallocating it. It can be useful to have a routine for resizing 3 dimensional matrices but we do not use it here. Note the use of mem_bytes_list() and mem_numvar_list() to notify the change in the number of structures and bytes in use. /* function for creating a variable of MAT3D type */ MAT3D *m3d_get(l,m,n) int l,m,n; { MAT3D *mat; .... /* alocate memory for structure */ if ((mat = NEW(MAT3D)) == (MAT3D *)NULL) error(E_MEM,"m3d_get"); else if (mem_info_is_on()) { /* record how many bytes are allocated to structure */ mem_bytes_list(TYPE_MAT3D,0,sizeof(MAT3D),M3D_LIST); /* record a new allocated variable */ mem_numvar_list(TYPE_MAT3D,1,M3D_LIST); } .... /* allocate memory for 3D array */ if ((mat->base = NEW_A(l*m*n,Real)) == (Real *)NULL) error(E_MEM,"m3d_get"); else if (mem_info_is_on()) mem_bytes_list(TYPE_MAT3D,0,l*m*n*sizeof(Real),M3D_LIST); .... return mat; } /* deallocate a variable of type MAT3D */ int m3d_free(mat) MAT3D *mat; { /* do not try to deallocate the NULL pointer */ if (mat == (MAT3D *)NULL) return -1; .... /* first deallocate base */ if (mat->base != (Real *)NULL) { if (mem_info_is_on()) /* record how many bytes is deallocated */ mem_bytes_list(TYPE_MAT3D,mat->max_l*mat->max_m*mat->max_n*sizeof(Real), 0,M3D_LIST); free((char *)mat->base); } .... /* deallocate MAT3D structure */ if (mem_info_is_on()) { mem_bytes_list(TYPE_MAT3D,sizeof(MAT3D),0,M3D_LIST); mem_numvar_list(TYPE_MAT3D,-1,M3D_LIST); } free((char *)mat); .... free((char *)mat); return 0; } We can now create the arrays necessary for mem_attach_list(). Note that m3d_sum can be static if it is in the same file as main(), where mem_attach_list is called. Otherwise it must be global. char *m3d_names[] = { "MAT3D" }; #define M3D_NUM (sizeof(m3d_names)/sizeof(*m3d_names)) int (*m3d_free_funcs[M3D_NUM])() = { m3d_free } static MEM_ARRAY m3d_sum[M3D_NUM]; The last thing is to attach the list to the system. void main() { MAT3D *M; .... mem_info_on(TRUE); /* switch memory info on */ /* attach the new list */ mem_attach_list(M3D_LIST,M3D_NUM,m3d_names,m3d_free_funcs,m3d_sum); .... M = m3d_get(3,4,5); .... /* making use of M->me[i][j][k], where i,j,k are non-negative and i < 3, j < 4, k < 5 */ .... mem_info_file(stdout,M3D_LIST); /* info on the number of allocated bytes of memory for types on the list M3D_LIST */ .... m3d_free(M); /* if M is not necessary */ .... } We can now use the function mem_info_file() for getting information about the number of bytes of allocated memory and number of allocated variables of type MAT3D; mem_stat_reg_list() for registering variables of this type and mem_stat_mark() and mem_stat_free_list() for deallocating static variables of this type. In the similar way you can create you own list of errors and attach it to the system. See the functions: int err_list_attach(int list_num, int list_len, char **err_ptr, int warn); /* for attaching a list of errors */ int err_is_list_attached(int list_num); /* checking if a list is attached */ extern int err_list_free(int list_num); /* freeing a list of errors */ where list_num is the number of the error list, list_len is the number of errors on the list, err_ptr is the character string explaining the error and warn can be TRUE if this is only a warning (the program continues to run) or it can be FALSE if it is an error (the program stops). The examples are the standard errors (error list 0) and warnings (error list 1) which are in the file err.c David Stewart and Zbigniew Leyk, 1993