Exemplo n.º 1
0
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;
}
Exemplo n.º 2
0
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;
}
Exemplo n.º 3
0
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, &param_set.TYPE[type].multiplier);
    if(strcasecmp("SIGNED",flgstr)==0) param_set.TYPE[type].SIGNED=TRUE;
    else param_set.TYPE[type].SIGNED=FALSE;
  }

  (*field)++;

}
Exemplo n.º 4
0
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;
			}
		}
	}
}
Exemplo n.º 5
0
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);
	}
}
Exemplo n.º 6
0
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);
}
Exemplo n.º 8
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;
} 
Exemplo n.º 9
0
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;
}
Exemplo n.º 10
0
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;
}
Exemplo n.º 11
0
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);
  
  }
}
Exemplo n.º 12
0
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;
}
Exemplo n.º 13
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;
			}
		}
	}
}
Exemplo n.º 14
0
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");
      
    }
  }

}
Exemplo n.º 15
0
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;
}
Exemplo n.º 16
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;
}
Exemplo n.º 17
0
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");
  }
}
Exemplo n.º 18
0
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);
}
Exemplo n.º 19
0
Arquivo: bsstep.c Projeto: gnovak/bin
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);
}
Exemplo n.º 20
0
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);  
}
Exemplo n.º 22
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];
	}
}
Exemplo n.º 23
0
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;
} 
Exemplo n.º 24
0
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;
}
Exemplo n.º 25
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;
}
Exemplo n.º 26
0
/**************************************************************
* 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);
}
Exemplo n.º 27
0
/*--------------------------------------------------------------------------*/
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];
      }

    }

  }

}
Exemplo n.º 29
0
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);
}
Exemplo n.º 30
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.
  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;
}