1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T Bell Laboratories or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
26 char binread[] = "rb", textread[] = "r";
27 char binwrite[] = "wb", textwrite[] = "w";
28 char *c_functions = "c_functions";
29 char *coutput = "c_output";
30 char *initfname = "raw_data";
31 char *initbname = "raw_data.b";
32 char *blkdfname = "block_data";
33 char *p1_file = "p1_file";
34 char *p1_bakfile = "p1_file.BAK";
35 char *sortfname = "init_file";
45 char *tmpdir = TMPDIR;
56 if (cdelete && coutput)
67 k = strlen(tmpdir) + 16;
68 c_functions = (char *)ckalloc(7*k);
69 initfname = c_functions + k;
70 initbname = initfname + k;
71 blkdfname = initbname + k;
72 p1_file = blkdfname + k;
73 p1_bakfile = p1_file + k;
74 sortfname = p1_bakfile + k;
78 if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
81 /* substitute \ for / to avoid confusion with a
82 * switch indicator in the system("sort ...")
83 * call in formatdata.c
85 for(s = tmpdir, t = buf; *s; s++, t++)
93 sprintf(c_functions, "%sf2c_func", t);
94 sprintf(initfname, "%sf2c_rd", t);
95 sprintf(blkdfname, "%sf2c_blkd", t);
96 sprintf(p1_file, "%sf2c_p1f", t);
97 sprintf(p1_bakfile, "%sf2c_p1fb", t);
98 sprintf(sortfname, "%sf2c_sort", t);
101 sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
102 sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
103 sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
104 sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
105 sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
106 sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
108 sprintf(initbname, "%s.b", initfname);
111 fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
112 initfname, blkdfname, p1_file, p1_bakfile, sortfname);
125 if (--s < s0 + 3 || s[-2] != '.'
126 || ((c = *--s) != 'f' && c != 'F')) {
128 Fatal("file name must end in .f or .F");
139 signal(SIGINT, SIG_IGN);
141 signal(SIGQUIT, SIG_IGN);
144 signal(SIGHUP, SIG_IGN);
146 signal(SIGTERM, SIG_IGN);
152 sig1catch(sig) int sig;
154 if (signal(sig, SIG_IGN) != SIG_IGN)
161 Fatal("floating exception during constant evaluation; cannot recover");
162 /* vax returns a reserved operand that generates
163 an illegal operand fault on next instruction,
164 which if ignored causes an infinite loop.
166 signal(SIGFPE, flovflo);
180 signal(SIGFPE, flovflo); /* catch overflows */
187 Fatal("Only one Fortran input file allowed under MS-DOS");
196 while((w = wait(&status)) != pid)
198 Fatal("bad wait code");
199 retcode |= status >> 8;
205 /* Unless SYSTEM_SORT is defined, the following gives a simple
206 * in-core version of dsort(). On Fortran source with huge DATA
207 * statements, the in-core version may exhaust the available memory,
208 * in which case you might either recompile this source file with
209 * SYSTEM_SORT defined (if that's reasonable on your system), or
210 * replace the dsort below with a more elaborate version that
211 * does a merging sort with the help of auxiliary files.
220 sprintf(buf, "sort <%s >%s", from, to);
221 return system(buf) >> 8;
228 { return strcmp(*(char **)a, *(char **)b); }
233 extern char *Alloc();
240 typedef struct Memb memb;
242 register char *x, *x0, *xe;
248 f = opf(from, textread);
249 mb = (memb *)Alloc(sizeof(memb));
252 xe = x + sizeof(mb->buf);
256 if (x >= xe && (c != EOF || x != x0)) {
261 mb1 = (memb *)Alloc(sizeof(memb));
264 memcpy(mb->buf, x0, n = x-x0);
267 xe = x0 + sizeof(mb->buf);
281 f = opf(to, textwrite);
282 if (x > x0) { /* shouldn't happen */
288 if (!nn) /* shouldn't happen */
290 z = z0 = (char **)Alloc(nn*sizeof(char *));
291 for(mb1 = mb; mb1; mb1 = mb1->next) {
301 qsort((char *)z0, nn, sizeof(char *), compare);
302 for(n = nn, z = z0; n > 0; n--)
303 fprintf(f, "%s\n", *z++);