static INT SetUnsymmetric (MULTIGRID *mg, INT fl, INT tl, const VECDATA_DESC *x, INT xclass, INT index)
{
SHORT i,j;
INT vtype;
INT lev;
for (lev=fl; lev<=tl; lev++)
l_setindex(GRID_ON_LEVEL(mg,lev));
j = 0;
for (vtype=0; vtype<NVECTYPES; vtype++)
if (VD_ISDEF_IN_TYPE(x,vtype))
{
SHORT ncomp = VD_NCMPS_IN_TYPE(x,vtype);
VECTOR *v;
DOUBLE_VECTOR pos;
A_VLOOP__TYPE_CLASS(lev,fl,tl,v,mg,vtype,xclass)
{
for (i=0; i<ncomp; i++)
VVALUE(v,VD_CMP_OF_TYPE(x,vtype,i)) = 0.0;
if (VECSKIP(v) != 0) continue;
if (j++ < index) continue;
if (VINDEX(v) % (index+2) == 0) continue;
VectorPosition(v,pos);
for (i=0; i<ncomp; i++)
VVALUE(v,VD_CMP_OF_TYPE(x,vtype,i)) = pos[i]+1.0/(1.0+index*VINDEX(v)*VINDEX(v));
}
}
#ifdef ModelP
if (a_vector_consistent(mg,fl,tl,x)) return(NUM_ERROR);
#endif
return (NUM_OK);
}
void __arc_init_fio(arc *c)
{
value io_ops;
io_ops = arc_mkvector(c, IO_last+1);
SVINDEX(io_ops, IO_closed_p, arc_mkaff(c, fio_closed_p, CNIL));
SVINDEX(io_ops, IO_ready, arc_mkaff(c, fio_ready, CNIL));
SVINDEX(io_ops, IO_wready, arc_mkaff(c, fio_wready, CNIL));
SVINDEX(io_ops, IO_getb, arc_mkaff(c, fio_getb, CNIL));
SVINDEX(io_ops, IO_putb, arc_mkaff(c, fio_putb, CNIL));
SVINDEX(io_ops, IO_seek, arc_mkaff(c, fio_seek, CNIL));
SVINDEX(io_ops, IO_tell, arc_mkaff(c, fio_tell, CNIL));
SVINDEX(io_ops, IO_close, arc_mkaff(c, fio_close, CNIL));
SVINDEX(VINDEX(c->builtins, BI_io), BI_io_fp, io_ops);
io_ops = arc_mkvector(c, IO_last+1);
SVINDEX(io_ops, IO_closed_p, arc_mkaff(c, fio_closed_p, CNIL));
SVINDEX(io_ops, IO_ready, arc_mkaff(c, fio_ready, CNIL));
SVINDEX(io_ops, IO_wready, arc_mkaff(c, fio_wready, CNIL));
SVINDEX(io_ops, IO_getb, arc_mkaff(c, fio_getb, CNIL));
SVINDEX(io_ops, IO_putb, arc_mkaff(c, fio_putb, CNIL));
SVINDEX(io_ops, IO_seek, arc_mkaff(c, fio_seek, CNIL));
SVINDEX(io_ops, IO_tell, arc_mkaff(c, fio_tell, CNIL));
SVINDEX(io_ops, IO_close, arc_mkaff(c, pio_close, CNIL));
SVINDEX(VINDEX(c->builtins, BI_io), BI_io_pfp, io_ops);
arc_bindsym(c, ARC_BUILTIN(c, S_STDIN_FD),
mkfio(c, T_INPORT, stdin, arc_mkstringc(c, "(stdin)")));
arc_bindsym(c, ARC_BUILTIN(c, S_STDOUT_FD),
mkfio(c, T_OUTPORT, stdout, arc_mkstringc(c, "(stdout)")));
arc_bindsym(c, ARC_BUILTIN(c, S_STDERR_FD),
mkfio(c, T_OUTPORT, stderr, arc_mkstringc(c, "(stderr)")));
}
/* add a word to the vocabulary */
static int add_word_to_vocabulary(char * text,
int start_pos, int end_pos,
char * vocab,
float * frequency)
{
int index,i,c;
int length = end_pos-start_pos;
if (length >= MAX_WORD_LENGTH-1) return 0;
if ((text[start_pos]>='a') && (text[start_pos]<='z')) {
index = (int)(text[start_pos]-'a');
}
else {
index = (int)(text[start_pos]-'A');
}
if (index >= 26) return 0;
i=0;
while (i < MAX_VOCAB_SIZE) {
if (vocab[VINDEX(index,i)]==0) break;
i++;
}
if (i < MAX_VOCAB_SIZE) {
for (c = 0; c < length; c++) {
vocab[VINDEX(index,i)+c] = tolower(text[start_pos+c]);
}
vocab[VINDEX(index,i)+c] = 0;
frequency[FINDEX(index,i)] = 1;
return 1;
}
return 0;
}
AFFEND
/* XXX - when a file handle opened by pipe-from is up for gc it uses
fclose instead of pclose! */
value arc_pipe_from(arc *c, value cmd)
{
FILE *fp;
int len;
char *cmdstr;
value ffp;
TYPECHECK(cmd, T_STRING);
len = FIX2INT(arc_strutflen(c, cmd));
cmdstr = (char *)alloca(sizeof(char)*(len+1));
arc_str2cstr(c, cmd, cmdstr);
fp = popen(cmdstr, "r");
if (fp == NULL) {
int en = errno;
arc_err_cstrfmt(c, "pipe-from: error executing command \"%s\", (%s; errno=%d)", cmdstr, strerror(en), en);
}
ffp = mkfio(c, T_INPORT, fp, cmd);
IO(ffp)->io_ops = VINDEX(VINDEX(c->builtins, BI_io), BI_io_pfp);
IO(ffp)->io_tfn = &procio_tfn;
return(ffp);
}
AFFEND
AFFDEF(arc_writeb)
{
AARG(byte);
AOARG(fd);
AFBEGIN;
if (arc_thr_argc(c, thr) == 0) {
arc_err_cstrfmt(c, "writeb: too few arguments");
return(CNIL);
}
if (!BOUND_P(AV(fd)))
STDOUT(fd);
IOW_TYPECHECK(AV(fd));
CHECK_CLOSED(AV(fd));
AFCALL(VINDEX(IO(AV(fd))->io_ops, IO_wready), AV(fd));
if (AFCRV == CNIL) {
arc_err_cstrfmt(c, "port is not ready for writing");
ARETURN(CNIL);
}
AFTCALL(VINDEX(IO(AV(fd))->io_ops, IO_putb), AV(fd), AV(byte));
AFEND;
}
AFFEND
static void hashtable_expand(arc *c, value hash)
{
unsigned int hv, index, i, j, nhashbits;
value oldtbl, newtbl, e;
nhashbits = HASH_BITS(hash) + 1;
newtbl = arc_mkvector(c, HASHSIZE(nhashbits));
((struct cell *)newtbl)->_type = T_TABLEVEC;
for (i=0; i<HASHSIZE(nhashbits); i++)
XVINDEX(newtbl, i) = CUNBOUND;
oldtbl = HASH_TABLE(hash);
/* Search for active keys and move them into the new table */
for (i=0; i<VECLEN(oldtbl); i++) {
e = VINDEX(oldtbl, i);
if (EMPTYP(e))
continue;
/* remove the old link now that we have a copy */
SVINDEX(oldtbl, i, CUNBOUND);
/* insert the old key into the new table */
hv = (unsigned int)FIX2INT(BHASHVAL(e));
index = hv & HASHMASK(nhashbits);
for (j=0; !EMPTYP(VINDEX(newtbl, index)); j++)
index = (index + PROBE(j)) & HASHMASK(nhashbits);
BTABLE(e) = newtbl;
XVINDEX(newtbl, index) = e;
SBINDEX(e, index); /* change index */
SVINDEX(oldtbl, i, CUNBOUND);
}
SET_HASHBITS(hash, nhashbits);
SET_LLIMIT(hash, (HASHSIZE(nhashbits)*MAX_LOAD_FACTOR) / 100);
HASH_TABLE(hash) = newtbl;
}
static arc_hs *decode_hs(arc *c, arc_hs *hs, value enc)
{
int i;
for (i=0; i<3; i++) {
hs->s[i] = ((unsigned long)(FIX2INT(VINDEX(enc, i*2)) & MASK)) |
(((unsigned long)((FIX2INT(VINDEX(enc, i*2+1))) & MASK)) << BITSHIFT);
}
hs->state = FIX2INT(VINDEX(enc, 6));
return(hs);
}
static void tablevec_sweeper(arc *c, value v)
{
int i;
/* Clear the BTABLE links for any active buckets within this tablevec
before fully sweeping it away. */
for (i=0; i<VECLEN(v); i++) {
if (EMPTYP(VINDEX(v, i)))
continue;
BTABLE(VINDEX(v, i)) = CNIL;
}
}
AFFEND
static value mkfio(arc *c, int type, FILE *fd, value name)
{
value fio;
fio = __arc_allocio(c, type, &fileio_tfn, sizeof(struct fileio_t));
IO(fio)->flags = 0;
IO(fio)->io_ops = VINDEX(VINDEX(c->builtins, BI_io), BI_io_fp);
IO(fio)->name = name;
FIODATA(fio)->closed = 0;
FIODATA(fio)->fp = fd;
return(fio);
}
/* sort the vocabulary into alphabetical order */
static void sort_vocabulary(char * vocab, float * frequency)
{
int i, j, k;
float freq;
char temp[MAX_WORD_LENGTH];
for (i = 0; i < 26; i++) {
for (j = 0; j < MAX_VOCAB_SIZE; j++) {
if (vocab[VINDEX(i,j)]==0) break;
for (k = j+1; k < MAX_VOCAB_SIZE; k++) {
if (vocab[VINDEX(i,k)]==0) break;
if (strcmp(&vocab[VINDEX(i,j)],
&vocab[VINDEX(i,k)]) > 0) {
/* swap word */
memcpy((void*)temp,(void*)&vocab[VINDEX(i,j)],
MAX_WORD_LENGTH*sizeof(char));
memcpy((void*)&vocab[VINDEX(i,j)],
(void*)&vocab[VINDEX(i,k)],
MAX_WORD_LENGTH*sizeof(char));
memcpy((void*)&vocab[VINDEX(i,k)], (void*)temp,
MAX_WORD_LENGTH*sizeof(char));
/* swap frequency */
freq = frequency[FINDEX(i,j)];
frequency[FINDEX(i,j)] = frequency[FINDEX(i,k)];
frequency[FINDEX(i,k)] = freq;
}
}
}
}
}
AFFEND
AFFDEF(arc_readc)
{
AOARG(fd);
AVAR(chr, buf, i, readb);
char cbuf[UTFmax]; /* this is always destroyed */
Rune ch;
int j;
AFBEGIN;
if (!BOUND_P(AV(fd)))
STDIN(fd);
IO_TYPECHECK(AV(fd));
CHECK_CLOSED(AV(fd));
if (IO(AV(fd))->ungetrune >= 0) {
ch = IO(AV(fd))->ungetrune;
IO(AV(fd))->ungetrune = -1;
ARETURN(arc_mkchar(c, ch));
}
if (IO(AV(fd))->flags & IO_FLAG_GETB_IS_GETC) {
AFCALL(VINDEX(IO(AV(fd))->io_ops, IO_getb), AV(fd));
if (NIL_P(AFCRV))
ARETURN(CNIL);
ARETURN(arc_mkchar(c, FIX2INT(AFCRV)));
}
WV(buf, arc_mkvector(c, UTFmax));
/* XXX - should put this in builtins */
WV(readb, arc_mkaff(c, arc_readb, CNIL));
for (WV(i, INT2FIX(0)); FIX2INT(AV(i)) < UTFmax; WV(i, INT2FIX(FIX2INT(AV(i)) + 1))) {
AFCALL(AV(readb), AV(fd));
WV(chr, AFCRV);
if (NIL_P(AV(chr)))
ARETURN(CNIL);
SVINDEX(AV(buf), FIX2INT(AV(i)), AV(chr));
/* Arcueid fixnum vector to C array of chars */
for (j=0; j<=FIX2INT(AV(i)); j++)
cbuf[j] = FIX2INT(VINDEX(AV(buf), j));
if (fullrune(cbuf, FIX2INT(AV(i)) + 1)) {
chartorune(&ch, cbuf);
ARETURN(arc_mkchar(c, ch));
}
}
ARETURN(CNIL);
AFEND;
}
value arc_hash_insert(arc *c, value hash, value key, value val)
{
unsigned int hv, index, i;
value e;
index = 0;
/* First of all, look for the key if a binding already exists for it */
e = hash_lookup(c, hash, key, &index);
if (BOUND_P(e)) {
/* if we are already bound, overwrite the old value */
e = VINDEX(HASH_TABLE(hash), index);
BVALUE(e) = val;
return(val);
}
/* Not yet bound. Look for a slot where we can put it */
if (HASH_NENTRIES(hash)+1 > HASH_LLIMIT(hash))
hashtable_expand(c, hash);
SET_NENTRIES(hash, HASH_NENTRIES(hash)+1);
hv = arc_hash(c, key);
index = hv & TABLEMASK(hash);
for (i=0;; i++) {
e = VINDEX(HASH_TABLE(hash), index);
/* If we see an empty bucket in our search, or if we see a bucket
whose key is the same as the key specified, we have found the
place where the element should go. This second case should never
happen, based on what we did above, but hey, belt and suspenders. */
if (EMPTYP(e) || arc_is2(c, BKEY(e), key) == CTRUE)
break;
/* We found a bucket, but it is occupied by some other key. Continue
probing. */
index = (index + PROBE(i)) & TABLEMASK(hash);
}
if (EMPTYP(e)) {
/* No such key in the hash table yet. Create a bucket and
assign it to the table. */
e = mkhashbucket(c, key, val, index, hash, INT2FIX(hv));
SVINDEX(HASH_TABLE(hash), index, e);
} else {
/* The key already exists. Use the current bucket but change the
value to the value specified. */
BVALUE(e) = val;
}
return(val);
}
AFFEND
AFFDEF(arc_tell)
{
AARG(fp);
AFBEGIN;
AFTCALL(VINDEX(IO(AV(fp))->io_ops, IO_tell), AV(fp));
AFEND;
}
/* initialise the vocabulary */
static void init_vocabulary(char * vocab)
{
int i,j;
for (i = 0; i < 26; i++) {
for (j = 0; j < MAX_VOCAB_SIZE; j++) {
vocab[VINDEX(i,j)] = 0;
}
}
}
AFFEND
AFFDEF(arc_writec)
{
AARG(chr);
AOARG(fd);
AVAR(buf, i, writeb, nbytes);
char cbuf[UTFmax];
Rune ch;
int j;
AFBEGIN;
if (arc_thr_argc(c, thr) == 0) {
arc_err_cstrfmt(c, "writec: too few arguments");
return(CNIL);
}
if (!BOUND_P(AV(fd)))
STDOUT(fd);
IOW_TYPECHECK(AV(fd));
CHECK_CLOSED(AV(fd));
if (IO(AV(fd))->flags & IO_FLAG_GETB_IS_GETC) {
AFCALL(VINDEX(IO(AV(fd))->io_ops, IO_putb), AV(fd),
INT2FIX(arc_char2rune(c, AV(chr))));
ARETURN(arc_mkchar(c, FIX2INT(AFCRV)));
}
/* XXX - should put this in builtins */
WV(writeb, arc_mkaff(c, arc_writeb, CNIL));
ch = arc_char2rune(c, AV(chr));
WV(nbytes, INT2FIX(runetochar(cbuf, &ch)));
/* Convert C char array into Arcueid vector of fixnums */
WV(buf, arc_mkvector(c, FIX2INT(AV(nbytes))));
for (j=0; j<FIX2INT(AV(nbytes)); j++)
SVINDEX(AV(buf), j, INT2FIX(cbuf[j]));
for (WV(i, INT2FIX(0)); FIX2INT(AV(i)) < FIX2INT(AV(nbytes)); WV(i, INT2FIX(FIX2INT(AV(i)) + 1))) {
AFCALL(AV(writeb),VINDEX(AV(buf), FIX2INT(AV(i))), AV(fd));
}
ARETURN(AV(chr));
AFEND;
}
/* returns 1 if the given word is in the vocabulary */
static int word_in_vocabulary(char * text,
int start_pos, int end_pos,
char * vocab, float * frequency,
int update_frequency,
float * returned_frequency)
{
int length = end_pos - start_pos;
int index,i=0,c;
if ((length==0) || (length>=MAX_WORD_LENGTH-1)) return 0;
if ((text[start_pos]>='a') && (text[start_pos]<='z')) {
index = (int)(text[start_pos]-'a');
}
else {
index = (int)(text[start_pos]-'A');
}
if (index >= 26) return 0;
while (i < MAX_VOCAB_SIZE) {
if (vocab[VINDEX(index,i)]==0) break;
if (strlen(&vocab[VINDEX(index,i)]) == length) {
for (c = start_pos; c < end_pos; c++) {
if (tolower(text[c]) !=
vocab[VINDEX(index,i) + c - start_pos]) break;
}
if (c == end_pos) {
if (update_frequency > 0) {
frequency[FINDEX(index,i)]++;
}
else {
*returned_frequency =
frequency[FINDEX(index,i)];
}
return 1;
}
}
i++;
}
return 0;
}
AFFEND
AFFDEF(arc_close)
{
ARARG(list);
AFBEGIN;
for (; !NIL_P(AV(list)); WV(list, cdr(AV(list)))) {
AFCALL(VINDEX(IO(car(AV(list)))->io_ops, IO_close), car(AV(list)));
}
ARETURN(CNIL);
AFEND;
}
/* saves the vocabulary in XML format */
void write_vocabulary_xml(char* vocab, float * frequency, FILE * fp)
{
int i,j,length=0;
char * str;
fprintf(fp,"%s"," <vocabulary>\n ");
for (i = 0; i < 26; i++) {
for (j = 0; j < MAX_VOCAB_SIZE; j++) {
if (vocab[VINDEX(i,j)]==0) break;
str = &vocab[VINDEX(i,j)];
length += strlen(str);
fprintf(fp,"%s ",str);
if (length > CONSOLE_WIDTH) {
fprintf(fp,"%s","\n ");
length = 0;
}
}
}
fprintf(fp,"%s","\n </vocabulary>\n");
fprintf(fp,"%s"," <vocabularyfreq>\n ");
length = 0;
for (i = 0; i < 26; i++) {
for (j = 0; j < MAX_VOCAB_SIZE; j++) {
if (vocab[VINDEX(i,j)]==0) break;
length += 11;
fprintf(fp,"%.8f ",frequency[FINDEX(i,j)]);
if (length > CONSOLE_WIDTH) {
fprintf(fp,"%s","\n ");
length = 0;
}
}
}
fprintf(fp,"%s","\n </vocabularyfreq>\n");
}
/* parse the given text string from an XML file and update the
vocabulary */
void parse_vocabulary_string(char * text, char* vocab)
{
int i,c,ctr=0,index,entry;
int length = strlen(text);
char value_str[256];
init_vocabulary(vocab);
for (i = 0; i < length; i++) {
if ((text[i] >= 'a') && (text[i] <= 'z') &&
(i < length-1)) {
value_str[ctr++] = text[i];
}
else {
if (ctr > 0) {
if ((i == length-1) &&
(text[i] >= 'a') && (text[i] <= 'z')) {
value_str[ctr++] = text[i];
}
value_str[ctr] = 0;
index = (int)(tolower(value_str[0])-'a');
entry = 0;
while (vocab[VINDEX(index,entry)]!=0) {
entry++;
if (entry==MAX_VOCAB_SIZE) break;
}
if (entry < MAX_VOCAB_SIZE) {
for (c = 0; c <= ctr; c++) {
vocab[VINDEX(index,entry) + c] =
value_str[c];
}
}
}
ctr = 0;
}
}
}
value arc_hash_delete(arc *c, value hash, value key)
{
unsigned int index;
value v, e;
v = hash_lookup(c, hash, key, &index);
if (v != CUNBOUND) {
e = VINDEX(HASH_TABLE(hash), index);
BTABLE(e) = CNIL;
SVINDEX(HASH_TABLE(hash), index, CUNDEF);
SET_NENTRIES(hash, HASH_NENTRIES(hash)-1);
}
return(v);
}
void arc_init_symtable(arc *c)
{
int i;
c->symtable = arc_mkwtable(c, ARC_HASHBITS);
c->rsymtable = arc_mkwtable(c, ARC_HASHBITS);
c->lastsym = 0;
/* Set up builtin symbols */
SVINDEX(c->builtins, BI_syms, arc_mkvector(c, S_THE_END));
for (i=0; i<S_THE_END; i++)
SARC_BUILTIN(c, i, arc_intern(c, arc_mkstringc(c, syms[i])));
/* Set up character escape table */
SVINDEX(c->builtins, BI_charesc, arc_mkhash(c, ARC_HASHBITS));
for (i=0; chartbl[i].str; i++) {
value str = arc_mkstringc(c, chartbl[i].str);
value chr = arc_mkchar(c, chartbl[i].val);
arc_hash_insert(c, VINDEX(c->builtins, BI_charesc), str, chr);
arc_hash_insert(c, VINDEX(c->builtins, BI_charesc), chr, str);
}
c->ctrue = ARC_BUILTIN(c, S_T);
}
int arc_hash_length(arc *c, value hash)
{
int count, i;
value e, tbl;
count = 0;
tbl = HASH_TABLE(hash);
for (i=0; i<VECLEN(tbl); i++) {
e = VINDEX(tbl, i);
if (EMPTYP(e))
continue;
count++;
}
return(count);
}
/* parse the given text string from an XML file and update the
vocabulary */
void parse_vocabulary_frequency_string(char * text,
char * vocab,
float * frequency)
{
int i,ctr=0,index=0,entry=0,found;
int length = strlen(text);
char value_str[256];
init_vocabulary_frequency(frequency);
for (i = 0; i < length; i++) {
if ((((text[i] >= '0') && (text[i] <= '9')) ||
(text[i] == '.') || (text[i] == ',')) &&
(i < length-1)) {
value_str[ctr++] = text[i];
}
else {
if (ctr > 0) {
if ((i == index-1) &&
(((text[i] >= '0') && (text[i] <= '9')) ||
(text[i] == '.') || (text[i] == ','))) {
value_str[ctr++] = text[i];
}
value_str[ctr] = 0;
found = 0;
while ((found == 0) && (index<26)) {
if (vocab[VINDEX(index,entry)]!=0) {
found = 1;
frequency[FINDEX(index,entry)] =
atof(value_str);
}
entry++;
if (entry==MAX_VOCAB_SIZE) {
index++;
entry = 0;
}
}
}
ctr = 0;
}
}
}
static AFFDEF(hash_isocmp)
{
AARG(v1, v2, vh1, vh2);
AVAR(iso2, tbl, e, v2val, i);
value vhh1, vhh2; /* not required after calls */
AFBEGIN;
if ((vhh1 = __arc_visit(c, AV(v1), AV(vh1))) != CNIL) {
/* If we find a visited object, see if v2 is also visited in vh2.
If not, they are not the same. */
vhh2 = __arc_visit(c, AV(v2), AV(vh2));
/* We see if the same value was produced on visiting. */
ARETURN((vhh2 == vhh1) ? CTRUE : CNIL);
}
/* Get value assigned by __arc_visit to v1. */
vhh1 = __arc_visit(c, AV(v1), AV(vh1));
/* If we somehow already visited v2 when v1 was not visited in the
same way, they cannot be the same. */
if (__arc_visit2(c, AV(v2), AV(vh2), vhh1) != CNIL)
ARETURN(CNIL);
/* Two hash tables must have identical numbers of entries to be isomorphic */
if (HASH_NENTRIES(AV(v1)) != HASH_NENTRIES(AV(v2)))
ARETURN(CNIL);
WV(tbl, HASH_TABLE(AV(v1)));
WV(iso2, arc_mkaff(c, arc_iso2, CNIL));
for (WV(i, INT2FIX(0)); FIX2INT(AV(i))<VECLEN(AV(tbl));
WV(i, INT2FIX(FIX2INT(AV(i)) + 1))) {
WV(e, VINDEX(AV(tbl), FIX2INT(AV(i))));
if (EMPTYP(AV(e)))
continue;
WV(v2val, arc_hash_lookup(c, AV(v2), BKEY(AV(e))));
AFCALL(AV(iso2), BVALUE(AV(e)), AV(v2val), AV(vh1), AV(vh2));
if (NIL_P(AFCRV))
ARETURN(CNIL);
}
ARETURN(CTRUE);
AFEND;
}
AFFEND
AFFDEF(arc_seek)
{
AARG(fp, offset);
AOARG(whence);
AFBEGIN;
if (!BOUND_P(AV(whence)))
WV(whence, INT2FIX(SEEK_SET));
if (AV(whence) == ARC_BUILTIN(c, S_SEEK_SET))
WV(whence, INT2FIX(SEEK_SET));
else if (AV(whence) == ARC_BUILTIN(c, S_SEEK_CUR))
WV(whence, INT2FIX(SEEK_CUR));
else if (AV(whence) == ARC_BUILTIN(c, S_SEEK_END))
WV(whence, INT2FIX(SEEK_END));
else if (!FIXNUM_P(AV(whence))) {
arc_err_cstrfmt(c, "invalid seek whence argument");
ARETURN(CNIL);
}
AFTCALL(VINDEX(IO(AV(fp))->io_ops, IO_seek), AV(fp), AV(offset), AV(whence));
AFEND;
}
/* compares one vocabulary against another and returns
lists of missing words, ones which are more and less frequent */
int compare_vocabulary(char * vocab1, char * vocab2,
float * frequency1, float * frequency2,
char * missing,
char * more, char * less,
float threshold,
int line_length)
{
int i,j,c,index,ctr;
char * wordstr;
float freq1,freq2,min;
int missing_ctr=0;
int more_words_ctr=0;
int less_words_ctr=0;
int word_length;
char more_words[MAX_WORD_LENGTH*MAX_COMPARE_RESULTS];
float more_words_freq[MAX_COMPARE_RESULTS];
char less_words[MAX_WORD_LENGTH*MAX_COMPARE_RESULTS];
float less_words_freq[MAX_COMPARE_RESULTS];
int total_difference=0;
/* clear the more and less words lists */
for (i = 0; i < MAX_COMPARE_RESULTS; i++) {
more_words[i*MAX_WORD_LENGTH] = 0;
less_words[i*MAX_WORD_LENGTH] = 0;
}
/* for each word in the first vocabulary */
ctr=0;
for (i = 0; i < 26; i++) {
for (j = 0; j < MAX_VOCAB_SIZE; j++) {
if (vocab1[VINDEX(i,j)]==0) break;
/* get the word */
wordstr = &vocab1[VINDEX(i,j)];
word_length = strlen(wordstr);
/* get the frequency of the word */
freq1 = frequency1[FINDEX(i,j)];
/* does this word exist in the second vocabulary? */
if (word_in_vocabulary(wordstr, 0, strlen(wordstr),
vocab2, frequency2, 0,&freq2)==0) {
total_difference++;
if (missing_ctr < 512) {
/* add word to the missing list */
for (c = 0; c < word_length; c++) {
missing[missing_ctr++] = wordstr[c];
ctr++;
}
missing[missing_ctr++] = ' ';
ctr++;
if (ctr>line_length) {
missing[missing_ctr++] = '\n';
ctr=0;
}
}
}
else {
if (freq2 - freq1 > threshold) {
/* more */
if (more_words_ctr < MAX_COMPARE_RESULTS) {
/* pick the next index in the sequence */
index = more_words_ctr;
more_words_ctr++;
}
else {
/* pick the word with the biggest
frequency difference */
min = 9999;
index = -1;
for (c = 0; c < MAX_COMPARE_RESULTS; c++) {
if (more_words_freq[c]>freq2-freq1) {
if (more_words_freq[c]<min) {
min = more_words_freq[c];
index = c;
}
}
}
}
if (index>-1) {
/* update to the more words */
for (c = 0; c < word_length; c++) {
more_words[index*MAX_WORD_LENGTH+c]=
wordstr[c];
}
more_words[index*MAX_WORD_LENGTH+c]=0;
more_words_freq[index] = freq2-freq1;
total_difference++;
}
}
if (freq1 - freq2 > threshold) {
/* less */
if (less_words_ctr < MAX_COMPARE_RESULTS) {
/* pick the next index in the sequence */
index = less_words_ctr;
less_words_ctr++;
}
else {
/* pick the word with the biggest
frequency difference */
min = 9999;
index = -1;
for (c = 0; c < MAX_COMPARE_RESULTS; c++) {
if (less_words_freq[c]>freq1-freq2) {
if (less_words_freq[c]<min) {
min = less_words_freq[c];
index = c;
}
}
}
}
if (index>-1) {
/* update to the less words */
for (c = 0; c < word_length; c++) {
less_words[index*MAX_WORD_LENGTH+c]=
wordstr[c];
}
less_words[index*MAX_WORD_LENGTH+c]=0;
less_words_freq[index] = freq1-freq2;
total_difference++;
}
}
}
}
}
/* terminate the missing words list */
missing[missing_ctr] = 0;
/* update the more words */
ctr = 0;
index = 0;
for (i = 0; i < more_words_ctr; i++) {
wordstr = &more_words[i*MAX_WORD_LENGTH];
for (c = 0; c < strlen(wordstr); c++) {
more[index++] = wordstr[c];
ctr++;
}
more[index++] = ' ';
ctr++;
if (ctr > line_length) {
ctr = 0;
more[index++] = '\n';
}
}
more[index] = 0;
/* update the less words */
ctr = 0;
index = 0;
for (i = 0; i < less_words_ctr; i++) {
wordstr = &less_words[i*MAX_WORD_LENGTH];
for (c = 0; c < strlen(wordstr); c++) {
less[index++] = wordstr[c];
ctr++;
}
less[index++] = ' ';
ctr++;
if (ctr > line_length) {
ctr = 0;
less[index++] = '\n';
}
}
less[index] = 0;
return total_difference;
}
static INT AMGSolver (NP_LINEAR_SOLVER *theNP, INT level,
VECDATA_DESC *x, VECDATA_DESC *b, MATDATA_DESC *A,
VEC_SCALAR abslimit, VEC_SCALAR reduction,
LRESULT *lresult)
{
NP_AMG *theAMGC;
VEC_SCALAR defect2reach;
INT rv,i,bl,PrintID;
char text[DISPLAY_WIDTH+4];
VEC_SCALAR Factor_One;
MULTIGRID *theMG;
GRID *theGrid;
INT converged=0;
int xcomp,bcomp;
VECTOR *theVector;
int k;
INT nComp_x,nComp_b;
int blocksize;
double ti;
int ii;
#ifdef ModelP
double clock_start;
#else
clock_t clock_start;
#endif
/* prepare solving */
theAMGC = (NP_AMG *) theNP;
theMG = theAMGC->ls.base.mg;
theGrid = GRID_ON_LEVEL(theMG,level);
theAMGC->sc.red_factor=reduction[0];
theAMGC->sc.dnorm_min=abslimit[0];
if (theAMGC->AMG_Build_failed)
{
dset(NP_MG(theNP),level,level,ALL_VECTORS,x,0.0);
return (0);
}
bl = 0;
for (i=0; i<MAX_VEC_COMP; i++) Factor_One[i] = 1.0;
/* allocate correction */
if (AllocVDFromVD(theNP->base.mg,0,level,x,&theAMGC->c)) {
lresult->error_code = __LINE__;
return(1);
}
/* print defect */
CenterInPattern(text,DISPLAY_WIDTH,ENVITEM_NAME(theAMGC),'*',"\n");
if (PreparePCR(x,theAMGC->display,text,&PrintID)) {
lresult->error_code = __LINE__;
return(1);
}
for (i=0; i<VD_NCOMP(x); i++)
lresult->first_defect[i] = lresult->last_defect[i];
if (sc_mul_check(defect2reach,lresult->first_defect,reduction,b)) {
lresult->error_code = __LINE__;
return(1);
}
if (DoPCR(PrintID,lresult->first_defect,PCR_CRATE)) {
lresult->error_code = __LINE__;
return(1);
}
if (sc_cmp(lresult->first_defect,abslimit,b)) lresult->converged = 1;
else lresult->converged = 0;
CSTART(); ti=0; ii=0;
/* fill values in x,b */
xcomp = VD_ncmp_cmpptr_of_otype(theAMGC->c,NODEVEC,&nComp_x)[0];
bcomp = VD_ncmp_cmpptr_of_otype(b,NODEVEC,&nComp_b)[0];
blocksize = nComp_x;
if (blocksize==0) goto exit;
if (nComp_b!=blocksize) goto exit;
for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
{
i = VINDEX(theVector);
for (k=0; k<blocksize; k++)
{
AMG_VECTOR_ENTRY(theAMGC->b,i*blocksize+k,0)=VVALUE(theVector,bcomp+k);
}
}
#ifdef ModelP
/* only master solves */
if (me == master)
{
#endif
AMG_dset(theAMGC->x,0.0);
if ((rv=AMG_Solve(theAMGC->x,theAMGC->b))<0)
{
lresult->error_code = __LINE__;
lresult->converged = 0;
goto exit;
}
lresult->converged = 1;
lresult->number_of_linear_iterations = rv;
/* write back solution values */
for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
{
i = VINDEX(theVector);
for (k=0; k<blocksize; k++)
VVALUE(theVector,xcomp+k)=AMG_VECTOR_ENTRY(theAMGC->x,i*blocksize+k,0);
}
if (dmatmul_minus(theNP->base.mg,0,level,ON_SURFACE,b,A,theAMGC->c)
!= NUM_OK) {
lresult->error_code = __LINE__;
return(1);
}
if (daxpyx(theAMGC->ls.base.mg,0,level,
ON_SURFACE,x,Factor_One,theAMGC->c) != NUM_OK) {
lresult->error_code = __LINE__;
return(1);
}
#ifdef ModelP
}
#endif
if (AMGSolverResiduum(theNP,bl,level,x,b,A,lresult))
return(1);
if (DoPCR(PrintID, lresult->last_defect,PCR_CRATE)) {
lresult->error_code = __LINE__;
return (1);
}
if (DoPCR(PrintID,lresult->last_defect,PCR_AVERAGE)) {
lresult->error_code = __LINE__;
return (1);
}
FreeVD(theNP->base.mg,0,level,theAMGC->c);
if (PostPCR(PrintID,NULL)) {
lresult->error_code = __LINE__;
return (1);
}
CSTOP(ti,ii);
if (theAMGC->sc.verbose>0)
{
if (lresult->number_of_linear_iterations != 0)
UserWriteF("AMG : L=%2d N=%2d TSOLVE=%10.4g TIT=%10.4g\n",level,
lresult->number_of_linear_iterations,ti,
ti/lresult->number_of_linear_iterations);
else
UserWriteF("AMG : L=%2d N=%2d TSOLVE=%10.4g\n",level,
lresult->number_of_linear_iterations,ti);
}
return (0);
exit:
return(1);
}
static INT AMGSolverPreProcess (NP_LINEAR_SOLVER *theNP, INT level,
VECDATA_DESC *VD_x, VECDATA_DESC *VD_b,
MATDATA_DESC *MD_A,
INT *baselevel, INT *result)
{
MULTIGRID *theMG;
GRID *theGrid;
int n,nonzeros,blocksize;
int Acomp;
MATRIX *theMatrix;
VECTOR *theVector;
int i,j,block_i,block_j;
int nRows_A,nCols_A,nComp_x,nComp_b;
NP_AMG *theAMGC;
double ti;
int ii;
#ifdef ModelP
double clock_start;
#else
clock_t clock_start;
#endif
theAMGC = (NP_AMG *) theNP;
/* prepare solving */
theMG = theAMGC->ls.base.mg;
theGrid = GRID_ON_LEVEL(theMG,level);
/* mark heap for use by amg */
#ifndef DYNAMIC_MEMORY_ALLOCMODEL
Mark(MGHEAP(theMG),FROM_BOTTOM,&amg_MarkKey);
#else
Mark(MGHEAP(theMG),FROM_TOP,&amg_MarkKey);
#endif
mark_counter++;
/* initialize sp package */
AMG_InstallPrintHandler((AMG_PrintFuncPtr)UserWrite);
amgMG=theMG; /* make it global for memory handler */
AMG_InstallMallocHandler((AMG_MallocFuncPtr)amgmalloc);
/* get access to components */
nRows_A = MD_ROWS_IN_RT_CT(MD_A,NODEVEC,NODEVEC);
nCols_A = MD_COLS_IN_RT_CT(MD_A,NODEVEC,NODEVEC);
nComp_x = VD_NCMPS_IN_TYPE(VD_x,NODEVEC);
nComp_b = VD_NCMPS_IN_TYPE(VD_b,NODEVEC);
blocksize = nComp_x;
if (blocksize==0) goto exit;
if (nComp_b!=blocksize) goto exit;
if (nCols_A!=blocksize) goto exit;
if (nRows_A!=blocksize) goto exit;
Acomp = MD_MCMP_OF_RT_CT(MD_A,NODEVEC,NODEVEC,0);
CSTART(); ti=0; ii=0;
/* diagonal scaling */
if (theAMGC->scale)
if (DiagonalScaleSystem(theGrid,MD_A,MD_A,VD_b)!=NUM_OK)
{
UserWrite("Error in scaling system\n");
goto exit;
}
/* gather some data for the matrix */
n = nonzeros = 0;
/* loop through all vectors, we assume there are only node vectors ! */
for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
{
VINDEX(theVector) = n++; /* renumber vectors just to be sure ... */
/* now speed through this row */
for (theMatrix=VSTART(theVector); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
nonzeros++;
}
#ifdef ModelP
if (me == master)
{
#endif
/* now allocate fine grid vectors x and b */
theAMGC->x = AMG_NewVector(n*blocksize,1,"x");
if (theAMGC->x==NULL) {
UserWrite("no memory for x\n");
goto exit;
}
theAMGC->b = AMG_NewVector(n*blocksize,1,"b");
if (theAMGC->b==NULL) {
UserWrite("no memory for b\n");
goto exit;
}
/* and a new matrix */
theAMGC->A = AMG_NewMatrix(n*blocksize,1,nonzeros*blocksize*blocksize,blocksize,"fine grid A");
if (theAMGC->A==NULL) {
UserWrite("no memory for A\n");
goto exit;
}
#ifdef ModelP
}
else
{
/* no master vectors allowed */
assert(n==0);
/* only master builds up coarse levels */
return (0);
}
#endif
/* now fill matrix */
for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
{
i = VINDEX(theVector);
/* count row length */
nonzeros=0;
for (theMatrix=VSTART(theVector); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
nonzeros++;
/* for each row */
for (block_i=0; block_i<blocksize; block_i++)
{
/* allocate row */
if (AMG_SetRowLength(theAMGC->A,i*blocksize+block_i,nonzeros*blocksize)!=AMG_OK)
{
UserWrite("Error in AMG_SetRowLength\n");
goto exit;
}
/* the diagonal block, be careful to allocate the main diagonal first */
theMatrix=VSTART(theVector);
if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,i*blocksize+block_i,
&(MVALUE(theMatrix,Acomp+block_i*blocksize+block_i)))<0)
{
UserWrite("Error in AMG_InsertValues\n");
goto exit;
}
for (block_j=0; block_j<blocksize; block_j++)
{
if (block_j==block_i) continue;
if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,i*blocksize+block_j,
&(MVALUE(theMatrix,Acomp+block_i*blocksize+block_j)))<0)
{
UserWrite("Error in AMG_InsertValues\n");
goto exit;
}
}
/* all the offdiagonal blocks */
for (theMatrix=MNEXT(VSTART(theVector)); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
{
j = VINDEX(MDEST(theMatrix));
for (block_j=0; block_j<blocksize; block_j++)
{
if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,j*blocksize+block_j,
&(MVALUE(theMatrix,Acomp+block_i*blocksize+block_j)))<0)
{
UserWrite("Error in AMG_InsertValues\n");
goto exit;
}
}
}
}
}
/*AMG_PrintMatrix(theAMGC->A,"Matrix");*/
/* call algebraic multigrid solver */
if (AMG_Build(&theAMGC->sc,&theAMGC->cc,theAMGC->A)!=AMG_OK) theAMGC->AMG_Build_failed=1;
theAMGC->AMG_Build_failed=0;
CSTOP(ti,ii);
if (theAMGC->sc.verbose>0)
UserWriteF("AMG : L=%2d BUILD=%10.4g\n",level,ti);
return(0); /* ok, matrix is set up */
exit: /* error */
if (mark_counter>0) {
#ifndef DYNAMIC_MEMORY_ALLOCMODEL
Release(MGHEAP(theMG),FROM_BOTTOM,amg_MarkKey);
#else
Release(MGHEAP(theMG),FROM_TOP,amg_MarkKey);
#endif
mark_counter--;
}
return(1);
}
INT l_nlgs (NP_NLGS *nlgs, NP_NL_ASSEMBLE *ass, GRID *grid, const DOUBLE *damp,
VECDATA_DESC *x, VECDATA_DESC *v, MATDATA_DESC *M,
VECDATA_DESC *d)
{
VECTOR *vec,*w,*first_vec;
NODE *theNode;
MULTIGRID *mg;
INT level;
INT rtype,ctype,myindex,error;
register MATRIX *mat;
register SHORT *tmpptr,*dcomp,*xcomp,*vcomp;
register SHORT i;
register SHORT n;
DEFINE_VD_CMPS(cy);
DEFINE_MD_CMPS(m);
DOUBLE r[MAX_SINGLE_VEC_COMP];
mg = nlgs->smoother.iter.base.mg;
level = GLEVEL(grid);
first_vec = FIRSTVECTOR(grid);
L_VLOOP__CLASS(vec,first_vec,ACTIVE_CLASS)
{
rtype = VTYPE(vec);
/* get node */
theNode = (NODE*)VOBJECT(vec);
n = VD_NCMPS_IN_TYPE(v,rtype);
if (n == 0) continue;
dcomp = VD_CMPPTR_OF_TYPE(d,rtype);
xcomp = VD_CMPPTR_OF_TYPE(x,rtype);
vcomp = VD_CMPPTR_OF_TYPE(v,rtype);
myindex = VINDEX(vec);
/* local Jacobi matrix */
if ((*ass->NLNAssembleMatrix)(ass,level,level,theNode,x,d,v,M,&error)) {
error = __LINE__;
REP_ERR_RETURN(error);
}
/* get defect */
for (i=0; i<n; i++)
r[i] = VVALUE(vec,dcomp[i]);
/* rhs */
for (ctype=0; ctype<=NVECTYPES; ctype++)
if (MD_ROWS_IN_RT_CT(M,rtype,ctype)>0)
{
SET_CMPS_22(cy,v,m,M,rtype,ctype,tmpptr);
s0 = s1 = 0.0;
for (mat=MNEXT(VSTART(vec)); mat!=NULL; mat=MNEXT(mat))
if (((VTYPE(w=MDEST(mat))==ctype) && (VCLASS(w)>=ACTIVE_CLASS)) && (myindex>VINDEX(w)))
MATMUL_22(s,mat,m,w,cy);
r[0] -= s0;
r[1] -= s1;
}
/* solve */
if (MySolveSmallBlock(n,VD_CMPPTR_OF_TYPE(v,rtype),VVALPTR(vec),
MD_MCMPPTR_OF_RT_CT(M,rtype,rtype),
MVALPTR(VSTART(vec)),r)!=0)
return (__LINE__);
/* damp */
for (i=0; i<n; i++)
VVALUE(vec,vcomp[i]) *= damp[i];
/* update solution */
for (i=0; i<n; i++)
VVALUE(vec,xcomp[i]) -= VVALUE(vec,vcomp[i]);
}
static INT TecplotCommand (INT argc, char **argv)
{
INT i,j,k,v; /* counters etc. */
INT counter; /* for formatting output */
char item[1024],it[256]; /* item buffers */
INT ic=0; /* item length */
VECTOR *vc; /* a vector pointer */
ELEMENT *el; /* an element pointer */
MULTIGRID *mg; /* our multigrid */
char filename[NAMESIZE]; /* file name for output file */
PFILE *pf; /* the output file pointer */
INT nv; /* number of variables (eval functions) */
EVALUES *ev[MAXVARIABLES]; /* pointers to eval function descriptors */
char ev_name[MAXVARIABLES][NAMESIZE]; /* names for eval functions */
char s[NAMESIZE]; /* name of eval proc */
char zonename[NAMESIZE+7] = ""; /* name for zone (initialized to
empty string) */
INT numNodes; /* number of data points */
INT numElements; /* number of elements */
INT gnumNodes; /* number of data points globally */
INT gnumElements; /* number of elements globallay */
PreprocessingProcPtr pre; /* pointer to prepare function */
ElementEvalProcPtr eval; /* pointer to evaluation function */
DOUBLE *CornersCoord[MAX_CORNERS_OF_ELEM]; /* pointers to coordinates */
DOUBLE LocalCoord[DIM]; /* is one of the corners local coordinates */
DOUBLE local[DIM]; /* local coordinate in DOUBLE */
DOUBLE value; /* returned by user eval proc */
INT oe,on;
INT saveGeometry; /* save geometry flag */
/* get current multigrid */
mg = GetCurrentMultigrid();
if (mg==NULL)
{
PrintErrorMessage('W',"tecplot","no multigrid open\n");
return (OKCODE);
}
/* scan options */
nv = 0; saveGeometry = 0;
for(i=1; i<argc; i++)
{
switch(argv[i][0])
{
case 'e' : /* read eval proc */
if (nv>=MAXVARIABLES)
{
PrintErrorMessage('E',"tecplot","too many variables specified\n");
break;
}
sscanf(argv[i],"e %s", s);
ev[nv] = GetElementValueEvalProc(s);
if (ev[nv]==NULL)
{
PrintErrorMessageF('E',"tecplot","could not find eval proc %s\n",s);
break;
}
if (sscanf(argv[i+1],"s %s", s) == 1)
{
strcpy(ev_name[nv],s);
i++;
}
else
strcpy(ev_name[nv],ev[nv]->v.name);
nv++;
break;
case 'z' :
sscanf(argv[i],"z %s", zonename+3);
memcpy(zonename, "T=\"", 3);
memcpy(zonename+strlen(zonename), "\", \0", 4);
break;
case 'g' :
sscanf(argv[i],"g %d", &saveGeometry);
if (saveGeometry<0) saveGeometry=0;
if (saveGeometry>1) saveGeometry=1;
break;
}
}
if (nv==0) UserWrite("tecplot: no variables given, printing mesh data only\n");
/* get file name and open output file */
if (sscanf(argv[0],expandfmt(CONCAT3(" tecplot %",NAMELENSTR,"[ -~]")),filename)!=1)
{
PrintErrorMessage('E',"tecplot","could not read name of logfile");
return(PARAMERRORCODE);
}
pf = pfile_open(filename);
if (pf==NULL) return(PARAMERRORCODE);
/********************************/
/* TITLE */
/********************************/
ic = 0;
sprintf(it,"TITLE = \"UG TECPLOT OUTPUT\"\n");
strcpy(item+ic,it); ic+=strlen(it);
sprintf(it,"VARIABLES = \"X\", \"Y\"");
strcpy(item+ic,it); ic+=strlen(it);
if (DIM==3) {
sprintf(it,", \"Z\"");
strcpy(item+ic,it); ic+=strlen(it);
}
for (i=0; i<nv; i++) {
sprintf(it,", \"%s\"",ev[i]->v.name);
strcpy(item+ic,it); ic+=strlen(it);
}
sprintf(it,"\n");
strcpy(item+ic,it); ic+=strlen(it);
pfile_master_puts(pf,item); ic=0;
/********************************/
/* compute sizes */
/********************************/
/* clear VCFLAG on all levels */
for (k=0; k<=TOPLEVEL(mg); k++)
for (vc=FIRSTVECTOR(GRID_ON_LEVEL(mg,k)); vc!=NULL; vc=SUCCVC(vc))
SETVCFLAG(vc,0);
/* run thru all levels of elements and set index */
numNodes = numElements = 0;
for (k=0; k<=TOPLEVEL(mg); k++)
for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
{
if (!EstimateHere(el)) continue; /* process finest level elements only */
numElements++; /* increase element counter */
for (i=0; i<CORNERS_OF_ELEM(el); i++)
{
vc = NVECTOR(CORNER(el,i));
if (VCFLAG(vc)) continue; /* we have this one already */
VINDEX(vc) = ++numNodes; /* number of data points, begins with 1 ! */
SETVCFLAG(vc,1); /* tag vector as visited */
}
}
#ifdef ModelP
gnumNodes = TPL_GlobalSumINT(numNodes);
gnumElements = TPL_GlobalSumINT(numElements);
on=get_offset(numNodes);
oe=get_offset(numElements);
/* clear VCFLAG on all levels */
for (k=0; k<=TOPLEVEL(mg); k++)
for (vc=FIRSTVECTOR(GRID_ON_LEVEL(mg,k)); vc!=NULL; vc=SUCCVC(vc))
SETVCFLAG(vc,0);
/* number in unique way */
for (k=0; k<=TOPLEVEL(mg); k++)
for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
{
if (!EstimateHere(el)) continue; /* process finest level elements only */
for (i=0; i<CORNERS_OF_ELEM(el); i++)
{
vc = NVECTOR(CORNER(el,i));
if (VCFLAG(vc)) continue; /* we have this one already */
VINDEX(vc) += on; /* add offset */
SETVCFLAG(vc,1); /* tag vector as visited */
}
}
#else
gnumNodes = numNodes;
gnumElements = numElements;
oe=on=0;
#endif
/********************************/
/* write ZONE data */
/* uses FEPOINT for data */
/* uses QUADRILATERAL in 2D */
/* and BRICK in 3D */
/********************************/
/* write zone record header */
if (DIM==2) sprintf(it,"ZONE %sN=%d, E=%d, F=FEPOINT, ET=QUADRILATERAL\n", zonename, gnumNodes,gnumElements);
if (DIM==3) sprintf(it,"ZONE %sN=%d, E=%d, F=FEPOINT, ET=BRICK\n", zonename, gnumNodes,gnumElements);
strcpy(item+ic,it); ic+=strlen(it);
pfile_master_puts(pf,item); ic=0;
/* write data in FEPOINT format, i.e. all variables of a node per line*/
for (k=0; k<=TOPLEVEL(mg); k++)
for (vc=FIRSTVECTOR(GRID_ON_LEVEL(mg,k)); vc!=NULL; vc=SUCCVC(vc))
SETVCFLAG(vc,0); /* clear all flags */
counter=0;
for (k=0; k<=TOPLEVEL(mg); k++)
for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
{
if (!EstimateHere(el)) continue; /* process finest level elements only */
for (i=0; i<CORNERS_OF_ELEM(el); i++)
CornersCoord[i] = CVECT(MYVERTEX(CORNER(el,i))); /* x,y,z of corners */
for (i=0; i<CORNERS_OF_ELEM(el); i++)
{
vc = NVECTOR(CORNER(el,i));
if (VCFLAG(vc)) continue; /* we have this one alre ady */
SETVCFLAG(vc,1); /* tag vector as visited */
sprintf(it,"%g",(double)XC(MYVERTEX(CORNER(el,i))));
strcpy(item+ic,it); ic+=strlen(it);
sprintf(it," %g",(double)YC(MYVERTEX(CORNER(el,i))));
strcpy(item+ic,it); ic+=strlen(it);
if (DIM == 3)
{
sprintf(it," %g",(double)ZC(MYVERTEX(CORNER(el,i))));
strcpy(item+ic,it); ic+=strlen(it);
}
/* now all the user variables */
/* get local coordinate of corner */
LocalCornerCoordinates(DIM,TAG(el),i,local);
for (j=0; j<DIM; j++) LocalCoord[j] = local[j];
for (v=0; v<nv; v++)
{
pre = ev[v]->PreprocessProc;
eval = ev[v]->EvalProc;
/* execute prepare function */
/* This is not really equivalent to
the FEBLOCK-version sinc we call "pre" more
often than there. D.Werner */
if (pre!=NULL) pre(ev_name[v],mg);
/* call eval function */
value = eval(el,(const DOUBLE **)CornersCoord,LocalCoord);
sprintf(it," %g",value);
strcpy(item+ic,it); ic+=strlen(it);
}
sprintf(it,"\n");
strcpy(item+ic,it); ic+=strlen(it);
pfile_tagged_puts(pf,item,counter+on); ic=0;
counter++;
}
}
pfile_sync(pf); /* end of segment */
sprintf(it,"\n");
strcpy(item+ic,it); ic+=strlen(it);
pfile_master_puts(pf,item); ic=0;
/* finally write the connectivity list */
counter=0;
for (k=0; k<=TOPLEVEL(mg); k++)
for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
{
if (!EstimateHere(el)) continue; /* process finest level elements only */
switch(DIM) {
case 2 :
switch(TAG(el)) {
case TRIANGLE :
sprintf(it,"%d %d %d %d\n",
VINDEX(NVECTOR(CORNER(el,0))),
VINDEX(NVECTOR(CORNER(el,1))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,2)))
);
break;
case QUADRILATERAL :
sprintf(it,"%d %d %d %d\n",
VINDEX(NVECTOR(CORNER(el,0))),
VINDEX(NVECTOR(CORNER(el,1))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,3)))
);
break;
default :
UserWriteF("tecplot: unknown 2D element type with tag(el) = %d detected. Aborting further processing of command tecplot\n", TAG(el));
return CMDERRORCODE;
break;
}
break;
case 3 :
switch(TAG(el)) {
case HEXAHEDRON :
sprintf(it,"%d %d %d %d "
"%d %d %d %d\n",
VINDEX(NVECTOR(CORNER(el,0))),
VINDEX(NVECTOR(CORNER(el,1))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,3))),
VINDEX(NVECTOR(CORNER(el,4))),
VINDEX(NVECTOR(CORNER(el,5))),
VINDEX(NVECTOR(CORNER(el,6))),
VINDEX(NVECTOR(CORNER(el,7)))
);
break;
case TETRAHEDRON :
sprintf(it,"%d %d %d %d "
"%d %d %d %d\n",
VINDEX(NVECTOR(CORNER(el,0))),
VINDEX(NVECTOR(CORNER(el,1))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,3))),
VINDEX(NVECTOR(CORNER(el,3))),
VINDEX(NVECTOR(CORNER(el,3))),
VINDEX(NVECTOR(CORNER(el,3)))
);
break;
case PYRAMID :
sprintf(it,"%d %d %d %d "
"%d %d %d %d\n",
VINDEX(NVECTOR(CORNER(el,0))),
VINDEX(NVECTOR(CORNER(el,1))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,3))),
VINDEX(NVECTOR(CORNER(el,4))),
VINDEX(NVECTOR(CORNER(el,4))),
VINDEX(NVECTOR(CORNER(el,4))),
VINDEX(NVECTOR(CORNER(el,4)))
);
break;
case PRISM :
sprintf(it,"%d %d %d %d "
"%d %d %d %d\n",
VINDEX(NVECTOR(CORNER(el,0))),
VINDEX(NVECTOR(CORNER(el,1))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,2))),
VINDEX(NVECTOR(CORNER(el,3))),
VINDEX(NVECTOR(CORNER(el,4))),
VINDEX(NVECTOR(CORNER(el,5))),
VINDEX(NVECTOR(CORNER(el,5)))
);
break;
default :
UserWriteF("tecplot: unknown 3D element type with tag(el) = %d detected. Aborting further processing of command tecplot\n", TAG(el));
return CMDERRORCODE;
break;
}
break;
}
strcpy(item+ic,it); ic+=strlen(it);
pfile_tagged_puts(pf,item,counter+oe); ic=0;
counter++;
}
pfile_sync(pf); /* end of segment */
/********************************/
/* GEOMETRY */
/* we will do this later, since */
/* domain interface will change */
/********************************/
pfile_close(pf);
return(OKCODE);
}
