double Fmax2(double a, double b, double c){
if(c>Fmax(a,b)){
return(c);
}else{
return(Fmax(a,b));
}
}
void canopy_snow_interception(double snow_max_loading, double LSAI, double Psnow, double Tc, double v, double Dt,
double *max_storage, double *storage, double *drip){
double load, unload;
double CT=1.87E5, CV=1.56E5;
*max_storage = snow_max_loading*LSAI;
load = ( (*max_storage) - (*storage) ) * (1. - exp(-Psnow/(*max_storage))); //Niu & Yang, 2004
*storage = (*storage) + load;
*drip = Psnow - load;
if((*storage)>(*max_storage)){
*drip = *drip - ( (*max_storage) - (*storage) );
*storage = (*max_storage);
}
unload = Fmin(*storage, (*storage)*(Fmax(0.0, Tc+3.0)/CT + v/CV)*Dt);
if(unload<0.1) unload=0.0; //prevents very low snowfalls
*drip = *drip + unload;
*storage = (*storage) - unload;
}
/*--------------------------------------------*/
double K(double psi, double K_sat, double imp, double i, double s, double r, double a, double n, double m, double v, double pmin, double T)
{
double TETA,psisat,K_unsat,iceratio;
psisat=(pow((pow(1.0-i/(s-r),-1.0/m)-1.0),1.0/n))*(-1.0/a);
if(psi>psisat) psi=psisat;
TETA=1.0/pow((1.0+pow(a*(-Fmax(pmin,psi)),n)),m);
if(T>=0){
K_unsat=K_sat*(0.000158685828*T*T+0.025263459766*T+0.731495819);
}else{
K_unsat=K_sat*0.73;
}
K_unsat*=(pow(TETA,v))*(pow((1-pow((1-pow(TETA,(1.0/m))),m)),2.0));
iceratio=i/(s-r);
K_unsat*=(pow(10.0,-imp*iceratio));
return K_unsat;
}
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;
}
void veg_transmittance(long r, long c, double rm, double v, double Ts, double Tg, double z0soil, double LSAI, double decaycoeff0,
double z0veg, double d0veg, double Hveg, double u_top, double Lo, double *rb, double *rh, double *ra, double *decay, double Loc,
short stabcorr_incanopy){
//double Cs, Cs_bare, Cs_dense = 0.004;
double Lc = 0.4; //characteristic dimension of vegetation [m]
double u_star = pow(v/rm,0.5);
double u_veg;
double zm = d0veg + z0veg;
//double W = 1.0-exp(-LSAI);
double phi=1.0, philog;
//double W = 1.0;
double n = decaycoeff0;
//stability
//over canopy
if(Lo<0){
phi=pow(1.0-16.0*Hveg/Lo,-0.5);
}else{
phi=1.0+5.0*Hveg/Lo;
}
//phi=1.0;
//under canopy
if(Loc<0){
philog=pow(1.0-15.0*zm/Loc,-0.25);
}else{
philog=1.0+4.7*zm/Loc;
}
if(stabcorr_incanopy==1) n=Fmin(1.E+5, n*pow(philog,0.5));
*decay=n;
//update aerodynamic resistance
//*ra=*ra + (Hveg/(n*ka*u_star*(Hveg-d0veg)/phi))*(exp(n*(1.0-zm/Hveg))-1.0);
//Zeng
//u_veg=u_star;
//Huntingford
u_veg=Fmax(0.001,u_top*exp(n*(zm/Hveg-1.0)));
//canopy resistance
*rb=Fmin(1.E20, 70.0*pow(Lc/u_veg,0.5));
//ground resistance
//Zeng
//Cs_bare=(pow(z0soil*u_star/1.5E-5,-0.45)*ka/0.13);
//*rh=1.0/( (W*Cs_dense + (1.0-W)*Cs_bare) * u_star);
//Huntingford
*rh=Fmin(1.E20,(Hveg*exp(n)/(n*ka*u_star*(Hveg-d0veg)/phi))*(exp(-n*z0soil/Hveg)-exp(-n*zm/Hveg)));
if(n<10) *rh=*rh+pow((exp(n)-exp(n*(1.-d0veg/Hveg)))*Hveg/(n*d0veg),0.45)*(u_star*2./ka);
}
static ut64 getFunctionSize(Sdb *db) {
#if 1
ut64 min = sdb_num_get (db, Fmin (addr), NULL);
ut64 max = sdb_num_get (db, Fmax (addr), NULL);
#else
ut64 min, max;
char *c, *bbs = sdb_get (db, "bbs", NULL);
int first = 1;
sdb_aforeach (c, bbs) {
ut64 addr = sdb_atoi (c);
ut64 addr_end = sdb_num_get (db, Fbb(addr), NULL);
if (first) {
min = addr;
max = addr_end;
first = 0;
} else {
if (addr<min)
min = addr;
if (addr_end>max)
max = addr_end;
}
sdb_aforeach_next (c);
}
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;
}
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 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 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;
}
void canopy_fluxes(long r, long c, double Tv, double Tg, double Ta, double Qgsat, double Qa, double zmu, double zmT, double z0,
double z0s, double d0, double z0r, double hveg, double v, double LR, double P, double SW, double LW, double e,
double LSAI, double decaycoeff0, double *land, double Wcrn, double Wcrnmax, double Wcsn, double Wcsnmax,
double *Esubl, double *Etrans, double *LWv, double *LWg, double *H, double *LE, double *h, double *dhdT,
double *Ts, double *Qs, double *r_uc, double *froot, double *theta, DOUBLEVECTOR *soil_transp_layer, long chgsgn,
double *Lobukhov, PAR *par, long n, double *rh, double *rv, double *rc, double *rb, double *u_top, double *decay,
double *Locc, double *LWup_above_v, double psi, double **soil, double *alpha, double *beta, double *T,
DOUBLEVECTOR *soil_evap_layer){
double rm, ft=0.0, fw, fwliq, fwice;
double Qv, dQvdT, Hg, Lt, Lv, R, dLWvdT, dHdT, dEdT, dEsubldT, E;
double Loc=1.E50, Loc0, Ts0;
long cont, cont2, l;
//CANOPY FRACTION SET AT THE MAX OF SNOW AND LIQUID WATER FRACTION ON CANOPY
fwliq=pow(Wcrn/Wcrnmax,2./3.);
fwice=pow(Wcsn/Wcsnmax,2./3.);
fw=Fmax(fwliq, fwice);
if(fw<0) fw=0.0;
if(fw>1) fw=1.0;
//LONGWAVE
longwave_vegetation(LW, e, Tg, Tv, LSAI, LWv, LWg, &dLWvdT, LWup_above_v);
//FIND SPECIFIC HUMIDITY IN THE VEGETATION LAYER
sat_spec_humidity(&Qv, &dQvdT, 1.0, Tv, P);
//UNDERCANOPY TURBULENT FLUXES
//iteration for Ts
cont2=0;
do{
Ts0=*Ts;
if(chgsgn>10){ //neglects stability corrections, if the number of iterations in Tcanopy is larger than a threshold
aero_resistance2(zmu, zmT, z0, d0, z0r, hveg, v, Ta, Ts0, Qa, *Qs, P, LR, LSAI, &rm, rh, rv, u_top, Lobukhov,
par->state_turb, 4, par->maxiter_Businger);
}else{ //considers stability corrections
aero_resistance2(zmu, zmT, z0, d0, z0r, hveg, v, Ta, Ts0, Qa, *Qs, P, LR, LSAI, &rm, rh, rv, u_top, Lobukhov,
par->state_turb, par->monin_obukhov, par->maxiter_Businger);
}
cont2++;
//iteration for Loc (within canopy Obukhov length)
cont=0;
do{
Loc0=Loc;
//if(cont==par->maxiter_Loc) Loc=-1.E50;
veg_transmittance(r, c, rm, v, Ts0, Tg, z0s, LSAI, decaycoeff0, z0, d0, hveg, *u_top, *Lobukhov, rb, r_uc, rh,
decay, Loc, par->stabcorr_incanopy);
*rv = (*rh);
find_actual_evaporation_parameters(r,c,alpha, beta, soil_evap_layer, theta, soil, T, psi, P, *r_uc, Ta, Qa, Qgsat, n);
/*if(Qg>(*Qs) && n==0){
*rv_ic = (*r_uc) + exp(8.206-4.255*sat);
}else{
*rv_ic = *r_uc;
}*/
*rb = (*rb) / LSAI;
if(Qv<(*Qs)){ //condensation
R=1.0;
}else{
canopy_evapotranspiration(*rb, Tv, Qa, P, SW, theta, land, soil, froot, &ft, soil_transp_layer);
R=fw+(1.0-fw)*ft;
}
*rc = (*rb) / R;
*Ts = (Ta/(*rh) + Tg/(*r_uc) + Tv/(*rb)) / (1./(*rh) + 1./(*r_uc) + 1./(*rb));
*Qs = (Qa/(*rv) + (*alpha)*Qgsat*(*beta)/(*r_uc) + Qv/(*rc)) / (1./(*rv) + (*beta)/(*r_uc) + 1./(*rc));
Hg=air_cp((*Ts+Tg)/2.) * air_density((*Ts+Tg)/2., (*Qs+(*alpha)*Qgsat)/2., P) * (Tg-(*Ts))/(*r_uc);
// -u*^3
// Loc = ------------------ Below Canopy Monin-Obukhov length (Niu&Yang)
// k(g/T)(Hg/(rho*C))
Loc=-pow(v/rm,1.5)/( ka*(g/(*Ts+tk))*(Hg/(air_density(*Ts,*Qs,P)*air_cp(*Ts))) );
if(Hg==0.0 || Hg!=Hg) Loc=1.E+50;
cont++;
}while(fabs(Loc0-Loc)>0.01 && cont<=par->maxiter_Loc);
/*if(cont==maxiter){
printf("Loc not converging, set at neutrality %ld %ld\n",r,c);
}*/
}while(cont2<par->maxiter_Ts && fabs((*Ts)-Ts0)>0.01);
/*if(fabs((*Ts)-Ts0)>0.01){
printf("Ts not converging %f %f %ld %ld\n",*Ts,Ts0,r,c);
}*/
//CANOPY FLUXES
turbulent_fluxes(*rb, *rc, P, *Ts, Tv, *Qs, Qv, dQvdT, H, &dHdT, &E, &dEdT);
//Et from transpiration, E-Et condensation or evaporation/sublimation from water on the canopy
Lt=Levap(Tv);
if(E>0){ //evaporation or sublimation
*Esubl=E*fw/R;
dEsubldT=dEdT*fw/R;
if(fwliq+fwice>0){
Lv=Lt + Lf*fwice/(fwliq+fwice); //linear interpolation to decide if sublimation or condensation occurs
}else{
Lv=Lt;
}
}else{ //condensation
*Esubl=E;
dEsubldT=dEdT;
if(Tv>=0){
Lv=Lt;
}else{
Lv=Lt + Lf;
}
}
*Etrans=E-(*Esubl);
for(l=1;l<=soil_transp_layer->nh;l++){
soil_transp_layer->co[l] = soil_transp_layer->co[l] * (*Etrans);
}
*LE=Lt*(*Etrans) + Lv*(*Esubl);
*h=(*LWv) - (*H) - (*LE);
*dhdT=dLWvdT - dHdT - Lt*(dEdT-dEsubldT) - Lv*dEsubldT;
if(*h!=(*h)) printf("No value in canopy fluxes Loc:%e v:%f rm:%e Ts:%f Tv:%f Ta:%f Tg:%f Hg:%f %ld %ld\n",
Loc,v,rm,*Ts,Tv,Ta,Tg,Hg,r,c);
*Locc=Loc;
}