static void solve_velocity_interior(Element_List **V, Bsystem **Vbsys){
register int i;
int N,nbl,rows,id,info;
int *bw = Vbsys[0]->Gmat->bwidth_c;
int eDIM = V[0]->flist[0]->dim();
double *hj;
int **ipiv = Vbsys[0]->Gmat->cipiv;
double **invc = Vbsys[0]->Gmat-> invc;
double **binvc = Vbsys[0]->Gmat->binvc;
double **invcd = Vbsys[0]->Gmat->invcd;
double ***dbinvc = Vbsys[0]->Gmat->dbinvc;
Element *E,*P;
for(i = 0; i < eDIM; ++i)
for(E=V[i]->fhead;E;E=E->next){
N = E->Nmodes - E->Nbmodes;
E->state = 't';
if(!N) continue;
id = E->geom->id;
nbl = E->Nbmodes;
hj = E->vert->hj + nbl;
P = V[eDIM]->flist[E->id];
rows = P->Nmodes;
if(Vbsys[0]->lambda->wave){
/* dbinvc only store dbi in this formulation */
dgemv('N', N, rows, -1., dbinvc[i][id], N, P->vert->hj, 1, 1.0,hj,1);
dgetrs('T',N,rows,invc[id],N,ipiv[id],dbinvc[i][id],N,info);
if(N > 3*bw[id])
dgbtrs('N', N, bw[id]-1,bw[id]-1, 1, invc[id], 3*bw[id]-2, ipiv[id],
hj, N, info);
else
dgetrs('N', N, 1, invc[id], N, ipiv[id], hj, N, info);
dgemv('N', N, nbl , -1., invcd [id], N, E->vert->hj, 1, 1.0,hj,1);
}
else{
if(N > 2*bw[id])
dpbtrs('L', N, bw[id]-1, 1, invc[id], bw[id], hj, N, info);
else
dpptrs('L', N, 1, invc[id], hj, N, info);
dgemv('N', N, nbl , -1., binvc [id], N, E->vert->hj, 1, 1.0,hj,1);
dgemv('N', N, rows, -1., dbinvc[i][id], N, P->vert->hj, 1, 1.0,hj,1);
}
}
}
int main()
{
int n = 3;
int info;
int ipiv[3];
double a[3][3] = {10., 1., 5.,
1., 2., -1.,
5., -1., 5.};
double b[3][3] = { 1., 0., 0.,
0., 1., 0.,
0., 0., 1.};
for (int i = 0; i < n; ++i)
{
for (int j = 0; j < n; ++j)
cout << setw(10) << a[j][i];
cout << endl;
}
cout << endl;
dgetf2(n, n, (double*)a, ipiv, info);
for (int i = 0; i < n; ++i)
{
for (int j = 0; j < n; ++j)
cout << setw(10) << a[j][i];
cout << endl;
}
cout << "info is " << info << endl;
dgetrs(n, n, 3, (double*)a, ipiv, (double*)b);
for (int i = 0; i < n; ++i)
{
for (int j = 0; j < n; ++j)
cout << setw(10) << b[j][i];
cout << endl;
}
return 0;
}
static void solve_pressure(Element_List **V, double *rhs, Bsystem **Vbsys)
{
register int i;
int eDIM = V[0]->flist[0]->dim();
int info,N,nbl,nblv,id,*bmap;
Bsystem *B = Vbsys[0], *PB = Vbsys[eDIM];
Element *E;
double *hj,*tmp;
double *sc = B->signchange;
if(eDIM == 2)
tmp = dvector(0,8*LGmax);
else
tmp = dvector(0,18*(LGmax-1)*(LGmax-1));
/* back solve for pressure */
for(E=V[eDIM]->fhead;E;E=E->next)
{
N = E->Nmodes - 1;
id = E->geom->id;
hj = E->vert->hj + 1;
E->state = 't';
/* solve interior and negate */
if(PB->lambda->wave)
{
dgetrs('N', N, 1, PB->Gmat->invc[id], N, PB->Gmat->cipiv[id],hj, N,
info);
}
else
{
dpptrs('L', N, 1, PB->Gmat->invc[id], hj, N, info);
dneg(N,hj,1);
}
bmap = PB->bmap[E->id];
nblv = V[0]->flist[E->id]->Nbmodes;
nbl = eDIM*nblv+1;
for(i = 0; i < nbl; ++i)
tmp[i] = rhs[bmap[i]];
for(i = 0; i < eDIM; ++i)
dvmul(nblv,sc,1,tmp+nblv*i,1,tmp+nblv*i,1);
if(PB->lambda->wave)
dgemv('N', N, nbl,-1.0, PB->Gmat->invcd[id], N, tmp, 1, 1.,hj,1);
else
dgemv('N', N, nbl,-1.0, PB->Gmat->binvc[id], N, tmp, 1, 1.,hj,1);
sc += nblv;
}
free(tmp);
}
void SqSylvMatrix::multInvLeft2(GeneralMatrix& a, GeneralMatrix& b,
double& rcond1, double& rcondinf) const
{
if (rows != a.numRows() || rows != b.numRows()) {
throw SYLV_MES_EXCEPTION("Wrong dimensions for multInvLeft2.");
}
// PLU factorization
Vector inv(data);
lapack_int * const ipiv = new lapack_int[rows];
lapack_int info;
lapack_int rows2 = rows;
dgetrf(&rows2, &rows2, inv.base(), &rows2, ipiv, &info);
// solve a
lapack_int acols = a.numCols();
double* abase = a.base();
dgetrs("N", &rows2, &acols, inv.base(), &rows2, ipiv,
abase, &rows2, &info);
// solve b
lapack_int bcols = b.numCols();
double* bbase = b.base();
dgetrs("N", &rows2, &bcols, inv.base(), &rows2, ipiv,
bbase, &rows2, &info);
delete [] ipiv;
// condition numbers
double* const work = new double[4*rows];
lapack_int* const iwork = new lapack_int[rows];
double norm1 = getNorm1();
dgecon("1", &rows2, inv.base(), &rows2, &norm1, &rcond1,
work, iwork, &info);
double norminf = getNormInf();
dgecon("I", &rows2, inv.base(), &rows2, &norminf, &rcondinf,
work, iwork, &info);
delete [] iwork;
delete [] work;
}
void mexFunction(int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[])
{
double *A, *B; /* pointers to input matrices */
double *B2; /* in/out arguments to DGESV*/
size_t m,n; /* matrix dimensions */
mwSignedIndex *iPivot; /* inputs to DGESV */
mwSignedIndex info;
size_t uno;
char *car;
uno = 1; car = 'N';
/* Check for proper number of arguments. */
if ( nrhs != 3) {
mexErrMsgIdAndTxt("MATLAB:matrixDivide64:rhs",
"This function requires 3 input matrices.");
}
A = mxGetPr(prhs[0]); /* pointer to first input matrix */
B = mxGetPr(prhs[1]); /* pointer to second input matrix */
iPivot = (mwSignedIndex*)mxGetData(prhs[2]);
/* dimensions of input matrices */
m = mxGetM(prhs[0]);
n = mxGetN(prhs[0]);
/* Validate input arguments */
if (n != m) {
mexErrMsgIdAndTxt("MATLAB:matrixDivide64:square",
"LAPACK function requires input matrix 1 must be square.");
}
plhs[0] = mxCreateDoubleMatrix(m, 1, mxREAL);
B2 = mxGetPr(plhs[0]);
memcpy(B2, B, m*mxGetElementSize(prhs[1]));
/* Call LAPACK */
dgetrs(&car, &n, &uno, A, &m, iPivot, B2, &m, &info);
/* plhs[0] now holds X */
}
void EIS_reg(double *y, double *theta, double *w, mwSignedIndex S,
double *beta)
{
mwSignedIndex i;
char *chN = "N", *chT = "T";
double one = 1.0, zero = 0.0;
double A[9], B[3], *X, *Y;
mwSignedIndex K, N;
mwSignedIndex IPIV[3], INFO;
/* Variable size arrays */
X = malloc((3*S)*sizeof(double));
Y = malloc((S)*sizeof(double));
K = 3;
N = 1;
/* create X and Y */
for (i=0; i<S; i++)
{
X[i] = w[i];
X[S+i] = w[i]*theta[i];
X[2*S+i] = -0.5*theta[i]*X[S+i];
Y[i] = w[i]*y[i];
}
dgemm(chT, chN, &K, &K, &S, &one, X, &S, X, &S, &zero, &A, &K); /* get X'*X*/
dgemm(chT, chN, &K, &N, &S, &one, X, &S, Y, &S, &zero, &B, &K); /* get X'*Y*/
dgetrf(&K, &K, &A, &K, &IPIV, &INFO); /* get LU factorisation of A*/
dgetrs(chN, &K, &N, &A, &K, &IPIV, &B, &K, &INFO); /* get solution B*/
beta[0] = B[1];
beta[1] = B[2];
/* Free allocated memory */
free(X); free(Y);
}
void genSurfFile(Element *E, double *x, double *y, double *z, Curve *curve)
{
register int i;
int info,l,lm[4];
int q1 = E->qa, q2 = E->qb,*vertid,fid, cnt, cnt1;
int ntot = Snp*(Snp+1)/2;
double **sj;
static int *chkfid;
if(!chkfid)
{
chkfid = ivector(0,Snface-1);
izero(Snface,chkfid,1);
}
vertid = curve->info.file.vert;
if(E->identify() == Nek_Prism)
q2 = E->qc;
// find face id;
cnt = vertid[0] + vertid[1] + vertid[2];
for(i = 0; i < Snface; ++i)
if(surfids[i][3] == cnt)
{ // just search vertices with same vertex id sum
if(vertid[0] == surfids[i][0])
{
if((vertid[1] == surfids[i][1])||(vertid[1] == surfids[i][2]))
{
chkfid[i]++;
if(chkfid[i] > 1) // check form mutiple calls to same face
fprintf(stderr,"gensurfFile: Error face %d is being "
"operated on multiple times\n",i);
if(vertid[1] == surfids[i][2])
{
Rotate(i,1);
Reflect(i);
}
fid = i;
break;
}
}
else if(vertid[0] == surfids[i][1])
{
if((vertid[1] == surfids[i][0])||(vertid[1] == surfids[i][2]))
{
chkfid[i]++;
if(chkfid[i] > 1) // check form mutiple calls to same face
fprintf(stderr,"gensurfFile: Error face %d is being "
"operated on multiple times\n",i);
if(vertid[1] == surfids[i][0])
Reflect(i);
else
Rotate(i,2);
fid = i;
break;
}
}
else if(vertid[0] == surfids[i][2])
{
if((vertid[1] == surfids[i][0])||(vertid[1] == surfids[i][1]))
{
chkfid[i]++;
if(chkfid[i] > 1) // check form mutiple calls to same face
fprintf(stderr,"gensurfFile: Error face %d is being "
"operated on multiple times\n",i);
if(vertid[1] == surfids[i][1])
{
Rotate(i,2);
Reflect(i);
}
else
Rotate(i,1); // set up to rotate Feisal to Nektar
fid = i;
break;
}
}
}
// invert basis
dgetrs('T', ntot, 1, *CollMat,ntot,CollMatIpiv,SurXpts[fid],ntot,info);
if(info)
fprintf(stderr,"Trouble solve collocation X matrix\n");
dgetrs('T', ntot, 1, *CollMat,ntot,CollMatIpiv,SurYpts[fid],ntot,info);
if(info)
fprintf(stderr,"Trouble solve collocation Y matrix\n");
dgetrs('T', ntot, 1, *CollMat,ntot,CollMatIpiv,SurZpts[fid],ntot,info);
if(info)
fprintf(stderr,"Trouble solve collocation Z matrix\n");
// Take out require modes and Backward transformation
// base it on LGmax at present although might cause problems with
// trijbwd if LGmax > qa
sj = dmatrix(0,2,0,LGmax*(LGmax+1)/2-1);
dzero(3*LGmax*(LGmax+1)/2,sj[0],1);
lm[0] = LGmax-2;
lm[1] = LGmax-2;
lm[2] = LGmax-2;
lm[3] = max(LGmax-3,0);
dcopy(3,SurXpts[fid],1,sj[0],1);
dcopy(3,SurYpts[fid],1,sj[1],1);
dcopy(3,SurZpts[fid],1,sj[2],1);
cnt = cnt1 = 3;
for(i=0;i<3;++i)
{
l = lm[i];
dcopy(min(Snp-2,l), SurXpts[fid]+cnt,1,sj[0]+cnt1,1);
dcopy(min(Snp-2,l), SurYpts[fid]+cnt,1,sj[1]+cnt1,1);
dcopy(min(Snp-2,l), SurZpts[fid]+cnt,1,sj[2]+cnt1,1);
cnt += Snp-2;
cnt1 += l;
}
l = lm[3];
for(i=0;i<l;++i)
{
dcopy(min(Snp-3,l)-i,SurXpts[fid]+cnt,1,sj[0]+cnt1,1);
dcopy(min(Snp-3,l)-i,SurYpts[fid]+cnt,1,sj[1]+cnt1,1);
dcopy(min(Snp-3,l)-i,SurZpts[fid]+cnt,1,sj[2]+cnt1,1);
cnt += Snp-3-i;
cnt1 += l-i;
}
JbwdTri(q1,q2,LGmax,lm,sj[0],x);
JbwdTri(q1,q2,LGmax,lm,sj[1],y);
JbwdTri(q1,q2,LGmax,lm,sj[2],z);
free_dmatrix(sj,0,0);
}
// Calculate the transpose inverse of matrix a
// and return the determinant
log_real_value TransposeInverseMatrix(const Array2 <doublevar> & a, Array2 <doublevar> & a1, const int n)
{
Array2 <doublevar> &temp(tmp2);
temp.Resize(n,n);
Array1 <int>& indx(itmp1);
indx.Resize(n);
doublevar d=1;
log_real_value logdet;
logdet.logval=0; logdet.sign=1;
//for(int i=0; i< n; i++) {
// cout << "matrix ";
// for(int j=0; j< n; j++) cout << a(i,j) << " ";
// cout << endl;
//}
#ifdef USE_LAPACK
//LAPACK routines don't handle n==1 case??
if(n==1) {
a1(0,0)=1.0/a(0,0);
logdet.logval=log(fabs(a(0,0)));
logdet.sign=a(0,0)<0?-1:1;
return logdet;
}
else {
for(int i=0; i < n;++i) {
for(int j=0; j< n; ++j) {
temp(j,i)=a(i,j);
a1(i,j)=0.0;
}
a1(i,i)=1.0;
}
if(dgetrf(n, n, temp.v, n, indx.v)> 0) {
return 0.0;
}
for(int j=0; j< n; ++j) {
dgetrs('N',n,1,temp.v,n,indx.v,a1.v+j*n,n);
}
}
for(int i=0; i< n; i++) {
if(indx(i)!=i+1) logdet.sign*=-1;
logdet.logval+=log(fabs(temp(i,i)));
if(temp(i,i) <0) logdet.sign*=-1;
}
//cout << " det " << det << " logval " << logdet.val() << endl;
//return det;
return logdet;
//#endif
#else
// a(i,j) first index i is row index (convention)
// elements of column vectors are stored contiguous in memory in C style arrays
// a(i) refers to a column vector
// calculate the inverse of the transposed matrix because this
// allows to pass a column vector to lubksb() instead of a row
// put the transposed matrix in temp
//cout << "temp " << endl;
for(int i=0;i<n;++i)
{
for(int j=0;j<n;++j)
{
temp(i,j)=a(i,j);
a1(i,j)=0.0;
}
a1(i,i)=1.0;
}
//cout << "ludcmp" << endl;
//if the matrix is singular, the determinant is zero.
d=1;
if(ludcmp(temp,n,indx,d)==0)
return 0;
//cout << "lubksb" << endl;
for(int j=0;j<n;++j)
{
// get column vector
Array1 <doublevar> yy;//(a1(j));
yy.refer(a1(j));
lubksb(temp,n,indx,yy);
}
//for(int j=0;j<n;++j) {
// d *= temp(j,j);
//}
logdet.logval=0;
logdet.sign=1;
for(int i=0; i< n; i++) {
if(indx(i)!=i) logdet.sign*=-1;
logdet.logval+=log(fabs(temp(i,i)));
if(temp(i,i) <0) logdet.sign*=-1;
}
//cout << " det " << d << " logval " << logdet.val() << endl;
return logdet;
#endif
}
void dgesv( long n, long nrhs, double a[], long lda, long ipiv[],
double b[], long ldb, long *info )
{
/**
* -- LAPACK driver routine (version 1.1) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. Scalar Arguments ..*/
/** ..
* .. Array Arguments ..*/
#undef ipiv_1
#define ipiv_1(a1) ipiv[a1-1]
#undef b_2
#define b_2(a1,a2) b[a1-1+ldb*(a2-1)]
#undef a_2
#define a_2(a1,a2) a[a1-1+lda*(a2-1)]
/** ..
*
* Purpose
* =======
*
* DGESV computes the solution to a real system of linear equations
* A * X = B,
* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
* The LU decomposition with partial pivoting and row interchanges is
* used to factor A as
* A = P * L * U,
* where P is a permutation matrix, L is unit lower triangular, and U is
* upper triangular. The factored form of A is then used to solve the
* system of equations A * X = B.
*
* Arguments
* =========
*
* N (input) INTEGER
* The number of linear equations, i.e., the order of the
* matrix A. N >= 0.
*
* NRHS (input) INTEGER
* The number of right hand sides, i.e., the number of columns
* of the matrix B. NRHS >= 0.
*
* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
* On entry, the N-by-N coefficient matrix A.
* On exit, the factors L and U from the factorization
* A = P*L*U; the unit diagonal elements of L are not stored.
*
* LDA (input) INTEGER
* The leading dimension of the array A. LDA >= max(1,N).
*
* IPIV (output) INTEGER array, dimension (N)
* The pivot indices that define the permutation matrix P;
* row i of the matrix was interchanged with row IPIV(i).
*
* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
* On entry, the N-by-NRHS matrix of right hand side matrix B.
* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
* LDB (input) INTEGER
* The leading dimension of the array B. LDB >= max(1,N).
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
* has been completed, but the factor U is exactly
* singular, so the solution could not be computed.
*
* =====================================================================
**/
/** ..
* .. Intrinsic Functions ..*/
/* intrinsic max;*/
/** ..
* .. Executable Statements ..
*
* Test the input parameters.
**/
/*-----implicit-declarations-----*/
/*-----end-of-declarations-----*/
*info = 0;
if( n<0 ) {
*info = -1;
} else if( nrhs<0 ) {
*info = -2;
} else if( lda<max( 1, n ) ) {
*info = -4;
} else if( ldb<max( 1, n ) ) {
*info = -7;
}
if( *info!=0 ) {
xerbla( "dgesv ", -*info );
return;
}
/**
* Compute the LU factorization of A.
**/
dgetrf( n, n, a, lda, ipiv, info );
if( *info==0 ) {
/**
* Solve the system A*X = B, overwriting B with X.
**/
dgetrs( 'n'/*o transpose*/, n, nrhs, a, lda, ipiv, b, ldb,
info );
}
return;
/**
* End of DGESV
**/
}
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);
}
