Term interp_term(void)
{
Symbol_data s;
Term symlist = get_nil_term();
for (s = Symbols; s != NULL; s = s->next) {
if (s->attribute != EQUALITY_SYMBOL) {
int i, n;
Term entry, symterm, tableterm;
symterm = get_rigid_term_dangerously(s->sn, s->arity);
for (i = 0; i < s->arity; i++)
ARG(symterm,i) = get_variable_term(i);
n = int_power(Domain_size, s->arity);
tableterm = get_nil_term();
for (i = n-1; i >= 0; i--) {
int id = s->base + i;
Term it;
if (Cells[id].value == NULL)
fatal_error("interp_term, incomplete interpretation");
it = nat_to_term(VARNUM(Cells[id].value));
tableterm = listterm_cons(it, tableterm);
}
entry = build_binary_term(str_to_sn(s->type == FUNCTION ? "function" : "relation", 2),
symterm, tableterm);
symlist = listterm_cons(entry, symlist);
}
}
return build_binary_term(str_to_sn("interpretation", 2),
nat_to_term(Domain_size),
symlist);
} /* interp_term */
/* PUBLIC */
void init_semantics(Plist interp_terms, Clock eval_clock,
char *type, int eval_limit, int eval_var_limit)
{
Plist p;
int max_domain_size = 0;
for (p = interp_terms; p; p = p->next) {
Interp a = compile_interp(p->v, FALSE);
max_domain_size = IMAX(max_domain_size, interp_size(a));
Compiled_interps = plist_prepend(Compiled_interps, a);
}
Compiled_interps = reverse_plist(Compiled_interps);
if (str_ident(type, "false_in_all"))
False_in_all = TRUE;
else if (str_ident(type, "false_in_some"))
False_in_all = FALSE;
else
fatal_error("init_semantics, bad type");
if (eval_var_limit == -1)
Eval_limit = eval_limit;
else {
Eval_limit = int_power(max_domain_size, eval_var_limit);
printf("eval_limit reset to %d.\n", Eval_limit);
}
Eval_clock = eval_clock;
} /* init_semantics */
int atoi(char* p){
int i,length,number=0;
for(length=0;'\0'!=*p;length++,p++)
;
p-=1;
for(i=0;i<length;i++,p--)
number+=(*p-'0')*int_power(10,i);
return number;
}
static
BOOL eval_limit_ok(Interp p, int number_of_vars)
{
if (Eval_limit == -1)
return TRUE;
else {
int evals_required = int_power(interp_size(p), number_of_vars);
return evals_required <= Eval_limit;
}
} /* eval_limit_ok */
X int_power(X base, X exp)
{
static_assert(std::is_integral<X>::value,
"type must be unsigned integral");
assert(!is_negative(exp));
if (exp == 0)
return 1;
if (exp == 1)
return base;
return base * int_power(base, exp - 1);
}
void print_model_standard(FILE *fp, BOOL print_head)
{
int syms_printed;
Symbol_data s;
if (print_head)
print_separator(fp, "MODEL", TRUE);
fprintf(fp, "\ninterpretation( %d, [number=%d, seconds=%d], [\n",
Domain_size, Total_models, (int) user_seconds());
syms_printed = 0;
for (s = Symbols; s != NULL; s = s->next) {
if (s->attribute != EQUALITY_SYMBOL) {
int i, n;
if (syms_printed > 0)
fprintf(fp, ",\n");
fprintf(fp, "\n %s(%s%s",
s->type == FUNCTION ? "function" : "relation",
sn_to_str(s->sn),
s->arity == 0 ? "" : "(_");
for (i = 1; i < s->arity; i++)
fprintf(fp, ",_");
fprintf(fp,"%s, [%s",
s->arity == 0 ? "" : ")",
s->arity >= 2 ? "\n\t\t\t " : "");
n = int_power(Domain_size, s->arity);
for (i = 0; i < n; i++) {
int id = s->base + i;
if (Cells[id].value == NULL)
fprintf(fp, "-");
else
fprintf(fp, "%2d", VARNUM(Cells[id].value));
if (i < n-1)
fprintf(fp, ",%s", (i+1) % Domain_size == 0 ? "\n\t\t\t " : "");
else
fprintf(fp, " ])");
}
syms_printed++;
}
}
fprintf(fp, "\n]).\n");
if (print_head)
print_separator(fp, "end of model", TRUE);
} /* print_model_standard */
Term decode_eterm_id(int id)
{
/* Assume the id is in range. */
Symbol_data s = Cells[id].symbol;
Term t = get_rigid_term_dangerously(s->sn, s->arity);
int n = Domain_size;
int x = id - s->base;
int i;
for (i = s->arity - 1; i >= 0; i--) {
int p = int_power(n, i);
int e = x / p;
ARG(t, (s->arity-1) - i) = Domain[e];
x = x % p;
}
return t;
} /* decode_eterm_id */
static
void init_for_domain_size(void)
{
int i, j, nextbase, id;
Symbol_data s;
/* Give each symbol its "base" value, which is used to index cells. */
nextbase = 0;
for (s = Symbols; s != NULL; s = s->next) {
s->base = nextbase;
nextbase += int_power(Domain_size, s->arity);
}
/* Set up the array of domain terms. All ground terms refer to these. */
Domain = malloc(Domain_size * sizeof(void *));
for (i = 0; i < Domain_size; i++)
Domain[i] = get_variable_term(i);
/* Set up the table of cells. */
Number_of_cells = nextbase;
Cells = malloc(Number_of_cells * sizeof(struct cell));
Ordered_cells = malloc(Number_of_cells * sizeof(void *));
for (id = 0; id < Number_of_cells; id++) {
struct cell *c = Cells + id;
int n;
c->id = id;
c->occurrences = NULL;
c->value = NULL;
c->symbol = find_symbol_node(id);
c->eterm = decode_eterm_id(id);
c->max_index = max_index(id, c->symbol);
n = id_to_domain_size(id);
c->possible = malloc(n * sizeof(void *));
for (j = 0; j < n; j++)
c->possible[j] = Domain[j]; /* really just a flag */
}
order_cells(flag(Opt->verbose));
if (flag(Opt->negprop))
init_negprop_index();
} /* init_for_domain_size */
void compack(g2float *fld,g2int ndpts,g2int idrsnum,g2int *idrstmpl,
unsigned char *cpack,g2int *lcpack)
//$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: compack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-11-07
//
// ABSTRACT: This subroutine packs up a data field using a complex
// packing algorithm as defined in the GRIB2 documentation. It
// supports GRIB2 complex packing templates with or without
// spatial differences (i.e. DRTs 5.2 and 5.3).
// It also fills in GRIB2 Data Representation Template 5.2 or 5.3
// with the appropriate values.
//
// PROGRAM HISTORY LOG:
// 2002-11-07 Gilbert
//
// USAGE: void compack(g2float *fld,g2int ndpts,g2int idrsnum,
// g2int *idrstmpl,unsigned char *cpack,g2int *lcpack)
//
// INPUT ARGUMENTS:
// fld[] - Contains the data values to pack
// ndpts - The number of data values in array fld[]
// idrsnum - Data Representation Template number 5.N
// Must equal 2 or 3.
// idrstmpl - Contains the array of values for Data Representation
// Template 5.2 or 5.3
// [0] = Reference value - ignored on input
// [1] = Binary Scale Factor
// [2] = Decimal Scale Factor
// .
// .
// [6] = Missing value management
// [7] = Primary missing value
// [8] = Secondary missing value
// .
// .
// [16] = Order of Spatial Differencing ( 1 or 2 )
// .
// .
//
// OUTPUT ARGUMENTS:
// idrstmpl - Contains the array of values for Data Representation
// Template 5.3
// [0] = Reference value - set by compack routine.
// [1] = Binary Scale Factor - unchanged from input
// [2] = Decimal Scale Factor - unchanged from input
// .
// .
// cpack - The packed data field
// lcpack - length of packed field cpack.
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE:
//
//$$$
{
const g2int zero=0;
g2int *ifld,*gref,*glen,*gwidth;
g2int *jmin, *jmax, *lbit;
g2int i,j,n, /* nbits, */ imin,imax,left;
g2int isd,itemp,ilmax,ngwidthref=0,nbitsgwidth=0;
g2int nglenref=0,nglenlast=0,iofst,ival1,ival2;
g2int minsd,nbitsd=0,maxorig,nbitorig,ngroups;
g2int lg,ng,igmax,iwmax,nbitsgref;
g2int glength,grpwidth,nbitsglen=0;
g2int kfildo, minpk, inc, maxgrps, ibit, jbit, kbit, novref, lbitref;
g2int missopt, miss1, miss2, ier;
g2float bscale,dscale,rmax,rmin,temp;
const g2int simple_alg = 0;
const g2float alog2=0.69314718f; // ln(2.0)
const g2int one=1;
bscale=(float)int_power(2.0,-idrstmpl[1]);
dscale=(float)int_power(10.0,idrstmpl[2]);
//
// Find max and min values in the data
//
rmax=fld[0];
rmin=fld[0];
for (j=1;j<ndpts;j++) {
if (fld[j] > rmax) rmax=fld[j];
if (fld[j] < rmin) rmin=fld[j];
}
//
// If max and min values are not equal, pack up field.
// If they are equal, we have a constant field, and the reference
// value (rmin) is the value for each point in the field and
// set nbits to 0.
//
if (rmin != rmax) {
iofst=0;
ifld=calloc(ndpts,sizeof(g2int));
gref=calloc(ndpts,sizeof(g2int));
gwidth=calloc(ndpts,sizeof(g2int));
glen=calloc(ndpts,sizeof(g2int));
//
// Scale original data
//
if (idrstmpl[1] == 0) { // No binary scaling
imin=(g2int)RINT(rmin*dscale);
//imax=(g2int)rint(rmax*dscale);
rmin=(g2float)imin;
for (j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(fld[j]*dscale)-imin;
}
else { // Use binary scaling factor
rmin=rmin*dscale;
//rmax=rmax*dscale;
for (j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(((fld[j]*dscale)-rmin)*bscale);
}
//
// Calculate spatial differences, if using DRS Template 5.3.
//
if (idrsnum == 3) { // spatial differences
if (idrstmpl[16]!=1 && idrstmpl[16]!=2) idrstmpl[16]=1;
if (idrstmpl[16] == 1) { // first order
ival1=ifld[0];
for (j=ndpts-1;j>0;j--)
ifld[j]=ifld[j]-ifld[j-1];
ifld[0]=0;
}
else if (idrstmpl[16] == 2) { // second order
ival1=ifld[0];
ival2=ifld[1];
for (j=ndpts-1;j>1;j--)
ifld[j]=ifld[j]-(2*ifld[j-1])+ifld[j-2];
ifld[0]=0;
ifld[1]=0;
}
//
// subtract min value from spatial diff field
//
isd=idrstmpl[16];
minsd=ifld[isd];
for (j=isd;j<ndpts;j++) if ( ifld[j] < minsd ) minsd=ifld[j];
for (j=isd;j<ndpts;j++) ifld[j]=ifld[j]-minsd;
//
// find num of bits need to store minsd and add 1 extra bit
// to indicate sign
//
temp=(float)(log((double)(abs(minsd)+1))/alog2);
nbitsd=(g2int)ceil(temp)+1;
//
// find num of bits need to store ifld[0] ( and ifld[1]
// if using 2nd order differencing )
//
maxorig=ival1;
if (idrstmpl[16]==2 && ival2>ival1) maxorig=ival2;
temp=(float)(log((double)(maxorig+1))/alog2);
nbitorig=(g2int)ceil(temp)+1;
if (nbitorig > nbitsd) nbitsd=nbitorig;
// increase number of bits to even multiple of 8 ( octet )
if ( (nbitsd%8) != 0) nbitsd=nbitsd+(8-(nbitsd%8));
//
// Store extra spatial differencing info into the packed
// data section.
//
if (nbitsd != 0) {
// pack first original value
if (ival1 >= 0) {
sbit(cpack,&ival1,iofst,nbitsd);
iofst=iofst+nbitsd;
}
else {
sbit(cpack,&one,iofst,1);
iofst=iofst+1;
itemp=abs(ival1);
sbit(cpack,&itemp,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
}
if (idrstmpl[16] == 2) {
// pack second original value
if (ival2 >= 0) {
sbit(cpack,&ival2,iofst,nbitsd);
iofst=iofst+nbitsd;
}
else {
sbit(cpack,&one,iofst,1);
iofst=iofst+1;
itemp=abs(ival2);
sbit(cpack,&itemp,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
}
}
// pack overall min of spatial differences
if (minsd >= 0) {
sbit(cpack,&minsd,iofst,nbitsd);
iofst=iofst+nbitsd;
}
else {
sbit(cpack,&one,iofst,1);
iofst=iofst+1;
itemp=abs(minsd);
sbit(cpack,&itemp,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
}
}
//printf("SDp %ld %ld %ld %ld\n",ival1,ival2,minsd,nbitsd);
} // end of spatial diff section
//
// Determine Groups to be used.
//
if ( simple_alg == 1 ) {
// set group length to 10; calculate number of groups
// and length of last group
ngroups=ndpts/10;
for (j=0;j<ngroups;j++) glen[j]=10;
itemp=ndpts%10;
if (itemp != 0) {
ngroups=ngroups+1;
glen[ngroups-1]=itemp;
}
}
else {
// Use Dr. Glahn's algorithm for determining grouping.
//
kfildo=6;
minpk=10;
inc=1;
maxgrps=(ndpts/minpk)+1;
jmin = calloc(maxgrps,sizeof(g2int));
jmax = calloc(maxgrps,sizeof(g2int));
lbit = calloc(maxgrps,sizeof(g2int));
missopt=0;
pack_gp(&kfildo,ifld,&ndpts,&missopt,&minpk,&inc,&miss1,&miss2,
jmin,jmax,lbit,glen,&maxgrps,&ngroups,&ibit,&jbit,
&kbit,&novref,&lbitref,&ier);
//print *,'SAGier = ',ier,ibit,jbit,kbit,novref,lbitref
for ( ng=0; ng<ngroups; ng++) glen[ng]=glen[ng]+novref;
free(jmin);
free(jmax);
free(lbit);
}
//
// For each group, find the group's reference value
// and the number of bits needed to hold the remaining values
//
n=0;
for (ng=0;ng<ngroups;ng++) {
// find max and min values of group
gref[ng]=ifld[n];
imax=ifld[n];
j=n+1;
for (lg=1;lg<glen[ng];lg++) {
if (ifld[j] < gref[ng]) gref[ng]=ifld[j];
if (ifld[j] > imax) imax=ifld[j];
j++;
}
// calc num of bits needed to hold data
if ( gref[ng] != imax ) {
temp=(float)(log((double)(imax-gref[ng]+1))/alog2);
gwidth[ng]=(g2int)ceil(temp);
}
else
gwidth[ng]=0;
// Subtract min from data
j=n;
for (lg=0;lg<glen[ng];lg++) {
ifld[j]=ifld[j]-gref[ng];
j++;
}
// increment fld array counter
n=n+glen[ng];
}
//
// Find max of the group references and calc num of bits needed
// to pack each groups reference value, then
// pack up group reference values
//
igmax=gref[0];
for (j=1;j<ngroups;j++) if (gref[j] > igmax) igmax=gref[j];
if (igmax != 0) {
temp=(float)(log((double)(igmax+1))/alog2);
nbitsgref=(g2int)ceil(temp);
sbits(cpack,gref,iofst,nbitsgref,0,ngroups);
itemp=nbitsgref*ngroups;
iofst=iofst+itemp;
// Pad last octet with Zeros, if necessary,
if ( (itemp%8) != 0) {
left=8-(itemp%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
}
else
nbitsgref=0;
//
// Find max/min of the group widths and calc num of bits needed
// to pack each groups width value, then
// pack up group width values
//
iwmax=gwidth[0];
ngwidthref=gwidth[0];
for (j=1;j<ngroups;j++) {
if (gwidth[j] > iwmax) iwmax=gwidth[j];
if (gwidth[j] < ngwidthref) ngwidthref=gwidth[j];
}
if (iwmax != ngwidthref) {
temp=(float)(log((double)(iwmax-ngwidthref+1))/alog2);
nbitsgwidth=(g2int)ceil(temp);
for (i=0;i<ngroups;i++)
gwidth[i]=gwidth[i]-ngwidthref;
sbits(cpack,gwidth,iofst,nbitsgwidth,0,ngroups);
itemp=nbitsgwidth*ngroups;
iofst=iofst+itemp;
// Pad last octet with Zeros, if necessary,
if ( (itemp%8) != 0) {
left=8-(itemp%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
}
else {
nbitsgwidth=0;
for (i=0;i<ngroups;i++) gwidth[i]=0;
}
//
// Find max/min of the group lengths and calc num of bits needed
// to pack each groups length value, then
// pack up group length values
//
//write(77,*)'GLENS: ',(glen(j),j=1,ngroups)
ilmax=glen[0];
nglenref=glen[0];
for (j=1;j<ngroups-1;j++) {
if (glen[j] > ilmax) ilmax=glen[j];
if (glen[j] < nglenref) nglenref=glen[j];
}
nglenlast=glen[ngroups-1];
if (ilmax != nglenref) {
temp=(float)(log((double)(ilmax-nglenref+1))/alog2);
nbitsglen=(g2int)ceil(temp);
for (i=0;i<ngroups-1;i++) glen[i]=glen[i]-nglenref;
sbits(cpack,glen,iofst,nbitsglen,0,ngroups);
itemp=nbitsglen*ngroups;
iofst=iofst+itemp;
// Pad last octet with Zeros, if necessary,
if ( (itemp%8) != 0) {
left=8-(itemp%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
}
else {
nbitsglen=0;
for (i=0;i<ngroups;i++) glen[i]=0;
}
//
// For each group, pack data values
//
n=0;
for (ng=0;ng<ngroups;ng++) {
glength=glen[ng]+nglenref;
if (ng == (ngroups-1) ) glength=nglenlast;
grpwidth=gwidth[ng]+ngwidthref;
if ( grpwidth != 0 ) {
sbits(cpack,ifld+n,iofst,grpwidth,0,glength);
iofst=iofst+(grpwidth*glength);
}
n=n+glength;
}
// Pad last octet with Zeros, if necessary,
if ( (iofst%8) != 0) {
left=8-(iofst%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
*lcpack=iofst/8;
//
if ( ifld!=0 ) free(ifld);
if ( gref!=0 ) free(gref);
if ( gwidth!=0 ) free(gwidth);
if ( glen!=0 ) free(glen);
}
else { // Constant field ( max = min )
/* nbits=0; */
*lcpack=0;
nbitsgref=0;
ngroups=0;
}
//
// Fill in ref value and number of bits in Template 5.2
//
mkieee(&rmin,idrstmpl+0,1); // ensure reference value is IEEE format
idrstmpl[3]=nbitsgref;
idrstmpl[4]=0; // original data were reals
idrstmpl[5]=1; // general group splitting
idrstmpl[6]=0; // No internal missing values
idrstmpl[7]=0; // Primary missing value
idrstmpl[8]=0; // secondary missing value
idrstmpl[9]=ngroups; // Number of groups
idrstmpl[10]=ngwidthref; // reference for group widths
idrstmpl[11]=nbitsgwidth; // num bits used for group widths
idrstmpl[12]=nglenref; // Reference for group lengths
idrstmpl[13]=1; // length increment for group lengths
idrstmpl[14]=nglenlast; // True length of last group
idrstmpl[15]=nbitsglen; // num bits used for group lengths
if (idrsnum == 3) {
idrstmpl[17]=nbitsd/8; // num bits used for extra spatial
// differencing values
}
}
g2int simunpack(unsigned char *cpack,g2int *idrstmpl,g2int ndpts,g2float *fld)
////$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: simunpack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-10-29
//
// ABSTRACT: This subroutine unpacks a data field that was packed using a
// simple packing algorithm as defined in the GRIB2 documentation,
// using info from the GRIB2 Data Representation Template 5.0.
//
// PROGRAM HISTORY LOG:
// 2002-10-29 Gilbert
//
// USAGE: int simunpack(unsigned char *cpack,g2int *idrstmpl,g2int ndpts,
// g2float *fld)
// INPUT ARGUMENT LIST:
// cpack - pointer to the packed data field.
// idrstmpl - pointer to the array of values for Data Representation
// Template 5.0
// ndpts - The number of data values to unpack
//
// OUTPUT ARGUMENT LIST:
// fld - Contains the unpacked data values. fld must be allocated
// with at least ndpts*sizeof(g2float) bytes before
// calling this routine.
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE:
//
//$$$//
{
g2int *ifld;
g2int j,nbits /* ,itype */;
g2float ref,bscale,dscale;
rdieee(idrstmpl+0,&ref,1);
bscale = (float)int_power(2.0,idrstmpl[1]);
dscale = (float)int_power(10.0,-idrstmpl[2]);
nbits = idrstmpl[3];
/* itype = idrstmpl[4]; */
ifld=(g2int *)calloc(ndpts,sizeof(g2int));
if ( ifld == 0 ) {
fprintf(stderr,"Could not allocate space in simunpack.\n"
"Data field NOT unpacked.\n");
return(1);
}
//
// if nbits equals 0, we have a constant field where the reference value
// is the data value at each gridpoint
//
if (nbits != 0) {
gbits(cpack,ifld,0,nbits,0,ndpts);
for (j=0;j<ndpts;j++) {
fld[j]=(((g2float)ifld[j]*bscale)+ref)*dscale;
}
}
else {
for (j=0;j<ndpts;j++) {
fld[j]=ref;
}
}
free(ifld);
return(0);
}
void simpack(g2float *fld,g2int ndpts,g2int *idrstmpl,unsigned char *cpack,g2int *lcpack)
//$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: simpack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-11-06
//
// ABSTRACT: This subroutine packs up a data field using the simple
// packing algorithm as defined in the GRIB2 documentation. It
// also fills in GRIB2 Data Representation Template 5.0 with the
// appropriate values.
//
// PROGRAM HISTORY LOG:
// 2002-11-06 Gilbert
//
// USAGE: CALL simpack(fld,ndpts,idrstmpl,cpack,lcpack)
// INPUT ARGUMENT LIST:
// fld[] - Contains the data values to pack
// ndpts - The number of data values in array fld[]
// idrstmpl - Contains the array of values for Data Representation
// Template 5.0
// [0] = Reference value - ignored on input
// [1] = Binary Scale Factor
// [2] = Decimal Scale Factor
// [3] = Number of bits used to pack data, if value is
// > 0 and <= 31.
// If this input value is 0 or outside above range
// then the num of bits is calculated based on given
// data and scale factors.
// [4] = Original field type - currently ignored on input
// Data values assumed to be reals.
//
// OUTPUT ARGUMENT LIST:
// idrstmpl - Contains the array of values for Data Representation
// Template 5.0
// [0] = Reference value - set by simpack routine.
// [1] = Binary Scale Factor - unchanged from input
// [2] = Decimal Scale Factor - unchanged from input
// [3] = Number of bits used to pack data, unchanged from
// input if value is between 0 and 31.
// If this input value is 0 or outside above range
// then the num of bits is calculated based on given
// data and scale factors.
// [4] = Original field type - currently set = 0 on output.
// Data values assumed to be reals.
// cpack - The packed data field
// lcpack - length of packed field starting at cpack.
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE:
//
//$$$
{
const g2int zero=0;
g2int *ifld;
g2int j,nbits,imin,imax,maxdif,nbittot,left;
g2float bscale,dscale,rmax,rmin,temp;
double maxnum;
const g2float alog2=0.69314718f; // ln(2.0)
bscale=(float)int_power(2.0,-idrstmpl[1]);
dscale=(float)int_power(10.0,idrstmpl[2]);
if (idrstmpl[3] <= 0 || idrstmpl[3] > 31)
nbits=0;
else
nbits=idrstmpl[3];
//
// Find max and min values in the data
//
rmax=fld[0];
rmin=fld[0];
for (j=1;j<ndpts;j++) {
if (fld[j] > rmax) rmax=fld[j];
if (fld[j] < rmin) rmin=fld[j];
}
ifld=calloc(ndpts,sizeof(g2int));
//
// If max and min values are not equal, pack up field.
// If they are equal, we have a constant field, and the reference
// value (rmin) is the value for each point in the field and
// set nbits to 0.
//
if (rmin != rmax) {
//
// Determine which algorithm to use based on user-supplied
// binary scale factor and number of bits.
//
if (nbits==0 && idrstmpl[1]==0) {
//
// No binary scaling and calculate minimum number of
// bits in which the data will fit.
//
imin=(g2int)RINT(rmin*dscale);
imax=(g2int)RINT(rmax*dscale);
maxdif=imax-imin;
temp=(float)(log((double)(maxdif+1))/alog2);
nbits=(g2int)ceil(temp);
rmin=(g2float)imin;
// scale data
for(j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(fld[j]*dscale)-imin;
}
else if (nbits!=0 && idrstmpl[1]==0) {
//
// Use minimum number of bits specified by user and
// adjust binary scaling factor to accommodate data.
//
rmin=rmin*dscale;
rmax=rmax*dscale;
maxnum=int_power(2.0,nbits)-1;
temp=(float)(log(maxnum/(rmax-rmin))/alog2);
idrstmpl[1]=(g2int)ceil(-1.0*temp);
bscale=(float)int_power(2.0,-idrstmpl[1]);
// scale data
for (j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(((fld[j]*dscale)-rmin)*bscale);
}
else if (nbits==0 && idrstmpl[1]!=0) {
//
// Use binary scaling factor and calculate minimum number of
// bits in which the data will fit.
//
rmin=rmin*dscale;
rmax=rmax*dscale;
maxdif=(g2int)RINT((rmax-rmin)*bscale);
temp=(float)(log((double)(maxdif+1))/alog2);
nbits=(g2int)ceil(temp);
// scale data
for (j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(((fld[j]*dscale)-rmin)*bscale);
}
else if (nbits!=0 && idrstmpl[1]!=0) {
//
// Use binary scaling factor and use minimum number of
// bits specified by user. Dangerous - may loose
// information if binary scale factor and nbits not set
// properly by user.
//
rmin=rmin*dscale;
// scale data
for (j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(((fld[j]*dscale)-rmin)*bscale);
}
//
// Pack data, Pad last octet with Zeros, if necessary,
// and calculate the length of the packed data in bytes
//
sbits(cpack,ifld+0,0,nbits,0,ndpts);
nbittot=nbits*ndpts;
left=8-(nbittot%8);
if (left != 8) {
sbit(cpack,&zero,nbittot,left); // Pad with zeros to fill Octet
nbittot=nbittot+left;
}
*lcpack=nbittot/8;
}
else {
nbits=0;
*lcpack=0;
}
//
// Fill in ref value and number of bits in Template 5.0
//
//printf("SAGmkieee %f\n",rmin);
mkieee(&rmin,idrstmpl+0,1); // ensure reference value is IEEE format
//printf("SAGmkieee %ld\n",idrstmpl[0]);
idrstmpl[3]=nbits;
idrstmpl[4]=0; // original data were reals
free(ifld);
}
void pngpack(g2float *fld,g2int width,g2int height,g2int *idrstmpl,
unsigned char *cpack,g2int *lcpack)
//$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: pngpack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2003-08-27
//
// ABSTRACT: This subroutine packs up a data field into PNG image format.
// After the data field is scaled, and the reference value is subtracted out,
// it is treated as a grayscale image and passed to a PNG encoder.
// It also fills in GRIB2 Data Representation Template 5.41 or 5.40010 with
// the appropriate values.
//
// PROGRAM HISTORY LOG:
// 2003-08-27 Gilbert
//
// USAGE: pngpack(g2float *fld,g2int width,g2int height,g2int *idrstmpl,
// unsigned char *cpack,g2int *lcpack);
// INPUT ARGUMENT LIST:
// fld[] - Contains the data values to pack
// width - number of points in the x direction
// height - number of points in the y direction
// idrstmpl - Contains the array of values for Data Representation
// Template 5.41 or 5.40010
// [0] = Reference value - ignored on input
// [1] = Binary Scale Factor
// [2] = Decimal Scale Factor
// [3] = number of bits for each data value - ignored on input
// [4] = Original field type - currently ignored on input
// Data values assumed to be reals.
//
// OUTPUT ARGUMENT LIST:
// idrstmpl - Contains the array of values for Data Representation
// Template 5.41 or 5.40010
// [0] = Reference value - set by pngpack routine.
// [1] = Binary Scale Factor - unchanged from input
// [2] = Decimal Scale Factor - unchanged from input
// [3] = Number of bits containing each grayscale pixel value
// [4] = Original field type - currently set = 0 on output.
// Data values assumed to be reals.
// cpack - The packed data field
// lcpack - length of packed field cpack.
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE: IBM SP
//
//$$$
{
g2int *ifld;
const g2float alog2=0.69314718f; // ln(2.0)
g2int j,nbits,imin,imax,maxdif;
g2int ndpts,nbytes;
g2float bscale,dscale,rmax,rmin,temp;
unsigned char *ctemp;
ifld=0;
ndpts=width*height;
bscale=(g2float)int_power(2.0,-idrstmpl[1]);
dscale=(g2float)int_power(10.0,idrstmpl[2]);
//
// Find max and min values in the data
//
rmax=fld[0];
rmin=fld[0];
for (j=1;j<ndpts;j++) {
if (fld[j] > rmax) rmax=fld[j];
if (fld[j] < rmin) rmin=fld[j];
}
maxdif = (g2int)RINT( (rmax-rmin)*dscale*bscale );
//
// If max and min values are not equal, pack up field.
// If they are equal, we have a constant field, and the reference
// value (rmin) is the value for each point in the field and
// set nbits to 0.
//
if (rmin != rmax && maxdif != 0 ) {
ifld=(g2int *)malloc(ndpts*sizeof(g2int));
//
// Determine which algorithm to use based on user-supplied
// binary scale factor and number of bits.
//
if (idrstmpl[1] == 0) {
//
// No binary scaling and calculate minimum number of
// bits in which the data will fit.
//
imin=(g2int)RINT(rmin*dscale);
imax=(g2int)RINT(rmax*dscale);
maxdif=imax-imin;
temp=(g2float)log((double)(maxdif+1))/alog2;
nbits=(g2int)ceil(temp);
rmin=(g2float)imin;
// scale data
for(j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(fld[j]*dscale)-imin;
}
else {
//
// Use binary scaling factor and calculate minimum number of
// bits in which the data will fit.
//
rmin=rmin*dscale;
rmax=rmax*dscale;
maxdif=(g2int)RINT((rmax-rmin)*bscale);
temp=(g2float)log((double)(maxdif+1))/alog2;
nbits=(g2int)ceil(temp);
// scale data
for (j=0;j<ndpts;j++)
ifld[j]=(g2int)RINT(((fld[j]*dscale)-rmin)*bscale);
}
//
// Pack data into full octets, then do PNG encode.
// and calculate the length of the packed data in bytes
//
if (nbits <= 8) {
nbits=8;
}
else if (nbits <= 16) {
nbits=16;
}
else if (nbits <= 24) {
nbits=24;
}
else {
nbits=32;
}
nbytes=(nbits/8)*ndpts;
ctemp=calloc(nbytes,1);
sbits(ctemp,ifld,0,nbits,0,ndpts);
//
// Encode data into PNG Format.
//
*lcpack=(g2int)enc_png((char *)ctemp,width,height,nbits,(char *)cpack);
if (*lcpack <= 0) {
printf("pngpack: ERROR Packing PNG = %d\n",(int)*lcpack);
}
free(ctemp);
}
else {
nbits=0;
*lcpack=0;
}
//
// Fill in ref value and number of bits in Template 5.0
//
mkieee(&rmin,idrstmpl+0,1); // ensure reference value is IEEE format
idrstmpl[3]=nbits;
idrstmpl[4]=0; // original data were reals
if (ifld != 0) free(ifld);
}
int comunpack(unsigned char *cpack,g2int lensec,g2int idrsnum,g2int *idrstmpl,g2int ndpts,g2float *fld)
/*//$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: comunpack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-10-29
//
// ABSTRACT: This subroutine unpacks a data field that was packed using a
// complex packing algorithm as defined in the GRIB2 documention,
// using info from the GRIB2 Data Representation Template 5.2 or 5.3.
// Supports GRIB2 complex packing templates with or without
// spatial differences (i.e. DRTs 5.2 and 5.3).
//
// PROGRAM HISTORY LOG:
// 2002-10-29 Gilbert
// 2004-12-16 Gilbert - Added test ( provided by Arthur Taylor/MDL )
// to verify that group widths and lengths are
// consistent with section length.
//
// USAGE: int comunpack(unsigned char *cpack,g2int lensec,g2int idrsnum,
// g2int *idrstmpl, g2int ndpts,g2float *fld)
// INPUT ARGUMENT LIST:
// cpack - pointer to the packed data field.
// lensec - length of section 7 (used for error checking).
// idrsnum - Data Representation Template number 5.N
// Must equal 2 or 3.
// idrstmpl - pointer to the array of values for Data Representation
// Template 5.2 or 5.3
// ndpts - The number of data values to unpack
//
// OUTPUT ARGUMENT LIST:
// fld - Contains the unpacked data values. fld must be allocated
// with at least ndpts*sizeof(g2float) bytes before
// calling this routine.
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE:
//
//$$$*/
{
g2int nbitsd=0,isign;
g2int j,iofst,ival1,ival2,minsd,itemp,l,k,n,non=0;
g2int *ifld,*ifldmiss=0;
g2int *gref,*gwidth,*glen;
g2int itype,ngroups,nbitsgref,nbitsgwidth,nbitsglen;
g2int msng1,msng2;
g2float ref,bscale,dscale,rmiss1,rmiss2;
g2int totBit, totLen;
/*printf('IDRSTMPL: ',(idrstmpl(j),j=1,16)*/
g2_rdieee(idrstmpl+0,&ref,1);
/* printf("SAGTref: %f\n",ref);*/
bscale = (g2float)int_power(2.0,idrstmpl[1]);
dscale = (g2float)int_power(10.0,-idrstmpl[2]);
nbitsgref = idrstmpl[3];
itype = idrstmpl[4];
ngroups = idrstmpl[9];
nbitsgwidth = idrstmpl[11];
nbitsglen = idrstmpl[15];
if (idrsnum == 3)
nbitsd=idrstmpl[17]*8;
/* Constant field*/
if (ngroups == 0) {
for (j=0;j<ndpts;j++) fld[j]=ref;
return(0);
}
iofst=0;
ifld=(g2int *)calloc(ndpts,sizeof(g2int));
/*printf("ALLOC ifld: %d %x\n",(int)ndpts,ifld);*/
gref=(g2int *)calloc(ngroups,sizeof(g2int));
/*printf("ALLOC gref: %d %x\n",(int)ngroups,gref);*/
gwidth=(g2int *)calloc(ngroups,sizeof(g2int));
/*printf("ALLOC gwidth: %d %x\n",(int)ngroups,gwidth);*/
/*
// Get missing values, if supplied
*/
if ( idrstmpl[6] == 1 ) {
if (itype == 0)
g2_rdieee(idrstmpl+7,&rmiss1,1);
else
rmiss1=(g2float)idrstmpl[7];
}
if ( idrstmpl[6] == 2 ) {
if (itype == 0) {
g2_rdieee(idrstmpl+7,&rmiss1,1);
g2_rdieee(idrstmpl+8,&rmiss2,1);
}
else {
rmiss1=(g2float)idrstmpl[7];
rmiss2=(g2float)idrstmpl[8];
}
}
/*printf("RMISSs: %f %f %f \n",rmiss1,rmiss2,ref);*/
/*
// Extract Spatial differencing values, if using DRS Template 5.3
*/
if (idrsnum == 3) {
if (nbitsd != 0) {
gbit(cpack,&isign,iofst,1);
iofst=iofst+1;
gbit(cpack,&ival1,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
if (isign == 1) ival1=-ival1;
if (idrstmpl[16] == 2) {
gbit(cpack,&isign,iofst,1);
iofst=iofst+1;
gbit(cpack,&ival2,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
if (isign == 1) ival2=-ival2;
}
gbit(cpack,&isign,iofst,1);
iofst=iofst+1;
gbit(cpack,&minsd,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
if (isign == 1) minsd=-minsd;
}
else {
ival1=0;
ival2=0;
minsd=0;
}
/*printf("SDu %ld %ld %ld %ld \n",ival1,ival2,minsd,nbitsd);*/
}
/*
// Extract Each Group's reference value
*/
/*printf("SAG1: %ld %ld %ld \n",nbitsgref,ngroups,iofst);*/
if (nbitsgref != 0) {
gbits(cpack,gref+0,iofst,nbitsgref,0,ngroups);
itemp=nbitsgref*ngroups;
iofst=iofst+itemp;
if (itemp%8 != 0) iofst=iofst+(8-(itemp%8));
}
else {
for (j=0;j<ngroups;j++)
gref[j]=0;
}
/*
// Extract Each Group's bit width
*/
/*printf("SAG2: %ld %ld %ld %ld \n",nbitsgwidth,ngroups,iofst,idrstmpl[10]);*/
if (nbitsgwidth != 0) {
gbits(cpack,gwidth+0,iofst,nbitsgwidth,0,ngroups);
itemp=nbitsgwidth*ngroups;
iofst=iofst+itemp;
if (itemp%8 != 0) iofst=iofst+(8-(itemp%8));
}
else {
for (j=0;j<ngroups;j++)
gwidth[j]=0;
}
for (j=0;j<ngroups;j++)
gwidth[j]=gwidth[j]+idrstmpl[10];
/*
// Extract Each Group's length (number of values in each group)
*/
glen=(g2int *)calloc(ngroups,sizeof(g2int));
/*printf("ALLOC glen: %d %x\n",(int)ngroups,glen);*/
/*printf("SAG3: %ld %ld %ld %ld %ld \n",nbitsglen,ngroups,iofst,idrstmpl[13],idrstmpl[12]);*/
if (nbitsglen != 0) {
gbits(cpack,glen,iofst,nbitsglen,0,ngroups);
itemp=nbitsglen*ngroups;
iofst=iofst+itemp;
if (itemp%8 != 0) iofst=iofst+(8-(itemp%8));
}
else {
for (j=0;j<ngroups;j++)
glen[j]=0;
}
for (j=0;j<ngroups;j++)
glen[j]=(glen[j]*idrstmpl[13])+idrstmpl[12];
glen[ngroups-1]=idrstmpl[14];
/*
// Test to see if the group widths and lengths are consistent with number of
// values, and length of section 7.
*/
totBit = 0;
totLen = 0;
for (j=0;j<ngroups;j++) {
totBit += (gwidth[j]*glen[j]);
totLen += glen[j];
}
if (totLen != ndpts) {
return 1;
}
if (totBit / 8. > lensec) {
return 1;
}
/*
// For each group, unpack data values
*/
if ( idrstmpl[6] == 0 ) { /* no missing values*/
n=0;
for (j=0;j<ngroups;j++) {
if (gwidth[j] != 0) {
gbits(cpack,ifld+n,iofst,gwidth[j],0,glen[j]);
for (k=0;k<glen[j];k++) {
ifld[n]=ifld[n]+gref[j];
n=n+1;
}
}
else {
for (l=n;l<n+glen[j];l++) ifld[l]=gref[j];
n=n+glen[j];
}
iofst=iofst+(gwidth[j]*glen[j]);
}
}
else if ( idrstmpl[6]==1 || idrstmpl[6]==2 ) {
/* missing values included*/
ifldmiss=(g2int *)malloc(ndpts*sizeof(g2int));
/*printf("ALLOC ifldmiss: %d %x\n",(int)ndpts,ifldmiss);*/
/*for (j=0;j<ndpts;j++) ifldmiss[j]=0;*/
n=0;
non=0;
for (j=0;j<ngroups;j++) {
/*printf(" SAGNGP %d %d %d %d\n",j,gwidth[j],glen[j],gref[j]);*/
if (gwidth[j] != 0) {
msng1=(g2int)int_power(2.0,gwidth[j])-1;
msng2=msng1-1;
gbits(cpack,ifld+n,iofst,gwidth[j],0,glen[j]);
iofst=iofst+(gwidth[j]*glen[j]);
for (k=0;k<glen[j];k++) {
if (ifld[n] == msng1) {
ifldmiss[n]=1;
/*ifld[n]=0;*/
}
else if (idrstmpl[6]==2 && ifld[n]==msng2) {
ifldmiss[n]=2;
/*ifld[n]=0;*/
}
else {
ifldmiss[n]=0;
ifld[non++]=ifld[n]+gref[j];
}
n++;
}
}
else {
msng1=(g2int)int_power(2.0,nbitsgref)-1;
msng2=msng1-1;
if (gref[j] == msng1) {
for (l=n;l<n+glen[j];l++) ifldmiss[l]=1;
}
else if (idrstmpl[6]==2 && gref[j]==msng2) {
for (l=n;l<n+glen[j];l++) ifldmiss[l]=2;
}
else {
for (l=n;l<n+glen[j];l++) ifldmiss[l]=0;
for (l=non;l<non+glen[j];l++) ifld[l]=gref[j];
non += glen[j];
}
n=n+glen[j];
}
}
}
if ( gref != 0 ) free(gref);
if ( gwidth != 0 ) free(gwidth);
if ( glen != 0 ) free(glen);
/*
// If using spatial differences, add overall min value, and
// sum up recursively
*/
/*printf("SAGod: %ld %ld\n",idrsnum,idrstmpl[16]);*/
if (idrsnum == 3) { /* spatial differencing*/
if (idrstmpl[16] == 1) { /* first order*/
ifld[0]=ival1;
if ( idrstmpl[6] == 0 ) itemp=ndpts; /* no missing values*/
else itemp=non;
for (n=1;n<itemp;n++) {
ifld[n]=ifld[n]+minsd;
ifld[n]=ifld[n]+ifld[n-1];
}
}
else if (idrstmpl[16] == 2) { /* second order*/
ifld[0]=ival1;
ifld[1]=ival2;
if ( idrstmpl[6] == 0 ) itemp=ndpts; /* no missing values*/
else itemp=non;
for (n=2;n<itemp;n++) {
ifld[n]=ifld[n]+minsd;
ifld[n]=ifld[n]+(2*ifld[n-1])-ifld[n-2];
}
}
}
/*
// Scale data back to original form
*/
/*printf("SAGT: %f %f %f\n",ref,bscale,dscale);*/
if ( idrstmpl[6] == 0 ) { /* no missing values*/
for (n=0;n<ndpts;n++) {
fld[n]=(((g2float)ifld[n]*bscale)+ref)*dscale;
}
}
else if ( idrstmpl[6]==1 || idrstmpl[6]==2 ) {
/* missing values included*/
non=0;
for (n=0;n<ndpts;n++) {
if ( ifldmiss[n] == 0 ) {
fld[n]=(((g2float)ifld[non++]*bscale)+ref)*dscale;
/*printf(" SAG %d %f %d %f %f %f\n",n,fld[n],ifld[non-1],bscale,ref,dscale);*/
}
else if ( ifldmiss[n] == 1 )
fld[n]=rmiss1;
else if ( ifldmiss[n] == 2 )
fld[n]=rmiss2;
}
if ( ifldmiss != 0 ) free(ifldmiss);
}
if ( ifld != 0 ) free(ifld);
return(0);
}
void p_model(BOOL print_head)
{
Symbol_data p;
int n = Domain_size;
if (print_head) {
print_separator(stdout, "MODEL", TRUE);
printf("\n%% Model %d at %.2f seconds.\n",
Total_models, user_seconds());
}
for (p = Symbols; p != NULL; p = p->next) {
char *name = sn_to_str(p->sn);
if (p->attribute != EQUALITY_SYMBOL) {
/* This prints both relations and functions. */
if (p->arity == 0) {
int v = f0_val(p->base);
if (v < 0)
printf("\n %s : -\n", name);
else
printf("\n %s : %d\n", name, v);
}
else if (p->arity == 1) {
char *s1 = n <= 10 ? "%2d" : "%3d";
char *s2 = n <= 10 ? "--" : "---";
char *s3 = n <= 10 ? " -" : " -";
int i;
for (i = 0; i < n; i++) {
printf("\n %s :\n", name);
printf(" ");
for (i = 0; i < n; i++)
printf(s1, i);
printf("\n ---");
for (i = 0; i < n; i++)
printf(s2);
printf("\n ");
for (i = 0; i < n; i++) {
int v = f1_val(p->base, i);
if (v < 0)
printf(s3);
else
printf(s1, v);
}
printf("\n");
}
}
else if (p->arity == 2) {
char *s1 = n <= 10 ? "%2d" : "%3d";
char *s2 = n <= 10 ? "--" : "---";
char *s3 = n <= 10 ? " -" : " -";
int i, j;
printf("\n %s :\n", name);
printf(" |");
for (i = 0; i < n; i++)
printf(s1, i);
printf("\n --+");
for (i = 0; i < n; i++)
printf(s2);
printf("\n");
for (i = 0; i < n; i++) {
printf("%5d |", i);
for (j = 0; j < n; j++) {
int v = f2_val(p->base, i, j);
if (v < 0)
printf(s3);
else
printf(s1, v);
}
printf("\n");
}
}
else {
int n = int_power(Domain_size, p->arity);
int i;
Variable_style save_style = variable_style();
set_variable_style(INTEGER_STYLE);
for (i = 0; i < n; i++) {
int id = p->base + i;
fwrite_term(stdout, Cells[id].eterm);
if (Cells[id].value == NULL)
printf(" = -.\n");
else
printf(" = %d.\n", VARNUM(Cells[id].value));
}
set_variable_style(save_style);
}
}
}
if (print_head)
print_separator(stdout, "end of model", TRUE);
} /* p_model */
void extend_representation (struct pcp_vars *pcp)
{
register int *y = y_address;
int *expand; /* array to store p-adic expansion */
register int rank = y[pcp->clend + pcp->cc];
register int i, j, gen, sum;
int bound;
int **M;
int index;
int *powers; /* store powers of p to avoid recomputation */
register int p = pcp->p;
int cp = pcp->lused;
int ptr;
bound = int_power (p, rank);
/* set up room to store p-adic expansion and powers of p */
expand = allocate_vector (rank, 0, TRUE);
powers = allocate_vector (rank, 0, FALSE);
for (i = 0; i < rank; ++i)
powers[i] = int_power (p, i);
/* set up matrix to store results */
M = allocate_matrix (bound, 2 * pcp->ndgen, 0, FALSE);
for (i = 0; i < bound; ++i) {
/* find the p-adic expansion of i */
compute_padic (powers, i, rank - 1, p, expand);
/* now process each defining generator and its inverse in turn */
for (gen = -pcp->ndgen; gen <= pcp->ndgen; ++gen) {
if (gen == 0) continue;
/* now copy p-adic expansion to y */
for (j = 0; j < rank; ++j)
y[cp + j + 1] = expand[j];
#if defined (DEBUG)
printf ("processing generator %d \n", gen);
printf ("Stored p-adic expansion for %d in y is ", i);
for (j = 1; j <= pcp->lastg; ++j) {
printf ("%d ", y[cp + j]);
}
printf ("\n");
#endif
/* look up image of gen which is stored as a generator-exponent
string in y; post-multiply the p-adic expansion by this image */
ptr = y[pcp->dgen + gen];
if (ptr != 0)
collect (ptr, cp, pcp);
#if defined (DEBUG)
printf ("result of collection is ");
for (j = 1; j <= pcp->lastg; ++j) {
printf ("%d ", y[cp + j]);
}
printf ("\n");
#endif
/* store the result of the multiplication */
sum = 0;
for (j = 1; j <= pcp->lastg; ++j)
sum += (y[cp + j] * powers[j - 1]);
index = (gen < 0) ? 2 * (-gen) - 1: 2 * gen - 2;
M[i][index] = sum;
}
for (j = 0; j < rank; ++j)
expand[j] = 0;
}
printf ("The extension matrix is\n");
print_matrix (M, bound, 2 * pcp->ndgen);
free_vector (expand, 0);
free_vector (powers, 0);
free_matrix (M, bound, 0);
}
g2int jpcunpack(unsigned char *cpack,g2int len,g2int *idrstmpl,g2int ndpts,
g2float *fld)
//$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: jpcunpack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2003-08-27
//
// ABSTRACT: This subroutine unpacks a data field that was packed into a
// JPEG2000 code stream
// using info from the GRIB2 Data Representation Template 5.40 or 5.40000.
//
// PROGRAM HISTORY LOG:
// 2003-08-27 Gilbert
//
// USAGE: jpcunpack(unsigned char *cpack,g2int len,g2int *idrstmpl,g2int ndpts,
// g2float *fld)
// INPUT ARGUMENT LIST:
// cpack - The packed data field (character*1 array)
// len - length of packed field cpack().
// idrstmpl - Pointer to array of values for Data Representation
// Template 5.40 or 5.40000
// ndpts - The number of data values to unpack
//
// OUTPUT ARGUMENT LIST:
// fld[] - Contains the unpacked data values
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE: IBM SP
//
//$$$
{
g2int *ifld;
g2int j,nbits,iret;
g2float ref,bscale,dscale;
rdieee(idrstmpl+0,&ref,1);
bscale = int_power(2.0,idrstmpl[1]);
dscale = int_power(10.0,-idrstmpl[2]);
nbits = idrstmpl[3];
//
// if nbits equals 0, we have a constant field where the reference value
// is the data value at each gridpoint
//
if (nbits != 0) {
ifld=(g2int *)calloc(ndpts,sizeof(g2int));
if ( ifld == 0 ) {
// fprintf(stderr,"Could not allocate space in jpcunpack.\n Data field NOT upacked.\n");
return(1);
}
iret=(g2int)dec_jpeg2000(cpack,len,ifld);
for (j=0;j<ndpts;j++) {
fld[j]=(((g2float)ifld[j]*bscale)+ref)*dscale;
}
free(ifld);
}
else {
for (j=0;j<ndpts;j++) fld[j]=ref;
}
return(0);
}
void misspack(g2float *fld,g2int ndpts,g2int idrsnum,g2int *idrstmpl,
unsigned char *cpack, g2int *lcpack)
/*$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: misspack
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-06-21
//
// ABSTRACT: This subroutine packs up a data field using a complex
// packing algorithm as defined in the GRIB2 documention. It
// supports GRIB2 complex packing templates with or without
// spatial differences (i.e. DRTs 5.2 and 5.3).
// It also fills in GRIB2 Data Representation Template 5.2 or 5.3
// with the appropriate values.
// This version assumes that Missing Value Management is being used and that
// 1 or 2 missing values appear in the data.
//
// PROGRAM HISTORY LOG:
// 2000-06-21 Gilbert
//
// USAGE: misspack(g2float *fld,g2int ndpts,g2int idrsnum,g2int *idrstmpl,
// unsigned char *cpack, g2int *lcpack)
// INPUT ARGUMENT LIST:
// fld[] - Contains the data values to pack
// ndpts - The number of data values in array fld[]
// idrsnum - Data Representation Template number 5.N
// Must equal 2 or 3.
// idrstmpl - Contains the array of values for Data Representation
// Template 5.2 or 5.3
// [0] = Reference value - ignored on input
// [1] = Binary Scale Factor
// [2] = Decimal Scale Factor
// .
// .
// [6] = Missing value management
// [7] = Primary missing value
// [8] = Secondary missing value
// .
// .
// [16] = Order of Spatial Differencing ( 1 or 2 )
// .
// .
//
// OUTPUT ARGUMENT LIST:
// idrstmpl - Contains the array of values for Data Representation
// Template 5.3
// [0] = Reference value - set by misspack routine.
// [1] = Binary Scale Factor - unchanged from input
// [2] = Decimal Scale Factor - unchanged from input
// .
// .
// cpack - The packed data field (character*1 array)
// *lcpack - length of packed field cpack().
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE:
//
//$$$*/
{
g2int *ifld, *ifldmiss, *jfld;
g2int *jmin, *jmax, *lbit;
static g2int zero=0;
g2int *gref, *gwidth, *glen;
g2int glength, grpwidth;
g2int i, n, iofst, imin, ival1, ival2, isd, minsd, nbitsd;
g2int nbitsgref, left, iwmax, ngwidthref, nbitsgwidth, ilmax;
g2int nglenref, nglenlast, nbitsglen, ij;
g2int j, missopt, nonmiss, itemp, maxorig, nbitorig, miss1, miss2;
g2int ngroups, ng, num0, num1, num2;
g2int imax, lg, mtemp, ier, igmax;
g2int kfildo, minpk, inc, maxgrps, ibit, jbit, kbit, novref, lbitref;
g2float rmissp, rmisss, bscale, dscale, rmin, temp;
static g2int simple_alg = 0;
static g2float alog2=0.69314718; /* ln(2.0) */
static g2int one=1;
bscale=int_power(2.0,-idrstmpl[1]);
dscale=int_power(10.0,idrstmpl[2]);
missopt=idrstmpl[6];
if ( missopt != 1 && missopt != 2 ) {
printf("misspack: Unrecognized option.\n");
*lcpack=-1;
return;
}
else { /* Get missing values */
g2_rdieee(idrstmpl+7,&rmissp,1);
if (missopt == 2) g2_rdieee(idrstmpl+8,&rmisss,1);
}
/*
// Find min value of non-missing values in the data,
// AND set up missing value mapping of the field.
*/
ifldmiss = calloc(ndpts,sizeof(g2int));
rmin=1E+37;
if ( missopt == 1 ) { /* Primary missing value only */
for ( j=0; j<ndpts; j++) {
if (fld[j] == rmissp) {
ifldmiss[j]=1;
}
else {
ifldmiss[j]=0;
if (fld[j] < rmin) rmin=fld[j];
}
}
}
if ( missopt == 2 ) { /* Primary and secondary missing values */
for ( j=0; j<ndpts; j++ ) {
if (fld[j] == rmissp) {
ifldmiss[j]=1;
}
else if (fld[j] == rmisss) {
ifldmiss[j]=2;
}
else {
ifldmiss[j]=0;
if (fld[j] < rmin) rmin=fld[j];
}
}
}
/*
// Allocate work arrays:
// Note: -ifldmiss[j],j=0,ndpts-1 is a map of original field indicating
// which of the original data values
// are primary missing (1), sencondary missing (2) or non-missing (0).
// -jfld[j],j=0,nonmiss-1 is a subarray of just the non-missing values
// from the original field.
*/
/*if (rmin != rmax) { */
iofst=0;
ifld = calloc(ndpts,sizeof(g2int));
jfld = calloc(ndpts,sizeof(g2int));
gref = calloc(ndpts,sizeof(g2int));
gwidth = calloc(ndpts,sizeof(g2int));
glen = calloc(ndpts,sizeof(g2int));
/*
// Scale original data
*/
nonmiss=0;
if (idrstmpl[1] == 0) { /* No binary scaling */
imin=(g2int)rint(rmin*dscale);
/*imax=(g2int)rint(rmax*dscale); */
rmin=(g2float)imin;
for ( j=0; j<ndpts; j++) {
if (ifldmiss[j] == 0) {
jfld[nonmiss]=(g2int)rint(fld[j]*dscale)-imin;
nonmiss++;
}
}
}
else { /* Use binary scaling factor */
rmin=rmin*dscale;
/*rmax=rmax*dscale; */
for ( j=0; j<ndpts; j++ ) {
if (ifldmiss[j] == 0) {
jfld[nonmiss]=(g2int)rint(((fld[j]*dscale)-rmin)*bscale);
nonmiss++;
}
}
}
/*
// Calculate Spatial differences, if using DRS Template 5.3
*/
if (idrsnum == 3) { /* spatial differences */
if (idrstmpl[16]!=1 && idrstmpl[16]!=2) idrstmpl[16]=2;
if (idrstmpl[16] == 1) { /* first order */
ival1=jfld[0];
for ( j=nonmiss-1; j>0; j--)
jfld[j]=jfld[j]-jfld[j-1];
jfld[0]=0;
}
else if (idrstmpl[16] == 2) { /* second order */
ival1=jfld[0];
ival2=jfld[1];
for ( j=nonmiss-1; j>1; j--)
jfld[j]=jfld[j]-(2*jfld[j-1])+jfld[j-2];
jfld[0]=0;
jfld[1]=0;
}
/*
// subtract min value from spatial diff field
*/
isd=idrstmpl[16];
minsd=jfld[isd];
for ( j=isd; j<nonmiss; j++ ) if ( jfld[j] < minsd ) minsd=jfld[j];
for ( j=isd; j<nonmiss; j++ ) jfld[j]=jfld[j]-minsd;
/*
// find num of bits need to store minsd and add 1 extra bit
// to indicate sign
*/
temp=log((double)(abs(minsd)+1))/alog2;
nbitsd=(g2int)ceil(temp)+1;
/*
// find num of bits need to store ifld[0] ( and ifld[1]
// if using 2nd order differencing )
*/
maxorig=ival1;
if (idrstmpl[16]==2 && ival2>ival1) maxorig=ival2;
temp=log((double)(maxorig+1))/alog2;
nbitorig=(g2int)ceil(temp)+1;
if (nbitorig > nbitsd) nbitsd=nbitorig;
/* increase number of bits to even multiple of 8 ( octet ) */
if ( (nbitsd%8) != 0) nbitsd=nbitsd+(8-(nbitsd%8));
/*
// Store extra spatial differencing info into the packed
// data section.
*/
if (nbitsd != 0) {
/* pack first original value */
if (ival1 >= 0) {
sbit(cpack,&ival1,iofst,nbitsd);
iofst=iofst+nbitsd;
}
else {
sbit(cpack,&one,iofst,1);
iofst=iofst+1;
itemp=abs(ival1);
sbit(cpack,&itemp,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
}
if (idrstmpl[16] == 2) {
/* pack second original value */
if (ival2 >= 0) {
sbit(cpack,&ival2,iofst,nbitsd);
iofst=iofst+nbitsd;
}
else {
sbit(cpack,&one,iofst,1);
iofst=iofst+1;
itemp=abs(ival2);
sbit(cpack,&itemp,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
}
}
/* pack overall min of spatial differences */
if (minsd >= 0) {
sbit(cpack,&minsd,iofst,nbitsd);
iofst=iofst+nbitsd;
}
else {
sbit(cpack,&one,iofst,1);
iofst=iofst+1;
itemp=abs(minsd);
sbit(cpack,&itemp,iofst,nbitsd-1);
iofst=iofst+nbitsd-1;
}
}
/*print *,'SDp ',ival1,ival2,minsd,nbitsd*/
} /* end of spatial diff section */
/*
// Expand non-missing data values to original grid.
*/
miss1=jfld[0];
for ( j=0; j<nonmiss; j++) if (jfld[j] < miss1) miss1 = jfld[j];
miss1--;
miss2=miss1-1;
n=0;
for ( j=0; j<ndpts; j++) {
if ( ifldmiss[j] == 0 ) {
ifld[j]=jfld[n];
n++;
}
else if ( ifldmiss[j] == 1 ) {
ifld[j]=miss1;
}
else if ( ifldmiss[j] == 2 ) {
ifld[j]=miss2;
}
}
/*
// Determine Groups to be used.
*/
if ( simple_alg == 1 ) {
/* set group length to 10 : calculate number of groups */
/* and length of last group */
ngroups=ndpts/10;
for (j=0;j<ngroups;j++) glen[j]=10;
itemp=ndpts%10;
if (itemp != 0) {
ngroups++;
glen[ngroups-1]=itemp;
}
}
else {
/* Use Dr. Glahn's algorithm for determining grouping.
*/
kfildo=6;
minpk=10;
inc=1;
maxgrps=(ndpts/minpk)+1;
jmin = calloc(maxgrps,sizeof(g2int));
jmax = calloc(maxgrps,sizeof(g2int));
lbit = calloc(maxgrps,sizeof(g2int));
g2_pack_gp(&kfildo,ifld,&ndpts,&missopt,&minpk,&inc,&miss1,&miss2,
jmin,jmax,lbit,glen,&maxgrps,&ngroups,&ibit,&jbit,
&kbit,&novref,&lbitref,&ier);
/*printf("SAGier = %d %d %d %d %d %d\n",ier,ibit,jbit,kbit,novref,lbitref);*/
for ( ng=0; ng<ngroups; ng++) glen[ng]=glen[ng]+novref;
free(jmin);
free(jmax);
free(lbit);
}
/*
// For each group, find the group's reference value (min)
// and the number of bits needed to hold the remaining values
*/
n=0;
for ( ng=0; ng<ngroups; ng++) {
/* how many of each type? */
num0=num1=num2=0;
for (j=n; j<n+glen[ng]; j++) {
if (ifldmiss[j] == 0 ) num0++;
if (ifldmiss[j] == 1 ) num1++;
if (ifldmiss[j] == 2 ) num2++;
}
if ( num0 == 0 ) { /* all missing values */
if ( num1 == 0 ) { /* all secondary missing */
gref[ng]=-2;
gwidth[ng]=0;
}
else if ( num2 == 0 ) { /* all primary missing */
gref[ng]=-1;
gwidth[ng]=0;
}
else { /* both primary and secondary */
gref[ng]=0;
gwidth[ng]=1;
}
}
else { /* contains some non-missing data */
/* find max and min values of group */
gref[ng]=2147483647;
imax=-2147483647;
j=n;
for ( lg=0; lg<glen[ng]; lg++ ) {
if ( ifldmiss[j] == 0 ) {
if (ifld[j] < gref[ng]) gref[ng]=ifld[j];
if (ifld[j] > imax) imax=ifld[j];
}
j++;
}
if (missopt == 1) imax=imax+1;
if (missopt == 2) imax=imax+2;
/* calc num of bits needed to hold data */
if ( gref[ng] != imax ) {
temp=log((double)(imax-gref[ng]+1))/alog2;
gwidth[ng]=(g2int)ceil(temp);
}
else {
gwidth[ng]=0;
}
}
/* Subtract min from data */
j=n;
mtemp=(g2int)int_power(2.,gwidth[ng]);
for ( lg=0; lg<glen[ng]; lg++ ) {
if (ifldmiss[j] == 0) /* non-missing */
ifld[j]=ifld[j]-gref[ng];
else if (ifldmiss[j] == 1) /* primary missing */
ifld[j]=mtemp-1;
else if (ifldmiss[j] == 2) /* secondary missing */
ifld[j]=mtemp-2;
j++;
}
/* increment fld array counter */
n=n+glen[ng];
}
/*
// Find max of the group references and calc num of bits needed
// to pack each groups reference value, then
// pack up group reference values
*/
/*printf(" GREFS: "); */
/*for (j=0;j<ngroups;j++) printf(" %d",gref[j]); printf("\n"); */
igmax=gref[0];
for (j=1;j<ngroups;j++) if (gref[j] > igmax) igmax=gref[j];
if (missopt == 1) igmax=igmax+1;
if (missopt == 2) igmax=igmax+2;
if (igmax != 0) {
temp=log((double)(igmax+1))/alog2;
nbitsgref=(g2int)ceil(temp);
/* reset the ref values of any "missing only" groups. */
mtemp=(g2int)int_power(2.,nbitsgref);
for ( j=0; j<ngroups; j++ ) {
if (gref[j] == -1) gref[j]=mtemp-1;
if (gref[j] == -2) gref[j]=mtemp-2;
}
sbits(cpack,gref,iofst,nbitsgref,0,ngroups);
itemp=nbitsgref*ngroups;
iofst=iofst+itemp;
/* Pad last octet with Zeros, if necessary, */
if ( (itemp%8) != 0) {
left=8-(itemp%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
}
else {
nbitsgref=0;
}
/*
// Find max/min of the group widths and calc num of bits needed
// to pack each groups width value, then
// pack up group width values
*/
/*write(77,*)'GWIDTHS: ',(gwidth(j),j=1,ngroups)*/
iwmax=gwidth[0];
ngwidthref=gwidth[0];
for (j=1;j<ngroups;j++) {
if (gwidth[j] > iwmax) iwmax=gwidth[j];
if (gwidth[j] < ngwidthref) ngwidthref=gwidth[j];
}
if (iwmax != ngwidthref) {
temp=log((double)(iwmax-ngwidthref+1))/alog2;
nbitsgwidth=(g2int)ceil(temp);
for ( i=0; i<ngroups; i++) gwidth[i]=gwidth[i]-ngwidthref;
sbits(cpack,gwidth,iofst,nbitsgwidth,0,ngroups);
itemp=nbitsgwidth*ngroups;
iofst=iofst+itemp;
/* Pad last octet with Zeros, if necessary,*/
if ( (itemp%8) != 0) {
left=8-(itemp%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
}
else {
nbitsgwidth=0;
for (i=0;i<ngroups;i++) gwidth[i]=0;
}
/*
// Find max/min of the group lengths and calc num of bits needed
// to pack each groups length value, then
// pack up group length values
*/
/*printf(" GLENS: ");*/
/*for (j=0;j<ngroups;j++) printf(" %d",glen[j]); printf("\n");*/
ilmax=glen[0];
nglenref=glen[0];
for (j=1;j<ngroups-1;j++) {
if (glen[j] > ilmax) ilmax=glen[j];
if (glen[j] < nglenref) nglenref=glen[j];
}
nglenlast=glen[ngroups-1];
if (ilmax != nglenref) {
temp=log((double)(ilmax-nglenref+1))/alog2;
nbitsglen=(g2int)ceil(temp);
for ( i=0; i<ngroups-1; i++) glen[i]=glen[i]-nglenref;
sbits(cpack,glen,iofst,nbitsglen,0,ngroups);
itemp=nbitsglen*ngroups;
iofst=iofst+itemp;
/* Pad last octet with Zeros, if necessary,*/
if ( (itemp%8) != 0) {
left=8-(itemp%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
}
else {
nbitsglen=0;
for (i=0;i<ngroups;i++) glen[i]=0;
}
/*
// For each group, pack data values
*/
/*write(77,*)'IFLDS: ',(ifld(j),j=1,ndpts)*/
n=0;
ij=0;
for ( ng=0; ng<ngroups; ng++) {
glength=glen[ng]+nglenref;
if (ng == (ngroups-1) ) glength=nglenlast;
grpwidth=gwidth[ng]+ngwidthref;
/*write(77,*)'NGP ',ng,grpwidth,glength,gref(ng)*/
if ( grpwidth != 0 ) {
sbits(cpack,ifld+n,iofst,grpwidth,0,glength);
iofst=iofst+(grpwidth*glength);
}
/* do kk=1,glength*/
/* ij=ij+1*/
/*write(77,*)'SAG ',ij,fld(ij),ifld(ij),gref(ng),bscale,rmin,dscale*/
/* enddo*/
n=n+glength;
}
/* Pad last octet with Zeros, if necessary,*/
if ( (iofst%8) != 0) {
left=8-(iofst%8);
sbit(cpack,&zero,iofst,left);
iofst=iofst+left;
}
*lcpack=iofst/8;
if ( ifld != 0 ) free(ifld);
free(jfld);
if ( ifldmiss != 0 ) free(ifldmiss);
free(gref);
free(gwidth);
free(glen);
/*}
//else { // Constant field ( max = min )
// nbits=0;
// *lcpack=0;
// nbitsgref=0;
// ngroups=0;
}*/
/*
// Fill in ref value and number of bits in Template 5.2
*/
mkieee(&rmin,idrstmpl+0,1); /* ensure reference value is IEEE format*/
idrstmpl[3]=nbitsgref;
idrstmpl[4]=0; /* original data were reals*/
idrstmpl[5]=1; /* general group splitting*/
idrstmpl[9]=ngroups; /* Number of groups*/
idrstmpl[10]=ngwidthref; /* reference for group widths*/
idrstmpl[11]=nbitsgwidth; /* num bits used for group widths*/
idrstmpl[12]=nglenref; /* Reference for group lengths*/
idrstmpl[13]=1; /* length increment for group lengths*/
idrstmpl[14]=nglenlast; /* True length of last group*/
idrstmpl[15]=nbitsglen; /* num bits used for group lengths*/
if (idrsnum == 3) {
idrstmpl[17]=nbitsd/8; /* num bits used for extra spatial*/
/* differencing values*/
}
}
void Helper::rdieee(g2int *rieee,g2float *a,g2int num)
//$$$ SUBPROGRAM DOCUMENTATION BLOCK
// . . . .
// SUBPROGRAM: rdieee
// PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-10-25
//
// ABSTRACT: This subroutine reads a list of real values in
// 32-bit IEEE floating point format.
//
// PROGRAM HISTORY LOG:
// 2002-10-25 Gilbert
//
// USAGE: void rdieee(g2int *rieee,g2float *a,g2int num)
// INPUT ARGUMENT LIST:
// rieee - g2int array of floating point values in 32-bit IEEE format.
// num - Number of floating point values to convert.
//
// OUTPUT ARGUMENT LIST:
// a - float array of real values. a must be allocated with at
// least 4*num bytes of memory before calling this function.
//
// REMARKS: None
//
// ATTRIBUTES:
// LANGUAGE: C
// MACHINE: IBM SP
//
//$$$
{
wxUint16 j;
wxInt32 isign,iexp,imant;
wxFloat32 sign,temp;
static wxFloat32 two23,two126;
static wxUint16 test=0;
wxInt32 msk1=0x80000000; // 10000000000000000000000000000000 binary
wxInt32 msk2=0x7F800000; // 01111111100000000000000000000000 binary
wxInt32 msk3=0x007FFFFF; // 00000000011111111111111111111111 binary
if ( test == 0 ) {
two23=(wxFloat32)int_power(2.0,-23);
two126=(wxFloat32)int_power(2.0,-126);
test=1;
}
for (j=0;j<num;j++) {
//
// Extract sign bit, exponent, and mantissa
//
isign=(rieee[j]&msk1)>>31;
iexp=(rieee[j]&msk2)>>23;
imant=(rieee[j]&msk3);
// wxLogMessage(wxString::Format(_T("SAGieee= %d %d %d\n"),isign,iexp,imant));
sign=1.0;
if (isign == -1) sign=-1.0;
if ( (iexp > 0) && (iexp < 255) ) {
temp=(wxFloat32)int_power(2.0,(iexp-127));
a[j]=sign*temp*(1.0+(two23*(wxFloat32)imant));
}
else if ( iexp == 0 ) {
if ( imant != 0 )
a[j]=sign*two126*two23*(wxFloat32)imant;
else
a[j]=sign*0.0;
}
else if ( iexp == 255 )
a[j]=sign*(1E+37);
// wxLogMessage(wxString::Format(_T("%f\n"),a[j]));
}
}