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); }