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; }
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; }
polygon_connection_attributes *get_connection(POLYGON *polygon,POLYGONVECTOR *polygons, long boundary, long displacement ,short print) { /*! * * \param polygon - (POLYGON *) polygon to which link are referred * \param polygons - (POLYGONS *) vector of polygons * \param boundary - (long) long value which indetifies the boundary * \param displacement - (long) displacement in the POLYNGONVECTOR polygons around the index value of polygon where to find the connections * \param print - (short) * * \author Emanuele Cordano * \date November 2008 * *\return a poygon_connection_atributes struct for a given polygon (polygon) within a polygon array (polygons) * */ polygon_connection_attributes *pca; long l,s,l_po1,l_po2,icnt; double dist; long A_min,A_max; /*! extremes of the search interval */ icnt=1; pca=(polygon_connection_attributes *)malloc((sizeof(polygon_connection_attributes))); if (!pca) printf("Error: polygon_connection_attributes was not allocated at %ld polygon",polygon->index); pca->connections=new_longvector(polygon->edge_indices->nh); pca->d_connections=new_doublevector(polygon->edge_indices->nh); initialize_longvector(pca->connections,boundary); initialize_doublevector(pca->d_connections,NULL_VALUE); A_min=fmax(polygon->index-displacement,polygons->nl); A_max=fmin(polygon->index+displacement,polygons->nh); for (l=A_min; l<=A_max; l++) { if (l!=polygon->index) { dist=1.0; l_po1=0; l_po2=0; s=shared_edges(polygon,polygons->element[l],NO_INTERSECTION,&l_po1,&l_po2,&dist); if (s!=NO_INTERSECTION ) { if (l_po1>polygon->edge_indices->nh) printf ("Error: Line %ld : (%ld for polygon %ld) Not coherent data!!! \n ",s,l_po1,polygon->index); pca->connections->element[l_po1]=polygons->element[l]->index; pca->d_connections->element[l_po1]=dist; // printf(" pca conn. %ld %lf",pca->connections->element[l_po1],pca->d_connections->element[l_po1]); } } } return pca; }
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); }
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); }
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; }
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_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 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_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_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; }
polygon_connection_attributes *get_connection_squares(POLYGON *polygon,POLYGONVECTOR *polygons, long boundary,long novalue, long r ,long c,LONGMATRIX *mask,short print) { /*! * * \param polygon - (POLYGON *) polygon to which link are referred * \param polygons - (POLYGONS *) vector of polygons * \param boundary - (long) long value which indetifies the boundary * \param novalue - (long) null value used in the pixel index matrix * \param r - (long) row * \param c - (long) column * \param (LONGMATRIX *) pixel index matrix * * \param print - (long) displacement in the POLYNGONVECTOR polygons around the index value of polygon where to find the connections * * \author Emanuele Cordano * \date July 2009 * *\return a poygon_connection_atributes struct for a given polygon (polygon) within a polygon array (polygons) * */ polygon_connection_attributes *pca; long l,s,l_po1,l_po2,icnt; double dist; long r_min,r_max,c_min,c_max; /*! extremes of the search interval */ long rs,cs; icnt=1; pca=(polygon_connection_attributes *)malloc((sizeof(polygon_connection_attributes))); if (!pca) printf("Error: polygon_connection_attributes was not allocated at %ld polygon",polygon->index); pca->connections=new_longvector(polygon->edge_indices->nh); pca->d_connections=new_doublevector(polygon->edge_indices->nh); initialize_longvector(pca->connections,boundary); initialize_doublevector(pca->d_connections,NULL_VALUE); r_min=fmax(r-1,mask->nrl); r_max=fmin(r+1,mask->nrh); c_min=fmax(c-1,mask->ncl); c_max=fmin(c+1,mask->nch); for (rs=r_min; rs<=r_max; rs++) { for (cs=c_min; cs<=c_max; cs++) { l=mask->element[rs][cs]; if ((l!=polygon->index) && (l!=novalue)) { dist=1.0; l_po1=0; l_po2=0; s=shared_edges(polygon,polygons->element[l],NO_INTERSECTION,&l_po1,&l_po2,&dist); if (s!=NO_INTERSECTION ) { if (l_po1>polygon->edge_indices->nh) printf ("Error: Line %ld : (%ld for polygon %ld) Not coherent data!!! \n ",s,l_po1,polygon->index); pca->connections->element[l_po1]=polygons->element[l]->index; pca->d_connections->element[l_po1]=dist; // printf(" pca conn. %ld %lf",pca->connections->element[l_po1],pca->d_connections->element[l_po1]); } } } } return pca; }
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(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; }
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_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; }
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); } } }