dmy_struct *make_dmy(global_param_struct *global) /********************************************************************** make_dmy Dag Lohmann January 1996 This subroutine creates an array of structures that contain information about the day, month and year of each time step. modifications: 7-25-96 Added hour count, so that model can run on less than a daily time step. KAC 5-17-99 Modified routine to use LEAPYR function, make use of simulation ending dates, and to skip over initial forcing data records so that the model can be run on subsets of more complete data records. KAC 8-19-99 Modified routine to estimate the number of records that should be skipped before starting to write model output, based on the number of years defined with the SKIPYEAR global variable. KAC 3-14-00 Fixed problem with accounting for number of days in February. If last simulation year was a leap year, number of days in February was not reset to 28 after working out number of records and before working out the number of forcing file records to skip. KAC 2006-02-07 Changed indexing of line 63 (if(endday...) by 1 GCT **********************************************************************/ { extern param_set_struct param_set; dmy_struct *temp; int hr, year, day, month, jday, ii, daymax; int days[12]={31,28,31,30,31,30,31,31,30,31,30,31}; int endmonth, endday, endyear, skiprec, i, offset; int tmpmonth, tmpday, tmpyear, tmphr, tmpjday, step; char DONE; char ErrStr[MAXSTRING]; hr = global->starthour; year = global->startyear; day = global->startday; month = global->startmonth; /** Check if user defined end date instead of number of records **/ if(global->nrecs < 0) { if((global->endyear < 0) || (global->endmonth < 0) || (global->endday < 0)) { nrerror("The model global file MUST define EITHER the number of records to simulate (NRECS), or the year (ENDYEAR), month (ENDMONTH), and day (ENDDAY) of the last full simulation day"); } endday = global->endday; endmonth = global->endmonth; endyear = global->endyear; if(LEAPYR(endyear)) days[1] = 29; else days[1] = 28; if(endday < days[global->endmonth-1]) endday++; else { endday = 1; endmonth++; if(endmonth > 12) { endmonth = 1; endyear++; } } DONE = FALSE; ii = 0; tmpyear = year; tmpmonth = month; tmpday = day; tmphr = hr; while(!DONE) { get_next_time_step(&tmpyear,&tmpmonth,&tmpday,&tmphr, &tmpjday,global->dt); ii++; if(tmpyear == endyear) if(tmpmonth == endmonth) if(tmpday == endday) DONE = TRUE; } global->nrecs = ii; } else { offset = 0; tmphr = hr; while (tmphr != 0) { tmphr += global->dt; offset++; if(tmphr >= 24) tmphr = 0; } if( ((global->dt * (global->nrecs - offset)) % 24) != 0 ) { sprintf(ErrStr,"Nrecs must be defined such that the model ends after completing a full day. Currently Nrecs is set to %i, while %i and %i are allowable values.", global->nrecs, ((global->dt * (global->nrecs - offset)) / 24) * 24, ((global->dt * (global->nrecs - offset)) / 24) * 24 + 24); nrerror(ErrStr); } } // allocate dmy struct temp = (dmy_struct*) calloc(global->nrecs, sizeof(dmy_struct)); /** Create Date Structure for each Modeled Time Step **/ jday = day; if( LEAPYR(year) ) days[1] = 29; else days[1] = 28; for ( ii = 0; ii < month-1; ii++ ) jday += days[ii]; DONE = FALSE; ii = 0; while(!DONE) { temp[ii].hour = hr; temp[ii].day = day; temp[ii].month = month; temp[ii].year = year; temp[ii].day_in_year = jday; get_next_time_step(&year,&month,&day,&hr,&jday,global->dt); ii++; if(ii == global->nrecs) DONE=TRUE; } /** Determine number of forcing records to skip before model start time **/ for ( i = 0; i < 2; i++ ) { if(param_set.FORCE_DT[i] != MISSING) { if(global->forceyear[i] > 0) { tmpyear = global->forceyear[i]; tmpmonth = global->forcemonth[i]; tmpday = global->forceday[i]; tmphr = global->forcehour[i]; tmpjday = tmpday; if ( LEAPYR(tmpyear) ) days[1] = 29; else days[1] = 28; for ( ii = 0; ii < tmpmonth-1; ii++) tmpjday += days[ii]; step = (int)(1./((float)global->dt/24.)); while(tmpyear < temp[0].year || (tmpyear == temp[0].year && tmpjday < temp[0].day_in_year)) { get_next_time_step(&tmpyear,&tmpmonth,&tmpday,&tmphr, &tmpjday,global->dt); global->forceskip[i] ++; } } } } /** Determine the number of records to skip before starting output files **/ skiprec = 0; for ( i = 0; i < global->skipyear; i++ ) { if(LEAPYR(temp[skiprec].year)) skiprec += 366 * 24 / global->dt; else skiprec += 365 * 24 / global->dt; } global->skipyear = skiprec; return temp; }
int main(int argc, char *argv[]){ struct RNAeval_args_info args_info; char *string, *structure, *orig_sequence, *tmp; char *rec_sequence, *rec_id, **rec_rest; char fname[FILENAME_MAX_LENGTH]; char *ParamFile; int i, length1, length2; float energy; int istty; int circular=0; int noconv=0; int verbose = 0; unsigned int rec_type, read_opt; string = orig_sequence = ParamFile = NULL; gquad = 0; dangles = 2; /* ############################################# # check the command line parameters ############################################# */ if(RNAeval_cmdline_parser (argc, argv, &args_info) != 0) exit(1); /* temperature */ if(args_info.temp_given) temperature = args_info.temp_arg; /* do not take special tetra loop energies into account */ if(args_info.noTetra_given) tetra_loop=0; /* set dangle model */ if(args_info.dangles_given){ if((args_info.dangles_arg < 0) || (args_info.dangles_arg > 3)) warn_user("required dangle model not implemented, falling back to default dangles=2"); else dangles = args_info.dangles_arg; } /* do not convert DNA nucleotide "T" to appropriate RNA "U" */ if(args_info.noconv_given) noconv = 1; /* set energy model */ if(args_info.energyModel_given) energy_set = args_info.energyModel_arg; /* take another energy parameter set */ if(args_info.paramFile_given) ParamFile = strdup(args_info.paramFile_arg); /* assume RNA sequence to be circular */ if(args_info.circ_given) circular=1; /* logarithmic multiloop energies */ if(args_info.logML_given) logML = 1; /* be verbose */ if(args_info.verbose_given) verbose = 1; /* gquadruplex support */ if(args_info.gquad_given) gquad = 1; /* free allocated memory of command line data structure */ RNAeval_cmdline_parser_free (&args_info); /* ############################################# # begin initializing ############################################# */ if (ParamFile!=NULL) read_parameter_file(ParamFile); rec_type = read_opt = 0; rec_id = rec_sequence = NULL; rec_rest = NULL; istty = isatty(fileno(stdout)) && isatty(fileno(stdin)); if(circular && gquad){ nrerror("G-Quadruplex support is currently not available for circular RNA structures"); } /* set options we wanna pass to read_record */ if(istty){ read_opt |= VRNA_INPUT_NOSKIP_BLANK_LINES; print_tty_input_seq_str("Use '&' to connect 2 sequences that shall form a complex.\n" "Input sequence (upper or lower case) followed by structure"); } /* ############################################# # main loop: continue until end of file ############################################# */ while( !((rec_type = read_record(&rec_id, &rec_sequence, &rec_rest, read_opt)) & (VRNA_INPUT_ERROR | VRNA_INPUT_QUIT))){ if(rec_id){ if(!istty) printf("%s\n", rec_id); (void) sscanf(rec_id, ">%" XSTR(FILENAME_ID_LENGTH) "s", fname); } else fname[0] = '\0'; cut_point = -1; string = tokenize(rec_sequence); length2 = (int) strlen(string); tmp = extract_record_rest_structure((const char **)rec_rest, 0, (rec_id) ? VRNA_OPTION_MULTILINE : 0); if(!tmp) nrerror("structure missing"); structure = tokenize(tmp); length1 = (int) strlen(structure); if(length1 != length2) nrerror("structure and sequence differ in length!"); free(tmp); /* convert DNA alphabet to RNA if not explicitely switched off */ if(!noconv) str_DNA2RNA(string); /* store case-unmodified sequence */ orig_sequence = strdup(string); /* convert sequence to uppercase letters only */ str_uppercase(string); if(istty){ if (cut_point == -1) printf("length = %d\n", length1); else printf("length1 = %d\nlength2 = %d\n", cut_point-1, length1-cut_point+1); } if(gquad) energy = energy_of_gquad_structure(string, structure, verbose); else energy = (circular) ? energy_of_circ_structure(string, structure, verbose) : energy_of_structure(string, structure, verbose); if (cut_point == -1) printf("%s\n%s", orig_sequence, structure); else { char *pstring, *pstruct; pstring = costring(orig_sequence); pstruct = costring(structure); printf("%s\n%s", pstring, pstruct); free(pstring); free(pstruct); } if (istty) printf("\n energy = %6.2f\n", energy); else printf(" (%6.2f)\n", energy); /* clean up */ (void) fflush(stdout); if(rec_id) free(rec_id); free(rec_sequence); free(structure); /* free the rest of current dataset */ if(rec_rest){ for(i=0;rec_rest[i];i++) free(rec_rest[i]); free(rec_rest); } rec_id = rec_sequence = structure = NULL; rec_rest = NULL; free(string); free(orig_sequence); string = orig_sequence = NULL; /* print user help for the next round if we get input from tty */ if(istty){ print_tty_input_seq_str("Use '&' to connect 2 sequences that shall form a complex.\n" "Input sequence (upper or lower case) followed by structure"); } } return EXIT_SUCCESS; }
void get_force_type(char *cmdstr, int file_num, int *field) { /************************************************************* get_force_type.c Keith Cherkauer January 20, 2000 This routine determines the current forcing file data type and stores its location in the description of the current forcing file. Modifications: 2005-Mar-24 Modified to accept ALMA forcing variables. TJB 2005-May-01 Added the ALMA vars CRainf, CSnowf, LSRainf, and LSSnowf. TJB 2005-May-02 Added the ALMA vars Wind_E and Wind_N. TJB 2006-Dec-29 Added REL_HUMID to the list of supported met input variables. TJB 2007-Jan-02 Added ALMA_INPUT option; removed TAIR and PSURF from list of supported met input variables. TJB 2007-Jan-05 Bugfix: replaced if(BINARY) with if(param_set.FORCE_FORMAT[file_num]==BINARY). TJB 2007-Feb-25 Removed all of the if statements if(param_set.FORCE_FORMAT[file_num]==BINARY) since this ended up requiring that the FORCE_FORMAT BINARY line appear in the global parameter file before the list of forcing variables in order to work. Since the sscanf() performs proper parsing regardless of ASCII (which doesn't have SIGNED or MULTIPLIER fields) vs. BINARY, I removed the if() statements altogether. TJB 2007-Sep-14 Initialize flgstr to "NULL". TJB 2010-Mar-31 Added RUNOFF_IN. TJB 2010-Sep-24 Renamed RUNOFF_IN to CHANNEL_IN. TJB 2011-Nov-04 Fixed comment describing TSKC. TJB *************************************************************/ extern param_set_struct param_set; char optstr[50]; char flgstr[10]; char ErrStr[MAXSTRING]; int type; /** Initialize flgstr **/ strcpy(flgstr,"NULL"); if((*field) >= param_set.N_TYPES[file_num]) { sprintf(ErrStr,"Too many variables defined for forcing file %i.",file_num); nrerror(ErrStr); } sscanf(cmdstr,"%*s %s",optstr); /*************************************** Get meteorological data forcing info ***************************************/ /* type 0: air temperature [C] (ALMA_INPUT: [K]) */ if(strcasecmp("AIR_TEMP",optstr)==0){ type = AIR_TEMP; } /* type 1: albedo [fraction] */ else if(strcasecmp("ALBEDO",optstr)==0){ type = ALBEDO; } /* type 2: incoming channel flow [m3] (ALMA_INPUT: [m3/s]) */ else if(strcasecmp("CHANNEL_IN",optstr)==0){ type = CHANNEL_IN; } /* type 3: convective rainfall [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("CRAINF",optstr)==0){ type = CRAINF; } /* type 4: convective snowfall [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("CSNOWF",optstr)==0){ type = CSNOWF; } /* type 5: air density [kg/m3] */ else if(strcasecmp("DENSITY",optstr)==0){ type = DENSITY; } /* type 6: incoming longwave radiation [W/m2] */ else if(strcasecmp("LONGWAVE",optstr)==0 || strcasecmp("LWDOWN",optstr)==0){ type = LONGWAVE; } /* type 7: large-scale rainfall [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("LSRAINF",optstr)==0){ type = LSRAINF; } /* type 8: large-scale snowfall [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("LSSNOWF",optstr)==0){ type = LSSNOWF; } /* type 9: precipitation [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("PREC",optstr)==0){ type = PREC; } /* type 10: air pressure [kPa] (ALMA_INPUT: [Pa]) */ else if(strcasecmp("PRESSURE",optstr)==0){ type = PRESSURE; } /* type 11: specific humidity [kg/kg] */ else if(strcasecmp("QAIR",optstr)==0){ type = QAIR; } /* type 12: rainfall [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("RAINF",optstr)==0){ type = RAINF; } /* type 13: relative humidity [fraction] */ else if(strcasecmp("REL_HUMID",optstr)==0){ type = REL_HUMID; } /* type 14: shortwave radiation [W/m2] */ else if(strcasecmp("SHORTWAVE",optstr)==0 || strcasecmp("SWDOWN",optstr)==0){ type = SHORTWAVE; } /* type 15: snowfall [mm] (ALMA_INPUT: [mm/s]) */ else if(strcasecmp("SNOWF",optstr)==0){ type = SNOWF; } /* type 16: maximum daily temperature [C] (ALMA_INPUT: [K]) */ else if(strcasecmp("TMAX",optstr)==0){ type = TMAX; } /* type 17: minimum daily temperature [C] (ALMA_INPUT: [K]) */ else if(strcasecmp("TMIN",optstr)==0){ type = TMIN; } /* type 18: cloud cover fraction */ else if(strcasecmp("TSKC",optstr)==0){ type = TSKC; } /* type 19: vapor pressure [kPa] (ALMA_INPUT: [Pa]) */ else if(strcasecmp("VP",optstr)==0){ type = VP; } /* type 20: wind speed [m/s] */ else if(strcasecmp("WIND",optstr)==0){ type = WIND; } /* type 21: zonal component of wind speed [m/s] */ else if(strcasecmp("WIND_E",optstr)==0){ type = WIND_E; } /* type 22: meridional component of wind speed [m/s] */ else if(strcasecmp("WIND_N",optstr)==0){ type = WIND_N; } /* type 23: unused (blank) data */ else if(strcasecmp("SKIP",optstr)==0){ type = SKIP; } /** Undefined variable type **/ else { sprintf(ErrStr,"Undefined forcing variable type %s in file %i.", optstr, file_num); nrerror(ErrStr); } param_set.TYPE[type].SUPPLIED=file_num+1; param_set.FORCE_INDEX[file_num][(*field)] = type; if (type == SKIP) { param_set.TYPE[type].multiplier = 1; param_set.TYPE[type].SIGNED=FALSE; } else { sscanf(cmdstr,"%*s %*s %s %lf",flgstr, ¶m_set.TYPE[type].multiplier); if(strcasecmp("SIGNED",flgstr)==0) param_set.TYPE[type].SIGNED=TRUE; else param_set.TYPE[type].SIGNED=FALSE; } (*field)++; }
void NR::sort2(Vec_IO_DP &arr, Vec_IO_DP &brr) { const int M=7,NSTACK=50; int i,ir,j,k,jstack=-1,l=0; DP a,b; Vec_INT istack(NSTACK); int n=arr.size(); ir=n-1; for (;;) { if (ir-l < M) { for (j=l+1;j<=ir;j++) { a=arr[j]; b=brr[j]; for (i=j-1;i>=l;i--) { if (arr[i] <= a) break; arr[i+1]=arr[i]; brr[i+1]=brr[i]; } arr[i+1]=a; brr[i+1]=b; } if (jstack < 0) break; ir=istack[jstack--]; l=istack[jstack--]; } else { k=(l+ir) >> 1; SWAP(arr[k],arr[l+1]); SWAP(brr[k],brr[l+1]); if (arr[l] > arr[ir]) { SWAP(arr[l],arr[ir]); SWAP(brr[l],brr[ir]); } if (arr[l+1] > arr[ir]) { SWAP(arr[l+1],arr[ir]); SWAP(brr[l+1],brr[ir]); } if (arr[l] > arr[l+1]) { SWAP(arr[l],arr[l+1]); SWAP(brr[l],brr[l+1]); } i=l+1; j=ir; a=arr[l+1]; b=brr[l+1]; for (;;) { do i++; while (arr[i] < a); do j--; while (arr[j] > a); if (j < i) break; SWAP(arr[i],arr[j]); SWAP(brr[i],brr[j]); } arr[l+1]=arr[j]; arr[j]=a; brr[l+1]=brr[j]; brr[j]=b; jstack += 2; if (jstack >= NSTACK) nrerror("NSTACK too small in sort2."); if (ir-i+1 >= j-l) { istack[jstack]=ir; istack[jstack-1]=i; ir=j-1; } else { istack[jstack]=j-1; istack[jstack-1]=l; l=i; } } } }
void frenel(float x, float *s, float *c) { void nrerror(char error_text[]); int k,n,odd; float a,ax,fact,pix2,sign,sum,sumc,sums,term,test; fcomplex b,cc,d,h,del,cs; ax=fabs(x); if (ax < sqrt(FPMIN)) { *s=0.0; *c=ax; } else if (ax <= XMIN) { sum=sums=0.0; sumc=ax; sign=1.0; fact=PIBY2*ax*ax; odd=TRUE; term=ax; n=3; for (k=1;k<=MAXIT;k++) { term *= fact/k; sum += sign*term/n; test=fabs(sum)*EPS; if (odd) { sign = -sign; sums=sum; sum=sumc; } else { sumc=sum; sum=sums; } if (term < test) break; odd=!odd; n += 2; } if (k > MAXIT) nrerror("series failed in frenel"); *s=sums; *c=sumc; } else { pix2=PI*ax*ax; b=Complex(1.0,-pix2); cc=Complex(1.0/FPMIN,0.0); d=h=Cdiv(ONE,b); n = -1; for (k=2;k<=MAXIT;k++) { n += 2; a = -n*(n+1); b=Cadd(b,Complex(4.0,0.0)); d=Cdiv(ONE,Cadd(RCmul(a,d),b)); cc=Cadd(b,Cdiv(Complex(a,0.0),cc)); del=Cmul(cc,d); h=Cmul(h,del); if (fabs(del.r-1.0)+fabs(del.i) < EPS) break; } if (k > MAXIT) nrerror("cf failed in frenel"); h=Cmul(Complex(ax,-ax),h); cs=Cmul(Complex(0.5,0.5), Csub(ONE,Cmul(Complex(cos(0.5*pix2),sin(0.5*pix2)),h))); *c=cs.r; *s=cs.i; } if (x < 0.0) { *c = -(*c); *s = -(*s); } }
void bessjy(float x, float xnu, float *rj, float *ry, float *rjp, float *ryp) { void beschb(double x, double *gam1, double *gam2, double *gampl, double *gammi); int i,isign,l,nl; double a,b,br,bi,c,cr,ci,d,del,del1,den,di,dlr,dli,dr,e,f,fact,fact2, fact3,ff,gam,gam1,gam2,gammi,gampl,h,p,pimu,pimu2,q,r,rjl, rjl1,rjmu,rjp1,rjpl,rjtemp,ry1,rymu,rymup,rytemp,sum,sum1, temp,w,x2,xi,xi2,xmu,xmu2; if (x <= 0.0 || xnu < 0.0) nrerror("bad arguments in bessjy"); nl=(x < XMIN ? (int)(xnu+0.5) : IMAX(0,(int)(xnu-x+1.5))); xmu=xnu-nl; xmu2=xmu*xmu; xi=1.0/x; xi2=2.0*xi; w=xi2/PI; isign=1; h=xnu*xi; if (h < FPMIN) h=FPMIN; b=xi2*xnu; d=0.0; c=h; for (i=1;i<=MAXIT;i++) { b += xi2; d=b-d; if (fabs(d) < FPMIN) d=FPMIN; c=b-1.0/c; if (fabs(c) < FPMIN) c=FPMIN; d=1.0/d; del=c*d; h=del*h; if (d < 0.0) isign = -isign; if (fabs(del-1.0) < EPS) break; } if (i > MAXIT) nrerror("x too large in bessjy; try asymptotic expansion"); rjl=isign*FPMIN; rjpl=h*rjl; rjl1=rjl; rjp1=rjpl; fact=xnu*xi; for (l=nl;l>=1;l--) { rjtemp=fact*rjl+rjpl; fact -= xi; rjpl=fact*rjtemp-rjl; rjl=rjtemp; } if (rjl == 0.0) rjl=EPS; f=rjpl/rjl; if (x < XMIN) { x2=0.5*x; pimu=PI*xmu; fact = (fabs(pimu) < EPS ? 1.0 : pimu/sin(pimu)); d = -log(x2); e=xmu*d; fact2 = (fabs(e) < EPS ? 1.0 : sinh(e)/e); beschb(xmu,&gam1,&gam2,&gampl,&gammi); ff=2.0/PI*fact*(gam1*cosh(e)+gam2*fact2*d); e=exp(e); p=e/(gampl*PI); q=1.0/(e*PI*gammi); pimu2=0.5*pimu; fact3 = (fabs(pimu2) < EPS ? 1.0 : sin(pimu2)/pimu2); r=PI*pimu2*fact3*fact3; c=1.0; d = -x2*x2; sum=ff+r*q; sum1=p; for (i=1;i<=MAXIT;i++) { ff=(i*ff+p+q)/(i*i-xmu2); c *= (d/i); p /= (i-xmu); q /= (i+xmu); del=c*(ff+r*q); sum += del; del1=c*p-i*del; sum1 += del1; if (fabs(del) < (1.0+fabs(sum))*EPS) break; } if (i > MAXIT) nrerror("bessy series failed to converge"); rymu = -sum; ry1 = -sum1*xi2; rymup=xmu*xi*rymu-ry1; rjmu=w/(rymup-f*rymu); } else { a=0.25-xmu2; p = -0.5*xi; q=1.0; br=2.0*x; bi=2.0; fact=a*xi/(p*p+q*q); cr=br+q*fact; ci=bi+p*fact; den=br*br+bi*bi; dr=br/den; di = -bi/den; dlr=cr*dr-ci*di; dli=cr*di+ci*dr; temp=p*dlr-q*dli; q=p*dli+q*dlr; p=temp; for (i=2;i<=MAXIT;i++) { a += 2*(i-1); bi += 2.0; dr=a*dr+br; di=a*di+bi; if (fabs(dr)+fabs(di) < FPMIN) dr=FPMIN; fact=a/(cr*cr+ci*ci); cr=br+cr*fact; ci=bi-ci*fact; if (fabs(cr)+fabs(ci) < FPMIN) cr=FPMIN; den=dr*dr+di*di; dr /= den; di /= -den; dlr=cr*dr-ci*di; dli=cr*di+ci*dr; temp=p*dlr-q*dli; q=p*dli+q*dlr; p=temp; if (fabs(dlr-1.0)+fabs(dli) < EPS) break; } if (i > MAXIT) nrerror("cf2 failed in bessjy"); gam=(p-f)/q; rjmu=sqrt(w/((p-f)*gam+q)); rjmu=SIGN(rjmu,rjl); rymu=rjmu*gam; rymup=rymu*(p+q/gam); ry1=xmu*xi*rymu-rymup; } fact=rjmu/rjl; *rj=rjl1*fact; *rjp=rjp1*fact; for (i=1;i<=nl;i++) { rytemp=(xmu+i)*xi2*ry1-rymu; rymu=ry1; ry1=rytemp; } *ry=rymu; *ryp=xnu*xi*rymu-ry1; }
int initialize_model_state(all_vars_struct *all_vars, all_vars_struct *all_vars_crop, dmy_struct dmy, global_param_struct *global_param, filep_struct filep, int cellnum, int Nveg, int Nnodes, double surf_temp, soil_con_struct *soil_con, veg_con_struct *veg_con, lake_con_struct lake_con) /********************************************************************** initialize_model_state Keith Cherkauer April 17, 2000 This routine initializes the model state (energy balance, water balance, and snow components). If a state file is provided to the model than its contents are checked to see if it agrees with the current simulation set-up, if so it is used to initialize the model state. If no state file is provided the model initializes all variables with defaults and the user should expect to throw out the beginning of the simulation period as model start-up. UNITS: (m, s, kg, C, moisture in mm) unless otherwise specified Modifications: 4-17-00 Modified from initialize_energy_bal.c and initialize_snow.c to provide a single controlling routine for initializing the model state. 9-00 Fixed bug where initialization of soil node temperatures and moitures was within two vegetation loops, thus only the first vegetation type was properly initialized. KAC 2-19-03 Modified to initialize soil and vegetation parameters for the dry grid cell fraction, if distributed precipitation is activated. KAC 11-18-02 Modified to initialize lake and wetland algorithms variables. LCB 2-10-03 Fixed looping problem with initialization of soil moisture. KAC 3-12-03 Modified so that soil layer ice content is only calculated when frozen soil is implemented and active in the current grid cell. KAC 04-10-03 Modified to read storm parameters from model state file. KAC 04-25-03 Modified to work with vegetation type specific storm parameters. KAC 07-May-04 Initialize soil_con->dz_node[Nnodes] to 0.0, since it is accessed in set_node_parameters(). TJB 01-Nov-04 Added support for state files containing SPATIAL_FROST and LAKE_MODEL state variables. TJB 2006-Apr-21 Replaced Cv (uninitialized) with lake_con.Cl[0] in surfstor calculation. TJB 2006-Sep-23 Implemented flexible output configuration; uses the new save_data structure to track changes in moisture storage over each time step; this needs initialization here. TJB 2006-Oct-10 Added snow[veg][band].snow_canopy to save_data.swe. TJB 2006-Oct-16 Merged infiles and outfiles structs into filep_struct; This included removing the unused init_snow file. TJB 2006-Nov-07 Removed LAKE_MODEL option. TJB 2007-Apr-24 Added EXP_TRANS option. JCA 2007-Apr-24 Zsum_node loaded into soil_con structure for later use without having to recalculate. JCA 2007-Aug-09 Added features for EXCESS_ICE option. JCA 2007-Aug-21 Return value of ErrorFlag if error in distribute_node_moisture_properties. JCA 2007-Sep-18 Check for soil moist exceeding max moist moved from read_initial_model_state to here. JCA 2007-Oct-24 Modified initialize_lake() to return ErrorFlag. TJB 2008-Mar-01 Reinserted missing logic for QUICK_FS in calls to distribute_node_moisture_properties() and estimate_layer_ice_content(). TJB 2009-Feb-09 Removed dz_node from call to distribute_node_moisture_properties. KAC via TJB 2009-Feb-09 Removed dz_node from call to find_0_degree_front. KAC via TJB 2009-Mar-15 Modified to not call estimate_layer_ice_content() if not modeling frozen soil. KAC via TJB 2009-Mar-16 Added resid_moist to argument list of estimate_layer_ice_content(). This allows computation of min_liq, the minimum allowable liquid water content in each layer as a function of temperature. TJB 2009-Jun-09 Modified to use extension of veg_lib structure to contain bare soil information. TJB 2009-Jul-26 Added initial estimate of incoming longwave at surface (LongUnderOut) for use in canopy snow T iteration. TJB 2009-Jul-31 Removed extra lake/wetland veg tile. TJB 2009-Sep-19 Added T fbcount to count TFALLBACK occurrences. TJB 2009-Sep-19 Made initialization of Tfoliage more accurate for snow bands. TJB 2009-Sep-28 Added initialization of energy structure. TJB 2009-Nov-15 Added check to ensure that depth of first thermal node is <= depth of first soil layer. TJB 2009-Dec-11 Removed initialization of save_data structure, since this is now performed by the initial call to put_data(). TJB 2009-Dec-11 Removed min_liq and options.MIN_LIQ. TJB 2010-Nov-11 Updated call to initialize_lake() to accommodate new skip_hydro flag. TJB 2011-Mar-01 Updated calls to initialize_soil() and initialize_lake() to accommodate new arguments. Added more detailed validation of soil moisture. TJB 2011-Mar-05 Added validation of initial soil moisture, ice, and snow variables to make sure they are self-consistent. TJB 2011-May-31 Removed options.GRND_FLUX. Now soil temperatures and ground flux are always computed. TJB 2011-Jun-03 Added options.ORGANIC_FRACT. Soil properties now take organic fraction into account. TJB 2011-Jul-05 Changed logic initializing soil temperatures so that type of initialization depends solely on options.QUICK_FLUX; options.Nnodes is no longer automatically reset here. TJB 2012-Jan-16 Removed LINK_DEBUG code BN 2012-Jan-28 Added stability check for case of (FROZEN_SOIL=TRUE && IMPLICIT=FALSE). TJB 2013-Jul-25 Fixed incorrect condition on lake initialization. TJB 2013-Jul-25 Moved computation of tmp_moist argument of compute_runoff_and_asat() so that it would always be initialized. TJB 2013-Dec-26 Removed EXCESS_ICE option. TJB 2013-Dec-27 Moved SPATIAL_FROST to options_struct. TJB 2013-Dec-27 Removed QUICK_FS option. TJB 2014-Jan-13 Added validation of Nnodes and dp for EXP_TRANS=TRUE. TJB 2014-Feb-09 Made non-spinup initial temperatures more consistent with annual average air temperature and bottom boundary temperature. TJB 2014-Mar-28 Removed DIST_PRCP option. TJB **********************************************************************/ { extern option_struct options; extern veg_lib_struct *veg_lib; char ErrStr[MAXSTRING]; char FIRST_VEG; int i, j, ii, veg, index; int idx; int cidx; int lidx; int nidx; double tmp_moist[MAX_LAYERS]; double tmp_runoff; int band; int frost_area; int ErrorFlag; double Cv; double Zsum, dp; double tmpdp, tmpadj, Bexp; double Tair; double tmp; double *M; double moist[MAX_VEG][MAX_BANDS][MAX_LAYERS]; double ice[MAX_VEG][MAX_BANDS][MAX_LAYERS][MAX_FROST_AREAS]; double Clake; double surf_swq; double pack_swq; double TreeAdjustFactor[MAX_BANDS]; double dt_thresh; int tmp_lake_idx; cell_data_struct **cell; energy_bal_struct **energy; lake_var_struct *lake_var; snow_data_struct **snow; veg_var_struct **veg_var; cell = all_vars->cell; energy = all_vars->energy; lake_var = &all_vars->lake_var; snow = all_vars->snow; veg_var = all_vars->veg_var; // Initialize soil depths dp = soil_con->dp; FIRST_VEG = TRUE; // increase initial soil surface temperature if air is very cold Tair = surf_temp; if ( surf_temp < -1. ) surf_temp = -1.; /******************************************** Initialize all snow pack variables - some may be reset if state file present ********************************************/ initialize_snow(snow, Nveg, cellnum); /******************************************** Initialize all soil layer variables - some may be reset if state file present ********************************************/ initialize_soil(cell, soil_con, veg_con, Nveg); /******************************************** Initialize all vegetation variables - some may be reset if state file present ********************************************/ initialize_veg(veg_var, veg_con, global_param, Nveg); /******************************************** Initialize all lake variables ********************************************/ if ( options.LAKES ) { tmp_lake_idx = lake_con.lake_idx; if (tmp_lake_idx < 0) tmp_lake_idx = 0; ErrorFlag = initialize_lake(lake_var, lake_con, soil_con, &(cell[tmp_lake_idx][0]), surf_temp, 0); if (ErrorFlag == ERROR) return(ErrorFlag); } /******************************************** Initialize all spatial frost variables ********************************************/ for ( frost_area = 0; frost_area < options.Nfrost; frost_area++ ) { if ( options.Nfrost == 1 ) soil_con->frost_fract[frost_area] = 1.; else if (options.Nfrost == 2 ) soil_con->frost_fract[frost_area] = 0.5; else { soil_con->frost_fract[frost_area] = 1. / (options.Nfrost - 1); if ( frost_area == 0 || frost_area == options.Nfrost-1 ) soil_con->frost_fract[frost_area] /= 2.; } } /******************************************************** Compute grid cell fractions for all subareas used in spatial distribution of soil frost routines. ********************************************************/ /************************************************************************ CASE 1: Not using quick ground heat flux, and initial conditions files provided ************************************************************************/ if(options.INIT_STATE) { read_initial_model_state(filep.init_state, all_vars, global_param, Nveg, options.SNOW_BAND, cellnum, soil_con, lake_con); /******Check that soil moisture does not exceed maximum allowed************/ for ( veg = 0 ; veg <= Nveg ; veg++ ) { for( band = 0; band < options.SNOW_BAND; band++ ) { for( lidx = 0; lidx < options.Nlayer; lidx++ ) { if ( cell[veg][band].layer[lidx].moist > soil_con->max_moist[lidx] ) { fprintf( stderr, "WARNING: Initial soil moisture (%f mm) exceeds maximum (%f mm) in layer %d for veg tile %d and snow band%d. Resetting to maximum.\n", cell[veg][band].layer[lidx].moist, soil_con->max_moist[lidx], lidx, veg, band ); for ( frost_area = 0; frost_area < options.Nfrost; frost_area++) cell[veg][band].layer[lidx].ice[frost_area] *= soil_con->max_moist[lidx]/cell[veg][band].layer[lidx].moist; cell[veg][band].layer[lidx].moist = soil_con->max_moist[lidx]; } for ( frost_area = 0; frost_area < options.Nfrost; frost_area++) { if (cell[veg][band].layer[lidx].ice[frost_area] > cell[veg][band].layer[lidx].moist) cell[veg][band].layer[lidx].ice[frost_area] = cell[veg][band].layer[lidx].moist; } tmp_moist[lidx] = cell[veg][band].layer[lidx].moist; } compute_runoff_and_asat(soil_con, tmp_moist, 0, &(cell[veg][band].asat), &tmp_runoff); } // Override possible bad values of soil moisture under lake coming from state file // (ideally we wouldn't store these in the state file in the first place) if (options.LAKES && veg == lake_con.lake_idx) { for( lidx = 0; lidx < options.Nlayer; lidx++ ) { lake_var->soil.layer[lidx].moist = soil_con->max_moist[lidx]; for ( frost_area = 0; frost_area < options.Nfrost; frost_area++) { if (lake_var->soil.layer[lidx].ice[frost_area] > lake_var->soil.layer[lidx].moist) lake_var->soil.layer[lidx].ice[frost_area] = lake_var->soil.layer[lidx].moist; } } } } /****** initialize moist and ice ************/ for ( veg = 0 ; veg <= Nveg ; veg++ ) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { for( lidx = 0; lidx < options.Nlayer; lidx++ ) { moist[veg][band][lidx] = cell[veg][band].layer[lidx].moist; for ( frost_area = 0; frost_area < options.Nfrost; frost_area++ ) ice[veg][band][lidx][frost_area] = cell[veg][band].layer[lidx].ice[frost_area]; } } } } /******Check that snow pack terms are self-consistent************/ for ( veg = 0 ; veg <= Nveg ; veg++ ) { for ( band = 0 ; band < options.SNOW_BAND ; band++ ) { if (snow[veg][band].swq > MAX_SURFACE_SWE) { pack_swq = snow[veg][band].swq-MAX_SURFACE_SWE; surf_swq = MAX_SURFACE_SWE; } else { pack_swq = 0; surf_swq = snow[veg][band].swq; snow[veg][band].pack_temp = 0; } if (snow[veg][band].surf_water > LIQUID_WATER_CAPACITY*surf_swq) { snow[veg][band].pack_water += snow[veg][band].surf_water - (LIQUID_WATER_CAPACITY*surf_swq); snow[veg][band].surf_water = LIQUID_WATER_CAPACITY*surf_swq; } if (snow[veg][band].pack_water > LIQUID_WATER_CAPACITY*pack_swq) { snow[veg][band].pack_water = LIQUID_WATER_CAPACITY*pack_swq; } } } } /************************************************************************ CASE 2: Initialize soil if using quick heat flux, and no initial soil properties file given ************************************************************************/ else if(options.QUICK_FLUX) { Nnodes = options.Nnode; /* Initialize soil node thicknesses */ soil_con->dz_node[0] = soil_con->depth[0]; soil_con->dz_node[1] = soil_con->depth[0]; soil_con->dz_node[2] = 2. * (dp - 1.5 * soil_con->depth[0]); soil_con->Zsum_node[0] = 0; soil_con->Zsum_node[1] = soil_con->depth[0]; soil_con->Zsum_node[2] = dp; for ( veg = 0 ; veg <= Nveg ; veg++ ) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { /* Initialize soil node temperatures */ energy[veg][band].T[0] = surf_temp; energy[veg][band].T[1] = surf_temp; energy[veg][band].T[2] = soil_con->avg_temp; /* Initialize soil layer moisture and ice contents */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { moist[veg][band][lidx] = cell[veg][band].layer[lidx].moist; for ( frost_area = 0; frost_area < options.Nfrost; frost_area++ ) ice[veg][band][lidx][frost_area] = 0.; } } } } } /***************************************************************** CASE 3: Initialize Energy Balance Variables if not using quick ground heat flux, and no Initial Condition File Given *****************************************************************/ else if(!options.QUICK_FLUX) { for ( veg = 0 ; veg <= Nveg ; veg++ ) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { if(!options.EXP_TRANS){ /* Initialize soil node temperatures and thicknesses Nodes set at surface, the depth of the first layer, twice the depth of the first layer, and at the damping depth. Extra nodes are placed equal distance between the damping depth and twice the depth of the first layer. */ soil_con->dz_node[0] = soil_con->depth[0]; soil_con->dz_node[1] = soil_con->depth[0]; soil_con->dz_node[2] = soil_con->depth[0]; soil_con->Zsum_node[0] = 0; soil_con->Zsum_node[1] = soil_con[0].depth[0]; Zsum = 2. * soil_con[0].depth[0]; soil_con->Zsum_node[2] = Zsum; tmpdp = dp - soil_con[0].depth[0] * 2.5; tmpadj = 3.5; for ( index = 3; index < Nnodes-1; index++ ) { if ( FIRST_VEG ) { soil_con->dz_node[index] = tmpdp/(((double)Nnodes-tmpadj)); } Zsum += (soil_con->dz_node[index] +soil_con->dz_node[index-1])/2.; soil_con->Zsum_node[index] = Zsum; } energy[veg][band].T[0] = surf_temp; for ( index = 1; index < Nnodes; index++ ) { energy[veg][band].T[index] = soil_con->avg_temp; } if ( FIRST_VEG ) { FIRST_VEG = FALSE; soil_con->dz_node[Nnodes-1] = (dp - Zsum - soil_con->dz_node[Nnodes-2] / 2. ) * 2.; Zsum += (soil_con->dz_node[Nnodes-2] +soil_con->dz_node[Nnodes-1])/2.; soil_con->Zsum_node[Nnodes-1] = Zsum; if((int)(Zsum*1000+0.5) != (int)(dp*1000+0.5)) { sprintf(ErrStr,"Sum of thermal node thicknesses (%f) in initialize_model_state do not equal dp (%f), check initialization procedure",Zsum,dp); nrerror(ErrStr); } } } else{ /* exponential grid transformation, EXP_TRANS = TRUE*/ /*calculate exponential function parameter */ if ( FIRST_VEG ) { Bexp = logf(dp+1.)/(double)(Nnodes-1); //to force Zsum=dp at bottom node /* validate Nnodes by requiring that there be at least 3 nodes in the top 50cm */ if (Nnodes < 5*logf(dp+1.)+1) { sprintf(ErrStr,"The number of soil thermal nodes (%d) is too small for the supplied damping depth (%f) with EXP_TRANS set to TRUE, leading to fewer than 3 nodes in the top 50 cm of the soil column. For EXP_TRANS=TRUE, Nnodes and dp must follow the relationship:\n5*ln(dp+1)<Nnodes-1\nEither set Nnodes to at least %d in the global param file or reduce damping depth to %f in the soil parameter file. Or set EXP_TRANS to FALSE in the global parameter file.",Nnodes,dp,(int)(5*logf(dp+1.))+2,exp(0.2*(Nnodes-1))+1); nrerror(ErrStr); } for ( index = 0; index <= Nnodes-1; index++ ) soil_con->Zsum_node[index] = expf(Bexp*index)-1.; if(soil_con->Zsum_node[0] > soil_con->depth[0]) { sprintf(ErrStr,"Depth of first thermal node (%f) in initialize_model_state is greater than depth of first soil layer (%f); increase the number of nodes or decrease the thermal damping depth dp (%f)",soil_con->Zsum_node[0],soil_con->depth[0],dp); nrerror(ErrStr); } } //top node index=0; if ( FIRST_VEG ) soil_con->dz_node[index] = soil_con->Zsum_node[index+1]-soil_con->Zsum_node[index]; energy[veg][band].T[index] = surf_temp; //middle nodes for ( index = 1; index < Nnodes-1; index++ ) { if ( FIRST_VEG ) { soil_con->dz_node[index] = (soil_con->Zsum_node[index+1]-soil_con->Zsum_node[index])/2.+(soil_con->Zsum_node[index]-soil_con->Zsum_node[index-1])/2.; } // energy[veg][band].T[index] = exp_interp(soil_con->Zsum_node[index],0.,soil_con[0].dp, // surf_temp,soil_con[0].avg_temp); energy[veg][band].T[index] = soil_con->avg_temp; } //bottom node index=Nnodes-1; if ( FIRST_VEG ) soil_con->dz_node[index] = soil_con->Zsum_node[index]-soil_con->Zsum_node[index-1]; energy[veg][band].T[index] = soil_con->avg_temp; } // end if !EXP_TRANS //initialize moisture and ice for each soil layer for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { moist[veg][band][lidx] = cell[veg][band].layer[lidx].moist; for ( frost_area = 0; frost_area < options.Nfrost; frost_area++ ) ice[veg][band][lidx][frost_area] = 0.; } } } } } /********************************* CASE 4: Unknown option *********************************/ else { for ( veg = 0 ; veg <= Nveg ; veg++ ) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { // Initialize soil for existing snow elevation bands if ( soil_con->AreaFract[band] > 0. ) { for ( index = 0; index < options.Nlayer; index++ ) { soil_con->dz_node[index] = 1.; } } } } } } /****************************************** Initialize soil thermal node properties ******************************************/ FIRST_VEG = TRUE; for ( veg = 0 ; veg <= Nveg ; veg++) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { // Initialize soil for existing snow elevation bands if ( soil_con->AreaFract[band] > 0. ) { /** Set soil properties for all soil nodes **/ if(FIRST_VEG) { FIRST_VEG = FALSE; set_node_parameters(soil_con->dz_node, soil_con->Zsum_node, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, soil_con->alpha, soil_con->beta, soil_con->gamma, soil_con->depth, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->quartz, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); } /* set soil moisture properties for all soil thermal nodes */ ErrorFlag = distribute_node_moisture_properties(energy[veg][band].moist, energy[veg][band].ice, energy[veg][band].kappa_node, energy[veg][band].Cs_node, soil_con->Zsum_node, energy[veg][band].T, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, moist[veg][band], soil_con->depth, soil_con->soil_dens_min, soil_con->bulk_dens_min, soil_con->quartz, soil_con->soil_density, soil_con->bulk_density, soil_con->organic, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); if ( ErrorFlag == ERROR ) return ( ErrorFlag ); /* Check node spacing v time step */ /* (note this is only approximate since heat capacity and conductivity can change considerably during the simulation depending on soil moisture and ice content) */ if ((options.FROZEN_SOIL && !options.QUICK_FLUX) && !options.IMPLICIT) { dt_thresh = 0.5*energy[veg][band].Cs_node[1]/energy[veg][band].kappa_node[1]*pow((soil_con->dz_node[1]),2)/3600; // in hours if (global_param->dt > dt_thresh) { sprintf(ErrStr,"ERROR: You are currently running FROZEN SOIL with an explicit method (IMPLICIT is set to FALSE). For the explicit method to be stable, time step %d hours is too large for the given thermal node spacing %f m, soil heat capacity %f J/m3/K, and soil thermal conductivity %f J/m/s/K. Either set IMPLICIT to TRUE in your global parameter file (this is the recommended action), or decrease time step length to <= %f hours, or decrease the number of soil thermal nodes.",global_param->dt,soil_con->dz_node[1],energy[veg][band].Cs_node[1],energy[veg][band].kappa_node[1],dt_thresh); nrerror(ErrStr); } } /* initialize layer moistures and ice contents */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { cell[veg][band].layer[lidx].moist = moist[veg][band][lidx]; for ( frost_area = 0; frost_area < options.Nfrost; frost_area++ ) cell[veg][band].layer[lidx].ice[frost_area] = ice[veg][band][lidx][frost_area]; } if (options.QUICK_FLUX) { ErrorFlag = estimate_layer_ice_content_quick_flux(cell[veg][band].layer, soil_con->depth, soil_con->dp, energy[veg][band].T[0], energy[veg][band].T[1], soil_con->avg_temp, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->frost_fract, soil_con->frost_slope, soil_con->FS_ACTIVE); } else { ErrorFlag = estimate_layer_ice_content(cell[veg][band].layer, soil_con->Zsum_node, energy[veg][band].T, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, soil_con->depth, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->frost_fract, soil_con->frost_slope, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); } /* Find freezing and thawing front depths */ if(!options.QUICK_FLUX && soil_con->FS_ACTIVE) find_0_degree_fronts(&energy[veg][band], soil_con->Zsum_node, energy[veg][band].T, Nnodes); } } } } // initialize miscellaneous energy balance terms for ( veg = 0 ; veg <= Nveg ; veg++) { for ( band = 0; band < options.SNOW_BAND; band++ ) { /* Set fluxes to 0 */ energy[veg][band].advected_sensible = 0.0; energy[veg][band].advection = 0.0; energy[veg][band].AtmosError = 0.0; energy[veg][band].AtmosLatent = 0.0; energy[veg][band].AtmosLatentSub = 0.0; energy[veg][band].AtmosSensible = 0.0; energy[veg][band].canopy_advection = 0.0; energy[veg][band].canopy_latent = 0.0; energy[veg][band].canopy_latent_sub = 0.0; energy[veg][band].canopy_refreeze = 0.0; energy[veg][band].canopy_sensible = 0.0; energy[veg][band].deltaCC = 0.0; energy[veg][band].deltaH = 0.0; energy[veg][band].error = 0.0; energy[veg][band].fusion = 0.0; energy[veg][band].grnd_flux = 0.0; energy[veg][band].latent = 0.0; energy[veg][band].latent_sub = 0.0; energy[veg][band].longwave = 0.0; energy[veg][band].LongOverIn = 0.0; energy[veg][band].LongUnderIn = 0.0; energy[veg][band].LongUnderOut = 0.0; energy[veg][band].melt_energy = 0.0; energy[veg][band].NetLongAtmos = 0.0; energy[veg][band].NetLongOver = 0.0; energy[veg][band].NetLongUnder = 0.0; energy[veg][band].NetShortAtmos = 0.0; energy[veg][band].NetShortGrnd = 0.0; energy[veg][band].NetShortOver = 0.0; energy[veg][band].NetShortUnder = 0.0; energy[veg][band].out_long_canopy = 0.0; energy[veg][band].out_long_surface = 0.0; energy[veg][band].refreeze_energy = 0.0; energy[veg][band].sensible = 0.0; energy[veg][band].shortwave = 0.0; energy[veg][band].ShortOverIn = 0.0; energy[veg][band].ShortUnderIn = 0.0; energy[veg][band].snow_flux = 0.0; /* Initial estimate of LongUnderOut for use by snow_intercept() */ tmp = energy[veg][band].T[0] + KELVIN; energy[veg][band].LongUnderOut = STEFAN_B * tmp * tmp * tmp * tmp; energy[veg][band].Tfoliage = Tair + soil_con->Tfactor[band]; } } // initialize Tfallback counters for ( veg = 0 ; veg <= Nveg ; veg++) { for ( band = 0; band < options.SNOW_BAND; band++ ) { energy[veg][band].Tfoliage_fbcount = 0; energy[veg][band].Tcanopy_fbcount = 0; energy[veg][band].Tsurf_fbcount = 0; for ( index = 0; index < Nnodes-1; index++ ) { energy[veg][band].T_fbcount[index] = 0; } } } // Compute treeline adjustment factors for ( band = 0; band < options.SNOW_BAND; band++ ) { if ( soil_con->AboveTreeLine[band] ) { Cv = 0; for ( veg = 0 ; veg < veg_con[0].vegetat_type_num ; veg++ ) { if ( veg_lib[veg_con[veg].veg_class].overstory ) Cv += veg_con[veg].Cv; } TreeAdjustFactor[band] = 1. / ( 1. - Cv ); } else TreeAdjustFactor[band] = 1.; } // Initialize crop structures for ( veg = 0 ; veg < veg_con[0].vegetat_type_num ; veg++ ) { if (veg_con[veg].crop_frac_active) { for ( band = 0; band < options.SNOW_BAND; band++ ) { for (idx = veg_con[veg].crop_frac_idx; idx<veg_con[veg].crop_frac_idx+2; idx++) { // Copy veg_var state data if (idx % 2 == 0) all_vars_crop->veg_var[idx][band].Wdew = 0; else all_vars_crop->veg_var[idx][band].Wdew = veg_var[veg][band].Wdew; if (options.CARBON) { for (cidx=0; cidx<options.Ncanopy; cidx++) { all_vars_crop->veg_var[idx][band].NscaleFactor[cidx] = veg_var[veg][band].NscaleFactor[cidx]; all_vars_crop->veg_var[idx][band].aPARLayer[cidx] = veg_var[veg][band].aPARLayer[cidx]; all_vars_crop->veg_var[idx][band].CiLayer[cidx] = veg_var[veg][band].CiLayer[cidx]; all_vars_crop->veg_var[idx][band].rsLayer[cidx] = veg_var[veg][band].rsLayer[cidx]; } } all_vars_crop->veg_var[idx][band].Ci = veg_var[veg][band].Ci; all_vars_crop->veg_var[idx][band].rc = veg_var[veg][band].rc; all_vars_crop->veg_var[idx][band].NPPfactor = veg_var[veg][band].NPPfactor; all_vars_crop->veg_var[idx][band].AnnualNPP = veg_var[veg][band].AnnualNPP; all_vars_crop->veg_var[idx][band].AnnualNPPPrev = veg_var[veg][band].AnnualNPPPrev; // Copy veg_var flux data all_vars_crop->veg_var[idx][band].canopyevap = veg_var[veg][band].canopyevap; all_vars_crop->veg_var[idx][band].throughfall = veg_var[veg][band].throughfall; all_vars_crop->veg_var[idx][band].aPAR = veg_var[veg][band].aPAR; all_vars_crop->veg_var[idx][band].GPP = veg_var[veg][band].GPP; all_vars_crop->veg_var[idx][band].Rphoto = veg_var[veg][band].Rphoto; all_vars_crop->veg_var[idx][band].Rdark = veg_var[veg][band].Rdark; all_vars_crop->veg_var[idx][band].Rmaint = veg_var[veg][band].Rmaint; all_vars_crop->veg_var[idx][band].Rgrowth = veg_var[veg][band].Rgrowth; all_vars_crop->veg_var[idx][band].Raut = veg_var[veg][band].Raut; all_vars_crop->veg_var[idx][band].NPP = veg_var[veg][band].NPP; all_vars_crop->veg_var[idx][band].Litterfall = veg_var[veg][band].Litterfall; // Copy cell state data for ( lidx = 0; lidx < 2; lidx++ ) { all_vars_crop->cell[idx][band].aero_resist[lidx] = cell[veg][band].aero_resist[lidx]; } all_vars_crop->cell[idx][band].asat = cell[veg][band].asat; all_vars_crop->cell[idx][band].CLitter = cell[veg][band].CLitter; all_vars_crop->cell[idx][band].CInter = cell[veg][band].CInter; all_vars_crop->cell[idx][band].CSlow = cell[veg][band].CSlow; for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { all_vars_crop->cell[idx][band].layer[lidx].bare_evap_frac = cell[veg][band].layer[lidx].bare_evap_frac; all_vars_crop->cell[idx][band].layer[lidx].Cs = cell[veg][band].layer[lidx].Cs; all_vars_crop->cell[idx][band].layer[lidx].kappa = cell[veg][band].layer[lidx].kappa; all_vars_crop->cell[idx][band].layer[lidx].moist = cell[veg][band].layer[lidx].moist; for ( frost_area = 0; frost_area < options.Nfrost; frost_area++ ) all_vars_crop->cell[idx][band].layer[lidx].ice[frost_area] = cell[veg][band].layer[lidx].ice[frost_area]; all_vars_crop->cell[idx][band].layer[lidx].phi = cell[veg][band].layer[lidx].phi; all_vars_crop->cell[idx][band].layer[lidx].T = cell[veg][band].layer[lidx].T; all_vars_crop->cell[idx][band].layer[lidx].zwt = cell[veg][band].layer[lidx].zwt; } // Copy cell flux data all_vars_crop->cell[idx][band].baseflow = cell[veg][band].baseflow; for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { all_vars_crop->cell[idx][band].layer[lidx].evap = cell[veg][band].layer[lidx].evap; } all_vars_crop->cell[idx][band].inflow = cell[veg][band].inflow; for ( lidx = 0; lidx < N_PET_TYPES; lidx++ ) { all_vars_crop->cell[idx][band].pot_evap[lidx] = cell[veg][band].pot_evap[lidx]; } all_vars_crop->cell[idx][band].runoff = cell[veg][band].runoff; all_vars_crop->cell[idx][band].RhLitter = cell[veg][band].RhLitter; all_vars_crop->cell[idx][band].RhLitter2Atm = cell[veg][band].RhLitter2Atm; all_vars_crop->cell[idx][band].RhInter = cell[veg][band].RhInter; all_vars_crop->cell[idx][band].RhSlow = cell[veg][band].RhSlow; all_vars_crop->cell[idx][band].RhTot = cell[veg][band].RhTot; all_vars_crop->cell[idx][band].rootmoist = cell[veg][band].rootmoist; all_vars_crop->cell[idx][band].wetness = cell[veg][band].wetness; all_vars_crop->cell[idx][band].zwt = cell[veg][band].zwt; all_vars_crop->cell[idx][band].zwt_lumped = cell[veg][band].zwt_lumped; // Copy snow state data all_vars_crop->snow[idx][band].albedo = snow[veg][band].albedo; all_vars_crop->snow[idx][band].canopy_albedo = snow[veg][band].canopy_albedo; all_vars_crop->snow[idx][band].coldcontent = snow[veg][band].coldcontent; all_vars_crop->snow[idx][band].coverage = snow[veg][band].coverage; all_vars_crop->snow[idx][band].density = snow[veg][band].density; all_vars_crop->snow[idx][band].depth = snow[veg][band].depth; all_vars_crop->snow[idx][band].last_snow = snow[veg][band].last_snow; all_vars_crop->snow[idx][band].max_snow_depth = snow[veg][band].max_snow_depth; all_vars_crop->snow[idx][band].MELTING = snow[veg][band].MELTING; all_vars_crop->snow[idx][band].pack_temp = snow[veg][band].pack_temp; all_vars_crop->snow[idx][band].pack_water = snow[veg][band].pack_water; all_vars_crop->snow[idx][band].snow = snow[veg][band].snow; if (idx % 2 == 0) all_vars_crop->snow[idx][band].snow_canopy = 0; else all_vars_crop->snow[idx][band].snow_canopy = snow[veg][band].snow_canopy; all_vars_crop->snow[idx][band].store_coverage = snow[veg][band].store_coverage; all_vars_crop->snow[idx][band].store_snow = snow[veg][band].store_snow; all_vars_crop->snow[idx][band].store_swq = snow[veg][band].store_swq; all_vars_crop->snow[idx][band].surf_temp = snow[veg][band].surf_temp; all_vars_crop->snow[idx][band].surf_temp_fbcount = snow[veg][band].surf_temp_fbcount; all_vars_crop->snow[idx][band].surf_temp_fbflag = snow[veg][band].surf_temp_fbflag; all_vars_crop->snow[idx][band].surf_water = snow[veg][band].surf_water; all_vars_crop->snow[idx][band].swq = snow[veg][band].swq; all_vars_crop->snow[idx][band].snow_distrib_slope = snow[veg][band].snow_distrib_slope; all_vars_crop->snow[idx][band].tmp_int_storage = snow[veg][band].tmp_int_storage; // Copy snow flux data all_vars_crop->snow[idx][band].blowing_flux = snow[veg][band].blowing_flux; all_vars_crop->snow[idx][band].canopy_vapor_flux = snow[veg][band].canopy_vapor_flux; all_vars_crop->snow[idx][band].mass_error = snow[veg][band].mass_error; all_vars_crop->snow[idx][band].melt = snow[veg][band].melt; all_vars_crop->snow[idx][band].Qnet = snow[veg][band].Qnet; all_vars_crop->snow[idx][band].surface_flux = snow[veg][band].surface_flux; all_vars_crop->snow[idx][band].transport = snow[veg][band].transport; all_vars_crop->snow[idx][band].vapor_flux = snow[veg][band].albedo; // Copy energy state data all_vars_crop->energy[idx][band].AlbedoLake = energy[veg][band].AlbedoLake; all_vars_crop->energy[idx][band].AlbedoOver = energy[veg][band].AlbedoOver; all_vars_crop->energy[idx][band].AlbedoUnder = energy[veg][band].AlbedoUnder; all_vars_crop->energy[idx][band].frozen = energy[veg][band].frozen; all_vars_crop->energy[idx][band].Nfrost = energy[veg][band].Nfrost; all_vars_crop->energy[idx][band].Nthaw = energy[veg][band].Nthaw; all_vars_crop->energy[idx][band].T1_index = energy[veg][band].T1_index; all_vars_crop->energy[idx][band].Tcanopy = energy[veg][band].Tcanopy; all_vars_crop->energy[idx][band].Tcanopy_fbcount = energy[veg][band].Tcanopy_fbcount; all_vars_crop->energy[idx][band].Tcanopy_fbflag = energy[veg][band].Tcanopy_fbflag; all_vars_crop->energy[idx][band].Tfoliage = energy[veg][band].Tfoliage; all_vars_crop->energy[idx][band].Tfoliage_fbcount = energy[veg][band].Tfoliage_fbcount; all_vars_crop->energy[idx][band].Tfoliage_fbflag = energy[veg][band].Tfoliage_fbflag; all_vars_crop->energy[idx][band].Tsurf = energy[veg][band].Tsurf; all_vars_crop->energy[idx][band].Tsurf_fbcount = energy[veg][band].Tsurf_fbcount; all_vars_crop->energy[idx][band].Tsurf_fbflag = energy[veg][band].Tsurf_fbflag; all_vars_crop->energy[idx][band].unfrozen = energy[veg][band].unfrozen; for (lidx=0; lidx<2; lidx++) { all_vars_crop->energy[idx][band].Cs[lidx] = energy[veg][band].Cs[lidx]; all_vars_crop->energy[idx][band].kappa[lidx] = energy[veg][band].kappa[lidx]; } for (index=0; index<Nnodes; index++) { all_vars_crop->energy[idx][band].Cs_node[index] = energy[veg][band].Cs_node[index]; all_vars_crop->energy[idx][band].fdepth[index] = energy[veg][band].fdepth[index]; all_vars_crop->energy[idx][band].ice[index] = energy[veg][band].ice[index]; all_vars_crop->energy[idx][band].kappa_node[index] = energy[veg][band].kappa_node[index]; all_vars_crop->energy[idx][band].moist[index] = energy[veg][band].moist[index]; all_vars_crop->energy[idx][band].T[index] = energy[veg][band].T[index]; all_vars_crop->energy[idx][band].T_fbcount[index] = energy[veg][band].T_fbcount[index]; all_vars_crop->energy[idx][band].T_fbflag[index] = energy[veg][band].T_fbflag[index]; all_vars_crop->energy[idx][band].tdepth[index] = energy[veg][band].tdepth[index]; } // Copy energy flux data all_vars_crop->energy[idx][band].advected_sensible = energy[veg][band].advected_sensible; all_vars_crop->energy[idx][band].advection = energy[veg][band].advection; all_vars_crop->energy[idx][band].AtmosError = energy[veg][band].AtmosError; all_vars_crop->energy[idx][band].AtmosLatent = energy[veg][band].AtmosLatent; all_vars_crop->energy[idx][band].AtmosLatentSub = energy[veg][band].AtmosLatentSub; all_vars_crop->energy[idx][band].AtmosSensible = energy[veg][band].AtmosSensible; all_vars_crop->energy[idx][band].canopy_advection = energy[veg][band].canopy_advection; all_vars_crop->energy[idx][band].canopy_latent = energy[veg][band].canopy_latent; all_vars_crop->energy[idx][band].canopy_latent_sub = energy[veg][band].canopy_latent_sub; all_vars_crop->energy[idx][band].canopy_refreeze = energy[veg][band].canopy_refreeze; all_vars_crop->energy[idx][band].canopy_sensible = energy[veg][band].canopy_sensible; all_vars_crop->energy[idx][band].deltaCC = energy[veg][band].deltaCC; all_vars_crop->energy[idx][band].deltaH = energy[veg][band].deltaH; all_vars_crop->energy[idx][band].error = energy[veg][band].error; all_vars_crop->energy[idx][band].fusion = energy[veg][band].fusion; all_vars_crop->energy[idx][band].grnd_flux = energy[veg][band].grnd_flux; all_vars_crop->energy[idx][band].latent = energy[veg][band].latent; all_vars_crop->energy[idx][band].latent_sub = energy[veg][band].latent_sub; all_vars_crop->energy[idx][band].longwave = energy[veg][band].longwave; all_vars_crop->energy[idx][band].LongOverIn = energy[veg][band].LongOverIn; all_vars_crop->energy[idx][band].LongUnderIn = energy[veg][band].LongUnderIn; all_vars_crop->energy[idx][band].LongUnderOut = energy[veg][band].LongUnderOut; all_vars_crop->energy[idx][band].melt_energy = energy[veg][band].melt_energy; all_vars_crop->energy[idx][band].NetLongAtmos = energy[veg][band].NetLongAtmos; all_vars_crop->energy[idx][band].NetLongOver = energy[veg][band].NetLongOver; all_vars_crop->energy[idx][band].NetLongUnder = energy[veg][band].NetLongUnder; all_vars_crop->energy[idx][band].NetShortAtmos = energy[veg][band].NetShortAtmos; all_vars_crop->energy[idx][band].NetShortGrnd = energy[veg][band].NetShortGrnd; all_vars_crop->energy[idx][band].NetShortOver = energy[veg][band].NetShortOver; all_vars_crop->energy[idx][band].NetShortUnder = energy[veg][band].NetShortUnder; all_vars_crop->energy[idx][band].out_long_canopy = energy[veg][band].out_long_canopy; all_vars_crop->energy[idx][band].out_long_surface = energy[veg][band].out_long_surface; all_vars_crop->energy[idx][band].refreeze_energy = energy[veg][band].refreeze_energy; all_vars_crop->energy[idx][band].sensible = energy[veg][band].sensible; all_vars_crop->energy[idx][band].shortwave = energy[veg][band].shortwave; all_vars_crop->energy[idx][band].ShortOverIn = energy[veg][band].ShortOverIn; all_vars_crop->energy[idx][band].ShortUnderIn = energy[veg][band].ShortUnderIn; all_vars_crop->energy[idx][band].snow_flux = energy[veg][band].snow_flux; } } } } return(0); }
veg_con_struct *read_vegparam(FILE *vegparam, int gridcel, int Nveg_type) /********************************************************************** read_vegparam.c Keith Cherkauer and Dag Lohmann 1997 This routine reads in vegetation parameters for the current grid cell. It also relates each vegetation class in the cell to the appropriate parameters in the vegetation library. Modifications: 09-24-98 Modified to read root zone distribution information so that soil layer root fractions can be computed for new soil layer depths - see calc_root_fractions.c KAC 07-15-99 Modified to read LAI values from a new line in the vegetation parameter file. Added specifically to work with the new global LAI files. 03-27-03 Modified code to update Wdmax based on LAI values read in for the current grid cell. If LAI is not obtained from this function, then the values cacluated in read_veglib.c are left unchanged. DP & KAC 09-02-2003 Moved COMPUTE_TREELINE flag from user_def.h to the options structure. Now when not set to FALSE, the value indicates the default above treeline vegetation if no usable vegetation types are in the grid cell (i.e. everything has a canopy). A negative value will cause the model to use bare soil. Make sure that positive index value refer to a non-canopied vegetation type in the vegetation library. KAC 08-Dec-03 Applied Alan Hamlet's fix for COMPUTE_TREELINE option, which fixed a segmentation fault when COMPUTE_TREELINE=TRUE. This consisted of removing the call to realloc and instead allocating an extra veg class to begin with, as well as assigning this extra veg class a very small fraction of the grid cell's area to avoid changing the results for areas below the treeline. TJB **********************************************************************/ { extern veg_lib_struct *veg_lib; extern option_struct options; #if LINK_DEBUG extern debug_struct debug; #endif veg_con_struct *temp; int vegcel, i, j, vegetat_type_num, skip, veg_class; int NoOverstory; float depth_sum; float sum; char str[500]; char ErrStr[MAXSTRING]; if(options.GLOBAL_LAI) skip=2; else skip=1; NoOverstory = 0; #if !NO_REWIND rewind(vegparam); #endif while ((fscanf(vegparam, "%d %d", &vegcel, &vegetat_type_num)) == 2 && vegcel != gridcel) { for (i = 0; i <= vegetat_type_num * skip; i++) fgets(str, 500, vegparam); } if (vegcel != gridcel) { fprintf(stderr, "Error in vegetation file. Grid cell %d not found\n", gridcel); exit(99); } if(vegetat_type_num >= MAX_VEG) { sprintf(ErrStr,"Vegetation parameter file wants more vegetation types in grid cell %i (%i) than are defined by MAX_VEG (%i) [NOTE: bare soil class is assumed]. Edit vicNl_def.h and recompile.",gridcel,vegetat_type_num+1,MAX_VEG); nrerror(ErrStr); } /** Allocate memory for vegetation grid cell parameters **/ if(vegetat_type_num>0) temp = (veg_con_struct*) calloc(vegetat_type_num+1, sizeof(veg_con_struct)); else temp = (veg_con_struct*) calloc(1, sizeof(veg_con_struct)); temp[0].Cv_sum = 0.0; for (i = 0; i < vegetat_type_num; i++) { temp[i].zone_depth = calloc(options.ROOT_ZONES,sizeof(float)); temp[i].zone_fract = calloc(options.ROOT_ZONES,sizeof(float)); temp[i].vegetat_type_num = vegetat_type_num; fscanf(vegparam, "%d", &temp[i].veg_class); fscanf(vegparam, "%lf", &temp[i].Cv); depth_sum = 0; sum = 0.; for(j=0;j<options.ROOT_ZONES;j++) { fscanf(vegparam,"%f %f",&temp[i].zone_depth[j], &temp[i].zone_fract[j]); depth_sum += temp[i].zone_depth[j]; sum += temp[i].zone_fract[j]; } if(depth_sum <= 0) { sprintf(str,"Root zone depths must sum to a value greater than 0."); nrerror(str); } if(sum != 1.) { fprintf(stderr,"WARNING: Root zone fractions sum to more than 1 ( = %f), normalizing fractions. If the sum is large, check that your vegetation parameter file is in the form - <zone 1 depth> <zone 1 fract> <zone 2 depth> <zone 2 fract> ...\n", sum); for(j=0;j<options.ROOT_ZONES;j++) { temp[i].zone_fract[j] /= sum; } } veg_class = MISSING; for(j=0;j<Nveg_type;j++) if(temp[i].veg_class == veg_lib[j].veg_class) veg_class = j; if(veg_class == MISSING) { sprintf(ErrStr,"Vegetation class %i from cell %i is not defined in the vegetation library file.", temp[i].veg_class, gridcel); nrerror(ErrStr); } else temp[i].veg_class = veg_class; temp[0].Cv_sum += temp[i].Cv; if ( options.GLOBAL_LAI ) { for ( j = 0; j < 12; j++ ) { fscanf(vegparam,"%lf",&veg_lib[temp[i].veg_class].LAI[j]); veg_lib[temp[i].veg_class].Wdmax[j] = LAI_WATER_FACTOR * veg_lib[temp[i].veg_class].LAI[j]; } } if ( options.COMPUTE_TREELINE && !veg_lib[temp[i].veg_class].overstory ) // Determine if cell contains non-overstory vegetation NoOverstory++; } if(temp[0].Cv_sum>1.0){ fprintf(stderr,"WARNING: Cv exceeds 1.0 at grid cell %d, fractions being adjusted to equal 1\n", gridcel); for(j=0;j<vegetat_type_num;j++) temp[j].Cv = temp[j].Cv / temp[0].Cv_sum; temp[0].Cv_sum = 1.; } if(temp[0].Cv_sum>0.99 && temp[0].Cv_sum<1.0){ fprintf(stderr,"WARNING: Cv > 0.99 and Cv < 1.0 at grid cell %d, model assuming that bare soil is not to be run - fractions being adjusted to equal 1\n", gridcel); for(j=0;j<vegetat_type_num;j++) temp[j].Cv = temp[j].Cv / temp[0].Cv_sum; temp[0].Cv_sum = 1.; } if ( options.SNOW_BAND > 1 && options.COMPUTE_TREELINE && ( !NoOverstory && temp[0].Cv_sum == 1. ) ) { // All vegetation in the current cell is defined with overstory. // Add default non-overstory vegetation so that snow bands above treeline // can be sucessfully simulated. if ( options.AboveTreelineVeg < 0 ) { // Above treeline snowband should be treated as bare soil for ( j = 0; j < vegetat_type_num; j++ ) temp[j].Cv -= ( 0.001 / (float)vegetat_type_num ); temp[0].Cv_sum -= 0.001; } else { // Above treeline snowband should use the defined vegetation // add vegetation to typenum // check that veg type exists in library and does not have overstory if(vegetat_type_num > 0) { for ( j = 0; j < vegetat_type_num; j++ ) { temp[j].Cv -= ( 0.001 / (float)vegetat_type_num ); temp[j].vegetat_type_num++; } temp[vegetat_type_num].Cv = 0.001; temp[vegetat_type_num].veg_class = options.AboveTreelineVeg; temp[vegetat_type_num].Cv_sum = temp[vegetat_type_num-1].Cv_sum; temp[vegetat_type_num].zone_depth = calloc( options.ROOT_ZONES, sizeof(float)); temp[vegetat_type_num].zone_fract = calloc( options.ROOT_ZONES, sizeof(float)); temp[vegetat_type_num].vegetat_type_num = vegetat_type_num+1; for ( j = 0; j < options.ROOT_ZONES; j++ ) { // Since root zones are not defined they are copied from the last // vegetation type. temp[vegetat_type_num].zone_depth[j] = temp[vegetat_type_num-1].zone_depth[j]; temp[vegetat_type_num].zone_fract[j] = temp[vegetat_type_num-1].zone_fract[j]; } } veg_class = MISSING; for ( j = 0; j < Nveg_type; j++ ) { // Identify current vegetation class if(temp[vegetat_type_num].veg_class == veg_lib[j].veg_class) { veg_class = j; break; } } if ( veg_class == MISSING ) { sprintf(ErrStr,"Vegetation class %i from cell %i is not defined in the vegetation library file.", temp[i].veg_class, gridcel); nrerror(ErrStr); } else { temp[vegetat_type_num].veg_class = veg_class; } if ( veg_lib[veg_class].overstory ) { sprintf(ErrStr,"Vegetation class %i is defined to have overstory, so it cannot be used as the default vegetation type for above canopy snow bands.", veg_lib[veg_class].veg_class ); nrerror(ErrStr); } } } return temp; }
gmx_bool gaussj(real **a, int n, real **b, int m) { int *indxc,*indxr,*ipiv; int i,icol=0,irow=0,j,k,l,ll; real big,dum,pivinv; indxc=ivector(1,n); indxr=ivector(1,n); ipiv=ivector(1,n); for (j=1;j<=n;j++) ipiv[j]=0; for (i=1;i<=n;i++) { big=0.0; for (j=1;j<=n;j++) if (ipiv[j] != 1) for (k=1;k<=n;k++) { if (ipiv[k] == 0) { if (fabs(a[j][k]) >= big) { big=fabs(a[j][k]); irow=j; icol=k; } } else if (ipiv[k] > 1) { nrerror("GAUSSJ: Singular Matrix-1", FALSE); return FALSE; } } ++(ipiv[icol]); if (irow != icol) { for (l=1;l<=n;l++) SWAP(a[irow][l],a[icol][l]) for (l=1;l<=m;l++) SWAP(b[irow][l],b[icol][l]) } indxr[i]=irow; indxc[i]=icol; if (a[icol][icol] == 0.0) { fprintf(stderr,"irow = %d, icol = %d\n",irow,icol); dump_mat(n,a); nrerror("GAUSSJ: Singular Matrix-2", FALSE); return FALSE; } pivinv=1.0/a[icol][icol]; a[icol][icol]=1.0; for (l=1;l<=n;l++) a[icol][l] *= pivinv; for (l=1;l<=m;l++) b[icol][l] *= pivinv; for (ll=1;ll<=n;ll++) if (ll != icol) { dum=a[ll][icol]; a[ll][icol]=0.0; for (l=1;l<=n;l++) a[ll][l] -= a[icol][l]*dum; for (l=1;l<=m;l++) b[ll][l] -= b[icol][l]*dum; } } for (l=n;l>=1;l--) { if (indxr[l] != indxc[l]) for (k=1;k<=n;k++) SWAP(a[k][indxr[l]],a[k][indxc[l]]); } free_ivector(ipiv,1); free_ivector(indxr,1); free_ivector(indxc,1); return TRUE; }
PUBLIC float profile_aln(const float *T1, const char *seq1, const float *T2, const char *seq2) { /* align the 2 probability profiles T1, T2 */ /* This is like a Needleman-Wunsch alignment, with affine gap-costs ala Gotoh. The score looks at both seq and pair profile */ float **S, **E, **F, tot_score; int i, j, length1, length2; length1 = strlen(seq1); length2 = strlen(seq2); S = newmat(length1, length2); E = newmat(length1, length2); F = newmat(length1, length2); E[0][0] = F[0][0] = open - ext; S[0][0] = 0; for (i=1; i<=length1; i++) F[i][0] = -9999; /* impossible */ for (j=1; j<=length2; j++) E[0][j] = -9999; /* impossible */ if (!free_ends) { for (i=1; i<=length1; i++) S[i][0] = E[i][0] = E[i-1][0] +ext; for (j=1; j<=length2; j++) S[0][j] = F[0][j] = F[0][j-1] +ext; } for (i=1; i<=length1; i++) { for (j=1; j<=length2; j++) { float M; E[i][j] = MAX(E[i-1][j]+ext, S[i-1][j]+open); F[i][j] = MAX(F[i][j-1]+ext, S[i][j-1]+open); M = S[i-1][j-1] + PrfEditScore(T1+3*i,T2+3*j, seq1[i-1], seq2[j-1]); S[i][j] = MAX3(M, E[i][j], F[i][j]); } } if (edit_backtrack) { double score=0; char state = 'S'; int pos, i,j; alignment[0] = (int *) space((length1+length2+1)*sizeof(int)); alignment[1] = (int *) space((length1+length2+1)*sizeof(int)); pos = length1+length2; i = length1; j = length2; tot_score = S[length1][length2]; if (free_ends) { /* find starting point for backtracking, search for highest entry in last row or column */ int imax=0; for (i=1; i<=length1; i++) { if (S[i][length2]>score) { score=S[i][length2]; imax=i; } } for (j=1; j<=length2; j++) { if (S[length1][j]>score) { score=S[length1][j]; imax=-j; } } if (imax<0) { for (j=length2; j> -imax; j--) { alignment[0][pos] = 0; alignment[1][pos--] = j; } i=length1; } else { for (i=length1; i>imax; i--) { alignment[0][pos] = i; alignment[1][pos--] = 0; } j=length2; } tot_score=score; } while (i>0 && j>0) { switch (state) { case 'E': score = E[i][j]; alignment[0][pos] = i; alignment[1][pos--] = 0; if (EQUAL(score, S[i-1][j] + open)) state = 'S'; i--; break; case 'F': score = F[i][j]; alignment[0][pos] = 0; alignment[1][pos--] = j; if (EQUAL(score, S[i][j-1] + open)) state = 'S'; j--; break; case 'S': score = S[i][j]; if (EQUAL(score, E[i][j])) state = 'E'; else if (EQUAL(score, F[i][j])) state = 'F'; else if (EQUAL(score, S[i-1][j-1] + PrfEditScore(T1+3*i,T2+3*j, seq1[i-1], seq2[j-1]))) { alignment[0][pos] = i; alignment[1][pos--] = j; i--; j--; } else nrerror("backtrack of alignment failed"); break; } } for (; j>0; j--) { alignment[0][pos] = 0; alignment[1][pos--] = j; } for (; i>0; i--) { alignment[0][pos] = i; alignment[1][pos--] = 0; } for(i=pos+1; i<=length1+length2; i++){ alignment[0][i-pos] = alignment[0][i]; alignment[1][i-pos] = alignment[1][i]; } alignment[0][0] = length1+length2-pos; /* length of alignment */ sprint_aligned_bppm(T1,seq1, T2,seq2); free(alignment[0]); free(alignment[1]); } for (i=0; i<=length1; i++) { free(S[i]); free(E[i]); free(F[i]); } free(S); free(E); free(F); return tot_score; }
void tqlialt(gdouble d[], gdouble e[], gint n, gdouble **z) { gint i,k,m,l,iter; gdouble s,r,p,g,f,dd,c,b; for (i = 1; i < n; i++) e[i-1] = e[i]; e[n-1] = 0; for (l = 0; l < n; l++) { iter = 0; do { for (m = l; m < n-1; m++) { dd = fabs(d[m])+fabs(d[m+1]); if (fabs(e[m])+dd == dd) break; } if (m != l) { if (iter++ == 30) { nrerror ("too many iterations in tqlialt\n"); return; } g = (d[l+1]-d[l])/(2.0*e[l]); r = sqrt(g*g+1); g = d[m]- d[l]+e[l]/(g+SIGN(r,g)); s = c = 1.0; p = 0.0; for (i = m-1; i >= l; i--) { f = s * e[i]; b = c * e[i]; if (fabs(f) >= fabs (g)) { c = g/f; r = sqrt (c*c+1); e [i+1] = f*r; s = 1.0/r; c *= s; } else { s = f/g; r = sqrt (s*s+1); e[i+1] = g*r; c = 1.0/r; s *= c; } g = d[i+1] - p; r = (d[i] - g)*s+2.0*c*b; p = s*r; d[i+1] = g+p; g = c * r-b; for (k = 0; k < n; k++) { f = z[k][i+1]; z[k][i+1] = s*z[k][i]+c*f; z[k][i] = c * z[k][i]-s*f; } } d[l] = d[l] -p; e [l] = g; e [m] = 0.0; } } while (m != l); } }
int main(void) { int i,j; float *data,*order,*s,**rays; char dummy[MAXSTR],txt[MAXSTR],city[NDAT+1][17],mon[NMON+1][5]; FILE *fp; data=vector(1,NDAT); order=vector(1,NDAT); s=vector(1,NMON); rays=matrix(1,NDAT,1,NMON); if ((fp = fopen("table2.dat","r")) == NULL) nrerror("Data file table2.dat not found\n"); fgets(dummy,MAXSTR,fp); fgets(txt,MAXSTR,fp); fscanf(fp,"%*15c"); for (i=1;i<=NMON;i++) fscanf(fp," %s",mon[i]); fgets(dummy,MAXSTR,fp); fgets(dummy,MAXSTR,fp); for (i=1;i<=NDAT;i++) { fscanf(fp,"%[^0123456789]",city[i]); city[i][16]='\0'; for (j=1;j<=NMON;j++) fscanf(fp,"%f",&rays[i][j]); fgets(dummy,MAXSTR,fp); } fclose(fp); printf("%s\n%16s",txt," "); for (i=1;i<=12;i++) printf(" %s",mon[i]); printf("\n"); for (i=1;i<=NDAT;i++) { printf("%s",city[i]); for (j=1;j<=12;j++) printf("%4d",(int) (0.5+rays[i][j])); printf("\n"); } printf(" press return to continue ...\n"); getchar(); /* Replace solar flux in each column by rank order */ for (j=1;j<=12;j++) { for (i=1;i<=NDAT;i++) { data[i]=rays[i][j]; order[i]=i; } sort2(NDAT,data,order); crank(NDAT,data,&s[j]); for (i=1;i<=NDAT;i++) rays[(int) (0.5+order[i])][j]=data[i]; } printf("%16s"," "); for (i=1;i<=12;i++) printf(" %s",mon[i]); printf("\n"); for (i=1;i<=NDAT;i++) { printf("%s",city[i]); for (j=1;j<=12;j++) printf("%4d",(int) (0.5+rays[i][j])); printf("\n"); } free_matrix(rays,1,NDAT,1,NMON); free_vector(s,1,NMON); free_vector(order,1,NDAT); free_vector(data,1,NDAT); return 0; }
void NR::indexx(Vec_I_INT &arr, Vec_O_INT &indx) { const int M=7,NSTACK=50; int i,indxt,ir,j,k,jstack=-1,l=0; int a; Vec_INT istack(NSTACK); int n=arr.size(); ir=n-1; for (j=0;j<n;j++) indx[j]=j; for (;;) { if (ir-l < M) { for (j=l+1;j<=ir;j++) { indxt=indx[j]; a=arr[indxt]; for (i=j-1;i>=l;i--) { if (arr[indx[i]] <= a) break; indx[i+1]=indx[i]; } indx[i+1]=indxt; } if (jstack < 0) break; ir=istack[jstack--]; l=istack[jstack--]; } else { k=(l+ir) >> 1; SWAP(indx[k],indx[l+1]); if (arr[indx[l]] > arr[indx[ir]]) { SWAP(indx[l],indx[ir]); } if (arr[indx[l+1]] > arr[indx[ir]]) { SWAP(indx[l+1],indx[ir]); } if (arr[indx[l]] > arr[indx[l+1]]) { SWAP(indx[l],indx[l+1]); } i=l+1; j=ir; indxt=indx[l+1]; a=arr[indxt]; for (;;) { do i++; while (arr[indx[i]] < a); do j--; while (arr[indx[j]] > a); if (j < i) break; SWAP(indx[i],indx[j]); } indx[l+1]=indx[j]; indx[j]=indxt; jstack += 2; if (jstack >= NSTACK) nrerror("NSTACK too small in indexx."); if (ir-i+1 >= j-l) { istack[jstack]=ir; istack[jstack-1]=i; ir=j-1; } else { istack[jstack]=j-1; istack[jstack-1]=l; l=i; } } } }
void read_initial_model_state(FILE *init_state, dist_prcp_struct *prcp, global_param_struct *gp, int Nveg, int Nbands, int cellnum, soil_con_struct *soil_con, int Ndist, char *init_STILL_STORM, int *init_DRY_TIME, lake_con_struct lake_con) /********************************************************************* read_initial_model_state Keith Cherkauer April 14, 2000 This subroutine initializes the model state at hour 0 of the date defined in the given state file. Soil moisture, soil thermal, and snowpack variables are stored for each vegetation type and snow band. However moisture variables from the distributed precipitation model are averaged so that the model is restarted with mu = 1. Modifications: 04-10-03 Rewritten to handle updates to vicNl_def.h and to write the file as binary to minimize write time and differences with simulations started with the state file. KAC 04-10-03 Modified to read storm parameters from the state file. KAC 06-03-03 Modified to read ASCII as well as BINARY state file. KAC 06-06-03 It is not necessary to initialize ice content from the model state file as the model recomutes it in subsequent steps. KAC 06-06-03 Added check to make sure that soil moisture obtained from the state file does not exceed the maximum moisture content. KAC 06-07-03 Added check to verify that the sum of the defined nodes equals the damping depth. KAC 03-Oct-03 Modified to loop over tmp_Nveg and tmp_Nband when searching for desired cellnum in ASCII file, rather than over Nveg and Nbands. As we skip over other records in the state file while searching for the desired record, the loop must parse each undesired record differently, according to how many veg classes and snow bands exist in the record (tmp_Nveg and tmp_Nband, respectively), rather than the number of veg classes and snow bands in the desired record (Nveg and Nbands, respectively). TJB 01-Nov-04 Modified to read state files containing SPATIAL_FROST and LAKE_MODEL state variables. TJB 02-Nov-04 Added a few more lake state variables. TJB 03-Nov-04 Now reads extra_veg from state file. TJB 2005-Apr-10 Fixed incorrect check on soil node depths. TJB 2005-Jan-10 modified to read lake nodal variables for each of the active nodes. JCA 2006-Jun-16 Skip reading if areafract < 0. GCT 2006-Aug-23 Changed order of fread/fwrite statements from ...1, sizeof... to ...sizeof, 1,... GCT 2006-Sep-07 Changed "Skip reading if areafract < 0" to "<=0". GCT 2006-Oct-16 Merged infiles and outfiles structs into filep_struct; This included moving infiles.statefile to filep.init_state. TJB 2006-Nov-07 Removed LAKE_MODEL option. TJB 2007-Apr-28 modified to read Zsum_node. JCA 2007-May-07 Fixed fread checks to make sure correct number of items were read in rather than the size of the item read in. JCA 2007-May-07 Nsum and sum removed from declaration. JCA 2007-Aug-24 Added features for EXCESS_ICE option. JCA 2007-Sep-14 Fixed bug for read-in during EXCESS_ICE option. JCA 2007-Sep-18 Check for soil moist exceeding max moist moved from here to initialize_model_state. JCA 2007-Nov-06 New list of lake state variables. LCB via TJB 2009-Jul-31 Removed extra lake/wetland veg tile; updated set of lake state variables. TJB 2009-Aug-27 Now once again expects to read data for all bands, regardless of whether they have area > 0. This makes it much easier to ensure that the value of Nbands stored in the state file matches the number of bands actually stored in the state file. TJB 2009-Sep-28 Now stores soil, snow, and energy states from lake separately from wetland. TJB 2010-Jan-10 Corrected typo in condition for checking Wdew. TJB *********************************************************************/ { extern option_struct options; char tmpstr[MAXSTRING]; char ErrStr[MAXSTRING]; char tmpchar; double tmpval; double depth_node[MAX_NODES]; int veg, iveg; int band, iband; int lidx; int nidx; int dist; int tmp_cellnum; int tmp_Nveg; int tmp_Nband; int tmp_char; int byte, Nbytes; int tmp_int, node; #if SPATIAL_FROST int frost_area; #endif cell_data_struct ***cell; snow_data_struct **snow; energy_bal_struct **energy; veg_var_struct ***veg_var; lake_var_struct *lake_var; cell = prcp->cell; veg_var = prcp->veg_var; snow = prcp->snow; energy = prcp->energy; lake_var = &prcp->lake_var; #if !NO_REWIND rewind(init_state); /* skip header */ if ( options.BINARY_STATE_FILE ) fread(&tmpstr, sizeof(int)*5, 1, init_state); else { fgets(tmpstr, MAXSTRING, init_state); fgets(tmpstr, MAXSTRING, init_state); } #endif /* read cell information */ if ( options.BINARY_STATE_FILE ) { fread( &tmp_cellnum, sizeof(int), 1, init_state ); fread( &tmp_Nveg, sizeof(int), 1, init_state ); fread( &tmp_Nband, sizeof(int), 1, init_state ); fread( &Nbytes, sizeof(int), 1, init_state ); } else fscanf( init_state, "%d %d %d", &tmp_cellnum, &tmp_Nveg, &tmp_Nband ); // Skip over unused cell information while ( tmp_cellnum != cellnum && !feof(init_state) ) { if ( options.BINARY_STATE_FILE ) { // skip rest of current cells info for ( byte = 0; byte < Nbytes; byte++ ) fread ( &tmpchar, 1, 1, init_state); // read info for next cell fread( &tmp_cellnum, sizeof(int), 1, init_state ); fread( &tmp_Nveg, sizeof(int), 1, init_state ); fread( &tmp_Nband, sizeof(int), 1, init_state ); fread( &Nbytes, sizeof(int), 1, init_state ); } else { // skip rest of current cells info fgets(tmpstr, MAXSTRING, init_state); // skip rest of general cell info #if EXCESS_ICE fgets(tmpstr, MAXSTRING, init_state); //excess ice info #endif for ( veg = 0; veg <= tmp_Nveg; veg++ ) { fgets(tmpstr, MAXSTRING, init_state); // skip dist precip info for ( band = 0; band < tmp_Nband; band++ ) fgets(tmpstr, MAXSTRING, init_state); // skip snowband info } if ( options.LAKES ) { fgets(tmpstr, MAXSTRING, init_state); // skip lake info } // read info for next cell fscanf( init_state, "%d %d %d", &tmp_cellnum, &tmp_Nveg, &tmp_Nband ); }//end if }//end while if ( feof(init_state) ) { sprintf(ErrStr, "Requested grid cell (%d) is not in the model state file.", cellnum); nrerror(ErrStr); } if ( tmp_Nveg != Nveg ) { sprintf(ErrStr,"The number of vegetation types in cell %d (%d) does not equal that defined in vegetation parameter file (%d). Check your input files.", cellnum, tmp_Nveg, Nveg); nrerror(ErrStr); } if ( tmp_Nband != Nbands ) { sprintf(ErrStr,"The number of snow bands in cell %d (%d) does not equal that defined in the snow band file (%d). Check your input files.", cellnum, tmp_Nband, Nbands); nrerror(ErrStr); } /* Read soil thermal node deltas */ for ( nidx = 0; nidx < options.Nnode; nidx++ ) { if ( options.BINARY_STATE_FILE ) fread( &soil_con->dz_node[nidx], sizeof(double), 1, init_state ); else fscanf( init_state, "%lf", &soil_con->dz_node[nidx] ); } if ( options.Nnode == 1 ) soil_con->dz_node[0] = 0; /* Read soil thermal node depths */ for ( nidx = 0; nidx < options.Nnode; nidx++ ) { if ( options.BINARY_STATE_FILE ) fread( &soil_con->Zsum_node[nidx], sizeof(double), 1, init_state ); else fscanf( init_state, "%lf", &soil_con->Zsum_node[nidx] ); } if ( options.Nnode == 1 ) soil_con->Zsum_node[0] = 0; if ( soil_con->Zsum_node[options.Nnode-1] - soil_con->dp > SMALL) { fprintf( stderr, "WARNING: Sum of soil nodes (%f) exceeds defined damping depth (%f). Resetting damping depth.\n", soil_con->Zsum_node[options.Nnode-1], soil_con->dp ); soil_con->dp = soil_con->Zsum_node[options.Nnode-1]; } /* Read dynamic soil properties */ #if EXCESS_ICE /* Read soil depth */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { if ( options.BINARY_STATE_FILE ) fread( &soil_con->depth[lidx], sizeof(double), 1, init_state ); else fscanf( init_state, "%lf", &soil_con->depth[lidx] ); } /* Read effective porosity */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { if ( options.BINARY_STATE_FILE ) fread( &soil_con->effective_porosity[lidx], sizeof(double), 1, init_state ); else fscanf( init_state, "%lf", &soil_con->effective_porosity[lidx] ); } /* Reading damping depth */ if ( options.BINARY_STATE_FILE ) fread( &soil_con->dp, sizeof(double), 1, init_state ); else fscanf( init_state, "%lf", &soil_con->dp ); #endif //EXCESS_ICE /* Input for all vegetation types */ for ( veg = 0; veg <= Nveg; veg++ ) { // read distributed precipitation variables if ( options.BINARY_STATE_FILE ) { fread( &prcp->mu[veg], sizeof(double), 1, init_state ); fread( &init_STILL_STORM[veg], sizeof(char), 1, init_state ); fread( &init_DRY_TIME[veg], sizeof(int), 1, init_state ); } else { fscanf( init_state, "%lf %d %d", &prcp->mu[veg], &tmp_char, &init_DRY_TIME[veg] ); init_STILL_STORM[veg] = (char)tmp_char; } /* Input for all snow bands */ for ( band = 0; band < Nbands; band++ ) { /* Read cell identification information */ if ( options.BINARY_STATE_FILE ) { if ( fread( &iveg, sizeof(int), 1, init_state) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &iband, sizeof(int), 1, init_state) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state,"%d %d", &iveg, &iband) == EOF ) nrerror("End of model state file found unexpectedly"); } if ( iveg != veg || iband != band ) { fprintf(stderr,"The vegetation and snow band indices in the model state file (veg = %d, band = %d) do not match those currently requested (veg = %d , band = %d). Model state file must be stored with variables for all vegetation indexed by variables for all snow bands.\n", iveg, iband, veg, band); nrerror(ErrStr); } // Read both wet and dry fractions if using distributed precipitation for ( dist = 0; dist < Ndist; dist ++ ) { /* Read total soil moisture */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { if ( options.BINARY_STATE_FILE ) { if ( fread( &cell[dist][veg][band].layer[lidx].moist, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state," %lf", &cell[dist][veg][band].layer[lidx].moist) == EOF ) nrerror("End of model state file found unexpectedly"); } } /* Read average ice content */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { #if SPATIAL_FROST for ( frost_area = 0; frost_area < FROST_SUBAREAS; frost_area++ ) { if ( options.BINARY_STATE_FILE ) { if ( fread( &cell[dist][veg][band].layer[lidx].ice[frost_area], sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state," %lf", &cell[dist][veg][band].layer[lidx].ice[frost_area]) == EOF ) nrerror("End of model state file found unexpectedly"); } } #else if ( options.BINARY_STATE_FILE ) { if ( fread( &cell[dist][veg][band].layer[lidx].ice, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state," %lf", &cell[dist][veg][band].layer[lidx].ice) == EOF ) nrerror("End of model state file found unexpectedly"); } #endif // SPATIAL_FROST } /* Read dew storage */ if ( veg < Nveg ) { if ( options.BINARY_STATE_FILE ) { if ( fread( &veg_var[dist][veg][band].Wdew, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state," %lf", &veg_var[dist][veg][band].Wdew) == EOF ) nrerror("End of model state file found unexpectedly"); } } } /* Read snow data */ if ( options.BINARY_STATE_FILE ) { if ( fread( &snow[veg][band].last_snow, sizeof(int), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].MELTING, sizeof(char), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].coverage, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].swq, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].surf_temp, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].surf_water, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].pack_temp, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].pack_water, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].density, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].coldcontent, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &snow[veg][band].snow_canopy, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state," %d %d %lf %lf %lf %lf %lf %lf %lf %lf %lf", &snow[veg][band].last_snow, &tmp_char, &snow[veg][band].coverage, &snow[veg][band].swq, &snow[veg][band].surf_temp, &snow[veg][band].surf_water, &snow[veg][band].pack_temp, &snow[veg][band].pack_water, &snow[veg][band].density, &snow[veg][band].coldcontent, &snow[veg][band].snow_canopy) == EOF ) nrerror("End of model state file found unexpectedly"); snow[veg][band].MELTING = (char)tmp_char; } // if(soil_con->glcel == 1) /* By Bibi */ // snow[veg][band].iwq = soil_con->BandIceThick[band] * (917.0 / 1000.); // else // snow[veg][band].iwq = 0.0; if(snow[veg][band].density > 0.) snow[veg][band].depth = 1000. * snow[veg][band].swq / snow[veg][band].density; /* Read soil thermal node temperatures */ for ( nidx = 0; nidx < options.Nnode; nidx++ ) { if ( options.BINARY_STATE_FILE ) { if ( fread( &energy[veg][band].T[nidx], sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { if ( fscanf(init_state," %lf", &energy[veg][band].T[nidx]) == EOF ) nrerror("End of model state file found unexpectedly"); } } } } if ( options.LAKES && lake_con.Cl[0] > 0 ) { if ( options.BINARY_STATE_FILE ) { // Read both wet and dry fractions if using distributed precipitation for ( dist = 0; dist < Ndist; dist ++ ) { /* Read total soil moisture */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { if ( fread( &lake_var->soil.layer[lidx].moist, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } /* Read average ice content */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { #if SPATIAL_FROST for ( frost_area = 0; frost_area < FROST_SUBAREAS; frost_area++ ) { if ( fread( &lake_var->soil.layer[lidx].ice[frost_area], sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } #else if ( fread( &lake_var->soil.layer[lidx].ice, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); #endif // SPATIAL_FROST } } /* Read snow data */ if ( fread( &lake_var->snow.last_snow, sizeof(int), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.MELTING, sizeof(char), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.coverage, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.swq, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.surf_temp, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.surf_water, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.pack_temp, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.pack_water, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.density, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.coldcontent, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->snow.snow_canopy, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if(lake_var->snow.density > 0.) lake_var->snow.depth = 1000. * lake_var->snow.swq / lake_var->snow.density; /* Read soil thermal node temperatures */ for ( nidx = 0; nidx < options.Nnode; nidx++ ) { if ( fread( &lake_var->energy.T[nidx], sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } /* Read lake-specific variables */ if ( fread( &lake_var->activenod, sizeof(int), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->dz, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->surfdz, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->ldepth, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); for ( node = 0; node <= lake_var->activenod; node++ ) { if ( fread( &lake_var->surface[node], sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } if ( fread( &lake_var->sarea, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->volume, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); for ( node = 0; node < lake_var->activenod; node++ ) { if ( fread( &lake_var->temp[node], sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } if ( fread( &lake_var->tempavg, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->areai, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->new_ice_area, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->ice_water_eq, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->hice, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->tempi, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->swe, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->surf_temp, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->pack_temp, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->coldcontent, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->surf_water, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->pack_water, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->SAlbedo, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); if ( fread( &lake_var->sdepth, sizeof(double), 1, init_state ) != 1 ) nrerror("End of model state file found unexpectedly"); } else { // Read both wet and dry fractions if using distributed precipitation for ( dist = 0; dist < Ndist; dist ++ ) { /* Read total soil moisture */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { if ( fscanf(init_state," %lf", &lake_var->soil.layer[lidx].moist) == EOF ) nrerror("End of model state file found unexpectedly"); } /* Read average ice content */ for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { #if SPATIAL_FROST for ( frost_area = 0; frost_area < FROST_SUBAREAS; frost_area++ ) { if ( fscanf(init_state," %lf", &lake_var->soil.layer[lidx].ice[frost_area]) == EOF ) nrerror("End of model state file found unexpectedly"); } #else if ( fscanf(init_state," %lf", &lake_var->soil.layer[lidx].ice) == EOF ) nrerror("End of model state file found unexpectedly"); #endif // SPATIAL_FROST } } /* Read snow data */ if ( fscanf(init_state," %d %d %lf %lf %lf %lf %lf %lf %lf %lf %lf", &lake_var->snow.last_snow, &tmp_char, &lake_var->snow.coverage, &lake_var->snow.swq, &lake_var->snow.surf_temp, &lake_var->snow.surf_water, &lake_var->snow.pack_temp, &lake_var->snow.pack_water, &lake_var->snow.density, &lake_var->snow.coldcontent, &lake_var->snow.snow_canopy) == EOF ) nrerror("End of model state file found unexpectedly"); lake_var->snow.MELTING = (char)tmp_char; if(lake_var->snow.density > 0.) lake_var->snow.depth = 1000. * lake_var->snow.swq / lake_var->snow.density; /* Read soil thermal node temperatures */ for ( nidx = 0; nidx < options.Nnode; nidx++ ) { if ( fscanf(init_state," %lf", &lake_var->energy.T[nidx]) == EOF ) nrerror("End of model state file found unexpectedly"); } /* Read lake-specific variables */ if ( fscanf(init_state," %d", &lake_var->activenod) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->dz) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->surfdz) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->ldepth) == EOF ) nrerror("End of model state file found unexpectedly"); for ( node = 0; node <= lake_var->activenod; node++ ) { if ( fscanf(init_state," %lf", &lake_var->surface[node]) == EOF ) nrerror("End of model state file found unexpectedly"); } if ( fscanf(init_state," %lf", &lake_var->sarea) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->volume) == EOF ) nrerror("End of model state file found unexpectedly"); for ( node = 0; node < lake_var->activenod; node++ ) { if ( fscanf(init_state," %lf", &lake_var->temp[node]) == EOF ) nrerror("End of model state file found unexpectedly"); } if ( fscanf(init_state," %lf", &lake_var->tempavg) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->areai) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->new_ice_area) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->ice_water_eq) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->hice) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->tempi) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->swe) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->surf_temp) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->pack_temp) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->coldcontent) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->surf_water) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->pack_water) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->SAlbedo) == EOF ) nrerror("End of model state file found unexpectedly"); if ( fscanf(init_state," %lf", &lake_var->sdepth) == EOF ) nrerror("End of model state file found unexpectedly"); } } }
int main(void) { int k; unsigned long i,j,lc,lcode=MAXLINE,n,nch,nrad,nt,nfreq[257],tmp,zero=0; unsigned char *code,mess[MAXLINE],ness[MAXLINE]; arithcode acode; FILE *fp; code=cvector(0,MAXLINE); acode.ilob=lvector(1,NWK); acode.iupb=lvector(1,NWK); acode.ncumfq=lvector(1,MC+2); if ((fp = fopen("text.dat","r")) == NULL) nrerror("Input file text.dat not found.\n"); for (j=1;j<=256;j++) nfreq[j]=0; while ((k=getc(fp)) != EOF) { if ((k -= 31) >= 1) nfreq[k]++; } fclose(fp); nch=96; nrad=256; /* here is the initialization that constructs the code */ arcmak(nfreq,(int)nch,(int)nrad,&acode); /* now ready to prompt for lines to encode */ for (;;) { printf("Enter a line:\n"); if (gets((char *)&mess[1]) == NULL) break; n=strlen((char *)&mess[1]); /* shift from 256 character alphabet to 96 printing characters */ for (j=1;j<=n;j++) mess[j] -= 32; /* message initialization */ lc=1; arcode(&zero,&code,&lcode,&lc,0,&acode); /* here we arithmetically encode mess(1:n) */ for (j=1;j<=n;j++) { tmp=mess[j]; arcode(&tmp,&code,&lcode,&lc,1,&acode); } /* message termination */ arcode(&nch,&code,&lcode,&lc,1,&acode); printf("Length of line input, coded= %lu %lu\n",n,lc-1); /* here we decode the message, hopefully to get the original back */ lc=1; arcode(&zero,&code,&lcode,&lc,0,&acode); for (j=1;j<=lcode;j++) { arcode(&i,&code,&lcode,&lc,-1,&acode); if (i == nch) break; else ness[j]=(unsigned char)i; } if (j > lcode) nrerror("Arith. coding: Never get here"); nt=j-1; printf("Decoded output:\n"); for (j=1;j<=nt;j++) printf("%c",(char)(ness[j]+32)); printf("\n"); if (nt != n) printf("Error ! j decoded != n input.\n"); } free_cvector(code,0,MAXLINE); free_lvector(acode.ncumfq,1,MC+2); free_lvector(acode.iupb,1,NWK); free_lvector(acode.ilob,1,NWK); printf("Normal completion\n"); return 0; }
gmx_bool mrqmin(real x[], real y[], real sig[], int ndata, real a[], int ma, int lista[], int mfit, real **covar, real **alpha, real *chisq, void (*funcs)(real,real *,real *,real *), real *alamda) { int k,kk,j,ihit; static real *da,*atry,**oneda,*beta,ochisq; if (*alamda < 0.0) { oneda=matrix1(1,mfit,1,1); atry=rvector(1,ma); da=rvector(1,ma); beta=rvector(1,ma); kk=mfit+1; for (j=1;j<=ma;j++) { ihit=0; for (k=1;k<=mfit;k++) if (lista[k] == j) ihit++; if (ihit == 0) lista[kk++]=j; else if (ihit > 1) { nrerror("Bad LISTA permutation in MRQMIN-1", FALSE); return FALSE; } } if (kk != ma+1) { nrerror("Bad LISTA permutation in MRQMIN-2", FALSE); return FALSE; } *alamda=0.001; mrqcof(x,y,sig,ndata,a,ma,lista,mfit,alpha,beta,chisq,funcs); ochisq=(*chisq); } for (j=1;j<=mfit;j++) { for (k=1;k<=mfit;k++) covar[j][k]=alpha[j][k]; covar[j][j]=alpha[j][j]*(1.0+(*alamda)); oneda[j][1]=beta[j]; } if (!gaussj(covar,mfit,oneda,1)) return FALSE; for (j=1;j<=mfit;j++) da[j]=oneda[j][1]; if (*alamda == 0.0) { covsrt(covar,ma,lista,mfit); free_vector(beta,1); free_vector(da,1); free_vector(atry,1); free_matrix(oneda,1,mfit,1); return TRUE; } for (j=1;j<=ma;j++) atry[j]=a[j]; for (j=1;j<=mfit;j++) atry[lista[j]] = a[lista[j]]+da[j]; mrqcof(x,y,sig,ndata,atry,ma,lista,mfit,covar,da,chisq,funcs); if (*chisq < ochisq) { *alamda *= 0.1; ochisq=(*chisq); for (j=1;j<=mfit;j++) { for (k=1;k<=mfit;k++) alpha[j][k]=covar[j][k]; beta[j]=da[j]; a[lista[j]]=atry[lista[j]]; } } else { *alamda *= 10.0; *chisq=ochisq; } return TRUE; }
void open_debug() { /********************************************************************** open_debug Keith Cherkauer October 10, 1997 This subroutine opens all requested debugging output files. Modifications: 07-May-04 Initialize debug_store_moist array when debug.PRT_MOIST is true (as well as under the other previously-defined conditions). TJB **********************************************************************/ extern debug_struct debug; extern option_struct options; char tempname[MAXSTRING]; int i, j; if(debug.DEBUG || debug.PRT_TEMP) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_temp.out"); if((debug.fg_temp=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_temp.out"); } if(debug.DEBUG || debug.PRT_MOIST) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_moist.out"); if((debug.fg_moist=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_moist.out"); } if(debug.DEBUG || debug.PRT_KAPPA) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_kappa.out"); if((debug.fg_kappa=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_kappa.out"); } if(debug.DEBUG || debug.PRT_BALANCE || debug.PRT_MOIST) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_balance.out"); if((debug.fg_balance=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_balance.out"); for(i=0;i<2;i++) { debug.inflow[i] = (double **)calloc(options.SNOW_BAND, sizeof(double*)); debug.outflow[i] = (double **)calloc(options.SNOW_BAND, sizeof(double*)); debug.store_moist[i] = (double **)calloc(options.SNOW_BAND, sizeof(double*)); for(j=0;j<options.SNOW_BAND;j++) { debug.inflow[i][j] = (double *)calloc(options.Nlayer+3, sizeof(double)); debug.outflow[i][j] = (double *)calloc(options.Nlayer+3, sizeof(double)); debug.store_moist[i][j] = (double *)calloc(options.Nlayer+3, sizeof(double)); } } } if(debug.DEBUG || debug.PRT_FLUX) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_energy.out"); if((debug.fg_energy=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_energy.out"); } if(debug.DEBUG || debug.PRT_SNOW) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_snow.out"); if((debug.fg_snow=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_snow.out"); } if(debug.DEBUG || debug.PRT_GRID) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_grid.out"); if((debug.fg_grid=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_grid.out"); } if(debug.DEBUG || debug.PRT_ATMOS) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_snowstep_atmos.out"); if((debug.fg_snowstep_atmos=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_snowstep_atmos.out"); } if(debug.DEBUG || debug.PRT_ATMOS) { strcpy(tempname,debug.debug_dir); strcat(tempname,"/VIC_modelstep_atmos.out"); if((debug.fg_modelstep_atmos=fopen(tempname,"w"))==NULL) nrerror("ERROR: Unable to open VIC_modelstep_atmos.out"); } }
void SvdCmp(double **a, int m, int n, double w[], double **v) { // SVD Composition int flag,i,its,j,jj,k,l,nm; double anorm,c,f,g,h,s,scale,x,y,z,*rv1; rv1=dVector(1,n); g=scale=anorm=0.0; for (i=1;i<=n;i++) { l=i+1; rv1[i]=scale*g; g=s=scale=0.0; if (i <= m) { for (k=i;k<=m;k++) scale += fabs(a[k][i]); if (scale) { for (k=i;k<=m;k++) { a[k][i] /= scale; s += a[k][i]*a[k][i]; } f=a[i][i]; g = -SIGN(sqrt(s),f); h=f*g-s; a[i][i]=f-g; for (j=l;j<=n;j++) { for (s=0.0,k=i;k<=m;k++) s += a[k][i]*a[k][j]; f=s/h; for (k=i;k<=m;k++) a[k][j] += f*a[k][i]; } for (k=i;k<=m;k++) a[k][i] *= scale; } } w[i]=scale *g; g=s=scale=0.0; if (i <= m && i != n) { for (k=l;k<=n;k++) scale += fabs(a[i][k]); if (scale) { for (k=l;k<=n;k++) { a[i][k] /= scale; s += a[i][k]*a[i][k]; } f=a[i][l]; g = -SIGN(sqrt(s),f); h=f*g-s; a[i][l]=f-g; for (k=l;k<=n;k++) rv1[k]=a[i][k]/h; for (j=l;j<=m;j++) { for (s=0.0,k=l;k<=n;k++) s += a[j][k]*a[i][k]; for (k=l;k<=n;k++) a[j][k] += s*rv1[k]; } for (k=l;k<=n;k++) a[i][k] *= scale; } } anorm=__max(anorm,(fabs(w[i])+fabs(rv1[i]))); } for (i=n;i>=1;i--) { if (i < n) { if (g) { for (j=l;j<=n;j++) v[j][i]=(a[i][j]/a[i][l])/g; for (j=l;j<=n;j++) { for (s=0.0,k=l;k<=n;k++) s += a[i][k]*v[k][j]; for (k=l;k<=n;k++) v[k][j] += s*v[k][i]; } } for (j=l;j<=n;j++) v[i][j]=v[j][i]=0.0; } v[i][i]=1.0; g=rv1[i]; l=i; } for (i=__min(m,n);i>=1;i--) { l=i+1; g=w[i]; for (j=l;j<=n;j++) a[i][j]=0.0; if (g) { g=1.0/g; for (j=l;j<=n;j++) { for (s=0.0,k=l;k<=m;k++) s += a[k][i]*a[k][j]; f=(s/a[i][i])*g; for (k=i;k<=m;k++) a[k][j] += f*a[k][i]; } for (j=i;j<=m;j++) a[j][i] *= g; } else for (j=i;j<=m;j++) a[j][i]=0.0; ++a[i][i]; } for (k=n;k>=1;k--) { for (its=1;its<=100;its++) { flag=1; for (l=k;l>=1;l--) { nm=l-1; if ((double)(fabs(rv1[l])+anorm) == anorm) { flag=0; break; } if ((double)(fabs(w[nm])+anorm) == anorm) break; } if (flag) { c=0.0; s=1.0; for (i=l;i<=k;i++) { f=s*rv1[i]; rv1[i]=c*rv1[i]; if ((double)(fabs(f)+anorm) == anorm) break; g=w[i]; h=Pythag(f,g); w[i]=h; h=1.0/h; c=g*h; s = -f*h; for (j=1;j<=m;j++) { y=a[j][nm]; z=a[j][i]; a[j][nm]=y*c+z*s; a[j][i]=z*c-y*s; } } } z=w[k]; if (l == k) { if (z < 0.0) { w[k] = -z; for (j=1;j<=n;j++) v[j][k] = -v[j][k]; } break; } if (its == 100) nrerror("no convergence in 30 svdcmp iterations"); x=w[l]; nm=k-1; y=w[nm]; g=rv1[nm]; h=rv1[k]; f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y); g=Pythag(f,1.0); f=((x-z)*(x+z)+h*((y/(f+SIGN(g,f)))-h))/x; c=s=1.0; for (j=l;j<=nm;j++) { i=j+1; g=rv1[i]; y=w[i]; h=s*g; g=c*g; z=Pythag(f,h); rv1[j]=z; c=f/z; s=h/z; f=x*c+g*s; g = g*c-x*s; h=y*s; y *= c; for (jj=1;jj<=n;jj++) { x=v[jj][j]; z=v[jj][i]; v[jj][j]=x*c+z*s; v[jj][i]=z*c-x*s; } z=Pythag(f,h); w[j]=z; if (z) { z=1.0/z; c=f*z; s=h*z; } f=c*g+s*y; x=c*y-s*g; for (jj=1;jj<=m;jj++) { y=a[jj][j]; z=a[jj][i]; a[jj][j]=y*c+z*s; a[jj][i]=z*c-y*s; } } rv1[l]=0.0; rv1[k]=f; w[k]=x; } } Free_dVector(rv1,1,n); }
void bsstep(float y[], float dydx[], int nv, float *xx, float htry, float eps, float yscal[], float *hdid, float *hnext, void (*derivs)(float, float [], float [])) { void mmid(float y[], float dydx[], int nvar, float xs, float htot, int nstep, float yout[], void (*derivs)(float, float[], float[])); void pzextr(int iest, float xest, float yest[], float yz[], float dy[], int nv); int i,iq,k,kk,km; static int first=1,kmax,kopt; static float epsold = -1.0,xnew; float eps1,errmax,fact,h,red,scale,work,wrkmin,xest; float *err,*yerr,*ysav,*yseq; static float a[IMAXX+1]; static float alf[KMAXX+1][KMAXX+1]; static int nseq[IMAXX+1]={0,2,4,6,8,10,12,14,16,18}; int reduct,exitflag=0; // d=matrix(1,KMAXX,1,KMAXX); d=matrix(1,nv,1,KMAXX); err=vector(1,KMAXX); x=vector(1,KMAXX); yerr=vector(1,nv); ysav=vector(1,nv); yseq=vector(1,nv); if (eps != epsold) { *hnext = xnew = -1.0e29; eps1=SAFE1*eps; a[1]=nseq[1]+1; for (k=1;k<=KMAXX;k++) a[k+1]=a[k]+nseq[k+1]; for (iq=2;iq<=KMAXX;iq++) { for (k=1;k<iq;k++) alf[k][iq]=pow(eps1,(a[k+1]-a[iq+1])/ ((a[iq+1]-a[1]+1.0)*(2*k+1))); } epsold=eps; for (kopt=2;kopt<KMAXX;kopt++) if (a[kopt+1] > a[kopt]*alf[kopt-1][kopt]) break; kmax=kopt; } h=htry; for (i=1;i<=nv;i++) ysav[i]=y[i]; if (*xx != xnew || h != (*hnext)) { first=1; kopt=kmax; } reduct=0; for (;;) { for (k=1;k<=kmax;k++) { xnew=(*xx)+h; if (xnew == (*xx)) nrerror("step size underflow in bsstep"); mmid(ysav,dydx,nv,*xx,h,nseq[k],yseq,derivs); xest=SQR(h/nseq[k]); pzextr(k,xest,yseq,y,yerr,nv); if (k != 1) { errmax=TINY; for (i=1;i<=nv;i++) errmax=FMAX(errmax,fabs(yerr[i]/yscal[i])); errmax /= eps; km=k-1; err[km]=pow(errmax/SAFE1,1.0/(2*km+1)); } if (k != 1 && (k >= kopt-1 || first)) { if (errmax < 1.0) { exitflag=1; break; } if (k == kmax || k == kopt+1) { red=SAFE2/err[km]; break; } else if (k == kopt && alf[kopt-1][kopt] < err[km]) { red=1.0/err[km]; break; } else if (kopt == kmax && alf[km][kmax-1] < err[km]) { red=alf[km][kmax-1]*SAFE2/err[km]; break; } else if (alf[km][kopt] < err[km]) { red=alf[km][kopt-1]/err[km]; break; } } } if (exitflag) break; red=FMIN(red,REDMIN); red=FMAX(red,REDMAX); h *= red; reduct=1; } *xx=xnew; *hdid=h; first=0; wrkmin=1.0e35; for (kk=1;kk<=km;kk++) { fact=FMAX(err[kk],SCALMX); work=fact*a[kk+1]; if (work < wrkmin) { scale=fact; wrkmin=work; kopt=kk+1; } } *hnext=h/scale; if (kopt >= k && kopt != kmax && !reduct) { fact=FMAX(scale/alf[kopt-1][kopt],SCALMX); if (a[kopt+1]*fact <= wrkmin) { *hnext=h/fact; kopt++; } } free_vector(yseq,1,nv); free_vector(ysav,1,nv); free_vector(yerr,1,nv); free_vector(x,1,KMAXX); free_vector(err,1,KMAXX); free_matrix(d,1,KMAXX,1,KMAXX); }
void simplx(float **a, int m, int n, int m1, int m2, int m3, int *icase, int izrov[], int iposv[]) { void simp1(float **a, int mm, int ll[], int nll, int iabf, int *kp, float *bmax); void simp2(float **a, int n, int l2[], int nl2, int *ip, int kp, float *q1); void simp3(float **a, int i1, int k1, int ip, int kp); int i,ip,ir,is,k,kh,kp,m12,nl1,nl2; int *l1,*l2,*l3; float q1,bmax; if (m != (m1+m2+m3)) nrerror("Bad input constraint counts in simplx"); l1=ivector(1,n+1); l2=ivector(1,m); l3=ivector(1,m); nl1=n; for (k=1;k<=n;k++) l1[k]=izrov[k]=k; nl2=m; for (i=1;i<=m;i++) { if (a[i+1][1] < 0.0) nrerror("Bad input tableau in simplx"); l2[i]=i; iposv[i]=n+i; } for (i=1;i<=m2;i++) l3[i]=1; ir=0; if (m2+m3) { ir=1; for (k=1;k<=(n+1);k++) { q1=0.0; for (i=m1+1;i<=m;i++) q1 += a[i+1][k]; a[m+2][k] = -q1; } do { simp1(a,m+1,l1,nl1,0,&kp,&bmax); if (bmax <= EPS && a[m+2][1] < -EPS) { *icase = -1; FREEALL return; } else if (bmax <= EPS && a[m+2][1] <= EPS) { m12=m1+m2+1; if (m12 <= m) { for (ip=m12;ip<=m;ip++) { if (iposv[ip] == (ip+n)) { simp1(a,ip,l1, nl1,1,&kp,&bmax); if (bmax > 0.0) goto one; } } } ir=0; --m12; if (m1+1 <= m12) for (i=m1+1;i<=m12;i++) if (l3[i-m1] == 1) for (k=1;k<=n+1;k++) a[i+1][k] = -a[i+1][k]; break; } simp2(a,n,l2,nl2,&ip,kp,&q1); if (ip == 0) { *icase = -1; FREEALL return; }
int update_thermal_nodes(all_vars_struct *all_vars, int Nveg, int Nnodes, soil_con_struct *soil_con, veg_con_struct *veg_con) /********************************************************************** update_thermal_nodes Jennifer Adam August 16, 2007 This routine is run after subsidence occurs (used only for EXCESS_ICE option). This routine updates the node depths and interpolates the current node temperatures to the new depths, then recalculates the nodal thermal properties. Much of this routine is taken directly from initialize_model_state. Modifications: 2009-Feb-09 Removed dz_node from call to distribute_node_moisture_properties. KAC via TJB 2009-Feb-09 Removed dz_node from call to find_0_degree_front. KAC via TJB 2012-Jan-16 Removed LINK_DEBUG code BN 2013-Dec-26 Removed EXCESS_ICE option. TJB **********************************************************************/ { extern option_struct options; extern veg_lib_struct *veg_lib; char ErrStr[MAXSTRING]; char FIRST_VEG; int veg, index; int lidx; int band; int ErrorFlag; double Cv; double Zsum, dp; double tmpdp, tmpadj, Bexp; double moist[MAX_VEG][MAX_BANDS][MAX_LAYERS]; cell_data_struct **cell; energy_bal_struct **energy; double Tnode_prior[MAX_NODES]; double Zsum_prior[MAX_NODES]; cell = all_vars->cell; energy = all_vars->energy; dp = soil_con->dp; FIRST_VEG = TRUE; /***************************************************************** Update soil thermal node depths, thicknesses, and temperatures. CASE 3: Initialize Energy Balance Variables if not using quick ground heat flux, and no Initial Condition File Given *****************************************************************/ /***************************************************************** Update soil thermal node depths and thicknesses. *****************************************************************/ //set previous Zsum for ( index = 0; index < Nnodes; index++ ) Zsum_prior[index] = soil_con->Zsum_node[index]; if(!options.EXP_TRANS){ /* Nodes set at surface, the depth of the first layer, twice the depth of the first layer, and at the damping depth. Extra nodes are placed equal distance between the damping depth and twice the depth of the first layer. */ soil_con->dz_node[0] = soil_con->depth[0]; soil_con->dz_node[1] = soil_con->depth[0]; soil_con->dz_node[2] = soil_con->depth[0]; soil_con->Zsum_node[0] = 0; soil_con->Zsum_node[1] = soil_con[0].depth[0]; Zsum = 2. * soil_con[0].depth[0]; soil_con->Zsum_node[2] = Zsum; tmpdp = dp - soil_con[0].depth[0] * 2.5; tmpadj = 3.5; for ( index = 3; index < Nnodes-1; index++ ) { soil_con->dz_node[index] = tmpdp/(((double)Nnodes-tmpadj)); Zsum += (soil_con->dz_node[index] +soil_con->dz_node[index-1])/2.; soil_con->Zsum_node[index] = Zsum; } soil_con->dz_node[Nnodes-1] = (dp - Zsum - soil_con->dz_node[Nnodes-2] / 2. ) * 2.; Zsum += (soil_con->dz_node[Nnodes-2] +soil_con->dz_node[Nnodes-1])/2.; soil_con->Zsum_node[Nnodes-1] = Zsum; if((int)(Zsum*1000+0.5) != (int)(dp*1000+0.5)) { sprintf(ErrStr,"Sum of thermal node thicknesses (%f) in initialize_model_state do not equal dp (%f), check initialization procedure",Zsum,dp); nrerror(ErrStr); } } else{ /* exponential grid transformation, EXP_TRANS = TRUE*/ /*calculate exponential function parameter */ Bexp = logf(dp+1.)/(double)(Nnodes-1); //to force Zsum=dp at bottom node for ( index = 0; index <= Nnodes-1; index++ ) soil_con->Zsum_node[index] = expf(Bexp*index)-1.; //top node index=0; soil_con->dz_node[index] = soil_con->Zsum_node[index+1]-soil_con->Zsum_node[index]; //middle nodes for ( index = 1; index < Nnodes-1; index++ ) { soil_con->dz_node[index] = (soil_con->Zsum_node[index+1]-soil_con->Zsum_node[index])/2.+(soil_con->Zsum_node[index]-soil_con->Zsum_node[index-1])/2.; } //bottom node index=Nnodes-1; soil_con->dz_node[index] = soil_con->Zsum_node[index]-soil_con->Zsum_node[index-1]; } #if VERBOSE fprintf(stderr,"More updated parameters in soil_con: dz_node and Zsum_node.\n"); #endif /****************************************** Update soil thermal node temperatures via linear interpolation. ******************************************/ for ( veg = 0 ; veg <= Nveg ; veg++ ) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { if ( soil_con->AreaFract[band] > 0. ) { //set previous temperatures for ( index = 0; index < Nnodes; index++ ) Tnode_prior[index] = energy[veg][band].T[index]; //top node: no need to update surface temperature //remaining nodes for ( index = 1; index < Nnodes; index++ ) { energy[veg][band].T[index] = linear_interp(soil_con->Zsum_node[index],Zsum_prior[index-1],Zsum_prior[index],Tnode_prior[index-1],Tnode_prior[index]); }//node } }//band } }//veg /****************************************** Update soil thermal node properties ******************************************/ FIRST_VEG = TRUE; for ( veg = 0 ; veg <= Nveg ; veg++) { // Initialize soil for existing vegetation types Cv = veg_con[veg].Cv; if ( Cv > 0 ) { for( band = 0; band < options.SNOW_BAND; band++ ) { // Initialize soil for existing snow elevation bands if ( soil_con->AreaFract[band] > 0. ) { /** Set soil properties for all soil nodes **/ if(FIRST_VEG) { FIRST_VEG = FALSE; set_node_parameters(soil_con->dz_node, soil_con->Zsum_node, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, soil_con->alpha, soil_con->beta, soil_con->gamma, soil_con->depth, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->quartz, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); } for ( lidx = 0; lidx < options.Nlayer; lidx++ ) moist[veg][band][lidx] = cell[veg][band].layer[lidx].moist; /* set soil moisture properties for all soil thermal nodes */ if ( !( options.LAKES && veg_con->LAKE != 0 ) ) { ErrorFlag = distribute_node_moisture_properties(energy[veg][band].moist, energy[veg][band].ice, energy[veg][band].kappa_node, energy[veg][band].Cs_node, soil_con->Zsum_node, energy[veg][band].T, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, moist[veg][band], soil_con->depth, soil_con->soil_dens_min, soil_con->bulk_dens_min, soil_con->quartz, soil_con->soil_density, soil_con->bulk_density, soil_con->organic, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); if ( ErrorFlag == ERROR ) return ( ErrorFlag ); } /* initialize layer moistures and ice contents */ if ( !( options.LAKES && veg_con->LAKE != 0 ) ) { if (options.QUICK_FLUX) { ErrorFlag = estimate_layer_ice_content_quick_flux(cell[veg][band].layer, soil_con->depth, soil_con->dp, energy[veg][band].T[0], energy[veg][band].T[1], soil_con->avg_temp, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->frost_fract, soil_con->frost_slope, soil_con->FS_ACTIVE); } else { ErrorFlag = estimate_layer_ice_content(cell[veg][band].layer, soil_con->Zsum_node, energy[veg][band].T, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, soil_con->depth, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->frost_fract, soil_con->frost_slope, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); } } /* Find freezing and thawing front depths */ if(!options.QUICK_FLUX && soil_con->FS_ACTIVE) if ( !( options.LAKES && veg_con->LAKE != 0 ) ) find_0_degree_fronts(&energy[veg][band], soil_con->Zsum_node, energy[veg][band].T, Nnodes); } }//band } }//veg return(0); }
DP NR::selip(const int k, Vec_I_DP &arr) { const int M=64; const DP BIG=1.0e30; int i,j,jl,jm,ju,kk,mm,nlo,nxtmm; DP ahi,alo,sum; Vec_INT isel(M+2); Vec_DP sel(M+2); int n=arr.size(); if (k < 0 || k > n-1) nrerror("bad input to selip"); kk=k; ahi=BIG; alo = -BIG; for (;;) { mm=nlo=0; sum=0.0; nxtmm=M+1; for (i=0;i<n;i++) { if (arr[i] >= alo && arr[i] <= ahi) { mm++; if (arr[i] == alo) nlo++; if (mm <= M) sel[mm-1]=arr[i]; else if (mm == nxtmm) { nxtmm=mm+mm/M; sel[(i+2+mm+kk) % M]=arr[i]; } sum += arr[i]; } } if (kk < nlo) { return alo; } else if (mm < M+1) { shell(mm,sel); ahi = sel[kk]; return ahi; } sel[M]=sum/mm; shell(M+1,sel); sel[M+1]=ahi; for (j=0;j<M+2;j++) isel[j]=0; for (i=0;i<n;i++) { if (arr[i] >= alo && arr[i] <= ahi) { jl=0; ju=M+2; while (ju-jl > 1) { jm=(ju+jl)/2; if (arr[i] >= sel[jm-1]) jl=jm; else ju=jm; } isel[ju-1]++; } } j=0; while (kk >= isel[j]) { alo=sel[j]; kk -= isel[j++]; } ahi=sel[j]; } }
veg_lib_struct *read_veglib(FILE *veglib, int *Ntype) /********************************************************************** read_veglib.c Keith Cherkauer 1997 This routine reads in a library of vegetation parameters for all vegetation classes used in the model. The veg class number is used to reference the information in this library. Modifications: 09-24-98 Modified to remove root fractions from the library file. See read_vegparam.c and calc_root_fraction.c for new root fraction distribution information. KAC 2009-Jun-09 Modified to use extension of veg_lib structure to contain bare soil information, as well as other land cover types used in potential evap calcualtions. TJB 2009-Oct-01 Added error message for case of LAI==0 and overstory==1. TJB 2010-Apr-28 Replaced GLOBAL_LAI with VEGPARAM_LAI and LAI_SRC. TJB 2012-Jan-16 Removed LINK_DEBUG code BN 2013-Jul-25 Added photosynthesis parameters. TJB 2014-Apr-25 Improved validation for LAI and albedo values. TJB 2014-Apr-25 Added partial vegcover fraction. TJB **********************************************************************/ { extern option_struct options; veg_lib_struct *temp; int i, j; int tmpflag; int Nveg_type; char str[MAXSTRING]; char ErrStr[MAXSTRING]; double maxd; char tmpstr[MAXSTRING]; rewind(veglib); fgets(str,MAXSTRING,veglib); Nveg_type = 0; while(!feof(veglib)) { if(str[0]<=57 && str[0]>=48) Nveg_type++; fgets(str,MAXSTRING,veglib); } rewind(veglib); temp = (veg_lib_struct *)calloc(Nveg_type+N_PET_TYPES_NON_NAT,sizeof(veg_lib_struct)); fscanf(veglib, "%s", str); i=0; while (!feof(veglib)) { if(str[0]<=57 && str[0]>=48) { temp[i].NVegLibTypes = Nveg_type; temp[i].veg_class = atoi(str); fscanf(veglib, "%d", &tmpflag); if(tmpflag==0) temp[i].overstory = FALSE; else temp[i].overstory = TRUE; fscanf(veglib, "%lf", &temp[i].rarc); fscanf(veglib, "%lf", &temp[i].rmin); for (j = 0; j < 12; j++) { fscanf(veglib, "%lf", &temp[i].LAI[j]); if (options.LAI_SRC == LAI_FROM_VEGLIB && temp[i].overstory && temp[i].LAI[j] == 0) { sprintf(ErrStr,"ERROR: veg library: the specified veg class (%d) is listed as an overstory class, but the LAI given for this class for month %d is 0\n", temp[i].veg_class, j); nrerror(ErrStr); } temp[i].Wdmax[j] = LAI_WATER_FACTOR * temp[i].LAI[j]; } if (options.VEGLIB_VEGCOVER) { for (j = 0; j < 12; j++) { fscanf(veglib, "%lf", &temp[i].vegcover[j]); if(temp[i].vegcover[j] < 0 || temp[i].vegcover[j] > 1) { sprintf(str,"Veg cover fraction must be between 0 and 1 (%f)", temp[i].vegcover[j]); nrerror(str); } if (temp[i].vegcover[j] < 0.01) temp[i].vegcover[j] = 0.01; } } else { for (j = 0; j < 12; j++) { temp[i].vegcover[j] = 1.00; } } for (j = 0; j < 12; j++) { fscanf(veglib, "%lf", &temp[i].albedo[j]); if(temp[i].albedo[j] < 0 || temp[i].albedo[j] > 1) { sprintf(str,"Albedo must be between 0 and 1 (%f)", temp[i].albedo[j]); nrerror(str); } } for (j = 0; j < 12; j++) { fscanf(veglib, "%lf", &temp[i].roughness[j]); } temp[i].wind_h = 0.; maxd = 0; for (j = 0; j < 12; j++) { fscanf(veglib, "%lf", &temp[i].displacement[j]); if(temp[i].displacement[j] > maxd) maxd = temp[i].displacement[j]; if(temp[i].LAI[j] > 0 && temp[i].displacement[j] <= 0) { sprintf(str,"Vegetation has leaves (LAI = %f), but no displacement (%f)", temp[i].LAI[j], temp[i].displacement[j]); nrerror(str); } } fscanf(veglib, "%lf", &temp[i].wind_h); if(temp[i].wind_h < maxd && temp[i].overstory) { sprintf(str,"Vegetation reference height (%f) for vegetation class %d, must be greater than the maximum displacement height (%f) when OVERSTORY has been set TRUE.", temp[i].wind_h,temp[i].veg_class,maxd); nrerror(str); } fscanf(veglib, "%f", &temp[i].RGL); /* minimum value of incoming solar radiation at which there will still be transpiration */ if(temp[i].RGL < 0) { sprintf(str,"Minimum value of incoming solar radiation at which there is transpiration (RGL) must be greater than 0 for vegetation class %d. Check that the vegetation library has the correct number of columns.", temp[i].veg_class); nrerror(str); } fscanf(veglib, "%lf", &temp[i].rad_atten); /* vegetation radiation attenuation factor */ if(temp[i].rad_atten < 0 || temp[i].rad_atten > 1) { sprintf(str,"The vegetation radiation attenuation factor must be greater than 0, and less than 1 for vegetation class %d. Check that the vegetation library has the correct number of columns.", temp[i].veg_class); nrerror(str); } fscanf(veglib, "%lf", &temp[i].wind_atten); /* canopy wind speed attenuation factor */ fscanf(veglib, "%lf", &temp[i].trunk_ratio); /* ratio of tree height that is trunk */ /* Carbon-cycling parameters */ if (options.VEGLIB_PHOTO) { fscanf(veglib, "%s", tmpstr); /* photosynthetic pathway */ if (!strcmp(tmpstr,"C3")) temp[i].Ctype = PHOTO_C3; else if (!strcmp(tmpstr,"C4")) temp[i].Ctype = PHOTO_C4; fscanf(veglib, "%lf", &temp[i].MaxCarboxRate); /* Maximum carboxylation rate at 25 deg C */ if (temp[i].Ctype == PHOTO_C3) { fscanf(veglib, "%lf", &temp[i].MaxETransport); /* Maximum electron transport rate at 25 deg C */ temp[i].CO2Specificity = 0; } else if (temp[i].Ctype == PHOTO_C4) { fscanf(veglib, "%lf", &temp[i].CO2Specificity); /* CO2 Specificity */ temp[i].MaxETransport = 0; } fscanf(veglib, "%lf", &temp[i].LightUseEff); /* Light-use efficiency */ fscanf(veglib, "%s", tmpstr); /* Nitrogen-scaling flag */ temp[i].NscaleFlag = atoi(tmpstr); /* Nitrogen-scaling flag */ fscanf(veglib, "%lf", &temp[i].Wnpp_inhib); /* Moisture level in top soil layer above which photosynthesis begins experiencing inhibition due to saturation */ fscanf(veglib, "%lf", &temp[i].NPPfactor_sat); /* photosynthesis multiplier when top soil layer is saturated */ } else { temp[i].Wnpp_inhib = 1.0; temp[i].NPPfactor_sat = 1.0; } /* Irrigation parameters */ if (options.VEGLIB_IRR) { for (j = 0; j < 12; j++) { fscanf(veglib, "%d", &temp[i].irr_active[j]); //fprintf(stderr,"class %d month %d irr_active %d\n",i,j,temp[i].irr_active[j]); if(temp[i].irr_active[j] != 0 && temp[i].irr_active[j] != 1) { sprintf(str,"Irrigation active flag must be either 0 or 1 (%d)", temp[i].irr_active[j]); nrerror(str); } } fscanf(veglib, "%s", tmpstr); /* irrigation soil moisture threshold */ if (!strcmp(tmpstr,"SAT")) temp[i].irr_sm_thresh = IRR_SAT; else if (!strcmp(tmpstr,"FC")) temp[i].irr_sm_thresh = IRR_FC; else if (!strcmp(tmpstr,"CR")) temp[i].irr_sm_thresh = IRR_CR; //else if (!strcmp(tmpstr,"GSM")) temp[i].irr_sm_thresh = IRR_GSM; //ingjerd commented out for now fscanf(veglib, "%s", tmpstr); /* irrigation soil moisture target */ if (!strcmp(tmpstr,"SAT")) temp[i].irr_sm_target = IRR_SAT; else if (!strcmp(tmpstr,"FC")) temp[i].irr_sm_target = IRR_FC; else if (!strcmp(tmpstr,"CR")) temp[i].irr_sm_target = IRR_CR; //else if (!strcmp(tmpstr,"GSM")) temp[i].irr_sm_target = IRR_GSM; //ingjerd commented out for now } else { // Initialize but don't use for (j = 0; j < 12; j++) { temp[i].irr_active[j] = 0; } temp[i].irr_sm_thresh = IRR_SAT; temp[i].irr_sm_target = IRR_SAT; } // Default crop fractions for (j = 0; j < 12; j++) { temp[i].crop_frac[j] = 1.0; } fgets(str, MAXSTRING, veglib); /* skip over end of line comments */ i++; } else fgets(str, MAXSTRING, veglib); fscanf(veglib, "%s", str); } if(i!=Nveg_type) { sprintf(ErrStr,"ERROR: Problem reading vegetation library file - make sure the file has the right number of columns.\n"); nrerror(ErrStr); } *Ntype = Nveg_type; for (i=0; i<N_PET_TYPES_NON_NAT; i++) { temp[Nveg_type+i].NVegLibTypes = Nveg_type; temp[Nveg_type+i].veg_class = Nveg_type+i+1; temp[Nveg_type+i].overstory = ref_veg_over[i]; temp[Nveg_type+i].rarc = ref_veg_rarc[i]; temp[Nveg_type+i].rmin = ref_veg_rmin[i]; for (j=0; j<12; j++) { temp[Nveg_type+i].LAI[j] = ref_veg_lai[i]; temp[Nveg_type+i].Wdmax[j] = LAI_WATER_FACTOR*ref_veg_lai[i]; temp[Nveg_type+i].albedo[j] = ref_veg_albedo[i]; temp[Nveg_type+i].roughness[j] = ref_veg_rough[i]; temp[Nveg_type+i].displacement[j] = ref_veg_displ[i]; temp[Nveg_type+i].vegcover[j] = ref_veg_vegcover[i]; temp[Nveg_type+i].crop_frac[j] = ref_veg_crop_frac[i]; } temp[Nveg_type+i].wind_h = ref_veg_wind_h[i]; temp[Nveg_type+i].RGL = ref_veg_RGL[i]; temp[Nveg_type+i].rad_atten = ref_veg_rad_atten[i]; temp[Nveg_type+i].wind_atten = ref_veg_wind_atten[i]; temp[Nveg_type+i].trunk_ratio = ref_veg_trunk_ratio[i]; } return temp; }
GLOBAL OPT_DTYPE opt_zbrent(optimize_struct *ostructp, OPT_DTYPE x1, OPT_DTYPE x2, OPT_DTYPE tol) { int iter; OPT_DTYPE a=x1,b=x2,c=x2,d,e,min1,min2; OPT_DTYPE fa=EVAL_AT(a),fb=EVAL_AT(b),fc,p,q,r,s,tol1,xm; if ((fa > 0.0 && fb > 0.0) || (fa < 0.0 && fb < 0.0)) nrerror("Root must be bracketed in zbrent"); fc=fb; for (iter=1;iter<=ITMAX;iter++) { if ((fb > 0.0 && fc > 0.0) || (fb < 0.0 && fc < 0.0)) { c=a; fc=fa; e=d=b-a; } if (fabs(fc) < fabs(fb)) { a=b; b=c; c=a; fa=fb; fb=fc; fc=fa; } tol1=2.0*EPS*fabs(b)+0.5*tol; xm=0.5*(c-b); if (fabs(xm) <= tol1 || fb == 0.0) return b; if (fabs(e) >= tol1 && fabs(fa) > fabs(fb)) { s=fb/fa; if (a == c) { p=2.0*xm*s; q=1.0-s; } else { q=fa/fc; r=fb/fc; p=s*(2.0*xm*q*(q-r)-(b-a)*(r-1.0)); q=(q-1.0)*(r-1.0)*(s-1.0); } if (p > 0.0) q = -q; p=fabs(p); min1=3.0*xm*q-fabs(tol1*q); min2=fabs(e*q); if (2.0*p < (min1 < min2 ? min1 : min2)) { e=d; d=p/q; } else { d=xm; e=d; } } else { d=xm; e=d; } a=b; fa=fb; if (fabs(d) > tol1) b += d; else b += SIGN(tol1,xm); fb=EVAL_AT(b); } nrerror("Maximum number of iterations exceeded in zbrent"); return 0.0; }
void bessik(float x, float xnu, float *ri, float *rk, float *rip, float *rkp) { void beschb(double x, double *gam1, double *gam2, double *gampl, double *gammi); void nrerror(char error_text[]); int i,l,nl; double a,a1,b,c,d,del,del1,delh,dels,e,f,fact,fact2,ff,gam1,gam2, gammi,gampl,h,p,pimu,q,q1,q2,qnew,ril,ril1,rimu,rip1,ripl, ritemp,rk1,rkmu,rkmup,rktemp,s,sum,sum1,x2,xi,xi2,xmu,xmu2; if (x <= 0.0 || xnu < 0.0) nrerror("bad arguments in bessik"); nl=(int)(xnu+0.5); xmu=xnu-nl; xmu2=xmu*xmu; xi=1.0/x; xi2=2.0*xi; h=xnu*xi; if (h < FPMIN) h=FPMIN; b=xi2*xnu; d=0.0; c=h; for (i=1;i<=MAXIT;i++) { b += xi2; d=1.0/(b+d); c=b+1.0/c; del=c*d; h=del*h; if (fabs(del-1.0) < EPS) break; } if (i > MAXIT) nrerror("x too large in bessik; try asymptotic expansion"); ril=FPMIN; ripl=h*ril; ril1=ril; rip1=ripl; fact=xnu*xi; for (l=nl;l>=1;l--) { ritemp=fact*ril+ripl; fact -= xi; ripl=fact*ritemp+ril; ril=ritemp; } f=ripl/ril; if (x < XMIN) { x2=0.5*x; pimu=PI*xmu; fact = (fabs(pimu) < EPS ? 1.0 : pimu/sin(pimu)); d = -log(x2); e=xmu*d; fact2 = (fabs(e) < EPS ? 1.0 : sinh(e)/e); beschb(xmu,&gam1,&gam2,&gampl,&gammi); ff=fact*(gam1*cosh(e)+gam2*fact2*d); sum=ff; e=exp(e); p=0.5*e/gampl; q=0.5/(e*gammi); c=1.0; d=x2*x2; sum1=p; for (i=1;i<=MAXIT;i++) { ff=(i*ff+p+q)/(i*i-xmu2); c *= (d/i); p /= (i-xmu); q /= (i+xmu); del=c*ff; sum += del; del1=c*(p-i*ff); sum1 += del1; if (fabs(del) < fabs(sum)*EPS) break; } if (i > MAXIT) nrerror("bessk series failed to converge"); rkmu=sum; rk1=sum1*xi2; } else { b=2.0*(1.0+x); d=1.0/b; h=delh=d; q1=0.0; q2=1.0; a1=0.25-xmu2; q=c=a1; a = -a1; s=1.0+q*delh; for (i=2;i<=MAXIT;i++) { a -= 2*(i-1); c = -a*c/i; qnew=(q1-b*q2)/a; q1=q2; q2=qnew; q += c*qnew; b += 2.0; d=1.0/(b+a*d); delh=(b*d-1.0)*delh; h += delh; dels=q*delh; s += dels; if (fabs(dels/s) < EPS) break; } if (i > MAXIT) nrerror("bessik: failure to converge in cf2"); h=a1*h; rkmu=sqrt(PI/(2.0*x))*exp(-x)/s; rk1=rkmu*(xmu+x+0.5-h)*xi; } rkmup=xmu*xi*rkmu-rk1; rimu=xi/(f*rkmu-rkmup); *ri=(rimu*ril1)/ril; *rip=(rimu*rip1)/ril; for (i=1;i<=nl;i++) { rktemp=(xmu+i)*xi2*rk1+rkmu; rkmu=rk1; rk1=rktemp; } *rk=rkmu; *rkp=xnu*xi*rkmu-rk1; }
/************************************************************** * Given an N x N matrix A, this routine replaces it by the LU * * decomposition of a rowwise permutation of itself. A and N * * are input. INDX is an output vector which records the row * * permutation effected by the partial pivoting; D is output * * as -1 or 1, depending on whether the number of row inter- * * changes was even or odd, respectively. This routine is used * * in combination with LUBKSB to solve linear equations or to * * invert a matrix. Return code is 1, if matrix is singular. * **************************************************************/ void ludcmp(double **a, int n, int *indx, double *d) { int i,imax,j,k; double big,dum,sum,temp; double *vv=vector(1,n); *d=1.0; for (i=1;i<=n;i++) { big=0.0; for (j=1;j<=n;j++) if ((temp=fabs(a[i][j])) > big) big=temp; if (big == 0.0) nrerror("allocation failure 1 in matrix()"); vv[i]=1.0/big; } for (j=1;j<=n;j++) { for (i=1;i<j;i++) { sum=a[i][j]; for (k=1;k<i;k++) sum -= a[i][k]*a[k][j]; a[i][j]=sum; } big=0.0; for (i=j;i<=n;i++) { sum=a[i][j]; for (k=1;k<j;k++) sum -= a[i][k]*a[k][j]; a[i][j]=sum; if ( (dum=vv[i]*fabs(sum)) >= big) { big=dum; imax=i; } } if (j != imax) { for (k=1;k<=n;k++) { dum=a[imax][k]; a[imax][k]=a[j][k]; a[j][k]=dum; } *d = -(*d); vv[imax]=vv[j]; } indx[j]=imax; if (a[j][j] == 0.0) a[j][j]=TINY; if (j != n) { dum=1.0/(a[j][j]); for (i=j+1;i<=n;i++) a[i][j] *= dum; } } free_vector(vv,1,n); }
/*--------------------------------------------------------------------------*/ int main(int argc, char *argv[]){ struct RNAalifold_args_info args_info; unsigned int input_type; char ffname[FILENAME_MAX_LENGTH], gfname[FILENAME_MAX_LENGTH], fname[FILENAME_MAX_LENGTH]; char *input_string, *string, *structure, *cstruc, *ParamFile, *ns_bases, *c; int n_seq, i, length, sym, r, noPS, with_sci; int endgaps, mis, circular, doAlnPS, doColor, doMEA, n_back, eval_energy, pf, istty; double min_en, real_en, sfact, MEAgamma, bppmThreshold, betaScale; char *AS[MAX_NUM_NAMES]; /* aligned sequences */ char *names[MAX_NUM_NAMES]; /* sequence names */ FILE *clust_file = stdin; pf_paramT *pf_parameters; model_detailsT md; fname[0] = ffname[0] = gfname[0] = '\0'; string = structure = cstruc = ParamFile = ns_bases = NULL; pf_parameters = NULL; endgaps = mis = pf = circular = doAlnPS = doColor = n_back = eval_energy = oldAliEn = doMEA = ribo = noPS = 0; do_backtrack = 1; dangles = 2; gquad = 0; sfact = 1.07; bppmThreshold = 1e-6; MEAgamma = 1.0; betaScale = 1.; with_sci = 0; set_model_details(&md); /* ############################################# # check the command line prameters ############################################# */ if(RNAalifold_cmdline_parser (argc, argv, &args_info) != 0) exit(1); /* temperature */ if(args_info.temp_given) temperature = args_info.temp_arg; /* structure constraint */ if(args_info.constraint_given) fold_constrained=1; /* do not take special tetra loop energies into account */ if(args_info.noTetra_given) md.special_hp = tetra_loop=0; /* set dangle model */ if(args_info.dangles_given){ if((args_info.dangles_arg != 0) && (args_info.dangles_arg != 2)) warn_user("required dangle model not implemented, falling back to default dangles=2"); else md.dangles = dangles=args_info.dangles_arg; } /* do not allow weak pairs */ if(args_info.noLP_given) md.noLP = noLonelyPairs = 1; /* do not allow wobble pairs (GU) */ if(args_info.noGU_given) md.noGU = noGU = 1; /* do not allow weak closing pairs (AU,GU) */ if(args_info.noClosingGU_given) md.noGUclosure = no_closingGU = 1; /* gquadruplex support */ if(args_info.gquad_given) md.gquad = gquad = 1; /* sci computation */ if(args_info.sci_given) with_sci = 1; /* do not convert DNA nucleotide "T" to appropriate RNA "U" */ /* set energy model */ if(args_info.energyModel_given) energy_set = args_info.energyModel_arg; /* take another energy parameter set */ if(args_info.paramFile_given) ParamFile = strdup(args_info.paramFile_arg); /* Allow other pairs in addition to the usual AU,GC,and GU pairs */ if(args_info.nsp_given) ns_bases = strdup(args_info.nsp_arg); /* set pf scaling factor */ if(args_info.pfScale_given) sfact = args_info.pfScale_arg; /* assume RNA sequence to be circular */ if(args_info.circ_given) circular=1; /* do not produce postscript output */ if(args_info.noPS_given) noPS = 1; /* partition function settings */ if(args_info.partfunc_given){ pf = 1; if(args_info.partfunc_arg != -1) do_backtrack = args_info.partfunc_arg; } /* MEA (maximum expected accuracy) settings */ if(args_info.MEA_given){ pf = doMEA = 1; if(args_info.MEA_arg != -1) MEAgamma = args_info.MEA_arg; } if(args_info.betaScale_given) betaScale = args_info.betaScale_arg; /* set the bppm threshold for the dotplot */ if(args_info.bppmThreshold_given) bppmThreshold = MIN2(1., MAX2(0.,args_info.bppmThreshold_arg)); /* set cfactor */ if(args_info.cfactor_given) cv_fact = args_info.cfactor_arg; /* set nfactor */ if(args_info.nfactor_given) nc_fact = args_info.nfactor_arg; if(args_info.endgaps_given) endgaps = 1; if(args_info.mis_given) mis = 1; if(args_info.color_given) doColor=1; if(args_info.aln_given) doAlnPS=1; if(args_info.old_given) oldAliEn = 1; if(args_info.stochBT_given){ n_back = args_info.stochBT_arg; do_backtrack = 0; pf = 1; init_rand(); } if(args_info.stochBT_en_given){ n_back = args_info.stochBT_en_arg; do_backtrack = 0; pf = 1; eval_energy = 1; init_rand(); } if(args_info.ribosum_file_given){ RibosumFile = strdup(args_info.ribosum_file_arg); ribo = 1; } if(args_info.ribosum_scoring_given){ RibosumFile = NULL; ribo = 1; } if(args_info.layout_type_given) rna_plot_type = args_info.layout_type_arg; /* alignment file name given as unnamed option? */ if(args_info.inputs_num == 1){ clust_file = fopen(args_info.inputs[0], "r"); if (clust_file == NULL) { fprintf(stderr, "can't open %s\n", args_info.inputs[0]); } } /* free allocated memory of command line data structure */ RNAalifold_cmdline_parser_free (&args_info); /* ############################################# # begin initializing ############################################# */ if(circular && gquad){ nrerror("G-Quadruplex support is currently not available for circular RNA structures"); } make_pair_matrix(); if (circular && noLonelyPairs) warn_user("depending on the origin of the circular sequence, " "some structures may be missed when using --noLP\n" "Try rotating your sequence a few times\n"); if (ParamFile != NULL) read_parameter_file(ParamFile); if (ns_bases != NULL) { nonstandards = space(33); c=ns_bases; i=sym=0; if (*c=='-') { sym=1; c++; } while (*c!='\0') { if (*c!=',') { nonstandards[i++]=*c++; nonstandards[i++]=*c; if ((sym)&&(*c!=*(c-1))) { nonstandards[i++]=*c; nonstandards[i++]=*(c-1); } } c++; } } istty = isatty(fileno(stdout))&&isatty(fileno(stdin)); /* ######################################################## # handle user input from 'stdin' if necessary ######################################################## */ if(fold_constrained){ if(istty){ print_tty_constraint_full(); print_tty_input_seq_str(""); } input_type = get_input_line(&input_string, VRNA_INPUT_NOSKIP_COMMENTS); if(input_type & VRNA_INPUT_QUIT){ return 0;} else if((input_type & VRNA_INPUT_MISC) && (strlen(input_string) > 0)){ cstruc = strdup(input_string); free(input_string); } else warn_user("constraints missing"); } if (istty && (clust_file == stdin)) print_tty_input_seq_str("Input aligned sequences in clustalw or stockholm format\n(enter a line starting with \"//\" to indicate the end of your input)"); n_seq = read_clustal(clust_file, AS, names); if (n_seq==0) nrerror("no sequences found"); if (clust_file != stdin) fclose(clust_file); /* ######################################################## # done with 'stdin' handling, now init everything properly ######################################################## */ length = (int) strlen(AS[0]); structure = (char *)space((unsigned) length+1); if(fold_constrained && cstruc != NULL) strncpy(structure, cstruc, length); if (endgaps) for (i=0; i<n_seq; i++) mark_endgaps(AS[i], '~'); /* ######################################################## # begin actual calculations ######################################################## */ if (circular) { int i; double s = 0; min_en = circalifold((const char **)AS, structure); for (i=0; AS[i]!=NULL; i++) s += energy_of_circ_structure(AS[i], structure, -1); real_en = s/i; } else { float *ens = (float *)space(2*sizeof(float)); min_en = alifold((const char **)AS, structure); if(md.gquad) energy_of_ali_gquad_structure((const char **)AS, structure, n_seq, ens); else energy_of_alistruct((const char **)AS, structure, n_seq, ens); real_en = ens[0]; free(ens); } string = (mis) ? consens_mis((const char **) AS) : consensus((const char **) AS); printf("%s\n%s", string, structure); if(istty){ if(with_sci){ float sci = min_en; float e_mean = 0; for (i=0; AS[i]!=NULL; i++){ char *seq = get_ungapped_sequence(AS[i]); char *str = (char *)space(sizeof(char) * (strlen(seq) + 1)); e_mean += fold(seq, str); free(seq); free(str); } e_mean /= i; sci /= e_mean; printf( "\n minimum free energy = %6.2f kcal/mol (%6.2f + %6.2f)" "\n SCI = %2.4f\n", min_en, real_en, min_en-real_en, sci); } else printf("\n minimum free energy = %6.2f kcal/mol (%6.2f + %6.2f)\n", min_en, real_en, min_en - real_en); } else { if(with_sci){ float sci = min_en; float e_mean = 0; for (i=0; AS[i]!=NULL; i++){ char *seq = get_ungapped_sequence(AS[i]); char *str = (char *)space(sizeof(char) * (strlen(seq) + 1)); e_mean += fold(seq, str); free(seq); free(str); } e_mean /= i; sci /= e_mean; printf(" (%6.2f = %6.2f + %6.2f) [%2.4f]\n", min_en, real_en, min_en-real_en, sci); } else printf(" (%6.2f = %6.2f + %6.2f) \n", min_en, real_en, min_en-real_en ); } strcpy(ffname, "alirna.ps"); strcpy(gfname, "alirna.g"); if (!noPS) { char **A; A = annote(structure, (const char**) AS); if(md.gquad){ if (doColor) (void) PS_rna_plot_a_gquad(string, structure, ffname, A[0], A[1]); else (void) PS_rna_plot_a_gquad(string, structure, ffname, NULL, A[1]); } else { if (doColor) (void) PS_rna_plot_a(string, structure, ffname, A[0], A[1]); else (void) PS_rna_plot_a(string, structure, ffname, NULL, A[1]); } free(A[0]); free(A[1]); free(A); } if (doAlnPS) PS_color_aln(structure, "aln.ps", (const char const **) AS, (const char const **) names); /* free mfe arrays */ free_alifold_arrays(); if (pf) { float energy, kT; char * mfe_struc; mfe_struc = strdup(structure); kT = (betaScale*((temperature+K0)*GASCONST))/1000.; /* in Kcal */ pf_scale = exp(-(sfact*min_en)/kT/length); if (length>2000) fprintf(stderr, "scaling factor %f\n", pf_scale); fflush(stdout); if (cstruc!=NULL) strncpy(structure, cstruc, length+1); pf_parameters = get_boltzmann_factors_ali(n_seq, temperature, betaScale, md, pf_scale); energy = alipf_fold_par((const char **)AS, structure, NULL, pf_parameters, do_backtrack, fold_constrained, circular); if (n_back>0) { /*stochastic sampling*/ for (i=0; i<n_back; i++) { char *s; double prob=1.; s = alipbacktrack(&prob); printf("%s ", s); if (eval_energy ) printf("%6g %.2f ",prob, -1*(kT*log(prob)-energy)); printf("\n"); free(s); } } if (do_backtrack) { printf("%s", structure); if (!istty) printf(" [%6.2f]\n", energy); else printf("\n"); } if ((istty)||(!do_backtrack)) printf(" free energy of ensemble = %6.2f kcal/mol\n", energy); printf(" frequency of mfe structure in ensemble %g\n", exp((energy-min_en)/kT)); if (do_backtrack) { FILE *aliout; cpair *cp; char *cent; double dist; FLT_OR_DBL *probs = export_ali_bppm(); plist *pl, *mfel; assign_plist_from_pr(&pl, probs, length, bppmThreshold); assign_plist_from_db(&mfel, mfe_struc, 0.95*0.95); if (!circular){ float *ens; cent = get_centroid_struct_pr(length, &dist, probs); ens=(float *)space(2*sizeof(float)); energy_of_alistruct((const char **)AS, cent, n_seq, ens); /*cent_en = energy_of_struct(string, cent);*/ /*ali*/ printf("%s %6.2f {%6.2f + %6.2f}\n",cent,ens[0]-ens[1],ens[0],(-1)*ens[1]); free(cent); free(ens); } if(doMEA){ float mea, *ens; plist *pl2; assign_plist_from_pr(&pl2, probs, length, 1e-4/(1+MEAgamma)); mea = MEA(pl2, structure, MEAgamma); ens = (float *)space(2*sizeof(float)); if(circular) energy_of_alistruct((const char **)AS, structure, n_seq, ens); else ens[0] = energy_of_structure(string, structure, 0); printf("%s {%6.2f MEA=%.2f}\n", structure, ens[0], mea); free(ens); free(pl2); } if (fname[0]!='\0') { strcpy(ffname, fname); strcat(ffname, "_ali.out"); } else strcpy(ffname, "alifold.out"); aliout = fopen(ffname, "w"); if (!aliout) { fprintf(stderr, "can't open %s skipping output\n", ffname); } else { print_aliout(AS, pl, bppmThreshold, n_seq, mfe_struc, aliout); } fclose(aliout); if (fname[0]!='\0') { strcpy(ffname, fname); strcat(ffname, "_dp.ps"); } else strcpy(ffname, "alidot.ps"); cp = make_color_pinfo(AS,pl, bppmThreshold, n_seq, mfel); (void) PS_color_dot_plot(string, cp, ffname); free(cp); free(pl); free(mfel); } free(mfe_struc); free_alipf_arrays(); free(pf_parameters); } if (cstruc!=NULL) free(cstruc); (void) fflush(stdout); free(string); free(structure); for (i=0; AS[i]; i++) { free(AS[i]); free(names[i]); } return 0; }
void initialize_model_state(dist_prcp_struct *prcp, dmy_struct dmy, global_param_struct *global_param, filep_struct filep, int cellnum, int Nveg, int Nnodes, int Ndist, double surf_temp, soil_con_struct *soil_con, veg_con_struct *veg_con, char *init_STILL_STORM, int *init_DRY_TIME, save_data_struct *save_data) /********************************************************************** initialize_model_state Keith Cherkauer April 17, 2000 This routine initializes the model state (energy balance, water balance, and snow components). If a state file is provided to the model than its contents are checked to see if it agrees with the current simulation set-up, if so it is used to initialize the model state. If no state file is provided the model initializes all variables with defaults and the user should expect to throw out the beginning of the simulation period as model start-up. UNITS: (m, s, kg, C, moisture in mm) unless otherwise specified Modifications: 4-17-00 Modified from initialize_energy_bal.c and initialize_snow.c to provide a single controlling routine for initializing the model state. 2-10-03 Fixed looping problem with initialization of soil moisture. KAC 3-12-03 Modified so that soil layer ice content is only calculated when frozen soil is implemented and active in the current grid cell. KAC 04-10-03 Modified to read storm parameters from model state file. KAC 07-May-04 Initialize soil_con->dz_node[Nnodes] to 0.0, since it is accessed in set_node_parameters(). TJB 2006-Sep-14 Implemented ALMA-compliant input and output; uses the new save_data structure to track changes in moisture storage over each time step; this needs initialization here. TJB 2006-Oct-25 Inserted "if (veg < Nveg)" before the line updating save_data->wdew, since Wdew is undefined for veg == Nveg. TJB 2006-Oct-26 Merged infiles and outfiles structs into filep_struct; This included removing the unused init_snow file. TJB 2006-Nov-15 Changed initial state reading from statefile to init_state GCT **********************************************************************/ { extern option_struct options; extern veg_lib_struct *veg_lib; #if LINK_DEBUG extern debug_struct debug; #endif #if QUICK_FS extern double temps[]; #endif char tmpstr[MAXSTRING]; char ErrStr[MAXSTRING]; char FIRST_VEG; int i, j, ii, veg, index, dist; int nidx, lidx; int tmpint; int dry; int band; int zindex; double sum, Lsum, Zsum, dp, Ltotal; double tmpdp, tmpadj; double *kappa, *Cs, *M; double moist[MAX_VEG][MAX_BANDS][MAX_LAYERS]; double ice[MAX_VEG][MAX_BANDS][MAX_LAYERS]; double unfrozen, frozen; double **layer_ice; double **layer_tmp; double *EMPTY; #if QUICK_FS double Aufwc, Bufwc; #endif char *EMPTY_C; double Cv; double mu; double TreeAdjustFactor[MAX_BANDS]; cell_data_struct ***cell; snow_data_struct **snow; energy_bal_struct **energy; veg_var_struct ***veg_var; cell = prcp->cell; veg_var = prcp->veg_var; snow = prcp->snow; energy = prcp->energy; dp = soil_con->dp; Ltotal = 0; for(index=0;index<options.Nlayer;index++) Ltotal += soil_con->depth[index]; FIRST_VEG = TRUE; // initialize storm parameters to start a new simulation (*init_DRY_TIME) = -999; /******************************************** Initialize all snow pack variables - some may be reset if state file present ********************************************/ initialize_snow(snow, Nveg, cellnum); /******************************************** Initialize all soil layer variables - some may be reset if state file present ********************************************/ initialize_soil(cell[WET], soil_con, Nveg); /******************************************** Initialize all vegetation variables - some may be reset if state file present ********************************************/ initialize_veg(veg_var[WET], veg_con, global_param); #if QUICK_FS if(options.FROZEN_SOIL) { /*********************************************************** Prepare table of maximum unfrozen water content values - This linearizes the equation for maximum unfrozen water content, reducing computation time for the frozen soil model. ***********************************************************/ for(lidx=0;lidx<options.Nlayer;lidx++) { for(ii=0;ii<QUICK_FS_TEMPS;ii++) { Aufwc = maximum_unfrozen_water(temps[ii], 1.0, soil_con->bubble[lidx], soil_con->expt[lidx]); Bufwc = maximum_unfrozen_water(temps[ii+1], 1.0, soil_con->bubble[lidx], soil_con->expt[lidx]); soil_con->ufwc_table_layer[lidx][ii][0] = linear_interp(0., temps[ii], temps[ii+1], Aufwc, Bufwc); soil_con->ufwc_table_layer[lidx][ii][1] = (Bufwc - Aufwc) / (temps[ii+1] - temps[ii]); } } } #endif /************************************************************************ CASE 1: Not using quick ground heat flux, and initial conditions files provided ************************************************************************/ if(options.INIT_STATE) { read_initial_model_state(filep.init_state, prcp, global_param, Nveg, options.SNOW_BAND, cellnum, soil_con, Ndist, init_STILL_STORM, init_DRY_TIME); for( veg = 0; veg <= Nveg; veg++ ) for( band = 0; band < options.SNOW_BAND; band++ ) for( lidx = 0; lidx < options.Nlayer; lidx++ ) { moist[veg][band][lidx] = cell[0][veg][band].layer[lidx].moist; ice[veg][band][lidx] = cell[0][veg][band].layer[lidx].ice; } } /************************************************************************ CASE 2: Initialize soil if using quick heat flux, and no initial soil properties file given ************************************************************************/ else if(options.QUICK_FLUX) { for ( veg = 0 ; veg <= Nveg ; veg++) { for ( band = 0; band < options.SNOW_BAND; band++ ) { /* Initialize soil node temperatures and thicknesses */ soil_con->dz_node[0] = soil_con->depth[0]; soil_con->dz_node[1] = soil_con->depth[0]; soil_con->dz_node[2] = 2. * (dp - 1.5 * soil_con->depth[0]); energy[veg][band].T[0] = surf_temp; energy[veg][band].T[1] = surf_temp; energy[veg][band].T[2] = soil_con->avg_temp; for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { moist[veg][band][lidx] = soil_con->init_moist[lidx]; ice[veg][band][lidx] = 0.; } } } } /***************************************************************** CASE 3: Initialize Energy Balance Variables if not using quick ground heat flux, and no Initial Condition File Given *****************************************************************/ else if(!options.QUICK_FLUX) { for ( veg = 0 ; veg <= Nveg ; veg++) { for ( band = 0; band < options.SNOW_BAND; band++ ) { /* Initialize soil node temperatures and thicknesses Nodes set at surface, the depth of the first layer, twice the depth of the first layer, and at the damping depth. Extra nodes are placed equal distance between the damping depth and twice the depth of the first layer. */ energy[veg][band].T[0] = surf_temp; soil_con->dz_node[0] = soil_con->depth[0]; soil_con->dz_node[1] = soil_con->depth[0]; soil_con->dz_node[2] = soil_con->depth[0]; energy[veg][band].T[Nnodes-1] = soil_con->avg_temp; energy[veg][band].T[1] = exp_interp(soil_con->depth[0], 0., dp, surf_temp, soil_con->avg_temp); energy[veg][band].T[2] = exp_interp(2. * soil_con->depth[0], 0., dp, surf_temp, soil_con->avg_temp); Zsum = 2. * soil_con[0].depth[0]; tmpdp = dp - soil_con[0].depth[0] * 2.5; tmpadj = 3.5; for(index=3;index<Nnodes-1;index++) { if(veg==0 && band==0) soil_con->dz_node[index] = tmpdp/(((double)Nnodes-tmpadj)); Zsum += (soil_con->dz_node[index] +soil_con->dz_node[index-1])/2.; energy[veg][band].T[index] = exp_interp(Zsum,0.,soil_con[0].dp, surf_temp, soil_con[0].avg_temp); } if(veg==0 && band==0) { soil_con->dz_node[Nnodes-1] = (dp - Zsum - soil_con->dz_node[Nnodes-2] / 2. ) * 2.; Zsum += (soil_con->dz_node[Nnodes-2] +soil_con->dz_node[Nnodes-1])/2.; if((int)(Zsum*1000+0.5) != (int)(dp*1000+0.5)) { sprintf(ErrStr,"Sum of thermal node thicknesses (%f) in initialize_model_state do not equal dp (%f), check initialization procedure",Zsum,dp); nrerror(ErrStr); } } for ( lidx = 0; lidx < options.Nlayer; lidx++ ) { moist[veg][band][lidx] = soil_con->init_moist[lidx]; ice[veg][band][lidx] = 0.; } } } } /********************************* CASE 4: Unknown option *********************************/ else { for ( veg = 0 ; veg <= Nveg ; veg++) { for ( band = 0; band < options.SNOW_BAND; band++ ) { for ( index = 0; index < options.Nlayer; index++ ) { soil_con->dz_node[index] = 1.; } } } } /****************************************** Initialize soil thermal node properties ******************************************/ /* dz_node[Nnodes] is accessed later despite not being set. This can cause run-time errors on some platforms. Therefore, set it to zero */ soil_con->dz_node[Nnodes]=0.0; if ( options.GRND_FLUX ) { for ( veg = 0 ; veg <= Nveg ; veg++) { for( band = 0; band < options.SNOW_BAND; band++ ) { /** Set soil properties for all soil nodes **/ if(FIRST_VEG) { FIRST_VEG = FALSE; set_node_parameters(soil_con->dz_node, soil_con->max_moist_node, soil_con->expt_node, soil_con->bubble_node, soil_con->alpha, soil_con->beta, soil_con->gamma, soil_con->depth, soil_con->max_moist, soil_con->expt, soil_con->bubble, soil_con->quartz, soil_con->layer_node_fract, #if QUICK_FS soil_con->ufwc_table_node, #endif Nnodes, options.Nlayer, soil_con->FS_ACTIVE); sum = soil_con->dz_node[0]/2. + soil_con->dz_node[Nnodes-1]/2.; for(nidx=1;nidx<Nnodes-1;nidx++) sum += soil_con->dz_node[nidx]; } /* set soil moisture properties for all soil thermal nodes */ distribute_node_moisture_properties(energy[veg][band].moist, energy[veg][band].ice, energy[veg][band].kappa_node, energy[veg][band].Cs_node, soil_con->dz_node, energy[veg][band].T, soil_con->max_moist_node, #if QUICK_FS soil_con->ufwc_table_node, #else soil_con->expt_node, soil_con->bubble_node, #endif moist[veg][band], soil_con->depth, soil_con->soil_density, soil_con->bulk_density, soil_con->quartz, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); /* initialize layer moistures and ice contents */ for(dry = 0; dry < Ndist; dry++) { for(lidx=0;lidx<options.Nlayer;lidx++) { cell[dry][veg][band].layer[lidx].moist = moist[veg][band][lidx]; cell[dry][veg][band].layer[lidx].ice = ice[veg][band][lidx]; } if(soil_con->FS_ACTIVE && options.FROZEN_SOIL) estimate_layer_ice_content(cell[dry][veg][band].layer, soil_con->dz_node, energy[veg][band].T, soil_con->max_moist_node, #if QUICK_FS soil_con->ufwc_table_node, #else soil_con->expt_node, soil_con->bubble_node, #endif soil_con->depth, soil_con->max_moist, #if QUICK_FS soil_con->ufwc_table_layer, #else soil_con->expt, soil_con->bubble, #endif soil_con->bulk_density, soil_con->soil_density, soil_con->quartz, soil_con->layer_node_fract, Nnodes, options.Nlayer, soil_con->FS_ACTIVE); } /* Find freezing and thawing front depths */ if(!options.QUICK_FLUX && soil_con->FS_ACTIVE) find_0_degree_fronts(&energy[veg][band], soil_con->dz_node, energy[veg][band].T, Nnodes); } } } // Compute treeline adjustment factors for ( band = 0; band < options.SNOW_BAND; band++ ) { if ( soil_con->AboveTreeLine[band] ) { Cv = 0; for ( veg = 0 ; veg < veg_con[0].vegetat_type_num ; veg++ ) { if ( veg_lib[veg_con[veg].veg_class].overstory ) Cv += veg_con[veg].Cv; } TreeAdjustFactor[band] = 1. / ( 1. - Cv ); } else TreeAdjustFactor[band] = 1.; } // Save initial moisture storages for differencing at end of time step save_data->total_soil_moist = 0; save_data->swe = 0; save_data->wdew = 0; for( veg = 0; veg <= Nveg; veg++ ) { if ( veg < veg_con[0].vegetat_type_num ) Cv = veg_con[veg].Cv; else Cv = (1.0 - veg_con[0].Cv_sum); if ( Cv > 0 ) { for ( dist = 0; dist < Ndist; dist++ ) { if(dist==0) mu = prcp[0].mu[veg]; else mu = 1. - prcp[0].mu[veg]; for( band = 0; band < options.SNOW_BAND; band++ ) { if (soil_con->AreaFract[band] > 0. && ( veg == veg_con[0].vegetat_type_num || ( !soil_con->AboveTreeLine[band] || (soil_con->AboveTreeLine[band] && !veg_lib[veg_con[veg].veg_class].overstory)))) { for(lidx=0;lidx<options.Nlayer;lidx++) { save_data->total_soil_moist += (cell[dist][veg][band].layer[lidx].moist) // layer[].moist appears to contain both liquid and ice * Cv * mu * soil_con->AreaFract[band] * TreeAdjustFactor[band]; } if (veg < Nveg) save_data->wdew += veg_var[dist][veg][band].Wdew * Cv * mu * soil_con->AreaFract[band] * TreeAdjustFactor[band]; } } } for( band = 0; band < options.SNOW_BAND; band++ ) { save_data->swe += snow[veg][band].swq * Cv * soil_con->AreaFract[band] * TreeAdjustFactor[band]; } } } }
void indexx(unsigned long n, double arr[], unsigned long indx[]) { unsigned long i,indxt,ir=n,itemp,j,k,l=1; int jstack=0,*istack; double a; istack=ivector(1,NSTACK); for (j=1;j<=n;j++) indx[j]=j; for (;;) { if (ir-l < M) { for (j=l+1;j<=ir;j++) { indxt=indx[j]; a=arr[indxt]; for (i=j-1;i>=1;i--) { if (arr[indx[i]] <= a) break; indx[i+1]=indx[i]; } indx[i+1]=indxt; } if (jstack == 0) break; ir=istack[jstack--]; l=istack[jstack--]; } else { k=(l+ir) >> 1; SWAP(indx[k],indx[l+1],itemp); if (arr[indx[l+1]] > arr[indx[ir]]) { SWAP(indx[l+1],indx[ir],itemp) } if (arr[indx[l]] > arr[indx[ir]]) { SWAP(indx[l],indx[ir],itemp) } if (arr[indx[l+1]] > arr[indx[l]]) { SWAP(indx[l+1],indx[l],itemp) } i=l+1; j=ir; indxt=indx[l]; a=arr[indxt]; for (;;) { do i++; while (arr[indx[i]] < a); do j--; while (arr[indx[j]] > a); if (j < i) break; SWAP(indx[i],indx[j],itemp) } indx[l]=indx[j]; indx[j]=indxt; jstack += 2; if (jstack > NSTACK) nrerror("NSTACK too small in indexx."); if (ir-i+1 >= j-l) { istack[jstack]=ir; istack[jstack-1]=i; ir=j-1; } else { istack[jstack]=j-1; istack[jstack-1]=l; l=i; } } } free_ivector(istack,1,NSTACK); }
veg_con_struct *read_vegparam(FILE *vegparam, int gridcel, int Nveg_type) /********************************************************************** read_vegparam.c Keith Cherkauer and Dag Lohmann 1997 This routine reads in vegetation parameters for the current grid cell. It also relates each vegetation class in the cell to the appropriate parameters in the vegetation library. Modifications: 09-24-98 Modified to read root zone distribution information so that soil layer root fractions can be computed for new soil layer depths - see calc_root_fractions.c KAC 07-15-99 Modified to read LAI values from a new line in the vegetation parameter file. Added specifically to work with the new global LAI files. 11-18-02 Added code to read in blowing snow parameters. LCB 03-27-03 Modified code to update Wdmax based on LAI values read in for the current grid cell. If LAI is not obtained from this function, then the values cacluated in read_veglib.c are left unchanged. DP & KAC 2006-Nov-07 Allocates MaxVeg+1 veg tiles. TJB 2007-May-11 Changed some 'fscanf' statements to 'fgets' and 'sscanf' to count rootzone and BLOWING fields. Also tests for fetch < 1. GCT 2007-Oct-31 Added missing brackets in if(options.GLOBAL_LAI) block. TJB 2008-Oct-23 Added blocks to free vegarr[]. LCB via TJB 2009-Jan-16 Added logic for COMPUTE_TREELINE option. TJB 2009-Jun-09 Modified to use extension of veg_lib structure to contain bare soil information. TJB 2009-Jun-17 Modified to understand both tabs and spaces as delimiters.TJB 2009-Jun-17 Fixed incorrect placement of free vegarr[] for case of GLOBAL_LAI==FALSE. TJB 2009-Jul-26 Allocate extra veg tile for COMPUTE_TREELINE case. TJB 2009-Jul-31 Removed extra veg tile for lake/wetland case. TJB 2009-Sep-14 Made error messages clearer. TJB 2009-Oct-01 Added error message for case of LAI==0 and overstory==1. TJB 2010-Apr-28 Replaced GLOBAL_LAI with VEGPARAM_LAI and LAI_SRC. TJB 2012-Jan-16 Removed LINK_DEBUG code BN 2013-Jul-25 Added photosynthesis parameters. TJB 2013-Dec-28 Removed NO_REWIND option. TJB 2014-Apr-25 Added optional albedo values; added VEGPARAM_ALB and ALB_SRC. TJB 2014-Apr-25 Added optional vegcover values; added VEGPARAM_VEGCOVER and VEGCOVER_SRC. TJB **********************************************************************/ { void ttrim( char *string ); extern veg_lib_struct *veg_lib; extern option_struct options; veg_con_struct *temp; int vegcel, i, j, k, vegetat_type_num, skip, veg_class; int MaxVeg; int Nfields, NfieldsMax; int NoOverstory; float depth_sum; float sum; char str[500]; char ErrStr[MAXSTRING]; char line[MAXSTRING]; char tmpline[MAXSTRING]; const char delimiters[] = " \t"; char *token; char *vegarr[500]; size_t length; int cidx; double tmp; skip = 1; if(options.VEGPARAM_LAI) skip++; if(options.VEGPARAM_VEGCOVER) skip++; if(options.VEGPARAM_ALB) skip++; NoOverstory = 0; while ( ( fscanf(vegparam, "%d %d", &vegcel, &vegetat_type_num) == 2 ) && vegcel != gridcel ){ if (vegetat_type_num < 0) { sprintf(ErrStr,"ERROR number of vegetation tiles (%i) given for cell %i is < 0.\n",vegetat_type_num,vegcel); nrerror(ErrStr); } for (i = 0; i <= vegetat_type_num * skip; i++){ if ( fgets(str, 500, vegparam) == NULL ){ sprintf(ErrStr,"ERROR unexpected EOF for cell %i while reading root zones and LAI\n",vegcel); nrerror(ErrStr); } } } fgets(str, 500, vegparam); // read newline at end of veg class line to advance to next line if (vegcel != gridcel) { fprintf(stderr, "Error in vegetation file. Grid cell %d not found\n", gridcel); exit(99); } if(vegetat_type_num >= MAX_VEG) { sprintf(ErrStr,"Vegetation parameter file wants more vegetation tiles in grid cell %i (%i) than are allowed by MAX_VEG (%i) [NOTE: bare soil class is assumed]. Edit vicNl_def.h and recompile.",gridcel,vegetat_type_num+1,MAX_VEG); nrerror(ErrStr); } // Make sure to allocate extra memory for bare soil tile // and optionally an above-treeline veg tile MaxVeg = vegetat_type_num+1; if ( options.AboveTreelineVeg >= 0 ) MaxVeg++; /** Allocate memory for vegetation grid cell parameters **/ temp = (veg_con_struct*) calloc( MaxVeg, sizeof(veg_con_struct)); temp[0].Cv_sum = 0.0; for (i = 0; i < vegetat_type_num; i++) { temp[i].zone_depth = calloc(options.ROOT_ZONES,sizeof(float)); temp[i].zone_fract = calloc(options.ROOT_ZONES,sizeof(float)); temp[i].vegetat_type_num = vegetat_type_num; /* Upper boundaries of canopy layers, expressed in terms of fraction of total LAI */ if (options.CARBON) { temp[i].CanopLayerBnd = calloc(options.Ncanopy,sizeof(double)); for (cidx=0; cidx<options.Ncanopy; cidx++) { /* apportion LAI equally among layers */ temp[i].CanopLayerBnd[cidx] = (double)((cidx+1))/(double)(options.Ncanopy); } } // Read the root zones line if ( fgets( line, MAXSTRING, vegparam ) == NULL ){ sprintf(ErrStr,"ERROR unexpected EOF for cell %i while reading vegetat_type_num %d\n",vegcel,vegetat_type_num); nrerror(ErrStr); } strcpy(tmpline, line); ttrim( tmpline ); token = strtok (tmpline, delimiters); /* token => veg_class, move 'line' pointer to next field */ Nfields = 0; vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(vegarr[Nfields],token); Nfields++; token = strtok (NULL, delimiters); while (token != NULL && (length=strlen(token))==0) token = strtok (NULL, delimiters); while ( token != NULL ) { vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(vegarr[Nfields],token); Nfields++; token = strtok (NULL, delimiters); while (token != NULL && (length=strlen(token))==0) token = strtok (NULL, delimiters); } NfieldsMax = 2 + 2 * options.ROOT_ZONES; /* Number of expected fields this line */ if( options.BLOWING ){ NfieldsMax += 3; } if ( Nfields != NfieldsMax ) { sprintf(ErrStr,"ERROR - cell %d - expecting %d fields but found %d in veg line %s\n",gridcel,NfieldsMax, Nfields, line); nrerror(ErrStr); } temp[i].LAKE = 0; temp[i].veg_class = atoi( vegarr[0] ); temp[i].Cv = atof( vegarr[1] ); depth_sum = 0; sum = 0.; for(j=0;j<options.ROOT_ZONES;j++) { temp[i].zone_depth[j] = atof( vegarr[2 + j*2] ); temp[i].zone_fract[j] = atof( vegarr[3 + j*2] ); depth_sum += temp[i].zone_depth[j]; sum += temp[i].zone_fract[j]; } if(depth_sum <= 0) { sprintf(str,"Root zone depths must sum to a value greater than 0."); nrerror(str); } if(sum != 1.) { fprintf(stderr,"WARNING: Root zone fractions sum to more than 1 ( = %f), normalizing fractions. If the sum is large, check that your vegetation parameter file is in the form - <zone 1 depth> <zone 1 fract> <zone 2 depth> <zone 2 fract> ...\n", sum); for(j=0;j<options.ROOT_ZONES;j++) { temp[i].zone_fract[j] /= sum; } } if(options.BLOWING) { j = 2 * options.ROOT_ZONES; temp[i].sigma_slope = atof( vegarr[2 + j] ); temp[i].lag_one = atof( vegarr[3 + j] ); temp[i].fetch = atof( vegarr[4 + j]) ; if( temp[i].sigma_slope <= 0. || temp[i].lag_one <= 0.) { sprintf(str,"Deviation of terrain slope must be greater than 0."); nrerror(str); } if( temp[i].fetch < 1.0 ) { sprintf(str,"ERROR - BLOWING parameter fetch should be >> 1 but cell %i has fetch = %.2f\n", gridcel, temp[i].fetch ); nrerror(str); } } veg_class = MISSING; for(j=0;j<Nveg_type;j++) if(temp[i].veg_class == veg_lib[j].veg_class) veg_class = j; if(veg_class == MISSING) { sprintf(ErrStr,"The vegetation class id %i in vegetation tile %i from cell %i is not defined in the vegetation library file.", temp[i].veg_class, i, gridcel); nrerror(ErrStr); } else temp[i].veg_class = veg_class; temp[0].Cv_sum += temp[i].Cv; for(k=0; k<Nfields; k++) free(vegarr[k]); if ( options.VEGPARAM_LAI ) { // Read the LAI line if ( fgets( line, MAXSTRING, vegparam ) == NULL ){ sprintf(ErrStr,"ERROR unexpected EOF for cell %i while reading LAI for vegetat_type_num %d\n",vegcel,vegetat_type_num); nrerror(ErrStr); } Nfields = 0; vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(tmpline, line); ttrim( tmpline ); token = strtok (tmpline, delimiters); strcpy(vegarr[Nfields],token); Nfields++; while( ( token = strtok (NULL, delimiters)) != NULL ){ vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(vegarr[Nfields],token); Nfields++; } NfieldsMax = 12; /* For LAI */ if ( Nfields != NfieldsMax ) { sprintf(ErrStr,"ERROR - cell %d - expecting %d LAI values but found %d in line %s\n",gridcel, NfieldsMax, Nfields, line); nrerror(ErrStr); } for ( j = 0; j < MONTHSPERYEAR; j++ ) { temp[i].albedo[j] = veg_lib[temp[i].veg_class].albedo[j]; temp[i].LAI[j] = veg_lib[temp[i].veg_class].LAI[j]; temp[i].vegcover[j] = veg_lib[temp[i].veg_class].vegcover[j]; temp[i].Wdmax[j] = veg_lib[temp[i].veg_class].Wdmax[j]; } if (options.LAI_SRC == FROM_VEGPARAM) { for ( j = 0; j < 12; j++ ) { tmp = atof( vegarr[j] ); if (tmp != NODATA_VH) temp[i].LAI[j] = tmp; if (veg_lib[temp[i].veg_class].overstory && temp[i].LAI[j] == 0) { sprintf(ErrStr,"ERROR: cell %d, veg tile %d: the specified veg class (%d) is listed as an overstory class in the veg LIBRARY, but the LAI given in the veg PARAM FILE for this tile for month %d is 0.\n",gridcel, i+1, temp[i].veg_class+1, j+1); nrerror(ErrStr); } temp[i].Wdmax[j] = LAI_WATER_FACTOR * temp[i].LAI[j]; } } for(k=0; k<Nfields; k++) free(vegarr[k]); } if ( options.VEGPARAM_VEGCOVER ) { // Read the vegcover line if ( fgets( line, MAXSTRING, vegparam ) == NULL ){ sprintf(ErrStr,"ERROR unexpected EOF for cell %i while reading vegcover for vegetat_type_num %d\n",vegcel,vegetat_type_num); nrerror(ErrStr); } Nfields = 0; vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(tmpline, line); ttrim( tmpline ); token = strtok (tmpline, delimiters); strcpy(vegarr[Nfields],token); Nfields++; while( ( token = strtok (NULL, delimiters)) != NULL ){ vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(vegarr[Nfields],token); Nfields++; } NfieldsMax = 12; /* For vegcover */ if ( Nfields != NfieldsMax ) { sprintf(ErrStr,"ERROR - cell %d - expecting %d vegcover values but found %d in line %s\n",gridcel, NfieldsMax, Nfields, line); nrerror(ErrStr); } if (options.VEGCOVER_SRC == FROM_VEGPARAM) { for ( j = 0; j < 12; j++ ) { tmp = atof( vegarr[j] ); if (tmp != NODATA_VH) temp[i].vegcover[j] = tmp; } } for(k=0; k<Nfields; k++) free(vegarr[k]); } if ( options.VEGPARAM_ALB ) { // Read the albedo line if ( fgets( line, MAXSTRING, vegparam ) == NULL ){ sprintf(ErrStr,"ERROR unexpected EOF for cell %i while reading albedo for vegetat_type_num %d\n",vegcel,vegetat_type_num); nrerror(ErrStr); } Nfields = 0; vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(tmpline, line); ttrim( tmpline ); token = strtok (tmpline, delimiters); strcpy(vegarr[Nfields],token); Nfields++; while( ( token = strtok (NULL, delimiters)) != NULL ){ vegarr[Nfields] = calloc( 500, sizeof(char)); strcpy(vegarr[Nfields],token); Nfields++; } NfieldsMax = 12; /* For albedo */ if ( Nfields != NfieldsMax ) { sprintf(ErrStr,"ERROR - cell %d - expecting %d albedo values but found %d in line %s\n",gridcel, NfieldsMax, Nfields, line); nrerror(ErrStr); } if (options.ALB_SRC == FROM_VEGPARAM) { for ( j = 0; j < 12; j++ ) { tmp = atof( vegarr[j] ); if (tmp != NODATA_VH) temp[i].albedo[j] = tmp; } } for(k=0; k<Nfields; k++) free(vegarr[k]); } // Determine if cell contains non-overstory vegetation if ( options.COMPUTE_TREELINE && !veg_lib[temp[i].veg_class].overstory ) NoOverstory++; } // Determine if we have bare soil if(temp[0].Cv_sum>1.0){ fprintf(stderr,"WARNING: Cv exceeds 1.0 at grid cell %d, fractions being adjusted to equal 1\n", gridcel); for(j=0;j<vegetat_type_num;j++) temp[j].Cv = temp[j].Cv / temp[0].Cv_sum; temp[0].Cv_sum = 1.; } else if(temp[0].Cv_sum>0.99 && temp[0].Cv_sum<1.0){ fprintf(stderr,"WARNING: Cv > 0.99 and Cv < 1.0 at grid cell %d, model assuming that bare soil is not to be run - fractions being adjusted to equal 1\n", gridcel); for(j=0;j<vegetat_type_num;j++) temp[j].Cv = temp[j].Cv / temp[0].Cv_sum; temp[0].Cv_sum = 1.; } // Handle veg above the treeline if ( options.SNOW_BAND > 1 && options.COMPUTE_TREELINE && ( !NoOverstory && temp[0].Cv_sum == 1. ) ) { // All vegetation in the current cell is defined with overstory. // Add default non-overstory vegetation so that snow bands above treeline // can be sucessfully simulated. if ( options.AboveTreelineVeg < 0 ) { // Above treeline snowband should be treated as bare soil for ( j = 0; j < vegetat_type_num; j++ ) temp[j].Cv -= ( 0.001 / (float)vegetat_type_num ); temp[0].Cv_sum -= 0.001; } else { // Above treeline snowband should use the defined vegetation // add vegetation to typenum // check that veg type exists in library and does not have overstory if(vegetat_type_num > 0) { for ( j = 0; j < vegetat_type_num; j++ ) { temp[j].Cv -= ( 0.001 / (float)vegetat_type_num ); temp[j].vegetat_type_num++; } temp[vegetat_type_num].Cv = 0.001; temp[vegetat_type_num].veg_class = options.AboveTreelineVeg; temp[vegetat_type_num].Cv_sum = temp[vegetat_type_num-1].Cv_sum; temp[vegetat_type_num].zone_depth = calloc( options.ROOT_ZONES, sizeof(float)); temp[vegetat_type_num].zone_fract = calloc( options.ROOT_ZONES, sizeof(float)); temp[vegetat_type_num].vegetat_type_num = vegetat_type_num+1; // Since root zones are not defined they are copied from the last // vegetation type. for ( j = 0; j < options.ROOT_ZONES; j++ ) { temp[vegetat_type_num].zone_depth[j] = temp[vegetat_type_num-1].zone_depth[j]; temp[vegetat_type_num].zone_fract[j] = temp[vegetat_type_num-1].zone_fract[j]; } } // Identify current vegetation class veg_class = MISSING; for ( j = 0; j < Nveg_type; j++ ) { if(temp[vegetat_type_num].veg_class == veg_lib[j].veg_class) { veg_class = j; break; } } if ( veg_class == MISSING ) { sprintf(ErrStr,"The vegetation class id %i defined for above-treeline from cell %i is not defined in the vegetation library file.", temp[vegetat_type_num].veg_class, gridcel); nrerror(ErrStr); } else { temp[vegetat_type_num].veg_class = veg_class; } if ( veg_lib[veg_class].overstory ) { sprintf(ErrStr,"Vegetation class %i is defined to have overstory, so it cannot be used as the default vegetation type for above canopy snow bands.", veg_lib[veg_class].veg_class ); nrerror(ErrStr); } } } // Bare soil tile if (temp[0].Cv_sum < 1.) { j = vegetat_type_num; temp[j].veg_class = Nveg_type; // Create a veg_class ID for bare soil, which is not mentioned in the veg library temp[j].Cv = 1.0 - temp[0].Cv_sum; // Don't allocate any root-zone-related arrays if(options.BLOWING) { if (vegetat_type_num > 0) { temp[j].sigma_slope = temp[0].sigma_slope; temp[j].lag_one = temp[0].lag_one; temp[j].fetch = temp[0].fetch; } else { temp[j].sigma_slope = 0.005; temp[j].lag_one = 0.95; temp[j].fetch = 2000; } } } return temp; }