double tau()
{
double tau;
return opf(tau,0.5);
}
setdata(register Addrp varp, register Constp valp, ftnint elen)
#endif
{
struct Constblock con;
register int type;
int i, k, valtype;
ftnint offset;
char *varname;
static Addrp badvar;
register unsigned char *s;
static int last_lineno;
static char *last_varname;
if (varp->vstg == STGCOMMON) {
if (!(dfile = blkdfile))
dfile = blkdfile = opf(blkdfname, textwrite);
}
else {
if (procclass == CLBLOCK) {
if (varp != badvar) {
badvar = varp;
warn1("%s is not in a COMMON block",
varp->uname_tag == UNAM_NAME
? varp->user.name->fvarname
: "???");
}
return;
}
if (!(dfile = initfile))
dfile = initfile = opf(initfname, textwrite);
}
varname = dataname(varp->vstg, varp->memno);
offset = varp->memoffset->constblock.Const.ci;
type = varp->vtype;
valtype = valp->vtype;
if(type!=TYCHAR && valtype==TYCHAR)
{
if(! ftn66flag
&& (last_varname != cur_varname || last_lineno != lineno)) {
/* prevent multiple warnings */
last_lineno = lineno;
warn1(
"non-character datum %.42s initialized with character string",
last_varname = cur_varname);
}
varp->vleng = ICON(typesize[type]);
varp->vtype = type = TYCHAR;
}
else if( (type==TYCHAR && valtype!=TYCHAR) ||
(cktype(OPASSIGN,type,valtype) == TYERROR) )
{
err("incompatible types in initialization");
return;
}
if(type == TYADDR)
con.Const.ci = valp->Const.ci;
else if(type != TYCHAR)
{
if(valtype == TYUNKNOWN)
con.Const.ci = valp->Const.ci;
else consconv(type, &con, valp);
}
k = 1;
switch(type)
{
case TYLOGICAL:
case TYINT1:
case TYLOGICAL1:
case TYLOGICAL2:
case TYSHORT:
case TYLONG:
#ifdef TYQUAD
case TYQUAD:
#endif
dataline(varname, offset, type);
prconi(dfile, con.Const.ci);
break;
case TYADDR:
dataline(varname, offset, type);
prcona(dfile, con.Const.ci);
break;
case TYCOMPLEX:
case TYDCOMPLEX:
k = 2;
case TYREAL:
case TYDREAL:
dataline(varname, offset, type);
prconr(dfile, &con, k);
break;
case TYCHAR:
k = valp -> vleng -> constblock.Const.ci;
if (elen < k)
k = elen;
s = (unsigned char *)valp->Const.ccp;
for(i = 0 ; i < k ; ++i) {
dataline(varname, offset++, TYCHAR);
fprintf(dfile, "\t%d\n", *s++);
}
k = elen - valp->vleng->constblock.Const.ci;
if(k > 0) {
dataline(varname, offset, TYBLANK);
fprintf(dfile, "\t%d\n", k);
}
break;
default:
badtype("setdata", type);
}
}
dsort(char *from, char *to)
#endif
{
struct Memb {
struct Memb *next;
int n;
char buf[32000];
};
typedef struct Memb memb;
memb *mb, *mb1;
register char *x, *x0, *xe;
register int c, n;
FILE *f;
char **z, **z0;
int nn = 0;
f = opf(from, textread);
mb = (memb *)Alloc(sizeof(memb));
mb->next = 0;
x0 = x = mb->buf;
xe = x + sizeof(mb->buf);
n = 0;
for(;;) {
c = getc(f);
if (x >= xe && (c != EOF || x != x0)) {
if (!n)
return 126;
nn += n;
mb->n = n;
mb1 = (memb *)Alloc(sizeof(memb));
mb1->next = mb;
mb = mb1;
memcpy(mb->buf, x0, n = x-x0);
x0 = mb->buf;
x = x0 + n;
xe = x0 + sizeof(mb->buf);
n = 0;
}
if (c == EOF)
break;
if (c == '\n') {
++n;
*x++ = 0;
x0 = x;
}
else
*x++ = c;
}
clf(&f, from, 1);
f = opf(to, textwrite);
if (x > x0) { /* shouldn't happen */
*x = 0;
++n;
}
mb->n = n;
nn += n;
if (!nn) /* shouldn't happen */
goto done;
z = z0 = (char **)Alloc(nn*sizeof(char *));
for(mb1 = mb; mb1; mb1 = mb1->next) {
x = mb1->buf;
n = mb1->n;
for(;;) {
*z++ = x;
if (--n <= 0)
break;
while(*x++);
}
}
qsort((char *)z0, nn, sizeof(char *), compare);
for(n = nn, z = z0; n > 0; n--)
fprintf(f, "%s\n", *z++);
free((char *)z0);
done:
clf(&f, to, 1);
do {
mb1 = mb->next;
free((char *)mb);
}
while(mb = mb1);
return 0;
}
