void expmv(double t, int n, matMat fmv, normFunc nf, traceFunc tf,
double* b, int ncol, int m_max, int p_max, double* tm, int recalcm,
char prec, double shift, char bal, int full_term, int prnt, int* info,
int wrklen, double* wrk, int iwrklen, int* iwrk)
{
int mv;
int mvd;
int unA;
int i;
int j;
int k;
double tt;
// double trace;
double tol;
/* size of Taylor approximation */
int tcol;
int wlen;
int nalen;
double* talpha;
double* teta;
double* C;
double* b1;
double* b2;
double* nawrk;
wlen = 2*p_max + 2*n*ncol + m_max*(p_max-1);
nalen = 3*n + (4*n+1)*ncol;
if (wrklen < wlen+nalen || iwrklen < 2*n + 4) {
if (prnt) {
Rprintf("Not enough workspace supplied!\n");
Rprintf(" Required 'double': %d\n",wlen+nalen);
Rprintf(" Supplied : %d\n",wrklen);
Rprintf(" Required 'int' : %d\n",2*n+4);
Rprintf(" Supplied : %d\n",iwrklen);
}
*info = -2;
return;
}
talpha = wrk;
teta = talpha + p_max;
C = teta + p_max;
b1 = C + m_max*(p_max-1);
b2 = b1 + n*ncol;
nawrk = b2 + n*ncol;
switch (prec) {
case 's':
tol = pow(2.,-24.);
break;
case 'h':
tol = pow(2.,-10.);
break;
case 'd':
default:
tol = pow(2.,-53.);
break;
}
// get required Taylor truncation (if not set)
if (recalcm) {
if (prnt > 2) Rprintf("Calculating required Taylor truncation...");
tt = 1.;
select_taylor_degree(n,fmv,t,b,ncol,nf,m_max,p_max,
prec,talpha,teta,tm,&mvd,&unA,shift,bal,0,
wrklen-wlen,nawrk,iwrklen,iwrk);
if (prnt > 3) {
for (i = 0; i < m_max; ++i) {
for (j = 0; j < p_max-1; ++j) {
Rprintf("%16.8e ",tm[j*m_max+i]);
}
Rprintf("\n");
}
}
mv = mvd;
if (prnt > 2) Rprintf("done.\n");
} else {
tt = t;
mv = 0;
mvd = 0;
}
double s = 1.0; // cost per column
double cost = 0.0;
double ccost = 0.0;
if (t == 0.0) {
tcol = 0;
} else {
k = 0;
for (i = 0; i < m_max; ++i) {
for (j = 0; j < p_max-1; ++j) {
C[k] = ceil(fabs(tt)*tm[j*(m_max)+i])*(i+1.);
if (C[k] == 0.0) C[k] = 1./0.;
++k;
}
}
cost = R_PosInf;
tcol = 0;
for (i = 0; i < m_max; ++i) {
ccost = R_PosInf;
for (j = 0; j < p_max-1; ++j) {
if (C[i*(p_max-1)+j] < ccost) {
ccost = C[i*(p_max-1)+j];
}
}
if (ccost < cost) {
cost = ccost;
tcol = i+1;
}
}
s = (cost/tcol > 1) ? cost/tcol : 1.0;
}
if (tcol == 0) {
if (prnt) {
Rprintf("Cannot calculate matrix exponential (under-/overflow?).\n");
Rprintf("Returned results may be gibberish.\n");
}
*info = -1;
return;
}
double eta = 1.0;
if (shift != 0.0) eta = exp(t*shift/s);
double* btmp = NULL;
memcpy(b1,b,n*ncol*sizeof(double));
if (prnt > 2) Rprintf("m = %2d, s = %g\n", tcol, s);
double c1, c2;
double bnorm;
int ss;
for (ss = 1; ss <= s; ++ss) {
c1 = inf_norm(n,ncol,b1);
if (prnt > 3) Rprintf("s = %d, ",ss);
if (prnt > 4) Rprintf("\n");
for (k = 1; k <= tcol; ++k) {
fmv('n',n,ncol,t/(s*k),b1,b2);
btmp = b1; b1 = b2; b2 = btmp; btmp = NULL;
++mv;
for (i = 0; i < n; ++i) {
for (j = 0; j < ncol; ++j) {
b[j*n+i] += b1[j*n+i];
}
}
c2 = inf_norm(n,ncol,b1);
if (prnt > 4) Rprintf("k=%3d: %9.2e %9.2e %9.2e",k,bnorm,c1,c2);
if (!full_term) {
bnorm = inf_norm(n,ncol,b);
if (prnt > 4) Rprintf(" %9.2e, \n",(c1+c2)/bnorm);
if (c1+c2 <= tol*bnorm) {
if (prnt == 4) {
Rprintf("k=%3d: %9.2e %9.2e %9.2e",k,bnorm,c1,c2);
Rprintf(" %9.2e, ",(c1+c2)/bnorm);
}
if (prnt > 3) Rprintf("m_actual = %2d\n", k);
break;
}
c1 = c2;
}
}
for (i = 0; i < n*ncol; ++i) b[i] *= eta;
memcpy(b1,b,n*ncol*sizeof(double));
}
iwrk[0] = tcol;
iwrk[1] = k;
}
void lin_alg::gauss_seidel_solve(double **a, double *x, double *b, int n, int max_iter, bool &solved, double tol, double &error)
{
// Solve the system Ax=b by Gauss-Seidel iteration method
// R. Sheehan 3 - 8 - 2011
bool cgt=false;
double *oldx = vector(n);
double *diffx = vector(n);
int n_iter = 1;
double bi, mi, err;
while(n_iter<max_iter){
// store the initial approximation to the solution
for(int i=1; i<=n; i++){
oldx[i] = x[i];
}
// iteratively compute the solution vector x
for(int i=1; i<=n; i++){
bi=b[i];
mi=a[i][i];
for(int j=1; j<i; j++){
bi -= a[i][j]*x[j];
}
for(int j=i+1; j<=n; j++){
bi -= a[i][j]*oldx[j];
}
x[i] = bi/mi;
}
// test for convergence
// compute x - x_{old} difference between the two is the error
diffx = vector_diff(x, oldx, n, n);
// error is measured as the length of the difference vector ||x - x_{old}||_{\infty}
err = inf_norm(diffx, n);
if( n_iter%4 == 0){
cout<<"iteration "<<n_iter<<" , error = "<<err<<endl;
}
if(abs(err)<tol){ // solution has converged, stop iterating
cout<<"\nGauss-Seidel Iteration Complete\nSolution converged in "<<n_iter<<" iterations\n";
cout<<"Error = "<<abs(err)<<endl<<endl;
error=abs(err);
cgt=solved=true;
break;
}
n_iter++; // solution has not converged, keep iterating
}
if(!cgt){ // solution did not converge
cout<<"\nError: Gauss-Seidel Iteration\n";
cout<<"Error: Solution did not converge in "<<max_iter<<" iterations\n";
cout<<"Error = "<<abs(err)<<endl;
error=abs(err);
solved=false;
}
delete[] oldx;
delete[] diffx;
}
void expm(Matrix A, Matrix B, double h) {
static int firsttime = TRUE;
static Matrix M;
static Matrix M2;
static Matrix M3;
static Matrix D;
static Matrix N;
if (firsttime) {
firsttime = FALSE;
M = my_matrix(1,3*N_DOFS,1,3*N_DOFS);
M2 = my_matrix(1,3*N_DOFS,1,3*N_DOFS);
M3 = my_matrix(1,3*N_DOFS,1,3*N_DOFS);
D = my_matrix(1,3*N_DOFS,1,3*N_DOFS);
N = my_matrix(1,3*N_DOFS,1,3*N_DOFS);
}
int norm = 0;
double c = 0.5;
int q = 6; // uneven p-q order for Pade approx.
int p = 1;
int i,j,k;
// Form the big matrix
mat_mult_scalar(A, h, A);
mat_equal_size(A, 2*N_DOFS, 2*N_DOFS, M);
for (i = 1; i <= 2*N_DOFS; ++i) {
for (j = 1; j <= N_DOFS; ++j) {
M[i][2*N_DOFS + j] = h * B[i][j];
}
}
//print_mat("M is:\n", M);
// scale M by power of 2 so that its norm < 1/2
norm = (int)(log2(inf_norm(M))) + 2;
//printf("Inf norm of M: %f \n", inf_norm(M));
if (norm < 0)
norm = 0;
mat_mult_scalar(M, 1/pow(2,(double)norm), M);
//printf("Norm of M logged, floored and 2 added is: %d\n", norm);
//print_mat("M after scaling is:\n", M);
for (i = 1; i <= 3*N_DOFS; i++) {
for (j = 1; j <= 3*N_DOFS; j++) {
N[i][j] = c * M[i][j];
D[i][j] = -c * M[i][j];
}
N[i][i] = N[i][i] + 1.0;
D[i][i] = D[i][i] + 1.0;
}
// set M2 equal to M
mat_equal(M, M2);
// start pade approximation
for (k = 2; k <= q; k++) {
c = c * (q - k + 1) / (double)(k * (2*q - k + 1));
mat_mult(M,M2,M2);
mat_mult_scalar(M2,c,M3);
mat_add(N,M3,N);
if (p == 1)
mat_add(D,M3,D);
else
mat_sub(D,M3,D);
p = -1 * p;
}
// multiply denominator with nominator i.e. D\E
my_inv_ludcmp(D, 3*N_DOFS, D);
mat_mult(D,N,N);
// undo scaling by repeated squaring
for (k = 1; k <= norm; k++)
mat_mult(N,N,N);
// get the matrices out
// read off the entries
for (i = 1; i <= 2*N_DOFS; i++) {
for (j = 1; j <= 2*N_DOFS; j++) {
A[i][j] = N[i][j];
}
for (j = 1; j <= N_DOFS; j++) {
B[i][j] = N[i][2*N_DOFS + j];
}
}
}
void lin_alg::jacobi_solve(double **a, double *x, double *b, int n, int max_iter, bool &solved, double tol, double &error)
{
// Solve the system Ax=b by Jacobi's iteration method
// This has the slowest convergence rate of the iterative techniques
// In practice you never use this algorithm
// Always use GS or SOR for iterative solution
// R. Sheehan 3 - 8 - 2011
bool cgt = false;
double *oldx = vector(n);
double *diffx = vector(n);
int n_iter = 1;
double bi, mi, err;
while(n_iter < max_iter){
// store the initial approximation to the solution
for(int i=1; i<=n; i++){
oldx[i] = x[i];
}
for(int i=1;i<=n;i++){
bi=b[i]; mi=a[i][i];
for(int j=1;j<=n;j++){
if(j!=i){
bi-=a[i][j]*oldx[j];
}
}
x[i]=bi/mi;
}
diffx = vector_diff(x, oldx, n, n);
err = inf_norm(diffx, n);
if( n_iter%4 == 0){
cout<<"iteration "<<n_iter<<" , error = "<<err<<endl;
}
if(abs(err)<tol){
cout<<"\nJacobi Iteration Complete\nSolution converged in "<<n_iter<<" iterations\n";
cout<<"Error = "<<abs(err)<<endl<<endl;
error = abs(err);
cgt = solved = true;
break;
}
n_iter++;
}
if(!cgt){
cout<<"\nError: Jacobi Iteration\n";
cout<<"Error: Solution did not converge in "<<max_iter<<" iterations\n\n";
}
delete[] oldx;
delete[] diffx;
}
void fem(size_t n, double errors[2], double (*fn_f)(double, double),
double (*fn_g)(unsigned char, double, double),
double (*fn_u)(double, double))
{
mesh m;
crs_matrix mat;
double * u, * rhs;
double local_stiffness[3][3];
double local_load[3];
size_t elem;
/* 1. Allocate and generate mesh */
get_mesh(&m, n);
#ifdef PRINT_DEBUG
print_mesh(&m);
#endif
/* 2. Allocate the linear system */
init_matrix(&mat, &m);
u = (double *) malloc(sizeof(double) * m.n_vertices);
if (u == NULL) err_exit("Allocation of solution vector failed!");
memset(u, 0, sizeof(double) * m.n_vertices);
rhs = (double *) malloc(sizeof(double) * m.n_vertices);
if (rhs == NULL)
err_exit("Allocation of right hand side failed!");
memset(rhs, 0, sizeof(double) * m.n_vertices);
/* 3. Assemble the matrix */
for (elem = 0; elem < m.n_triangles; ++elem)
{
/* Compute local stiffness and load */
get_local_stiffness(local_stiffness, &m, elem);
get_local_load(local_load, &m, elem, fn_f);
#ifdef PRINT_DEBUG
print_local_stiffness(local_stiffness);
print_local_load(local_load);
#endif
/* insert into global matrix and rhs */
assemble_local2global_stiffness(local_stiffness, &mat, &m, elem);
assemble_local2global_load(local_load, rhs, &m, elem);
}
#ifdef PRINT_DEBUG
printf("Matrix after assembly:\n");
print_matrix(&mat);
printf("rhs after assembly:\n");
for(size_t i = 0; i < m.n_vertices; ++i) {
printf("%5.2f\n", rhs[i]);
}
printf("\n");
#endif
/* 4. Apply boundary conditions */
apply_dbc(&mat, rhs, &m, fn_g);
#ifdef PRINT_DEBUG
printf("Matrix after application of BCs:\n");
print_matrix(&mat);
printf("rhs after application of BCs:\n");
for(size_t i = 0; i < m.n_vertices; ++i) {
printf("%5.2f\n", rhs[i]);
}
printf("\n");
#endif
/* 5. Solve the linear system */
solve(&mat, u, rhs);
/* 6. Evaluate error */
errors[0] = l2_norm(u, &m, fn_u);
errors[1] = inf_norm(u, &m, fn_u);
/* free allocated resources */
free(u);
free(rhs);
rhs = NULL;
free_matrix(&mat);
free_mesh(&m);
}
