int get_diagonal(DOUBLEVECTOR *diagonal, DOUBLEVECTOR *x0, double dt, t_Matrix_element_with_voidp Matrix, void *data) {
/*
*
* \author Emanuele Cordano
* \date May 2010
*
*\param diagonal (DOUBLEVECTOR *) - the diagonal doublevector of the matrix
*\param Matrix (t_Matrix) - a matrix from which the diagonal is extracted
*
*\brief it saved the square root of diagonal of Matrix in a doublevector
*
*\return 0 in case of success , -1 otherwise
*
*/
long i;
DOUBLEVECTOR *x_v;
x_v=new_doublevector(diagonal->nh);
for (i=x_v->nl;i<=x_v->nh;i++) {
x_v->co[i]=0.0;
}
for (i=x_v->nl;i<=x_v->nh;i++) {
x_v->co[i]=1.0;
diagonal->co[i]=Fmax( (*Matrix)(i,x_v,x0,dt,data) , MAX_VALUE_DIAG );
x_v->co[i]=0.0;
}
free_doublevector(x_v);
return 0;
}
int get_upper_diagonal(DOUBLEVECTOR *udiagonal, DOUBLEVECTOR *x0, double dt, t_Matrix_element_with_voidp Matrix, void *data) {
/*
*
* \author Emanuele Cordano,Stefano Endrizzi
* \date May August 2009
*
*\param diagonal (DOUBLEVECTOR *) - the upper diagonal doublevector of the matrix
*\param Matrix (t_Matrix) - a matrix from which the diagonal is extracted
*
*\brief it saved the upper diagonal of Matrix in a doublevector
*
*\return 0 in case of success , -1 otherwise
*
*/
long i;
DOUBLEVECTOR *x_v;
x_v=new_doublevector(udiagonal->nh+1);
for (i=x_v->nl;i<=x_v->nh;i++) {
x_v->co[i]=0.0;
}
for (i=udiagonal->nl;i<=udiagonal->nh;i++) {
x_v->co[i]=1.0;
udiagonal->co[i]=(*Matrix)(i+1,x_v,x0,dt,data);
//diagonal->co[i]=1.;
x_v->co[i]=0.0;
}
free_doublevector(x_v);
return 0;
}
void topofilter(DOUBLEMATRIX *Zin, DOUBLEMATRIX *Zout, long novalue, long n){
long r, c, nr, nc, ir, ic, i;
DOUBLEVECTOR *values;
long cnt;
values=new_doublevector((2*n+1)*(2*n+1));
nr=Zin->nrh;
nc=Zin->nch;
for (r=1; r<=nr; r++) {
for (c=1; c<=nc; c++) {
if ((long)Zin->co[r][c] != novalue) {
cnt=0;
for (ir=-n; ir<=n; ir++) {
for (ic=-n; ic<=n; ic++) {
if (r+ir>=1 && r+ir<=nr && c+ic>=1 && c+ic<=nc) {
if((long)Zin->co[r+ir][c+ic]!=novalue){
cnt++;
values->co[cnt]=Zin->co[r+ir][c+ic];
}
}
}
}
/*order_values(values, cnt);
if (fmod(cnt, 2)>1.E-5) {
Zout->co[r][c] = values->co[(long)(0.5*(cnt+1))];
}else{
Zout->co[r][c] = 0.5*(values->co[(long)(0.5*(cnt))]+values->co[(long)(0.5*(cnt)+1)]);
}*/
Zout->co[r][c] = 0.;
for (i=1; i<=cnt; i++) {
Zout->co[r][c] += values->co[i]/(double)cnt;
}
}else {
Zout->co[r][c] = (double)novalue;
}
}
}
free_doublevector(values);
}
void solve_SSOR_preconditioning(double w, DOUBLEVECTOR *x, DOUBLEVECTOR *B, LONGVECTOR *Li, LONGVECTOR *Lp, DOUBLEVECTOR *Lx,
LONGVECTOR *Ui, LONGVECTOR *Up, DOUBLEVECTOR *Ux){
//L D-1 U x = B
//L y = B
//D-1 U x = y
//U x = D y
long i;
DOUBLEVECTOR *y;
y = new_doublevector(x->nh);
Lx->co[1] /= w;
Ux->co[1] /= w;
for(i=2;i<=x->nh;i++){
Lx->co[Lp->co[i-1]+1] /= w;
Ux->co[Up->co[i]] /= w;
}
solve_lower_diagonal_system(y, B, Ui, Up, Ux);
y->co[1] *= Lx->co[1]*(2.-w);
for(i=2;i<=x->nh;i++){
y->co[i] *= Lx->co[Lp->co[i-1]+1]*(2.-w);
}
solve_upper_diagonal_system(x, y, Li, Lp, Lx);
Lx->co[1] *= w;
Ux->co[1] *= w;
for(i=2;i<=x->nh;i++){
Lx->co[Lp->co[i-1]+1] *= w;
Ux->co[Up->co[i]] *= w;
}
free_doublevector(y);
}
POLYGON *read_polygon(FILE *fd,short print) {
/*!
* \autor Emanuele Cordano
* \date May 2009
*
* \param (FILE *) - file pointer
* \param (short) - print
*
*/
int ix=1; /* x coordinate of the centroid */
int iy=ix+1; /* y coordinate of the centroid */
int ipolygon_index=iy+1; /* index of the polygon */
int iarea2d=ipolygon_index+1; /* area of the polygon */
int n_data=iarea2d;
long i;
DOUBLEVECTOR *v_data;
POLYGON *po;
v_data=read_doublearray(fd,print);
if (v_data->nh<=n_data) printf ("Error in read_polygon there no sufficient data !!\n");
po=(POLYGON *)malloc(sizeof(POLYGON));
if (!po) t_error("Polygon in read_polygon struct was not allocated");
po->area2D=v_data->element[iarea2d];
po->index=v_data->element[ipolygon_index];
po->centroid=new_point(po->index,v_data->element[ix],v_data->element[iy],NULL_ELEVATION);
po->edge_indices=new_longvector(v_data->nh-n_data);
for(i=po->edge_indices->nl;i<=po->edge_indices->nh;i++) {
po->edge_indices->element[i]=v_data->element[i+n_data];
}
free_doublevector(v_data);
return po;
}
polygon_connection_attributes *read_connections(FILE *fd,short print) {
/*!
* \author Emanuele Cordano
* \date May 2009
*
* \param fd - (FILE *) file pointer
* \param print - (short)
*
*
*/
polygon_connection_attributes *pca;
DOUBLEVECTOR *v_data;
long j;
v_data=read_doublearray(fd,no_PRINT);
int s=(v_data->nh-1)%2;
if (s!=0) printf("Error in read_connections (index %ld) odd number of elements in the vector after the first one which is the polygon index",v_data->nh);
long l=(v_data->nh-1)/2;
pca=(polygon_connection_attributes *)malloc((sizeof(polygon_connection_attributes)));
if (!pca) printf("Error: polygon_connection_attributes was not allocated at %ld polygon",(long)v_data->element[1]);
pca->connections=new_longvector(l);
pca->d_connections=new_doublevector(l);
for (j=pca->connections->nl;j<=pca->connections->nh;j++) {
pca->connections->element[j]=(long)(v_data->element[j*2]);
pca->d_connections->element[j]=v_data->element[j*2+1];
}
free_doublevector(v_data);
return pca;
}
void tridiag2(short a, long r, long c, long nx, double wdi, DOUBLEVECTOR *diag_inf, double wd, DOUBLEVECTOR *diag, double wds, DOUBLEVECTOR *diag_sup, DOUBLEVECTOR *b, DOUBLEVECTOR *e)
//solve A(wdi*diag_inf,wd*diag,wds*diag_sup) * e + b = 0
{
long j;
double bet;
DOUBLEVECTOR *gam;
gam=new_doublevector(nx);
if(wd*diag->co[1]==0.0){
printf("type=%d r=%ld c=%ld\n",a,r,c);
t_error("Error 1 in tridiag");
}
bet=wd*diag->co[1];
e->co[1]=-b->co[1]/bet;
//Decomposition and forward substitution
for(j=2;j<=nx;j++){
gam->co[j]=wds*diag_sup->co[j-1]/bet;
bet=wd*diag->co[j]-wdi*diag_inf->co[j-1]*gam->co[j];
if(bet==0.0){
printf("type=%d r=%ld c=%ld\n",a,r,c);
printf("l=%ld diag(l)=%f diag_inf(l-1)=%f diag_sup(l-1)=%f\n",j,wd*diag->co[j],wdi*diag_inf->co[j-1],wds*diag_sup->co[j-1]);
t_error("Error 2 in tridiag");
}
e->co[j]=(-b->co[j]-wdi*diag_inf->co[j-1]*e->co[j-1])/bet;
}
//Backsubstitution
for(j=(nx-1);j>=1;j--){
e->co[j]-=gam->co[j+1]*e->co[j+1];
}
free_doublevector(gam);
}
int get_diagonal(DOUBLEVECTOR *diagonal, t_Matrix_element Matrix) {
/*
*
* \author Emanuele Cordano
* \date May 2008
*
*\param diagonal (DOUBLEVECTOR *) - the diagonal doublevector of the matrix
*\param Matrix (t_Matrix) - a matrix from which the diagonal is extracted
*
*\brief it saved the square root of diagonal of Matrix in a doublevector
*
*\return 0 in case of success , -1 otherwise
*
*/
long i;
DOUBLEVECTOR *x_v;
x_v=new_doublevector(diagonal->nh);
// y_v=new_doublevector(diagonal->nh);
for (i=x_v->nl; i<=x_v->nh; i++) {
x_v->element[i]=0.0;
}
for (i=x_v->nl; i<=x_v->nh; i++) {
x_v->element[i]=1.0;
diagonal->element[i]=(*Matrix)(i,x_v);
x_v->element[i]=0.0;
}
free_doublevector(x_v);
//free_doublevector(y_v);
return 0;
}
/*---------------- 6. The most important subroutine of the main: "time_loop" ---------------*/
void time_loop(ALLDATA *A){
clock_t tstart, tend;
short en=0, wt=0, out;
long i, sy, r, c, j, l;
double t, Dt, JD0, JDb, JDe, W, th, th0;
double Vout, Voutsub, Voutsup, Vbottom, C0, C1;
FILE *f;
//double mean;
STATEVAR_3D *S=NULL, *G=NULL;
SOIL_STATE *L, *C;
STATE_VEG *V;
DOUBLEVECTOR *a, *Vsup_ch, *Vsub_ch;
S=(STATEVAR_3D *)malloc(sizeof(STATEVAR_3D));
allocate_and_initialize_statevar_3D(S, (double)number_novalue, A->P->max_snow_layers, Nr, Nc);
if(A->P->max_glac_layers>0){
G=(STATEVAR_3D *)malloc(sizeof(STATEVAR_3D));
allocate_and_initialize_statevar_3D(G, (double)number_novalue, A->P->max_glac_layers, Nr, Nc);
}
L=(SOIL_STATE *)malloc(sizeof(SOIL_STATE));
initialize_soil_state(L, A->P->total_pixel, Nl);
C=(SOIL_STATE *)malloc(sizeof(SOIL_STATE));
initialize_soil_state(C, A->C->r->nh, Nl);
V=(STATE_VEG *)malloc(sizeof(STATE_VEG));
initialize_veg_state(V, A->P->total_pixel);
a=new_doublevector(A->P->total_pixel);
Vsub_ch=new_doublevector(A->C->r->nh);
Vsup_ch=new_doublevector(A->C->r->nh);
time( &start_time );
//periods
i_sim = i_sim0;
do{
//runs
A->I->time = A->P->delay_day_recover*86400.;//Initialize time
A->P->delay_day_recover = 0.;
do{
if( A->I->time > (A->P->end_date->co[i_sim] - A->P->init_date->co[i_sim])*86400. - 1.E-5){
printf("Number of times the simulation #%ld has been run: %ld\n",i_sim,i_run);
f=fopen(logfile, "a");
fprintf(f,"Number of times the simulation #%ld has been run: %ld\n",i_sim,i_run);
fclose(f);
print_run_average(A->S, A->T, A->P);
i_run++;
A->I->time = 0.0;//Initialize time
A->M->line_interp_WEB_LR = 0;
A->M->line_interp_Bsnow_LR = 0;
for (i=1; i<=A->M->st->Z->nh; i++) {
A->M->line_interp_WEB[i-1] = 0;
A->M->line_interp_Bsnow[i-1] = 0;
}
if(i_run <= A->P->run_times->co[i_sim]){
reset_to_zero(A->P, A->S, A->L, A->N, A->G, A->E, A->M, A->W);
init_run(A->S, A->P);
}
}else {
//find time step from file or inpts
set_time_step(A->P, A->I);
//time at the beginning of the time step
JD0 = A->P->init_date->co[i_sim]+A->I->time/secinday;
//time step variables
t = 0.;
Dt = A->P->Dt;
//time step subdivisions
do{
JDb = A->P->init_date->co[i_sim]+(A->I->time+t)/secinday;
if (t + Dt > A->P->Dt) Dt = A->P->Dt - t;
//iterations
do{
JDe = A->P->init_date->co[i_sim]+(A->I->time+t+Dt)/secinday;
//copy state variables on
copy_snowvar3D(A->N->S, S);
copy_doublevector(A->N->age, a);
if (A->P->max_glac_layers>0) copy_snowvar3D(A->G->G, G);
copy_soil_state(A->S->SS, L);
copy_soil_state(A->C->SS, C);
copy_veg_state(A->S->VS, V);
/*for (j=1; j<=A->W->H1->nh; j++) {
l=A->T->lrc_cont->co[j][1];
r=A->T->lrc_cont->co[j][2];
c=A->T->lrc_cont->co[j][3];
printf("START %ld %ld %ld %e\n",l,r,c,A->S->SS->P->co[l][A->T->j_cont[r][c]]);
}*/
//init
initialize_doublevector(Vsub_ch, 0.);
initialize_doublevector(Vsup_ch, 0.);
Vout = 0.;
Voutsub = 0.;
Voutsup = 0.;
Vbottom = 0.;
//meteo
tstart=clock();
meteo_distr(A->M->line_interp_WEB, A->M->line_interp_WEB_LR, A->M, A->W, A->T, A->P, JD0, JDb, JDe);
tend=clock();
t_meteo+=(tend-tstart)/(double)CLOCKS_PER_SEC;
if(A->P->en_balance == 1){
tstart=clock();
en = EnergyBalance(Dt, JD0, JDb, JDe, L, C, S, G, V, a, A, &W);
tend=clock();
t_energy+=(tend-tstart)/(double)CLOCKS_PER_SEC;
}
if(A->P->wat_balance == 1 && en == 0){
tstart=clock();
wt = water_balance(Dt, JD0, JDb, JDe, L, C, A, Vsub_ch, Vsup_ch, &Vout, &Voutsub, &Voutsup, &Vbottom);
tend=clock();
t_water+=(tend-tstart)/(double)CLOCKS_PER_SEC;
}
if (en != 0 || wt != 0) {
if(Dt > A->P->min_Dt) Dt *= 0.5;
out = 0;
f = fopen(logfile, "a");
if (en != 0) {
fprintf(f,"Energy balance not converging\n");
}else {
fprintf(f,"Water balance not converging\n");
}
fprintf(f,"Reducing time step to %f s, t:%f s\n",Dt,t);
fclose(f);
}else {
out = 1;
}
//printf("Dt:%f min:%f\n",Dt,A->P->min_Dt);
}while( out == 0 && Dt > A->P->min_Dt );
/*if (en != 0 || wt != 0) {
f = fopen(FailedRunFile, "w");
fprintf(f, "Simulation Period:%ld\n",i_sim);
fprintf(f, "Run Time:%ld\n",i_run);
fprintf(f, "Number of days after start:%f\n",A->I->time/86400.);
if (en != 0 && wt == 0) {
fprintf(f, "ERROR: Energy balance does not converge, Dt:%f\n",Dt);
}else if (en == 0 && wt != 0) {
fprintf(f, "ERROR: Water balance does not converge, Dt:%f\n",Dt);
}else {
fprintf(f, "ERROR: Water and energy balance do not converge, Dt:%f\n",Dt);
}
fclose(f);
t_error("Fatal Error! Geotop is closed. See failing report.");
}*/
if (en != 0 || wt != 0) {
//f = fopen(FailedRunFile, "w");
f = fopen(logfile, "a");
//fprintf(f, "Simulation Period:%ld\n",i_sim);
//fprintf(f, "Run Time:%ld\n",i_run);
//fprintf(f, "Number of days after start:%f\n",A->I->time/86400.);
if (en != 0 && wt == 0) {
fprintf(f, "WARNING: Energy balance does not converge, Dt:%f\n",Dt);
}else if (en == 0 && wt != 0) {
fprintf(f, "WARNING: Water balance does not converge, Dt:%f\n",Dt);
}else {
fprintf(f, "WARNING: Water and energy balance do not converge, Dt:%f\n",Dt);
}
fclose(f);
//t_error("Fatal Error! Geotop is closed. See failing report.");
}
t += Dt;
if (A->P->state_pixel == 1 && A->P->dUzrun == 1) {
for (j=1; j<=A->P->rc->nrh; j++) {
for (l=1; l<=Nl; l++){
r = A->P->rc->co[j][1];
c = A->P->rc->co[j][2];
sy = A->S->type->co[r][c];
th = theta_from_psi(A->S->SS->P->co[l][A->T->j_cont[r][c]], A->S->SS->thi->co[l][A->T->j_cont[r][c]], l, A->S->pa->co[sy], PsiMin);
if(th > A->S->pa->co[sy][jsat][l]-A->S->SS->thi->co[l][A->T->j_cont[r][c]]) th = A->S->pa->co[sy][jsat][l]-A->S->SS->thi->co[l][A->T->j_cont[r][c]];
C0 = A->S->pa->co[sy][jct][l]*(1.-A->S->pa->co[sy][jsat][l])*A->S->pa->co[sy][jdz][l] + c_ice*A->S->SS->thi->co[l][A->T->j_cont[r][c]] + c_liq*th;
th0 = th;
th = theta_from_psi(L->P->co[l][A->T->j_cont[r][c]], L->thi->co[l][A->T->j_cont[r][c]], l, A->S->pa->co[sy], PsiMin);
if(th > A->S->pa->co[sy][jsat][l]-L->thi->co[l][A->T->j_cont[r][c]]) th = A->S->pa->co[sy][jsat][l]-L->thi->co[l][A->T->j_cont[r][c]];
C1 = A->S->pa->co[sy][jct][l]*(1.-A->S->pa->co[sy][jsat][l])*A->S->pa->co[sy][jdz][l] + c_ice*L->thi->co[l][A->T->j_cont[r][c]] + c_liq*th;
A->S->dUzrun->co[j][l] += 1.E-6*( 0.5*(C0+C1)*(L->T->co[l][A->T->j_cont[r][c]] - A->S->SS->T->co[l][A->T->j_cont[r][c]]) + Lf*(th-th0)*A->S->pa->co[sy][jdz][l] );
}
}
}
//write state variables
copy_snowvar3D(S, A->N->S);
copy_doublevector(a, A->N->age);
if (A->P->max_glac_layers>0) copy_snowvar3D(G, A->G->G);
copy_soil_state(L, A->S->SS);
copy_soil_state(C, A->C->SS);
copy_veg_state(V, A->S->VS);
add_doublevector(Vsub_ch, A->C->Vsub);
add_doublevector(Vsup_ch, A->C->Vsup);
A->C->Vout += Vout;
A->W->Voutbottom += Vbottom;
A->W->Voutlandsub += Voutsub;
A->W->Voutlandsup += Voutsup;
//printf("%f\n",A->I->time);
//record time step
odb[ootimestep] = Dt * (Dt/A->P->Dtplot_basin->co[i_sim]);
//write output variables
fill_output_vectors(Dt, W, A->E, A->N, A->G, A->W, A->M, A->P, A->I, A->T, A->S);
//reset Dt
if (Dt < A->P->Dt) Dt *= 2.;
}while(t < A->P->Dt);
if(A->P->blowing_snow==1){
tstart=clock();
windtrans_snow(A->N, A->M, A->W, A->L, A->T, A->P, A->I->time);
tend=clock();
t_blowingsnow+=(tend-tstart)/(double)CLOCKS_PER_SEC;
}
tstart=clock();
write_output(A->I, A->W, A->C, A->P, A->T, A->L, A->S, A->E, A->N, A->G, A->M);
tend=clock();
t_out+=(tend-tstart)/(double)CLOCKS_PER_SEC;
A->I->time += A->P->Dt;//Increase TIME
}
}while(i_run <= A->P->run_times->co[i_sim]);//end of time-cycle
if (A->P->newperiodinit != 0) end_period_1D(A->S, A->T, A->P);
if (i_sim < A->P->init_date->nh) change_grid(i_sim, i_sim+1, A->P, A->T, A->L, A->W, A->C);
reset_to_zero(A->P, A->S, A->L, A->N, A->G, A->E, A->M, A->W);
init_run(A->S, A->P);
i_sim++;
i_run0 = 1;
i_run = i_run0;
}while (i_sim <= A->P->init_date->nh);
deallocate_statevar_3D(S);
if(A->P->max_glac_layers>0) deallocate_statevar_3D(G);
deallocate_soil_state(L);
deallocate_soil_state(C);
deallocate_veg_state(V);
free_doublevector(a);
free_doublevector(Vsub_ch);
free_doublevector(Vsup_ch);
}
long BiCGSTAB_unpreconditioned(double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x, DOUBLEVECTOR *b,
LONGVECTOR *Li, LONGVECTOR *Lp, DOUBLEVECTOR *Lx){
DOUBLEVECTOR *r0, *r, *p, *v, *s, *t;
double rho, rho1, alpha, omeg, beta, norm_r0;
long i=0, j;
r0 = new_doublevector(x->nh);
r = new_doublevector(x->nh);
p = new_doublevector(x->nh);
v = new_doublevector(x->nh);
s = new_doublevector(x->nh);
t = new_doublevector(x->nh);
product_using_only_lower_diagonal_part(r, x, Li, Lp, Lx);
for (j=x->nl;j<=x->nh;j++ ) {
r->co[j] = b->co[j] - r->co[j];
r0->co[j] = r->co[j];
p->co[j] = 0.;
v->co[j] = 0.;
}
norm_r0 = norm_2(r0,r0->nh);
rho = 1.;
alpha = 1.;
omeg = 1.;
while ( i<=x->nh && norm_2(r,r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
rho1 = product(r0, r);
beta = (rho1/rho)*(alpha/omeg);
rho = rho1;
for (j=x->nl;j<=x->nh;j++ ) {
p->co[j] = r->co[j] + beta*(p->co[j] - omeg*v->co[j]);
}
product_using_only_lower_diagonal_part(v, p, Li, Lp, Lx);
alpha = rho/product(r0, v);
for (j=x->nl;j<=x->nh;j++ ) {
s->co[j] = r->co[j] - alpha*v->co[j];
}
product_using_only_lower_diagonal_part(t, s, Li, Lp, Lx);
omeg = product(t, s)/product(t, t);
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += (alpha*p->co[j] + omeg*s->co[j]);
r->co[j] = s->co[j] - omeg*t->co[j];
}
i++;
printf("i:%ld normr0:%e normr:%e\n",i,norm_r0,norm_2(r,r->nh));
}
free_doublevector(r0);
free_doublevector(r);
free_doublevector(p);
free_doublevector(v);
free_doublevector(s);
free_doublevector(t);
return i;
}
long CG(double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x, DOUBLEVECTOR *x0, double dt,
DOUBLEVECTOR *b, t_Matrix_element_with_voidp function, void *data){
/*!
*\param icnt - (long) number of reiterations
*\param epsilon - (double) required tollerance (2-order norm of the residuals)
*\param x - (DOUBLEVECTOR *) vector of the unknowns x in Ax=b
*\param b - (DOUBLEVECTOR *) vector of b in Ax=b
*\param funz - (t_Matrix_element_with_voidp) - (int) pointer to the application A (x and y doublevector y=A(param)x ) it return 0 in case of success, -1 otherwise.
*\param data - (void *) data and parameters related to the argurment t_Matrix_element_with_voidp funz
*
*
*\brief algorithm proposed by Jonathan Richard Shewckuck in http://www.cs.cmu.edu/~jrs/jrspapers.html#cg and http://www.cs.cmu.edu/~quake-papers/painless-conjugate-gradient.pdf
*
* \author Emanuele Cordano
* \date June 2009
*
*\return the number of reitarations
*/
double delta,alpha,beta,delta_new;
DOUBLEVECTOR *r, *d,*q,*y,*sr,*diag,*udiag;
int sl;
long icnt_max;
long icnt;
long j;
double p;
double norm_r0;
r=new_doublevector(x->nh);
d=new_doublevector(x->nh);
q=new_doublevector(x->nh);
y=new_doublevector(x->nh);
sr=new_doublevector(x->nh);
diag=new_doublevector(x->nh);
udiag=new_doublevector(x->nh-1);
icnt=0;
icnt_max=x->nh;
//icnt_max=(long)(sqrt((double)x->nh));
for (j=x->nl;j<=x->nh;j++){
y->co[j]=(*function)(j,x,x0,dt,data);
}
get_diagonal(diag,x0,dt,function,data);
get_upper_diagonal(udiag,x0,dt,function,data);
delta_new=0.0;
for (j=y->nl;j<=y->nh;j++) {
r->co[j]=b->co[j]-y->co[j];
if (diag->co[j]<0.0) {
diag->co[j]=1.0;
printf("\n Error in jacobi_preconditioned_conjugate_gradient_search function: diagonal of the matrix (%lf) is negative at %ld \n",diag->co[j],j);
stop_execution();
}
}
tridiag(0,0,0,x->nh,udiag,diag,udiag,r,d);
for (j=y->nl;j<=y->nh;j++) {
//d->co[j]=r->co[j]/diag->co[j];
delta_new+=r->co[j]*d->co[j];
}
norm_r0 = norm_2(r, r->nh);
while ( icnt<=icnt_max && norm_2(r, r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
delta=delta_new;
p=0.0;
for(j=q->nl;j<=q->nh;j++) {
q->co[j]=(*function)(j,d,x0,dt,data);
p+=q->co[j]*d->co[j];
}
alpha=delta_new/p;
for(j=x->nl;j<=x->nh;j++) {
x->co[j]=x->co[j]+alpha*d->co[j];
}
delta_new=0.0;
sl=0;
for (j=y->nl;j<=y->nh;j++) {
if (icnt%MAX_ITERATIONS==0) {
y->co[j]=(*function)(j,x,x0,dt,data);
r->co[j]=b->co[j]-y->co[j];
} else {
r->co[j]=r->co[j]-alpha*q->co[j];
}
}
tridiag(0,0,0,x->nh,udiag,diag,udiag,r,sr);
for (j=y->nl;j<=y->nh;j++) {
delta_new+=sr->co[j]*r->co[j];
}
beta=delta_new/delta;
for (j=d->nl;j<=d->nh;j++) {
d->co[j]=sr->co[j]+beta*d->co[j];
}
icnt++;
//printf("i:%ld normr0:%e normr:%e\n",icnt,norm_r0,norm_2(r,r->nh));
}
//printf("norm_r:%e\n",norm_2(r,r->nh));
free_doublevector(udiag);
free_doublevector(diag);
free_doublevector(sr);
free_doublevector(r);
free_doublevector(d);
free_doublevector(q);
free_doublevector(y);
return icnt;
}
long BiCGSTAB_LU_SSOR(double w, double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x, DOUBLEVECTOR *b,
LONGVECTOR *Li, LONGVECTOR *Lp, DOUBLEVECTOR *Lx, LONGVECTOR *Ui, LONGVECTOR *Up, DOUBLEVECTOR *Ux){
DOUBLEVECTOR *r0, *r, *p, *v, *s, *t, *y, *z, *ss, *tt;
double rho, rho1, alpha, omeg, beta, norm_r0;
long i=0, j;
r0 = new_doublevector(x->nh);
r = new_doublevector(x->nh);
p = new_doublevector(x->nh);
v = new_doublevector(x->nh);
s = new_doublevector(x->nh);
t = new_doublevector(x->nh);
y = new_doublevector(x->nh);
z = new_doublevector(x->nh);
ss = new_doublevector(x->nh);
tt = new_doublevector(x->nh);
product_using_only_upper_diagonal_part(r, x, Ui, Up, Ux);
for (j=x->nl;j<=x->nh;j++ ) {
r->co[j] = b->co[j] - r->co[j];
r0->co[j] = r->co[j];
p->co[j] = 0.;
v->co[j] = 0.;
}
norm_r0 = norm_2(r0,r0->nh);
rho = 1.;
alpha = 1.;
omeg = 1.;
while ( i<=x->nh && norm_2(r,r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
rho1 = product(r0, r);
beta = (rho1/rho)*(alpha/omeg);
rho = rho1;
for (j=x->nl;j<=x->nh;j++ ) {
p->co[j] = r->co[j] + beta*(p->co[j] - omeg*v->co[j]);
}
solve_SSOR_preconditioning(w, y, p, Li, Lp, Lx, Ui, Up, Ux);
product_using_only_upper_diagonal_part(v, y, Ui, Up, Ux);
alpha = rho/product(r0, v);
for (j=x->nl;j<=x->nh;j++ ) {
s->co[j] = r->co[j] - alpha*v->co[j];
}
solve_SSOR_preconditioning(w, z, s, Li, Lp, Lx, Ui, Up, Ux);
product_using_only_upper_diagonal_part(t, z, Ui, Up, Ux);
solve_lower_diagonal_system(tt, t, Ui, Up, Ux);
solve_lower_diagonal_system(ss, s, Ui, Up, Ux);
omeg = product(tt, ss)/product(tt, tt);
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += (alpha*y->co[j] + omeg*z->co[j]);
r->co[j] = s->co[j] - omeg*t->co[j];
}
i++;
printf("i:%ld normr0:%e normr:%e\n",i,norm_r0,norm_2(r,r->nh));
}
free_doublevector(r0);
free_doublevector(r);
free_doublevector(p);
free_doublevector(v);
free_doublevector(s);
free_doublevector(t);
free_doublevector(y);
free_doublevector(z);
free_doublevector(ss);
free_doublevector(tt);
return i;
}
long BiCGSTAB_strict_lower_matrix_plus_identity_by_vector(double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x,
DOUBLEVECTOR *b, DOUBLEVECTOR *y, LONGVECTOR *Li, LONGVECTOR *Lp, DOUBLEVECTOR *Lx){
//solve sistem (A+Iy)*x = B, find x
//A M-matrix described by its lower diagonal part
DOUBLEVECTOR *r0, *r, *p, *v, *s, *t, *diag, *udiag, *yy, *z;
double rho, rho1, alpha, omeg, beta, norm_r0;
long i=0, j;
r0 = new_doublevector(x->nh);
r = new_doublevector(x->nh);
p = new_doublevector(x->nh);
v = new_doublevector(x->nh);
s = new_doublevector(x->nh);
t = new_doublevector(x->nh);
diag = new_doublevector(x->nh);
udiag = new_doublevector(x->nh-1);
yy = new_doublevector(x->nh);
z = new_doublevector(x->nh);
get_diag_strict_lower_matrix_plus_identity_by_vector(diag, udiag, y, Li, Lp, Lx);
//product_using_only_strict_lower_diagonal_part_plus_identity_by_vector(r, x, y, Li, Lp, Lx);
for (j=x->nl;j<=x->nh;j++ ) {
//r->co[j] = b->co[j] - r->co[j];
r->co[j] = b->co[j];
r0->co[j] = r->co[j];
p->co[j] = 0.;
v->co[j] = 0.;
}
norm_r0 = norm_2(r0,r0->nh);
rho = 1.;
alpha = 1.;
omeg = 1.;
while ( i<=x->nh && norm_2(r,r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
rho1 = product(r0, r);
beta = (rho1/rho)*(alpha/omeg);
rho = rho1;
for (j=x->nl;j<=x->nh;j++ ) {
p->co[j] = r->co[j] + beta*(p->co[j] - omeg*v->co[j]);
}
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, p, yy);
product_using_only_strict_lower_diagonal_part_plus_identity_by_vector(v, yy, y, Li, Lp, Lx);
alpha = rho/product(r0, v);
for (j=x->nl;j<=x->nh;j++ ) {
s->co[j] = r->co[j] - alpha*v->co[j];
}
if(norm_2(s,s->nh)>1.E-10){
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, s, z);
product_using_only_strict_lower_diagonal_part_plus_identity_by_vector(t, z, y, Li, Lp, Lx);
omeg = product(t, s)/product(t, t);
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += (alpha*yy->co[j] + omeg*z->co[j]);
r->co[j] = s->co[j] - omeg*t->co[j];
}
}else{
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += alpha*yy->co[j];
r->co[j] = s->co[j];
}
}
i++;
//printf("i:%ld normr0:%e normr:%e\n",i,norm_r0,norm_2(r,r->nh));
}
free_doublevector(r0);
free_doublevector(r);
free_doublevector(p);
free_doublevector(v);
free_doublevector(s);
free_doublevector(t);
free_doublevector(diag);
free_doublevector(udiag);
free_doublevector(yy);
free_doublevector(z);
return i;
}
long BiCGSTAB_upper(double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x, DOUBLEVECTOR *b,
LONGVECTOR *Ai, LONGVECTOR *Ap, DOUBLEVECTOR *Ax){
DOUBLEVECTOR *r0, *r, *p, *v, *s, *t, *diag, *udiag, *y, *z;
double rho, rho1, alpha, omeg, beta, norm_r0;
long i=0, j;
r0 = new_doublevector(x->nh);
r = new_doublevector(x->nh);
p = new_doublevector(x->nh);
v = new_doublevector(x->nh);
s = new_doublevector(x->nh);
t = new_doublevector(x->nh);
diag = new_doublevector(x->nh);
udiag = new_doublevector(x->nh-1);
y = new_doublevector(x->nh);
z = new_doublevector(x->nh);
get_diag_upper_matrix(diag, udiag, Ai, Ap, Ax);
product_using_only_upper_diagonal_part(r, x, Ai, Ap, Ax);
for (j=x->nl;j<=x->nh;j++ ) {
r->co[j] = b->co[j] - r->co[j];
r0->co[j] = r->co[j];
p->co[j] = 0.;
v->co[j] = 0.;
}
norm_r0 = norm_2(r0,r0->nh);
rho = 1.;
alpha = 1.;
omeg = 1.;
while ( i<=x->nh && norm_2(r,r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
rho1 = product(r0, r);
beta = (rho1/rho)*(alpha/omeg);
rho = rho1;
for (j=x->nl;j<=x->nh;j++ ) {
p->co[j] = r->co[j] + beta*(p->co[j] - omeg*v->co[j]);
}
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, p, y);
product_using_only_upper_diagonal_part(v, y, Ai, Ap, Ax);
alpha = rho/product(r0, v);
for (j=x->nl;j<=x->nh;j++ ) {
s->co[j] = r->co[j] - alpha*v->co[j];
}
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, s, z);
product_using_only_upper_diagonal_part(t, z, Ai, Ap, Ax);
omeg = product(t, s)/product(t, t);
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += (alpha*y->co[j] + omeg*z->co[j]);
r->co[j] = s->co[j] - omeg*t->co[j];
}
i++;
//printf("i:%ld normr0:%e normr:%e\n",i,norm_r0,norm_2(r,r->nh));
}
free_doublevector(r0);
free_doublevector(r);
free_doublevector(p);
free_doublevector(v);
free_doublevector(s);
free_doublevector(t);
free_doublevector(diag);
free_doublevector(udiag);
free_doublevector(y);
free_doublevector(z);
return i;
}
long BiCGSTAB(double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x, DOUBLEVECTOR *x0,
double dt, DOUBLEVECTOR *b, t_Matrix_element_with_voidp function, void *data){
/* \author Stefano Endrizzi
\date March 2010
from BI-CGSTAB: A FAST AND SMOOTHLY CONVERGING VARIANT OF BI-CG FOR THE SOLUTION OF NONSYMMETRIC LINEAR SYSTEMS
by H. A. VAN DER VORST - SIAM J. ScI. STAT. COMPUT. Vol. 13, No. 2, pp. 631-644, March 1992
*/
DOUBLEVECTOR *r0, *r, *p, *v, *s, *t, *diag, *udiag, *y, *z;
//DOUBLEVECTOR *tt, *ss;
double rho, rho1, alpha, omeg, beta, norm_r0;
long i=0, j;
r0 = new_doublevector(x->nh);
r = new_doublevector(x->nh);
p = new_doublevector(x->nh);
v = new_doublevector(x->nh);
s = new_doublevector(x->nh);
t = new_doublevector(x->nh);
diag = new_doublevector(x->nh);
udiag = new_doublevector(x->nh-1);
y = new_doublevector(x->nh);
z = new_doublevector(x->nh);
//tt = new_doublevector(x->nh);
//ss = new_doublevector(x->nh);
get_diagonal(diag,x0,dt,function,data);
get_upper_diagonal(udiag,x0,dt,function,data);
for (j=x->nl;j<=x->nh;j++ ) {
r0->co[j] = b->co[j] - (*function)(j,x,x0,dt,data);
r->co[j] = r0->co[j];
p->co[j] = 0.;
v->co[j] = 0.;
}
norm_r0 = norm_2(r0,r0->nh);
rho = 1.;
alpha = 1.;
omeg = 1.;
while ( i<=x->nh && norm_2(r,r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
rho1 = product(r0, r);
beta = (rho1/rho)*(alpha/omeg);
rho = rho1;
for (j=x->nl;j<=x->nh;j++ ) {
p->co[j] = r->co[j] + beta*(p->co[j] - omeg*v->co[j]);
}
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, p, y);
for (j=x->nl;j<=x->nh;j++ ) {
v->co[j] = (*function)(j,y,x0,dt,data);
}
alpha = rho/product(r0, v);
for (j=x->nl;j<=x->nh;j++ ) {
s->co[j] = r->co[j] - alpha*v->co[j];
}
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, s, z);
for (j=x->nl;j<=x->nh;j++ ) {
t->co[j] = (*function)(j,z,x0,dt,data);
}
/*tridiag(0, 0, 0, x->nh, udiag, diag, udiag, t, tt);
tridiag(0, 0, 0, x->nh, udiag, diag, udiag, s, ss);
omeg = product(tt, ss)/product(tt, tt);*/
omeg = product(t, s)/product(t, t);
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += (alpha*y->co[j] + omeg*z->co[j]);
r->co[j] = s->co[j] - omeg*t->co[j];
}
i++;
//printf("i:%ld normr0:%e normr:%e\n",i,norm_r0,norm_2(r,r->nh));
}
free_doublevector(r0);
free_doublevector(r);
free_doublevector(p);
free_doublevector(v);
free_doublevector(s);
free_doublevector(t);
free_doublevector(diag);
free_doublevector(udiag);
free_doublevector(y);
free_doublevector(z);
//free_doublevector(tt);
//free_doublevector(ss);
return i;
}
void main(int nar, char* ar[])
{
int i,j,k,l,m, n=0, num, nnn[4];
float*u; // ,*f;
double*f;
parlist par;
FILE *in,*out,*col,*grs;
char name[100];
char buffer[48];
float cpu[2];
clock_t t;
/* set default values */
par.sigma=2; par.seed=200294;
par.dim=intvector(1,3); par.dim[1]=64; par.dim[2]=32; par.dim[3]=16;
empty(&par.inname); empty(&par.outname);
empty(&par.colname); empty(&par.grsname);
par.length=1; par.nongauss=0; par.lo=-4; par.hi=4; par.bins=100;
par.med=0; par.pixel=1; par.normal=1; par.time=0;
/* work through arguments */
while(++n<nar){
if(ar[n][0]=='-'&&ar[n][1]){
switch(ar[n][1]) {
case'0' : par.grsname =READSTR; break;
case'1' : par.colname =READSTR; break;
case'L' : par.length =READINT; break;
case'N' : par.normal =0; break;
case'b' : par.bins =READINT; break;
case'g' : par.nongauss=READINT; break;
case'h' : par.hi =READFLT; break;
case'i' : par.inname =READSTR; break;
case'l' : par.lo =READFLT; break;
case'm' : par.med =READINT; break;
case'o' : par.outname =READSTR; break;
case'p' : par.pixel =READINT; break;
case'r' : par.seed =READINT; break;
case's' : par.sigma =READFLT; break;
case't' : par.time =1; break;
case'x' : par.dim[1] =READINT; break;
case'y' : par.dim[2] =READINT; break;
case'z' : par.dim[3] =READINT; break;
default : Explain(stderr,ar[0],&par);
}
}
else {
Explain(stderr,ar[0],&par);
}
}
par.a=1./(float)par.dim[1]; /* grid constant is used everywhere */
/* allocate some memory */
n=par.dim[1]*par.dim[2]*par.dim[3];
u=vector(0,2*n);
/* open input file and read data */
fileopenr(&in,par.inname);
/* printf("%s"," here 1a \n");
printf("size = %d\n",sizeof(in)); */
if(in) {
//f=vector(0,n);
f=doublevector(0,n);
fread((void*)buffer,sizeof(char),24,in);
if(n!=fread((void*)f,sizeof(double),n,in)) {
fprintf(stderr,"error when reading input!\n");
exit(99);
}
/* printf("f[0] %d\n",&f[0]);
printf("f[0]wert %g\n", f[0]);
printf("f[1]wert %g\n", f[1]);
printf("f[1]wert %g\n", f[2]);
printf("f[1]wert %g\n", f[3]); */
printf("---\n");
//for(i=0;i<n;i++) u[2*i]=f[i],u[2*i+1]=0;
for(i=0;i<n;i++) u[2*i]=(float)f[i],u[2*i+1]=0;
/* printf("u[0] %d\n",&u[0]);
printf("u[0]wert %g\n", u[0]);
printf("f[0] %d\n",&f[0]);
printf("f[0]wert %g\n", f[0]);
printf("u[1] %d\n",&u[1]);
printf("u[1]wert %g\n", u[1]);
printf("f[1] %d\n",&f[1]);
printf("f[1]wert %g\n", f[1]);
printf("%s"," here 1c \n"); */
//free_vector(f,0,n);
free_doublevector(f,0,n);
/* printf("%s"," here 1d \n");
printf("par.sigma = %g\n",par.sigma); */
if(par.sigma>0) fourn(u-1,par.dim,3,1);
}
/* printf("%s"," here 1e \n"); */
fileclose(in);
/* printf("%s"," here 1 \n"); */
/* open output files */
fileopenw(&out,par.outname);
/* printf("%s"," here 2 \n"); */
cpu[0]=cpu[1]=0;
for(num=0; num<par.length; num++) {
/* random field in Fourier space */
if(par.time) t=clock();
if(!in) randomfield(u,&par);
if(par.time) cpu[0]+=(clock()-t)/(float)CLOCKS_PER_SEC;
/* convolution and normalization */
if(par.time) t=clock();
if(par.sigma>0) convolution(u,&par);
if(par.sigma>0) fourn(u-1,par.dim,3,-1);
normalize(u,&par);
if(par.time) cpu[0]+=(clock()-t)/(float)CLOCKS_PER_SEC;
/* printf("%s"," here 2c \n");*/
/* perform statistics */
if(par.time) t=clock();
minkowski(out,u,&par);
if(par.time) cpu[1]+=(clock()-t)/(float)CLOCKS_PER_SEC;
}
/* printf("%s"," here 3 \n"); */
if(par.time)
fprintf(stderr,"CPU: %13s%13s\n"
" %8.2f sec %8.2f sec\n",
"fields","minkowski",cpu[0],cpu[1]);
/* output xpm bitmap data */
fileopenw(&col,par.colname); if(col) picture(1,col,u,&par); fileclose(col);
fileopenw(&grs,par.grsname); if(grs) picture(0,grs,u,&par); fileclose(grs);
/* finish */
fileclose(out);
free_vector(u,0,2*n);
exit(0);
}
long jacobi_preconditioned_conjugate_gradient_search(long icnt, double epsilon, DOUBLEVECTOR *x, DOUBLEVECTOR *b, t_Matrix_element funz) {
/*!
*\param icnt - (long) number of reiterations
*\param epsilon - (double) required tollerance (2-order norm of the residuals)
*\param x - (DOUBLEVECTOR *) vector of the unknowns x in Ax=b
*\param b - (DOUBLEVECTOR *) vector of b in Ax=b
*\param funz - (t_Matrix_element) - (int) pointer to the application A (x and y doublevector y=A(param)x ) it return 0 in case of success, -1 otherwise.
*
*
*\brief algorithm proposed by Jonathan Richard Shewckuck in http://www.cs.cmu.edu/~jrs/jrspapers.html#cg and http://www.cs.cmu.edu/~quake-papers/painless-conjugate-gradient.pdf
*
* \author Emanuele Cordano
* \date June 2009
*
*\return the number of reitarations
*/
double delta,delta_new,alpha,beta,delta0;
DOUBLEVECTOR *r, *d,*q,*y,*sr,*diag;
int sl;
long icnt_max;
long j;
double p;
r=new_doublevector(x->nh);
d=new_doublevector(x->nh);
q=new_doublevector(x->nh);
y=new_doublevector(x->nh);
sr=new_doublevector(x->nh);
diag=new_doublevector(x->nh);
icnt=0;
icnt_max=x->nh;
for (j=x->nl; j<=x->nh; j++) {
y->element[j]=(*funz)(j,x);
}
get_diagonal(diag,funz);
// print_doublevector_elements(diag,PRINT);
// stop_execution();
delta_new=0.0;
for (j=y->nl; j<=y->nh; j++) {
r->element[j]=b->element[j]-y->element[j];
if (diag->element[j]<0.0) {
diag->element[j]=1.0;
printf("\n Error in jacobi_preconditioned_conjugate_gradient_search function: diagonal of the matrix (%lf) is negative at %ld \n",diag->element[j],j);
stop_execution();
}
// diag->element[j]=fmax(diag->element[j],MAX_VALUE_DIAG*fabs(r->element[j]));
//d->element[j]=r->element[j]/diag->element[j];
if (diag->element[j]==0.0) { //ec 20100315
d->element[j]=0.0;
} else {
d->element[j]=r->element[j]/(diag->element[j]);
}
delta_new+=r->element[j]*d->element[j];
}
// printf("delta0 =%le", delta0);
// double epsilon0=epsilon;
// double pe=5.0;
while ((icnt<=icnt_max) && (max_doublevector(r)>epsilon)) {
delta=delta_new;
// s=(* funz)(q,d);
p=0.0;
for(j=q->nl; j<=q->nh; j++) {
q->element[j]=(*funz)(j,d);
p+=q->element[j]*d->element[j];
}
alpha=delta_new/p;
for(j=x->nl; j<=x->nh; j++) {
x->element[j]=x->element[j]+alpha*d->element[j];
}
delta_new=0.0;
sl=0;
for (j=y->nl; j<=y->nh; j++) {
if (icnt%MAX_REITERTION==0) {
y->element[j]=(*funz)(j,x);
r->element[j]=b->element[j]-y->element[j];
} else {
r->element[j]=r->element[j]-alpha*q->element[j];
}
if (diag->element[j]==0.0) { // ec_20100315
sr->element[j]=0.0;
d->element[j]=0.0;
} else {
sr->element[j]=r->element[j]/diag->element[j];
}
delta_new+=sr->element[j]*r->element[j];
/* if (((j==y->nl) && sl==0 ) || (sl==1)) {
printf("delta_new =%le (j=%ld) ",delta_new,j);
// if (delta_new==0.0) sl=1;
}*/
}
beta=delta_new/delta;
// double aa=1.0e-21;
// ec Initial residual: printf("delta_new =%le p=%le alpha=%le beta=%le delta_max=%le\n",delta_new,p,alpha,beta,max_doublevector(r));
for (j=d->nl; j<=d->nh; j++) {
d->element[j]=sr->element[j]+beta*d->element[j];
}
icnt++;
}
free_doublevector(diag);
free_doublevector(sr);
free_doublevector(r);
free_doublevector(d);
free_doublevector(q);
free_doublevector(y);
return icnt;
}
long BiCGSTAB_diag(double tol_rel, double tol_min, double tol_max, DOUBLEVECTOR *x, DOUBLEVECTOR *b,
LONGVECTOR *Li, LONGVECTOR *Lp, DOUBLEVECTOR *Lx){
DOUBLEVECTOR *r0, *r, *p, *v, *s, *t, *y, *z, *d;
//DOUBLEVECTOR *ss, *tt;
double rho, rho1, alpha, omeg, beta, norm_r0;
long i=0, j, jlim;
r0 = new_doublevector(x->nh);
r = new_doublevector(x->nh);
p = new_doublevector(x->nh);
v = new_doublevector(x->nh);
s = new_doublevector(x->nh);
t = new_doublevector(x->nh);
y = new_doublevector(x->nh);
z = new_doublevector(x->nh);
d = new_doublevector(x->nh);
//ss = new_doublevector(x->nh);
//tt = new_doublevector(x->nh);
for(j=1;j<=x->nh;j++){
if(j>1){
jlim = Lp->co[j-1]+1;
}else{
jlim = 1;
}
d->co[j] = Lx->co[jlim];
}
product_using_only_lower_diagonal_part(r, x, Li, Lp, Lx);
for (j=x->nl;j<=x->nh;j++ ) {
r->co[j] = b->co[j] - r->co[j];
r0->co[j] = r->co[j];
p->co[j] = 0.;
v->co[j] = 0.;
}
norm_r0 = norm_2(r0,r0->nh);
rho = 1.;
alpha = 1.;
omeg = 1.;
while ( i<=x->nh && norm_2(r,r->nh) > Fmax( tol_min , Fmin( tol_max , tol_rel*norm_r0) ) ) {
rho1 = product(r0, r);
beta = (rho1/rho)*(alpha/omeg);
rho = rho1;
for (j=x->nl;j<=x->nh;j++ ) {
p->co[j] = r->co[j] + beta*(p->co[j] - omeg*v->co[j]);
y->co[j] = p->co[j]/d->co[j];
}
product_using_only_lower_diagonal_part(v, y, Li, Lp, Lx);
alpha = rho/product(r0, v);
for (j=x->nl;j<=x->nh;j++ ) {
s->co[j] = r->co[j] - alpha*v->co[j];
z->co[j] = s->co[j]/d->co[j];
}
product_using_only_lower_diagonal_part(t, z, Li, Lp, Lx);
omeg = product(t, s)/product(t, t);
for (j=x->nl;j<=x->nh;j++ ) {
x->co[j] += (alpha*y->co[j] + omeg*z->co[j]);
r->co[j] = s->co[j] - omeg*t->co[j];
}
i++;
printf("i:%ld normr0:%e normr:%e\n",i,norm_r0,norm_2(r,r->nh));
}
free_doublevector(r0);
free_doublevector(r);
free_doublevector(p);
free_doublevector(v);
free_doublevector(s);
free_doublevector(t);
free_doublevector(y);
free_doublevector(z);
free_doublevector(d);
//free_doublevector(ss);
//free_doublevector(tt);
return i;
}
void find_actual_evaporation_parameters(long R, long C, double *alpha, double *beta, DOUBLEVECTOR *evap_layer, double *theta,
double **soil, double *T, double psi, double P, double rv, double Ta, double Qa, double Qgsat, long nsnow){
DOUBLEVECTOR *r;
double hs, F, A, B, Qs, D, Qsat, rho;
long l, n = evap_layer->nh;
if(nsnow>0){//snow or ice
*alpha = 1.0;
*beta = 1.0;
initialize_doublevector(evap_layer, 0.);
}else{
rho = air_density(0.5*(Ta+T[1]), Qa, P);
//from Ye and Pielke, 1993 - bare soil evaporation
if(psi > 10.){ //ponding
*alpha = 1.0;
*beta = 1.0;
evap_layer->co[1] = rho * ( Qgsat - Qa ) / rv;
}else if(theta[1] >= soil[jsat][1]){ //saturation
*alpha = 1.0;
*beta = theta[1];
evap_layer->co[1] = theta[1] * rho * ( Qgsat - Qa ) / rv;
}else{ //unsaturated
A = 0.;
B = 0.;
r = new_doublevector(n); ////molecular diffusivity resistances [s/m]
//calculates water vapor fluxes
for(l=1;l<=n;l++){
D = D00 * pow((T[l]+tk)/tk, 2.) * (Pa0/P); //molecular diffusivity water vapor [mm2/s]
r->co[l] = (1.E3/D) * soil[jdz][l];
Qsat = SpecHumidity(SatVapPressure(T[l], P), P);
if(l>1) r->co[l] += r->co[l-1];
if( theta[l] <= soil[jfc][l] ){
hs = 0.5 * ( 1. - cos( Pi * ( theta[l] - soil[jres][l] ) / ( soil[jfc][l] - soil[jres][l] ) ) );
}else{
hs = 1.;
}
evap_layer->co[l] = rho*(soil[jsat][l] - theta[l]) * hs * Qsat / r->co[l];
A += ( (soil[jsat][l] - theta[l]) / (soil[jsat][1] - theta[1]) ) * (rv/r->co[l]) * hs * Qsat;
B += ( (soil[jsat][l] - theta[l]) / (soil[jsat][1] - theta[1]) ) * (rv/r->co[l]);
}
Qs = ( Qa + A ) / ( 1. + B );
for(l=1;l<=n;l++){
evap_layer->co[l] -= rho*(soil[jsat][l] - theta[l]) * Qs / r->co[l];
}
free_doublevector(r);
//calculates evaporation from the surface
F = ( soil[jsat][1] ) / ( soil[jsat][1] - soil[jres][1] );
evap_layer->co[1] += rho*( theta[1] - soil[jres][1] ) * F * ( Qgsat - Qa ) / rv;
*beta = ( soil[jsat][1] - theta[1] ) + ( theta[1] - soil[jres][1] ) * F - ( soil[jsat][1] - theta[1] ) / ( 1. + B );
*alpha = ( ( theta[1] - soil[jres][1] ) * F + ( soil[jsat][1] - theta[1] ) * A / ( Qgsat * (1. + B ) ) ) / (*beta);
}
}
}