INT NS_DIM_PREFIX CheckSymmetryOfMatrix (GRID *theGrid, MATDATA_DESC *A)
{
MATRIX *m,*mt;
VECTOR *v,*w;
DOUBLE *mptr,*mtptr;
register SHORT i,j,rcomp,ccomp,*mcomp,*mtcomp,vtype,mtype;
for (v=FIRSTVECTOR(theGrid); v!=NULL; v=SUCCVC(v)) {
vtype = VTYPE(v);
for (m=VSTART(v); m!=NULL; m=MNEXT(m)) {
mt = MADJ(m);
w = MDEST(m);
mtype = MTP(vtype,VTYPE(w));
rcomp = MD_ROWS_IN_MTYPE(A,mtype);
if (rcomp == 0) continue;
ccomp = MD_COLS_IN_MTYPE(A,mtype);
if (ccomp == 0) continue;
mcomp = MD_MCMPPTR_OF_MTYPE(A,mtype);
mptr = MVALUEPTR(m,0);
mtcomp = MD_MCMPPTR_OF_MTYPE(A,MTP(VTYPE(w),vtype));
mtptr = MVALUEPTR(m,0);
for (i=0; i<ccomp; i++)
for (j=0; j<rcomp; j++)
if (mptr[mcomp[i*rcomp+j]] != mtptr[mtcomp[j*ccomp+i]])
return(1);
}
}
return(0);
}
char *
convexp(char *re)
/* re - unconverted irregular expression */
{
char *cre; /* pointer to converted regular expression */
/* allocate room for the converted expression */
if (re == NIL)
return (NIL);
if (*re == '\0')
return (NIL);
cre = malloc (4 * strlen(re) + 3);
ccre = cre;
ure = re;
/* start the conversion with a \a */
*cre = META | OPT;
MSYM(cre) = 'a';
ccre = MNEXT(cre);
/* start the conversion (its recursive) */
expconv ();
*ccre = 0;
return (cre);
}
INT l_nlgs (NP_NLGS *nlgs, NP_NL_ASSEMBLE *ass, GRID *grid, const DOUBLE *damp,
VECDATA_DESC *x, VECDATA_DESC *v, MATDATA_DESC *M,
VECDATA_DESC *d)
{
VECTOR *vec,*w,*first_vec;
NODE *theNode;
MULTIGRID *mg;
INT level;
INT rtype,ctype,myindex,error;
register MATRIX *mat;
register SHORT *tmpptr,*dcomp,*xcomp,*vcomp;
register SHORT i;
register SHORT n;
DEFINE_VD_CMPS(cy);
DEFINE_MD_CMPS(m);
DOUBLE r[MAX_SINGLE_VEC_COMP];
mg = nlgs->smoother.iter.base.mg;
level = GLEVEL(grid);
first_vec = FIRSTVECTOR(grid);
L_VLOOP__CLASS(vec,first_vec,ACTIVE_CLASS)
{
rtype = VTYPE(vec);
/* get node */
theNode = (NODE*)VOBJECT(vec);
n = VD_NCMPS_IN_TYPE(v,rtype);
if (n == 0) continue;
dcomp = VD_CMPPTR_OF_TYPE(d,rtype);
xcomp = VD_CMPPTR_OF_TYPE(x,rtype);
vcomp = VD_CMPPTR_OF_TYPE(v,rtype);
myindex = VINDEX(vec);
/* local Jacobi matrix */
if ((*ass->NLNAssembleMatrix)(ass,level,level,theNode,x,d,v,M,&error)) {
error = __LINE__;
REP_ERR_RETURN(error);
}
/* get defect */
for (i=0; i<n; i++)
r[i] = VVALUE(vec,dcomp[i]);
/* rhs */
for (ctype=0; ctype<=NVECTYPES; ctype++)
if (MD_ROWS_IN_RT_CT(M,rtype,ctype)>0)
{
SET_CMPS_22(cy,v,m,M,rtype,ctype,tmpptr);
s0 = s1 = 0.0;
for (mat=MNEXT(VSTART(vec)); mat!=NULL; mat=MNEXT(mat))
if (((VTYPE(w=MDEST(mat))==ctype) && (VCLASS(w)>=ACTIVE_CLASS)) && (myindex>VINDEX(w)))
MATMUL_22(s,mat,m,w,cy);
r[0] -= s0;
r[1] -= s1;
}
/* solve */
if (MySolveSmallBlock(n,VD_CMPPTR_OF_TYPE(v,rtype),VVALPTR(vec),
MD_MCMPPTR_OF_RT_CT(M,rtype,rtype),
MVALPTR(VSTART(vec)),r)!=0)
return (__LINE__);
/* damp */
for (i=0; i<n; i++)
VVALUE(vec,vcomp[i]) *= damp[i];
/* update solution */
for (i=0; i<n; i++)
VVALUE(vec,xcomp[i]) -= VVALUE(vec,vcomp[i]);
}
static INT AMGSolverPreProcess (NP_LINEAR_SOLVER *theNP, INT level,
VECDATA_DESC *VD_x, VECDATA_DESC *VD_b,
MATDATA_DESC *MD_A,
INT *baselevel, INT *result)
{
MULTIGRID *theMG;
GRID *theGrid;
int n,nonzeros,blocksize;
int Acomp;
MATRIX *theMatrix;
VECTOR *theVector;
int i,j,block_i,block_j;
int nRows_A,nCols_A,nComp_x,nComp_b;
NP_AMG *theAMGC;
double ti;
int ii;
#ifdef ModelP
double clock_start;
#else
clock_t clock_start;
#endif
theAMGC = (NP_AMG *) theNP;
/* prepare solving */
theMG = theAMGC->ls.base.mg;
theGrid = GRID_ON_LEVEL(theMG,level);
/* mark heap for use by amg */
#ifndef DYNAMIC_MEMORY_ALLOCMODEL
Mark(MGHEAP(theMG),FROM_BOTTOM,&amg_MarkKey);
#else
Mark(MGHEAP(theMG),FROM_TOP,&amg_MarkKey);
#endif
mark_counter++;
/* initialize sp package */
AMG_InstallPrintHandler((AMG_PrintFuncPtr)UserWrite);
amgMG=theMG; /* make it global for memory handler */
AMG_InstallMallocHandler((AMG_MallocFuncPtr)amgmalloc);
/* get access to components */
nRows_A = MD_ROWS_IN_RT_CT(MD_A,NODEVEC,NODEVEC);
nCols_A = MD_COLS_IN_RT_CT(MD_A,NODEVEC,NODEVEC);
nComp_x = VD_NCMPS_IN_TYPE(VD_x,NODEVEC);
nComp_b = VD_NCMPS_IN_TYPE(VD_b,NODEVEC);
blocksize = nComp_x;
if (blocksize==0) goto exit;
if (nComp_b!=blocksize) goto exit;
if (nCols_A!=blocksize) goto exit;
if (nRows_A!=blocksize) goto exit;
Acomp = MD_MCMP_OF_RT_CT(MD_A,NODEVEC,NODEVEC,0);
CSTART(); ti=0; ii=0;
/* diagonal scaling */
if (theAMGC->scale)
if (DiagonalScaleSystem(theGrid,MD_A,MD_A,VD_b)!=NUM_OK)
{
UserWrite("Error in scaling system\n");
goto exit;
}
/* gather some data for the matrix */
n = nonzeros = 0;
/* loop through all vectors, we assume there are only node vectors ! */
for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
{
VINDEX(theVector) = n++; /* renumber vectors just to be sure ... */
/* now speed through this row */
for (theMatrix=VSTART(theVector); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
nonzeros++;
}
#ifdef ModelP
if (me == master)
{
#endif
/* now allocate fine grid vectors x and b */
theAMGC->x = AMG_NewVector(n*blocksize,1,"x");
if (theAMGC->x==NULL) {
UserWrite("no memory for x\n");
goto exit;
}
theAMGC->b = AMG_NewVector(n*blocksize,1,"b");
if (theAMGC->b==NULL) {
UserWrite("no memory for b\n");
goto exit;
}
/* and a new matrix */
theAMGC->A = AMG_NewMatrix(n*blocksize,1,nonzeros*blocksize*blocksize,blocksize,"fine grid A");
if (theAMGC->A==NULL) {
UserWrite("no memory for A\n");
goto exit;
}
#ifdef ModelP
}
else
{
/* no master vectors allowed */
assert(n==0);
/* only master builds up coarse levels */
return (0);
}
#endif
/* now fill matrix */
for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
{
i = VINDEX(theVector);
/* count row length */
nonzeros=0;
for (theMatrix=VSTART(theVector); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
nonzeros++;
/* for each row */
for (block_i=0; block_i<blocksize; block_i++)
{
/* allocate row */
if (AMG_SetRowLength(theAMGC->A,i*blocksize+block_i,nonzeros*blocksize)!=AMG_OK)
{
UserWrite("Error in AMG_SetRowLength\n");
goto exit;
}
/* the diagonal block, be careful to allocate the main diagonal first */
theMatrix=VSTART(theVector);
if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,i*blocksize+block_i,
&(MVALUE(theMatrix,Acomp+block_i*blocksize+block_i)))<0)
{
UserWrite("Error in AMG_InsertValues\n");
goto exit;
}
for (block_j=0; block_j<blocksize; block_j++)
{
if (block_j==block_i) continue;
if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,i*blocksize+block_j,
&(MVALUE(theMatrix,Acomp+block_i*blocksize+block_j)))<0)
{
UserWrite("Error in AMG_InsertValues\n");
goto exit;
}
}
/* all the offdiagonal blocks */
for (theMatrix=MNEXT(VSTART(theVector)); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
{
j = VINDEX(MDEST(theMatrix));
for (block_j=0; block_j<blocksize; block_j++)
{
if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,j*blocksize+block_j,
&(MVALUE(theMatrix,Acomp+block_i*blocksize+block_j)))<0)
{
UserWrite("Error in AMG_InsertValues\n");
goto exit;
}
}
}
}
}
/*AMG_PrintMatrix(theAMGC->A,"Matrix");*/
/* call algebraic multigrid solver */
if (AMG_Build(&theAMGC->sc,&theAMGC->cc,theAMGC->A)!=AMG_OK) theAMGC->AMG_Build_failed=1;
theAMGC->AMG_Build_failed=0;
CSTOP(ti,ii);
if (theAMGC->sc.verbose>0)
UserWriteF("AMG : L=%2d BUILD=%10.4g\n",level,ti);
return(0); /* ok, matrix is set up */
exit: /* error */
if (mark_counter>0) {
#ifndef DYNAMIC_MEMORY_ALLOCMODEL
Release(MGHEAP(theMG),FROM_BOTTOM,amg_MarkKey);
#else
Release(MGHEAP(theMG),FROM_TOP,amg_MarkKey);
#endif
mark_counter--;
}
return(1);
}
char *
expmatch(char *s, char *re, char *mstring)
/* s - string to check for a match in */
/* re - a converted irregular expression */
/* mstring - where to put whatever matches a \p */
{
char *cs; /* the current symbol */
char *ptr, *s1; /* temporary pointer */
boolean matched; /* a temporary boolean */
/* initial conditions */
if (re == NIL)
return (NIL);
cs = re;
matched = FALSE;
/* loop till expression string is exhausted (or at least pretty tired) */
while (*cs) {
switch (*cs & (OPER | STR | META)) {
/* try to match a string */
case STR:
matched = !STRNCMP (s, SSTR(cs), SCNT(cs));
if (matched) {
/* hoorah it matches */
s += SCNT(cs);
cs = SNEXT(cs);
} else if (*cs & ALT) {
/* alternation, skip to next expression */
cs = SNEXT(cs);
} else if (*cs & OPT) {
/* the match is optional */
cs = SNEXT(cs);
matched = 1; /* indicate a successful match */
} else {
/* no match, error return */
return (NIL);
}
break;
/* an operator, do something fancy */
case OPER:
switch (OSYM(cs)) {
/* this is an alternation */
case '|':
if (matched)
/* last thing in the alternation was a match, skip ahead */
cs = OPTR(cs);
else
/* no match, keep trying */
cs = ONEXT(cs);
break;
/* this is a grouping, recurse */
case '(':
ptr = expmatch (s, ONEXT(cs), mstring);
if (ptr != NIL) {
/* the subexpression matched */
matched = 1;
s = ptr;
} else if (*cs & ALT) {
/* alternation, skip to next expression */
matched = 0;
} else if (*cs & OPT) {
/* the match is optional */
matched = 1; /* indicate a successful match */
} else {
/* no match, error return */
return (NIL);
}
cs = OPTR(cs);
break;
}
break;
/* try to match a metasymbol */
case META:
switch (MSYM(cs)) {
/* try to match anything and remember what was matched */
case 'p':
/*
* This is really the same as trying the match the
* remaining parts of the expression to any subset
* of the string.
*/
s1 = s;
do {
ptr = expmatch (s1, MNEXT(cs), mstring);
if (ptr != NIL && s1 != s) {
/* we have a match, remember the match */
strncpy (mstring, s, s1 - s);
mstring[s1 - s] = '\0';
return (ptr);
} else if (ptr != NIL && (*cs & OPT)) {
/* it was aoptional so no match is ok */
return (ptr);
} else if (ptr != NIL) {
/* not optional and we still matched */
return (NIL);
}
if (!isidchr(*s1))
return (NIL);
if (*s1 == '\\')
_escaped = _escaped ? FALSE : TRUE;
else
_escaped = FALSE;
} while (*s1++);
return (NIL);
/* try to match anything */
case 'a':
/*
* This is really the same as trying the match the
* remaining parts of the expression to any subset
* of the string.
*/
s1 = s;
do {
ptr = expmatch (s1, MNEXT(cs), mstring);
if (ptr != NIL && s1 != s) {
/* we have a match */
return (ptr);
} else if (ptr != NIL && (*cs & OPT)) {
/* it was aoptional so no match is ok */
return (ptr);
} else if (ptr != NIL) {
/* not optional and we still matched */
return (NIL);
}
if (*s1 == '\\')
_escaped = _escaped ? FALSE : TRUE;
else
_escaped = FALSE;
} while (*s1++);
return (NIL);
/* fail if we are currently _escaped */
case 'e':
if (_escaped)
return(NIL);
cs = MNEXT(cs);
break;
/* match any number of tabs and spaces */
case 'd':
ptr = s;
while (*s == ' ' || *s == '\t')
s++;
if (s != ptr || s == Start) {
/* match, be happy */
matched = 1;
cs = MNEXT(cs);
} else if (*s == '\n' || *s == '\0') {
/* match, be happy */
matched = 1;
cs = MNEXT(cs);
} else if (*cs & ALT) {
/* try the next part */
matched = 0;
cs = MNEXT(cs);
} else if (*cs & OPT) {
/* doesn't matter */
matched = 1;
cs = MNEXT(cs);
} else
/* no match, error return */
return (NIL);
break;
/* check for end of line */
case '$':
if (*s == '\0' || *s == '\n') {
/* match, be happy */
s++;
matched = 1;
cs = MNEXT(cs);
} else if (*cs & ALT) {
/* try the next part */
matched = 0;
cs = MNEXT(cs);
} else if (*cs & OPT) {
/* doesn't matter */
matched = 1;
cs = MNEXT(cs);
} else
/* no match, error return */
return (NIL);
break;
/* check for start of line */
case '^':
if (s == Start) {
/* match, be happy */
matched = 1;
cs = MNEXT(cs);
} else if (*cs & ALT) {
/* try the next part */
matched = 0;
cs = MNEXT(cs);
} else if (*cs & OPT) {
/* doesn't matter */
matched = 1;
cs = MNEXT(cs);
} else
/* no match, error return */
return (NIL);
break;
/* end of a subexpression, return success */
case ')':
return (s);
}
break;
}
}
return (s);
}
static void
expconv(void)
{
char *cs; /* pointer to current symbol in converted exp */
char c; /* character being processed */
char *acs; /* pinter to last alternate */
int temp;
/* let the conversion begin */
acs = NIL;
cs = NIL;
while (*ure != NIL) {
switch (c = *ure++) {
case '\\':
switch (c = *ure++) {
/* escaped characters are just characters */
default:
if (cs == NIL || (*cs & STR) == 0) {
cs = ccre;
*cs = STR;
SCNT(cs) = 1;
ccre += 2;
} else
SCNT(cs)++;
*ccre++ = c;
break;
/* normal(?) metacharacters */
case 'a':
case 'd':
case 'e':
case 'p':
if (acs != NIL && acs != cs) {
do {
temp = OCNT(acs);
OCNT(acs) = ccre - acs;
acs -= temp;
} while (temp != 0);
acs = NIL;
}
cs = ccre;
*cs = META;
MSYM(cs) = c;
ccre = MNEXT(cs);
break;
}
break;
/* just put the symbol in */
case '^':
case '$':
if (acs != NIL && acs != cs) {
do {
temp = OCNT(acs);
OCNT(acs) = ccre - acs;
acs -= temp;
} while (temp != 0);
acs = NIL;
}
cs = ccre;
*cs = META;
MSYM(cs) = c;
ccre = MNEXT(cs);
break;
/* mark the last match sequence as optional */
case '?':
if (cs)
*cs = *cs | OPT;
break;
/* recurse and define a subexpression */
case '(':
if (acs != NIL && acs != cs) {
do {
temp = OCNT(acs);
OCNT(acs) = ccre - acs;
acs -= temp;
} while (temp != 0);
acs = NIL;
}
cs = ccre;
*cs = OPER;
OSYM(cs) = '(';
ccre = ONEXT(cs);
expconv ();
OCNT(cs) = ccre - cs; /* offset to next symbol */
break;
/* return from a recursion */
case ')':
if (acs != NIL) {
do {
temp = OCNT(acs);
OCNT(acs) = ccre - acs;
acs -= temp;
} while (temp != 0);
acs = NIL;
}
cs = ccre;
*cs = META;
MSYM(cs) = c;
ccre = MNEXT(cs);
return;
/* mark the last match sequence as having an alternate */
/* the third byte will contain an offset to jump over the */
/* alternate match in case the first did not fail */
case '|':
if (acs != NIL && acs != cs)
OCNT(ccre) = ccre - acs; /* make a back pointer */
else
OCNT(ccre) = 0;
*cs |= ALT;
cs = ccre;
*cs = OPER;
OSYM(cs) = '|';
ccre = ONEXT(cs);
acs = cs; /* remember that the pointer is to be filles */
break;
/* if its not a metasymbol just build a scharacter string */
default:
if (cs == NIL || (*cs & STR) == 0) {
cs = ccre;
*cs = STR;
SCNT(cs) = 1;
ccre = SSTR(cs);
} else
SCNT(cs)++;
*ccre++ = c;
break;
}
}
if (acs != NIL) {
do {
temp = OCNT(acs);
OCNT(acs) = ccre - acs;
acs -= temp;
} while (temp != 0);
acs = NIL;
}
}
