void Hex::fill_column(double **Mat, int loc, Bsystem *B, int nm, int offset){
int N,ll,tid,gid;
const int nvs = B->nv_solve, nes = B->ne_solve;
int *e = B->edge;
register int j;
N = Nmodes-Nbmodes;
for(j = 0; j < NHex_verts; ++j)
if(vert[j].gid < nvs)
Mat[vert[j].gid][loc] += vert[j].hj[0];
for(j = 0; j < NHex_edges; ++j)
if((gid = edge[j].gid) < nes){
ll = edge[j].l;
dvadd(ll,edge[j].hj,1,Mat[e[gid]]+loc,nm,Mat[e[gid]]+loc,nm);
}
tid = B->nsolve + offset;
if(N) dvadd(N,*face->hj,1,Mat[tid]+loc,nm,Mat[tid]+loc,nm);
}
main()
{
/* test program for above utility routines */
double **a, **b, **c, **bT;
double *x, *y, *z;
FILE *infile, *outfile;
int a_rows, a_cols, b_rows, b_cols, errors, xn, yn;
infile = fopen("mat.in", "r");
outfile = fopen("mat.dat", "w");
a = dReadMatrix( infile, &a_rows, &a_cols, &errors);
b = dReadMatrix( infile, &b_rows, &b_cols, &errors);
x = dReadVector( infile, &xn, &errors);
y = dReadVector( infile, &yn, &errors);
getchar();
dmdump( stdout, "Matrix A", a, a_rows, a_cols, "%8.2lf");
dmdump( stdout, "Matrix B", b, b_rows, b_cols, "%8.2lf");
dvdump( stdout, "Vector x", x, xn, "%8.2lf");
dvdump( stdout, "Vector y", y, yn, "%8.2lf");
z = dvector( 1, xn );
dvadd( x, xn, y, z );
dvdump( stdout, "x + y", z, xn, "%8.2lf");
dvsub( x, xn, y, z );
dvdump( stdout, "x - y", z, xn, "%8.2lf");
dvsmy( x, xn, 2.0, z );
dvdump( stdout, "2x", z, xn, "%8.2lf");
printf("Magnitude of 2x: %7.2lf\n", dvmag( z, xn ));
printf("dot product x.y: %7.2lf\n", dvdot( x, xn, y));
dmvmult( a, a_rows, a_cols, x, xn, z );
dvdump( stdout, "Ax", z, xn, "%8.2lf");
c = dmatrix( 1, a_rows, 1, b_cols );
bT = dmatrix( 1, b_cols, 1, b_rows );
dmtranspose( b, b_rows, b_cols, bT);
dmdump( stdout, "Matrix B (transposed)", bT, b_cols, b_rows, "%8.2lf");
dmmult( a, a_rows, a_cols, bT, b_cols, b_rows, c);
dmdump( stdout, "Matrix AB", c, a_rows, b_rows, "%8.2lf");
/* dmfillUT( a, a_rows, a_cols );
dmdump( stdout, "Symmetrified matrix A", a, a_rows, a_cols, "%8.2lf"); */
free_dmatrix( a, 1, a_rows, 1, a_cols);
free_dmatrix( b, 1, b_rows, 1, b_cols);
free_dmatrix( c, 1, a_rows, 1, b_cols);
free_dvector( x, 1, xn );
free_dvector( y, 1, yn );
}
/* This routine integrates the transformed values */
void integrate_CNAB(int Je, double dt, Element_List *U, Element_List *Uf[])
{
register int i;
int nq = U->hjtot*U->nz;
dsmul(nq, Beta_Int[Je-1]*dt, Uf[Je-1]->base_hj, 1, Uf[Je-1]->base_hj, 1);
for(i = 0; i < Je-1; ++i)
daxpy(nq, Beta_Int[i]*dt, Uf[i]->base_hj,1, Uf[Je-1]->base_hj, 1);
dvadd(nq, Uf[Je-1]->base_hj,1, U->base_hj, 1, U->base_hj, 1);
reshuffle(Uf,Je);
}
static void SetupRecur_Precon(Bsystem *B){
MatPre *M = B->Pmat = (MatPre *)malloc(sizeof(MatPre));
/* at present just store diagonal of whole matrix in M->ivert */
switch(B->Precon){
case Pre_Diag: /* diagonal preconditioner */
{
Rsolver *R = B->rslv;
int nsolve = R->rdata[R->nrecur-1].cstart;
double **a = R->A.a;
Recur *rdata = R->rdata + R->nrecur-1;
int npatch = rdata->npatch;
int *alen = rdata->patchlen_a;
int **map = rdata->map;
int i,n,pos;
M->info.diag.ndiag = nsolve;
M->info.diag.idiag = dvector(0,nsolve-1);
dzero(nsolve,M->info.diag.idiag,1);
for(n = 0; n < npatch; ++n)
for(i = 0,pos = 0; i < alen[n]; pos +=alen[n]-i,++i)
M->info.diag.idiag[map[n][i]] += a[n][pos];
InvtPrecon(B);
}
break;
case Pre_Block: /* block diagonal preconditioner */
{
#if 0
register int j,k;
int al, gid, gid1, pos, nvs = B->rslv->Ainfo.nv_solve;
Blockp Blk = B->rslv->precon->blk;
M->nvert = nvs;
if(nvs) {
M->ivert = dvector(0, nvs*(nvs+1)/2-1);
dzero(nvs*(nvs+1)/2,M->ivert,1);
}
M->nedge = Blk.nlgid;
M->Ledge = ivector(0,M->nedge-1);
M->iedge = (double **)malloc(M->nedge*sizeof(double *));
for(i = 0; i < npatch; ++i)
for(j = 0; j < Blk.nle[i]; ++j)
M->Ledge[Blk.lgid[i][j]] = Blk.edglen[i][j];
for(i = 0; i < M->nedge; ++i){
M->iedge[i] = dvector(0,M->Ledge[i]*(M->Ledge[i]+1)/2-1);
dzero(M->Ledge[i]*(M->Ledge[i]+1)/2,M->iedge[i],1);
}
/* For the iterative solver all the global vertex dof are
listed first then the local dof and finally the local edges */
for(i = 0; i < npatch; ++i){
al = alen[i];
for(j =0,pos = 0; j < Blk.ngv[i]; ++j, pos += al--){
gid = map[i][j];
M->ivert[(gid*(gid+1))/2 + gid*(nvs-gid)] += a[i][pos];
for(k = j+1; k < Blk.ngv[i]; ++k){
gid1 = map[i][k];
if(gid < gid1)
M->ivert[(gid*(gid+1))/2 + gid*(nvs-gid) + gid1-gid]
+= a[i][pos+k-j];
else if(gid == gid1) /* special case of periodic element */
M->ivert[(gid*(gid+1))/2 + gid*(nvs-gid1)]
+= 2*a[i][pos+k-j];
else
M->ivert[(gid1*(gid1+1))/2 + gid1*(nvs-gid1) + gid-gid1]
+= a[i][pos+k-j];
}
}
/* set up local blocks - note: it is assumed that the local
vertices are ordered in a similar fashion either side of
the patch */
for(j = 0; j < Blk.nle[i]; ++j){
for(k = 0,n=0; k < Blk.edglen[i][j];pos += al--,
n += Blk.edglen[i][j]-k, ++k)
dvadd(Blk.edglen[i][j]-k,a[i]+pos,1,M->iedge[Blk.lgid[i][j]]+n,1,
M->iedge[Blk.lgid[i][j]]+n,1);
}
}
InvtPrecon(B, nsolve);
#endif
fprintf(stderr,"H_MatrixR.C: iterative -r not implemented\n");
}
break;
case Pre_None: /* no preconditioner */
break;
default:
error_msg(Unknown value of PRECON);
break;
}
}
static void Bsolve_Stokes_PCG(Element_List **V, Bsystem **B, double *p){
int eDIM = V[0]->flist[0]->dim();
const int nsolve = B[eDIM]->nsolve;
int iter = 0;
double tolcg, alpha, beta, eps, rtz, rtz_old, epsfac;
static double *u0 = (double*)0;
static double *u = (double*)0;
static double *r = (double*)0;
static double *w = (double*)0;
static double *z = (double*)0, **wk;
static int nsol = 0, nglob = 0;
if(nsolve > nsol){
if(nsol){
free(u0); free(u); free(r); free(z); free_dmatrix(wk,0,0);
}
/* Temporary arrays */
u0 = dvector(0,B[eDIM]->nglobal-1);/* intial divergence-free solution */
u = dvector(0,nsolve-1); /* Solution */
r = dvector(0,nsolve-1); /* residual */
z = dvector(0,nsolve-1); /* precondition solution */
if(eDIM == 2)
wk = dmatrix(0,1,0,eDIM*4*LGmax);
else
wk = dmatrix(0,1,0,eDIM*6*LGmax*LGmax);
nsol = nsolve;
}
if(B[eDIM]->nglobal > nglob){
if(nglob)
free(w);
w = dvector(0,B[eDIM]->nglobal-1); /* A*Search direction */
nglob = B[eDIM]->nglobal;
}
divergence_free_init(V,u0,p,B,wk);
dzero (B[eDIM]->nglobal, w, 1);
dzero (nsolve, u, 1);
dcopy (nsolve, p, 1, r, 1);
tolcg = dparam("TOLCG");
epsfac = 1.0;
eps = sqrt(ddot(nsolve,r,1,r,1))*epsfac;
if (option("verbose") > 1)
printf("\t %3d iterations, error = %#14.6g %lg %lg\n",
iter, eps/epsfac, epsfac, tolcg);
rtz = eps;
/* =========================================================== *
* ---- Conjugate Gradient Iteration ---- *
* =========================================================== */
while (eps > tolcg && iter++ < MAX_ITERATIONS ){
/* while (sqrt(rtz) > tolcg && iter++ < MAX_ITERATIONS ){*/
Precon_Stokes(V[0],B[eDIM],r,z);
rtz = ddot (nsolve, r, 1, z, 1);
if (iter > 1) { /* Update search direction */
beta = rtz / rtz_old;
dsvtvp(nsolve, beta, p, 1, z, 1, p, 1);
}
else
dcopy(nsolve, z, 1, p, 1);
A_Stokes(V,B,p,w,wk);
alpha = rtz/ddot(nsolve, p, 1, w, 1);
daxpy(nsolve, alpha, p, 1, u, 1); /* Update solution... */
daxpy(nsolve,-alpha, w, 1, r, 1); /* ...and residual */
rtz_old = rtz;
eps = sqrt(ddot(nsolve, r, 1, r, 1))*epsfac; /* Compute new L2-error */
fprintf(stdout,"%d %lg %lg\n",iter,eps,sqrt(rtz));
}
/* =========================================================== *
* End of Loop *
* =========================================================== */
/* Save solution and clean up */
dcopy(nsolve,u,1,p,1);
/* add back u0 */
dvadd(nsolve,u0,1,p,1,p,1);
if (iter > MAX_ITERATIONS){
error_msg (Bsolve_Stokes_CG failed to converge);
}
else if (option("verbose") > 1)
printf("\t %3d iterations, error = %#14.6g %lg %lg\n",
iter, eps/epsfac, epsfac, tolcg);
return;
}
void solve_boundary(Element_List **V, Element_List **Vf,
double *rhs, double *u0, Bsystem **Vbsys){
int eDIM = V[0]->flist[0]->dim();
const int nsolve = Vbsys[eDIM]->nsolve;
int info;
Bsystem *B = Vbsys[0], *PB = Vbsys[eDIM];
if(nsolve){
const int bwidth = PB->Gmat->bwidth_a;
if(B->rslv){ /* recursive Static condensation solver */
Rsolver *R = PB->rslv;
int nrecur = R->nrecur;
int aslv = R->rdata[nrecur-1].cstart, bw = R->Ainfo.bwidth_a;
Recur_setrhs(R,rhs);
if(PB->singular)
rhs[PB->singular-1] = 0.0;
if(B->smeth == direct){
if(aslv)
if(2*bw < aslv){ /* banded matrix */
error_msg(error in solve_boundary_pressure);
}
else /* symmetric matrix */
dsptrs('L', aslv, 1, R->A.inva, R->A.pivota, rhs, aslv, info);
}
else{
error_msg(Implement recursive iterative solver);
/*Recur_Bsolve_CG(PB,rhs,U->flist[0]->type);*/
}
Recur_backslv(R,rhs,'n');
}
else{
if(PB->singular)
rhs[PB->singular-1] = 0.0;
if(B->smeth == iterative){
if(iparam("ITER_PCR")){
Bsolve_Stokes_PCR(V, Vbsys, rhs);
}
else
Bsolve_Stokes_PCG(V, Vbsys, rhs);
}
else{
if(B->lambda->wave){
if(3*bwidth < nsolve){ /* banded matrix */
error_msg(pack non-symmetrix solver not completed);
}
else /* symmetric matrix */
dgetrs('N', nsolve,1, *PB->Gmat->inva, nsolve,
PB->Gmat->pivota, rhs, nsolve,info);
}
else{
if(2*bwidth < nsolve) /* banded matrix */
dpbtrs('L', nsolve, bwidth-1, 1, *PB->Gmat->inva, bwidth,
rhs, nsolve, info);
else /* symmetric matrix */
dsptrs('L', nsolve,1, *PB->Gmat->inva, PB->Gmat->pivota, rhs,
nsolve,info);
}
}
}
}
/* add intial conditions for pressure and internal velocity solve*/
dvadd(PB->nglobal,u0,1,rhs,1,rhs,1);
ScatrBndry_Stokes(rhs,V,Vbsys);
}
static void setupRHS (Element_List **V, Element_List **Vf,double *rhs,
double *u0, Bndry **Vbc, Bsystem **Vbsys){
register int i,k;
int N,nbl;
int eDIM = V[0]->flist[0]->dim();
Bsystem *PB = Vbsys[eDIM],*B = Vbsys[0];
int nel = B->nel,info;
int **ipiv = B->Gmat->cipiv;
double **binvc = B->Gmat->binvc;
double **invc = B->Gmat->invc;
double ***dbinvc = B->Gmat->dbinvc;
double **p_binvc = PB->Gmat->binvc;
Element *E,*E1;
Bndry *Ebc;
double *tmp;
if(eDIM == 2)
tmp = dvector(0,max(8*LGmax,(LGmax-2)*(LGmax-2)));
else
tmp = dvector(0,18*LGmax*LGmax);
B = Vbsys[0];
PB = Vbsys[eDIM];
#ifdef __LIBCATAMOUNT__
st1 = dclock();
#else
st1 = clock();
#endif
/* save initial condition */
saveinit(V,u0,Vbsys);
Timing1("saveinit..........");
/* take inner product if in physical space */
for(i = 0; i < eDIM; ++i){
if(Vf[i]->fhead->state == 'p')
Vf[i]->Iprod(Vf[i]);
}
/* zero pressure field */
dzero(Vf[eDIM]->hjtot,Vf[eDIM]->base_hj,1);
Timing1("zeroing...........");
/* condense out interior from u-vel + p */
for(i = 0; i < eDIM; ++i)
for(E=Vf[i]->fhead;E;E=E->next){
nbl = E->Nbmodes;
N = E->Nmodes - nbl;
if(N)
dgemv('T', N, nbl, -1., binvc[E->geom->id], N,
E->vert->hj+nbl, 1, 1., E->vert->hj,1);
}
Timing1("first condense(v).");
for(i = 0; i < eDIM; ++i)
for(E=Vf[i]->fhead;E;E=E->next){
nbl = E->Nbmodes;
N = E->Nmodes - nbl;
if(N) {
E1 = Vf[eDIM]->flist[E->id];
if(B->lambda->wave){
dcopy(N,E->vert->hj+nbl,1,tmp,1);
dgetrs('N', N, 1, invc[E->geom->id], N,ipiv[E->geom->id],tmp,N,info);
dgemv('T', N, E1->Nmodes, -1., dbinvc[i][E->geom->id], N,
tmp, 1, 1., E1->vert->hj,1);
}
else{
dgemv('T', N, E1->Nmodes, -1., dbinvc[i][E->geom->id], N,
E->vert->hj+nbl, 1, 1., E1->vert->hj,1);
}
}
}
Timing1("first condense(p).");
/* add flux terms */
for(i = 0; i < eDIM; ++i)
for(Ebc = Vbc[i]; Ebc; Ebc = Ebc->next)
if(Ebc->type == 'F' || Ebc->type == 'R')
Vf[i]->flist[Ebc->elmt->id]->Add_flux_terms(Ebc);
/* second level of factorisation to orthogonalise basis to p */
for(E=Vf[eDIM]->fhead;E;E=E->next){
E1 = Vf[0]->flist[E->id];
nbl = eDIM*E1->Nbmodes + 1;
N = E->Nmodes-1;
dgemv('T', N, nbl, -1.0, p_binvc[E->geom->id], N,
E->vert->hj+1, 1, 0.0, tmp,1);
for(i = 0; i < eDIM; ++i){
E1 = Vf[i]->flist[E->id];
dvadd(E1->Nbmodes,tmp+i*E1->Nbmodes,1,E1->vert->hj,1,E1->vert->hj,1);
}
E->vert->hj[0] += tmp[nbl-1];
}
Timing1("second condense...");
/* subtract boundary initial conditions */
if(PB->smeth == iterative){
double **wk;
double **a = PB->Gmat->a;
if(eDIM == 2)
wk = dmatrix(0,1,0,eDIM*4*LGmax);
else
wk = dmatrix(0,1,0,eDIM*6*LGmax*LGmax);
for(k = 0; k < nel; ++k){
nbl = V[0]->flist[k]->Nbmodes;
/* gather vector */
for(i = 0; i < eDIM; ++i)
dcopy(nbl,V[i]->flist[k]->vert->hj,1,wk[0]+i*nbl,1);
dspmv('U',eDIM*nbl+1,1.0,a[V[0]->flist[k]->geom->id],
wk[0],1,0.0,wk[1],1);
/* subtract of Vf */
for(i = 0; i < eDIM; ++i)
dvsub(nbl,Vf[i]->flist[k]->vert->hj,1,wk[1]+i*nbl,1,
Vf[i]->flist[k]->vert->hj,1);
Vf[eDIM]->flist[k]->vert->hj[0] -= wk[1][eDIM*nbl];
}
GathrBndry_Stokes(Vf,rhs,Vbsys);
free_dmatrix(wk,0,0);
}
else{
if(Vbc[0]->DirRHS){
GathrBndry_Stokes(Vf,rhs,Vbsys);
/* subtract of bcs */
dvsub(PB->nsolve,rhs,1,Vbc[0]->DirRHS,1,rhs,1);
/* zero ic vector */
dzero(PB->nsolve,u0,1);
}
else{
/* zero out interior components since only deal with boundary initial
conditions (interior is always direct) */
for(i = 0; i < eDIM; ++i)
for(E = V[i]->fhead; E; E = E->next){
nbl = E->Nbmodes;
N = E->Nmodes - nbl;
dzero(N, E->vert->hj + nbl, 1);
}
/* inner product of divergence for pressure forcing */
for(i = 0; i < eDIM; ++i)
V[i]->Trans(V[i], J_to_Q);
V[0]->Grad(V[eDIM],0,0,'x');
V[1]->Grad(0,Vf[eDIM],0,'y');
dvadd(V[1]->htot,V[eDIM]->base_h,1,Vf[eDIM]->base_h,1,
V[eDIM]->base_h,1);
if(eDIM == 3){
V[2]->Grad(0,V[eDIM],0,'z');
dvadd(V[2]->htot,V[eDIM]->base_h,1,Vf[eDIM]->base_h,1,
V[eDIM]->base_h,1);
}
#ifndef PCONTBASE
for(k = 0; k < nel; ++k)
V[eDIM]->flist[k]->Ofwd(*V[eDIM]->flist[k]->h,
V[eDIM]->flist[k]->vert->hj,
V[eDIM]->flist[k]->dgL);
#else
V[eDIM]->Iprod(V[eDIM]);
#endif
for(i = 0; i < eDIM; ++i){
for(k = 0; k < nel; ++k){
E = V[i]->flist[k];
nbl = E->Nbmodes;
N = E->Nmodes - nbl;
E->HelmHoltz(PB->lambda+k);
dscal(E->Nmodes, -B->lambda[k].d, E->vert->hj, 1);
if(N) {
/* condense out interior terms in velocity */
dgemv('T', N, nbl, -1., binvc[E->geom->id], N,
E->vert->hj+nbl, 1, 1., E->vert->hj,1);
/* condense out interior terms in pressure*/
E1 = V[eDIM]->flist[k];
if(B->lambda->wave){
dcopy(N,E->vert->hj+nbl,1,tmp,1);
dgetrs('N',N,1,invc[E->geom->id],N,ipiv[E->geom->id],tmp,N,info);
dgemv('T', N, E1->Nmodes, -1., dbinvc[i][E->geom->id], N,
tmp, 1, 1., E1->vert->hj,1);
}
else{
dgemv('T', N, E1->Nmodes, -1., dbinvc[i][E->geom->id], N,
E->vert->hj+nbl, 1, 1., E1->vert->hj,1);
}
}
}
}
/* second level of factorisation to orthogonalise basis to p */
/* p - vel */
for(E=V[eDIM]->fhead;E;E=E->next){
E1 = V[0]->flist[E->id];
nbl = eDIM*E1->Nbmodes + 1;
N = E->Nmodes-1;
dgemv('T', N, nbl, -1.0, p_binvc[E->geom->id], N,
E->vert->hj+1, 1, 0.0, tmp,1);
for(i = 0; i < eDIM; ++i){
E1 = V[i]->flist[E->id];
dvadd(E1->Nbmodes,tmp+i*E1->Nbmodes,1,E1->vert->hj,1,E1->vert->hj,1);
dvadd(E1->Nbmodes,E1->vert->hj,1,Vf[i]->flist[E->id]->vert->hj,1,
Vf[i]->flist[E->id]->vert->hj,1);
}
Vf[eDIM]->flist[E->id]->vert->hj[0] += E->vert->hj[0] + tmp[nbl-1];
}
Timing1("bc condense.......");
GathrBndry_Stokes(Vf,rhs,Vbsys);
Timing1("GatherBndry.......");
}
}
/* finally copy inner product of f into v for inner solve */
for(i = 0; i < eDIM; ++i)
for(E = V[i]->fhead; E; E= E->next){
nbl = E->Nbmodes;
N = E->Nmodes - nbl;
E1 = Vf[i]->flist[E->id];
dcopy(N, E1->vert->hj+nbl, 1, E->vert->hj+nbl, 1);
}
for(E = Vf[eDIM]->fhead; E; E = E->next){
E1 = V[eDIM]->flist[E->id];
dcopy(E->Nmodes,E->vert->hj,1,E1->vert->hj,1);
}
dzero(PB->nglobal-PB->nsolve, rhs + PB->nsolve, 1);
free(tmp);
}