1 /****************************************************************
2 Copyright (C) 1997-2001 Lucent Technologies
3 All Rights Reserved
4 
5 Permission to use, copy, modify, and distribute this software and
6 its documentation for any purpose and without fee is hereby
7 granted, provided that the above copyright notice appear in all
8 copies and that both that the copyright notice and this
9 permission notice and warranty disclaimer appear in supporting
10 documentation, and that the name of Lucent or any of its entities
11 not be used in advertising or publicity pertaining to
12 distribution of the software without specific, written prior
13 permission.
14 
15 LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
16 INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
17 IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
18 SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
19 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
20 IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
21 ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
22 THIS SOFTWARE.
23 ****************************************************************/
24 
25 /* include vararg/stdarg stuff first to avoid trouble with C++ */
26 #ifdef KR_headers
27 #include "varargs.h"
28 #else
29 #include "stddef.h"
30 #include "stdarg.h"
31 #endif
32 
33 #include "asl.h"
34 
35 #ifdef __cplusplus
36 extern "C" {
37 #endif
38 
39 real edagread_one = 1.;
40 char *progname;
41 ASL *cur_ASL;
42 ASLhead ASLhead_ASL = {&ASLhead_ASL, &ASLhead_ASL};
43 
44  static char anyedag[] = "fg_read (or one of its variants)";
45  static char psedag[] = "pfg_read, pfgh_read, or jacpdim";
46 
47  ASL *
48 #ifdef KR_headers
set_cur_ASL(a)49 set_cur_ASL(a) ASL *a;
50 #else
51 set_cur_ASL(ASL *a)
52 #endif
53 {
54 	ASL *rv = cur_ASL;
55 	cur_ASL = a;
56 	return rv;
57 	}
58 
59   ASL *
get_cur_ASL(VOID)60 get_cur_ASL(VOID)
61 { return cur_ASL; }
62 
63  void
64 #ifdef KR_headers
exit_ASL(R,n)65 exit_ASL(R, n) EdRead *R; int n;
66 #else
67 exit_ASL(EdRead *R, int n)
68 #endif
69 {
70 	Jmp_buf *J;
71 	if ((J = R->asl->i.err_jmp_) && n > 0)
72 		longjmp(J->jb, n);
73 	exit(n);
74 	}
75 
76  void
scream(va_alist)77 scream
78 #ifdef KR_headers
79 	(va_alist)
80  va_dcl
81 {
82 	EdRead *R;
83 	char *fmt;
84 	int n;
85 	va_list ap;
86 	va_start(ap);
87 	R = va_arg(ap, EdRead*);
88 	n = va_arg(ap, int);
89 	fmt = va_arg(ap, char*);
90 #else
91 	(EdRead *R, int n, const char *fmt, ...)
92 {
93 	va_list ap;
94 	va_start(ap, fmt);
95 #endif
96 	vfprintf(Stderr, fmt, ap);
97 	exit_ASL(R, n);
98 	} /*}*/
99 
100  static real
101 #ifdef KR_headers
102 notread(what, pred) char *what, *pred;
103 #else
104 notread(char *what, char *pred)
105 #endif
106 {
107 	fprintf(Stderr, "\n*** %s called before %s.\n", what, pred);
108 	exit(1);
109 	/* not reached */
110 	return 0;
111 	}
112 
113  static real
114 #ifdef KR_headers
115 obj0val(a, nobj, X, nerror) ASL *a; real *X; int nobj; fint *nerror;
116 #else
117 obj0val(ASL *a, int nobj, real *X, fint *nerror)
118 #endif
119 {
120 	Not_Used(a);
121 	Not_Used(nobj);
122 	Not_Used(X);
123 	Not_Used(nerror);
124 	return notread("objval", anyedag);
125 	}
126 
127  static void
128 #ifdef KR_headers
129 obj0grd(a, nobj, X, G, nerror) ASL *a; int nobj; fint *nerror; real *X, *G;
130 #else
131 obj0grd(ASL *a, int nobj, real *X, real *G, fint *nerror)
132 #endif
133 {
134 	Not_Used(a);
135 	Not_Used(nobj);
136 	Not_Used(X);
137 	Not_Used(G);
138 	Not_Used(nerror);
139 	notread("objgrd", anyedag);
140 	}
141 
142  static void
143 #ifdef KR_headers
144 con0val(a, X, R, nerror) ASL *a; real *X, *R; fint *nerror;
145 #else
146 con0val(ASL *a, real *X, real *R, fint *nerror)
147 #endif
148 {
149 	Not_Used(a);
150 	Not_Used(X);
151 	Not_Used(R);
152 	Not_Used(nerror);
153 	notread("conval", anyedag);
154 	}
155 
156  static void
157 #ifdef KR_headers
158 jac0val(a, X, J, nerror) ASL *a; real *X, *J; fint *nerror;
159 #else
160 jac0val(ASL *a, real *X, real *J, fint *nerror)
161 #endif
162 {
163 	Not_Used(a);
164 	Not_Used(X);
165 	Not_Used(J);
166 	Not_Used(nerror);
167 	notread("jacval", anyedag);
168 	}
169 
170  static real
171 #ifdef KR_headers
172 con0ival(a, i, X, nerror) ASL *a; int i; real *X; fint *nerror;
173 #else
174 con0ival(ASL *a, int i, real *X, fint *nerror)
175 #endif
176 {
177 	Not_Used(a);
178 	Not_Used(i);
179 	Not_Used(X);
180 	Not_Used(nerror);
181 	notread("conival", anyedag);
182 	return 0.;
183 	}
184 
185  static int
186 #ifdef KR_headers
187 lcon0val(a, i, X, nerror) ASL *a; int i; real *X; fint *nerror;
188 #else
189 lcon0val(ASL *a, int i, real *X, fint *nerror)
190 #endif
191 {
192 	Not_Used(a);
193 	Not_Used(i);
194 	Not_Used(X);
195 	Not_Used(nerror);
196 	notread("conival", anyedag);
197 	return 0;
198 	}
199 
200  static void
201 #ifdef KR_headers
202 con0grd(a, i, X, G, nerror) ASL *a; int i; real *X, *G; fint *nerror;
203 #else
204 con0grd(ASL *a, int i, real *X, real *G, fint *nerror)
205 #endif
206 {
207 	Not_Used(a);
208 	Not_Used(i);
209 	Not_Used(X);
210 	Not_Used(G);
211 	Not_Used(nerror);
212 	notread("congrd", anyedag);
213 	}
214 
215  static void
216 #ifdef KR_headers
217 hv0comp(a, hv, p, nobj, ow, y) ASL *a; real *hv, *p, *ow, *y; int nobj;
218 #else
219 hv0comp(ASL *a, real *hv, real *p, int nobj, real *ow, real *y)
220 #endif
221 {
222 	Not_Used(a);
223 	Not_Used(hv);
224 	Not_Used(p);
225 	Not_Used(nobj);
226 	Not_Used(ow);
227 	Not_Used(y);
228 	notread("hvcomp", "pfgh_read or fgh_read");
229 	}
230 
231  static void
232 #ifdef KR_headers
233 hv0init(a, n, no, ow, y) ASL *a; int n, no; real *ow, *y;
234 #else
235 hv0init(ASL *a, int n, int no, real *ow, real *y)
236 #endif
237 {
238 	Not_Used(a);
239 	Not_Used(n);
240 	Not_Used(no);
241 	Not_Used(ow);
242 	Not_Used(y);
243 	notread("hvinit", "pfgh_read");
244 	}
245 
246  static void
247 #ifdef KR_headers
248 hes0set(a, flags, obj, nobj, con, ncon) ASL *a; int flags; int obj;
249 					int nobj; int con; int ncon;
250 #else
251 hes0set(ASL *a, int flags, int obj, int nobj, int con, int ncon)
252 #endif
253 {
254 	Not_Used(a);
255 	Not_Used(flags);
256 	Not_Used(obj);
257 	Not_Used(nobj);
258 	Not_Used(con);
259 	Not_Used(ncon);
260 	notread("duthes, fullhes, or sputhes", "pfgh_read or jacpdim");
261 	}
262 
263  static void
264 #ifdef KR_headers
265 x0known(a, x, nerror) ASL *a; real *x; fint *nerror;
266 #else
267 x0known(ASL *a, real *x, fint *nerror)
268 #endif
269 {
270 	Not_Used(a);
271 	Not_Used(x);
272 	Not_Used(nerror);
273 	notread("xknown", psedag);
274 	}
275 
276  static void
277 #ifdef KR_headers
278 dut0hes(a, H, nobj, ow, y) ASL *a; real *H; int nobj; real *ow, *y;
279 #else
280 dut0hes(ASL *a, real *H, int nobj, real *ow, real *y)
281 #endif
282 {
283 	Not_Used(a);
284 	Not_Used(H);
285 	Not_Used(nobj);
286 	Not_Used(ow);
287 	Not_Used(y);
288 	notread("duthes", "pfgh_read or jacpdim");
289 	}
290 
291  static void
292 #ifdef KR_headers
293 ful0hes(a, H, LH, nobj, ow, y) ASL *a; real *H, *ow, *y; fint LH; int nobj;
294 #else
295 ful0hes(ASL *a, real *H, fint LH, int nobj, real *ow, real *y)
296 #endif
297 {
298 	Not_Used(a);
299 	Not_Used(H);
300 	Not_Used(LH);
301 	Not_Used(nobj);
302 	Not_Used(ow);
303 	Not_Used(y);
304 	notread("fullhes", "pfgh_read or jacpdim");
305 	}
306 
307  static void
308 #ifdef KR_headers
309 sut0hes(a, p, H, nobj, ow, y) ASL *a; SputInfo **p; real *H; int nobj; real *ow, *y;
310 #else
311 sut0hes(ASL *a, SputInfo **p, real *H, int nobj, real *ow, real *y)
312 #endif
313 {
314 	Not_Used(a);
315 	Not_Used(p);
316 	Not_Used(H);
317 	Not_Used(nobj);
318 	Not_Used(ow);
319 	Not_Used(y);
320 	notread("sputhes", "pfgh_read or jacpdim");
321 	}
322 
323  static fint
324 #ifdef KR_headers
325 sut0set(a, p, nobj, have_ow, have_y, both)
326 	ASL *a; SputInfo **p; int nobj, have_ow, have_y, both;
327 #else
328 sut0set(ASL *a, SputInfo **p, int nobj, int have_ow, int have_y, int both)
329 #endif
330 {
331 	Not_Used(a);
332 	Not_Used(p);
333 	Not_Used(nobj);
334 	Not_Used(have_ow);
335 	Not_Used(have_y);
336 	Not_Used(both);
337 	notread("sputset", "pfgh_read or jacpdim");
338 	return 0;
339 	}
340 
341 Edagpars edagpars_ASL = {
342 	{0,0},	/* h */
343 	1.,	/* hffactor */
344 	5,	/* FUNNEL_MIN */
345 	5,	/* maxfwd */
346 	1,	/* need_funcadd */
347 	100,	/* vrefGulp */
348 	1,	/* want_derivs */
349 	12,	/* ihd_limit */
350 	-1,	/* solve_code */
351 	obj0val,
352 	obj0grd,
353 	con0val,
354 	jac0val,
355 	con0ival,
356 	con0grd,
357 	hv0comp,
358 	hv0init,
359 	hes0set,
360 	lcon0val,
361 	x0known,
362 	dut0hes,
363 	ful0hes,
364 	sut0hes,
365 	sut0set
366 	};
367 
368  int
369 #ifdef KR_headers
370 edag_peek(R) EdRead *R;
371 #else
372 edag_peek(EdRead *R)
373 #endif
374 {
375 	int c;
376 	R->Line++;
377 	R->lineinc = 0;
378 	R->rl_buf[0] = c = getc(R->nl);
379 	return c;
380 	}
381 
382  static void
383 #ifdef KR_headers
384 eatcr(nl) FILE *nl;
385 #else
386 eatcr(FILE *nl)
387 #endif
388 {
389 	int c;
390 
391 	while((c = getc(nl)) == '\r');
392 	if (c >= 0 && c != '\n')
393 		ungetc(c, nl);
394 	}
395 
396  char *
397 #ifdef KR_headers
398 read_line(R) EdRead *R;
399 #else
400 read_line(EdRead *R)
401 #endif
402 {
403 	char *s, *se;
404 	int x;
405 	char *rv;
406 	FILE *nl = R->nl;
407 
408 	s = R->rl_buf;
409 	se = s + sizeof(R->rl_buf) - 1;
410 	if (R->lineinc)
411 		R->Line++;
412 	else {
413 		s++;
414 		R->lineinc = 1;
415 		}
416 	rv = s;
417 	for(;;) {
418 		x = getc(nl);
419 		if (x < ' ') {
420 			if (x < 0) {
421  eof:
422 				if (R->can_end)
423 					return 0;
424 				fprintf(Stderr,
425 				 "Premature end of file, line %ld of %s\n",
426 					R->Line, R->asl->i.filename_);
427 				exit_ASL(R,1);
428 				}
429 			if (x == '\n')
430 				break;
431 			if (x == '\r') {
432 				eatcr(nl);
433 				break;
434 				}
435 			}
436 		*s++ = x;
437 		if (s >= se) {
438 			for(;;) {
439 				x = getc(nl);
440 				if (x == '\r') {
441 					eatcr(nl);
442 					goto eol;
443 					}
444 				if (x == '\n')
445 					goto eol;
446 				if (x < 0)
447 					goto eof;
448 				}
449 			}
450 		}
451  eol:
452 	*s = 0;
453 	return rv;
454 	}
455 
456  static void
457 #ifdef KR_headers
458 memfailure(who, what, len) char *who, *what; size_t len;
459 #else
460 memfailure(char *who, char *what, size_t len)
461 #endif
462 {
463 	fprintf(Stderr, "%s(%lu) failure: %s.\n", who, (long)len, what);
464 	exit(1);
465 	}
466 
467 static char	ran_out[] =	"ran out of memory";
468 
469 #ifdef KR_headers
470  Char *
471 mymalloc(len) size_t len;
472 #else
473  void *
474 mymalloc(size_t len)
475 #endif
476 {
477 #ifdef KR_headers
478 	char *rv;
479 #else
480 	void *rv;
481 #endif
482 	static char who[] = "malloc";
483 	rv = malloc(len);
484 	if (!rv) {
485 		/* Defend against stupid systems: malloc(0) */
486 		/* should return a nonzero value.  Routines in */
487 		/* amplsolver.a should never call malloc(0), but */
488 		/* solvers may do so. */
489 		if (!len)
490 			rv = malloc(sizeof(real));
491 		if (!rv)
492 			memfailure(who, ran_out, len);
493 		}
494 	return rv;
495 	}
496 
497 #ifdef KR_headers
498  Char *
499 myralloc(rv, len) char *rv; size_t len;
500 #else
501  void *
502 myralloc(void *rv, size_t len)
503 #endif
504 {
505 	static char who[] = "realloc";
506 	rv = realloc(rv, len);
507 	if (!rv) {
508 		if (!len)
509 			rv = malloc(sizeof(real));
510 		if (!rv)
511 			memfailure(who, ran_out, len);
512 		}
513 	return rv;
514 	}
515 
516  void
517 what_prog(VOID)
518 {
519 	if (progname)
520 		fprintf(Stderr, "%s: ", progname);
521 	}
522 
523  void
524 #ifdef KR_headers
525 badread(R) EdRead *R;
526 #else
527 badread(EdRead *R)
528 #endif
529 {
530 	what_prog();
531 	fprintf(Stderr, "error reading line %ld of %s:\n\t", R->Line, R->asl->i.filename_);
532 	}
533 
534  void
535 #ifdef KR_headers
536 badline(R) EdRead *R;
537 #else
538 badline(EdRead *R)
539 #endif
540 {
541 	ASL *asl = R->asl;
542 	FILE *nl;
543 	char *s, *se;
544 	int x;
545 
546 	fprintf(Stderr, "bad line %ld of %s", R->Line, filename);
547 	if (xscanf == ascanf) {
548 		if (!R->lineinc) {
549 			nl = R->nl;
550 			s = R->rl_buf;
551 			se = s + sizeof(R->rl_buf) - 1;
552 			while(s < se && (x = getc(nl)) >= ' ')
553 				*++s = x;
554 			*s = 0;
555 			}
556 		fprintf(Stderr, ": %s\n", R->rl_buf);
557 		}
558 	else
559 		fprintf(Stderr, "\n");
560 	exit_ASL(R,1);
561 	}
562 
563 #undef asl
564 
565 #define Mb_gulp 31
566  typedef struct Mblock {
567 	struct Mblock *next;
568 	Char *m[Mb_gulp];
569 	} Mblock;
570 
571  Char **
572 #ifdef KR_headers
573 M1record_ASL(I, x) Edaginfo *I; Char *x;
574 #else
575 M1record_ASL(Edaginfo *I, Char *x)
576 #endif
577 {
578 	Mblock *mb;
579 	Char **rv;
580 
581 	if (I->Mbnext >= I->Mblast) {
582 		mb = (Mblock *)Malloc(sizeof(Mblock));
583 		mb->next = (Mblock*)I->Mb;
584 		I->Mb = (Char*)mb;
585 		I->Mbnext = mb->m;
586 		I->Mblast = mb->m + Mb_gulp;
587 		}
588 	rv = I->Mbnext++;
589 	*rv = x;
590 	return rv;
591 	}
592 
593  Char *
594 #ifdef KR_headers
595 M1alloc_ASL(I, n) Edaginfo *I; size_t n;
596 #else
597 M1alloc_ASL(Edaginfo *I, size_t n)
598 #endif
599 {
600 	Mblock *mb;
601 
602 	if (I->Mbnext >= I->Mblast) {
603 		mb = (Mblock *)Malloc(sizeof(Mblock));
604 		mb->next = (Mblock*)I->Mb;
605 		I->Mb = (Char*)mb;
606 		I->Mbnext = mb->m;
607 		I->Mblast = mb->m + Mb_gulp;
608 		}
609 	return *I->Mbnext++ = Malloc(n);
610 	}
611 
612  Char *
613 #ifdef KR_headers
614 M1zapalloc_ASL(I, n) Edaginfo *I; size_t n;
615 #else
616 M1zapalloc_ASL(Edaginfo *I, size_t n)
617 #endif
618 {
619 	Char *rv;
620 
621 	memset(rv = M1alloc_ASL(I, n), 0, n);
622 	return rv;
623 	}
624 
625  void
626 #ifdef KR_headers
627 M1free_ASL(I, mnext, mlast) Edaginfo *I; Char **mnext, **mlast;
628 #else
629 M1free_ASL(Edaginfo *I, Char **mnext, Char **mlast)
630 #endif
631 {
632 	Char **x, **x0;
633 	Mblock *Mb, *mb;
634 	Char **Mblast;
635 
636 	if (!(Mb = (Mblock *)I->Mb))
637 		return;
638 	x = (Char **)I->Mbnext;
639 	Mblast = I->Mblast;
640 	I->Mbnext = mnext;
641 	I->Mblast = mlast;
642 	x0 = Mb->m;
643 	for(;;) {
644 		if (mlast == Mblast)
645 			x0 = mnext;
646 		while(x > x0)
647 			if (*--x)
648 				free(*x);
649 		if (mlast == Mblast) {
650 			I->Mb = (Char*)Mb;
651 			return;
652 			}
653 		mb = Mb->next;
654 		free(Mb);
655 		if (!(Mb = mb))
656 			break;
657 		x0 = Mb->m;
658 		Mblast = x = x0 + Mb_gulp;
659 		}
660 	I->Mb = 0;
661 	}
662 
663  void
664 #ifdef KR_headers
665 xknown_(x) real *x;
666 #else
667 xknown_(real *x)
668 #endif
669 {
670 	ASL *asl;
671 	if (!(asl = cur_ASL))
672 		badasl_ASL(asl,0,"xknown");
673 	xknowne(x, (fint*)0);
674 	}
675 
676  void
677 #ifdef KR_headers
678 xknowe_(x, nerror) real *x; fint *nerror;
679 #else
680 xknowe_(real *x, fint *nerror)
681 #endif
682 {
683 	ASL *asl;
684 	if (!(asl = cur_ASL))
685 		badasl_ASL(asl,0,"xknown");
686 	xknowne(x, nerror);
687 	}
688 
689 
690  void
691 xunkno_(VOID)
692 {
693 	ASL *asl;
694 	if (!(asl = cur_ASL))
695 		badasl_ASL(asl,0,"xunkno");
696 	asl->i.x_known = 0;
697 	}
698 
699  void
700 #ifdef KR_headers
701 mnnzchk_ASL(asl, M, N, NZ, who1) ASL*asl; fint *M,*N,*NZ; char*who1;
702 #else
703 mnnzchk_ASL(ASL *asl, fint *M, fint *N, fint *NZ, char *who1)
704 #endif
705 {
706 	int n;
707 	if (!asl || (n = asl->i.ASLtype) < ASL_read_fg || n > ASL_read_pfgh)
708 		badasl_ASL(asl, ASL_read_fg, who1);
709 	ASL_CHECK(asl, n, who1);
710 	if (*M != n_con || *N != c_vars || *NZ != nzjac) {
711 		what_prog();
712 		fprintf(Stderr,
713  "%s: got M = %ld, N = %ld, NZ = %ld\nexpected M = %d, N = %d, NZ = %d\n",
714 			who1, (long)*M, (long)*N, *NZ, n_con, c_vars, nzjac);
715 		exit(1);
716 		}
717 	}
718 
719  void
720 #ifdef KR_headers
721 LUcopy_ASL(nv, L, U, LU) int nv; real *L, *U, *LU;
722 #else
723 LUcopy_ASL(int nv, real *L, real *U, real *LU)
724 #endif
725 {
726 	real *LUe;
727 	for(LUe = LU + 2*nv; LU < LUe; LU += 2) {
728 		*L++ = LU[0];
729 		*U++ = LU[1];
730 		}
731 	}
732 
733  int
734 #ifdef KR_headers
735 already_ASL(who) char *who;
736 #else
737 already_ASL(char *who)
738 #endif
739 {
740 	fprintf(Stderr, "%s called after ASL_alloc().\n", who);
741 	return 1;
742 	}
743 
744  void
745 #ifdef KR_headers
746 ASL_free(aslp) ASL **aslp;
747 #else
748 ASL_free(ASL **aslp)
749 #endif
750 {
751 	ASL *a;
752 	ASLhead *h;
753 	extern void at_end_ASL ANSI((Exitcall*));
754 
755 	if (!(a = *aslp))
756 		return;
757 	if (a == cur_ASL)
758 		cur_ASL = 0;
759 	h = a->p.h.prev;
760 	(h->next = a->p.h.next)->prev = h;
761 	if (a->i.arprev)
762 		at_end_ASL(a->i.arprev);
763 	M1free(&a->i, (Char**)0, (Char**)0);
764 	free((Char*)a);
765 	*aslp = 0;
766 	}
767 
768  void
769 #ifdef KR_headers
770 badasl_ASL(a, n, who) ASL *a; int n; char *who;
771 #else
772 badasl_ASL(ASL *a, int n, char *who)
773 #endif
774 {
775 	if (!Stderr)
776 		Stderr_init_ASL();	/* set Stderr if necessary */
777 	if (a)
778 		fprintf(Stderr,
779 			"\n*** %s needs ASL_alloc(%d), not ASL_alloc(%d)\n",
780 			who, n, a->i.ASLtype);
781 	else if (n)
782 		fprintf(Stderr, "\n*** %s called before ASL_alloc(%d)\n",
783 			who, n);
784 	else
785 		fprintf(Stderr,
786 		 "\n*** %s called before ASL_alloc, jacdim, jac2dim, or jacpdim\n", who);
787 	exit(1);
788 	}
789 
790 #define SKIP_NL2_DEFINES
791 #include "nlp.h"
792 #include "nlp2.h"
793 #include "asl_pfg.h"
794 #include "asl_pfgh.h"
795 
796  ASL *
797 #ifdef KR_headers
798 ASL_alloc(k) int k;
799 #else
800 ASL_alloc(int k)
801 #endif
802 {
803 	static int msize[5] = {
804 		sizeof(ASL_fg),
805 		sizeof(ASL_fg),
806 		sizeof(ASL_fgh),
807 		sizeof(ASL_pfg),
808 		sizeof(ASL_pfgh)
809 		};
810 	ASL *a;
811 	ASLhead *h;
812 	int n;
813 
814 	if (!Stderr)
815 		Stderr_init_ASL();	/* set Stderr if necessary */
816 	Mach_ASL();
817 	if (k < 1 || k > 5)
818 		return 0;
819 	a = (ASL*) mymalloc(n = msize[k-1]);
820 	memcpy(a, &edagpars_ASL, sizeof(Edagpars));
821 	memset(&a->i, 0, n - sizeof(Edagpars));
822 	a->i.ASLtype = k;
823 	a->i.n_prob = 1;
824 	switch(k) {
825 	  case ASL_read_pfg:	((ASL_pfg*)a)->P.merge = 1; break;
826 	  case ASL_read_pfgh:	((ASL_pfgh*)a)->P.merge = 1;
827 	  }
828 	h = a->p.h.next = ASLhead_ASL.next;
829 	a->p.h.prev = h->prev;
830 	h->prev = ASLhead_ASL.next = &a->p.h;
831 	return cur_ASL = a;
832 	}
833 
834 #define Egulp 400
835 
836  Char *
837 #ifdef KR_headers
838 mem_ASL(asl, len) ASL *asl; unsigned int len;
839 #else
840 mem_ASL(ASL *asl, unsigned int len)
841 #endif
842 {
843 	fint k;
844 	char *memNext;
845 
846 	if (len >= 256)
847 		return M1alloc(len);
848 #ifdef Double_Align
849 	len = (len + (sizeof(real)-1)) & ~(sizeof(real)-1);
850 #else
851 	len = (len + (sizeof(int)-1)) & ~(sizeof(int)-1);
852 #endif
853 	ACQUIRE_DTOA_LOCK(MEM_LOCK);
854 	memNext = asl->i.memNext;
855 	if (memNext + len >= asl->i.memLast) {
856 		memNext = (char *)M1alloc(k = Egulp*Sizeof(expr) + len);
857 		asl->i.memLast = memNext + k;
858 		}
859 	asl->i.memNext = memNext + len;
860 	FREE_DTOA_LOCK(MEM_LOCK);
861 	return memNext;
862 	}
863 
864  EdRead *
865 #ifdef KR_headers
866 EdReadInit_ASL(R, asl, nl, S) EdRead *R; ASL *asl; FILE *nl; void *S;
867 #else
868 EdReadInit_ASL(EdRead *R, ASL *asl, FILE *nl, void *S)
869 #endif
870 {
871 	R->asl = asl;
872 	R->nl = nl;
873 	R->S = S;
874 	R->Line = 10;
875 	R->lineinc = 1;
876 	R->can_end = 0;
877 	R->dadjfcn = asl->i.dadjfcn;
878 	R->iadjfcn = asl->i.iadjfcn;
879 	return R;
880 	}
881 
882  void
883 #ifdef KR_headers
884 Suf_read_ASL(R, readall) EdRead *R; int readall;
885 #else
886 Suf_read_ASL(EdRead *R, int readall)
887 #endif
888 {
889 	int *d, isreal, i, k, n, nx, nx1;
890 	real *r, t;
891 	SufDesc *D;
892 	char *fmt;
893 	ASL *asl = R->asl;
894 	char sufname[128];
895 
896 	if (xscanf(R, "%d %d %127s", &k, &n, sufname) != 3)
897 		badline(R);
898 	if (k < 0 || k > 7 || n <= 0)
899 		badline(R);
900 	isreal = k & ASL_Sufkind_real;
901 	k &= ASL_Sufkind_mask;
902 	nx = (&asl->i.n_var_)[k];
903 	if (k == 1)
904 		nx += n_lcon;
905 	if (n > nx)
906 		badline(R);
907 	if (readall & 1) {
908  new_D:
909 		D = (SufDesc*)M1zapalloc(sizeof(SufDesc) + strlen(sufname) + 1);
910 		D->next = asl->i.suffixes[k];
911 		asl->i.suffixes[k] = D;
912 		asl->i.nsuff[k]++;
913 		asl->i.nsuffixes++;
914 		strcpy(D->sufname = (char*)(D+1), sufname);
915 		D->kind = k;
916 		if (isreal)
917 			D->kind |= ASL_Sufkind_real;
918 		}
919 	else for(D = asl->i.suffixes[k]; ; D = D->next) {
920 		if (!D) {
921 			if (readall)
922 				goto new_D;
923  skip:
924 			/* Skip this suffix table */
925 			fmt = (char*)(isreal ? "%d %lf" : "%d %d");
926 			do if (xscanf(R,fmt,&k,&t) != 2)
927 					badline(R);
928 				while(--n);
929 			return;
930 			}
931 		if (k == (D->kind & ASL_Sufkind_mask)
932 		 && !strcmp(sufname,D->sufname))
933 			break;
934 		}
935 	if ((D->kind & ASL_Sufkind_outonly) == ASL_Sufkind_outonly)
936 		goto skip;
937 	nx1 = nx + D->nextra;
938 	if (D->kind & ASL_Sufkind_real) {
939 		D->u.i = 0;
940 		if (!(r = D->u.r))
941 			D->u.r = r = (real*)mem(nx1*sizeof(real));
942 		if (n < nx)
943 			memset(r,0,nx*sizeof(real));
944 		if (nx < nx1)
945 			memset(r+nx, 0, (nx1-nx)*sizeof(real));
946 		if (isreal)
947 			do  {
948 				if (xscanf(R,"%d %lf",&i,&t) != 2
949 				 || i < 0 || i >= nx)
950 					badline(R);
951 				r[i] = t;
952 				}
953 				while(--n);
954 		else
955 			do  {
956 				if (xscanf(R,"%d %d",&i,&k) != 2
957 				 || i < 0 || i >= nx)
958 					badline(R);
959 				r[i] = k;
960 				}
961 				while(--n);
962 		}
963 	else {
964 		D->u.r = 0;
965 		if (!(d = D->u.i))
966 			D->u.i = d = (int*)mem(nx1*sizeof(int));
967 		if (n < nx)
968 			memset(d,0,nx*sizeof(int));
969 		if (nx < nx1)
970 			memset(d+nx, 0, (nx1-nx)*sizeof(int));
971 		if (isreal)
972 			do {
973 				if (xscanf(R,"%d %lf",&i,&t) != 2
974 				 || i < 0 || i >= nx)
975 					badline(R);
976 				d[i] = (int)(t + 0.5);
977 				} while(--n);
978 		else
979 			do {
980 				if (xscanf(R,"%d %d",&i,&k) != 2
981 				 || i < 0 || i >= nx)
982 					badline(R);
983 				d[i] = k;
984 				}
985 				while(--n);
986 		}
987 	D->kind |= ASL_Sufkind_input;
988 	}
989 
990  real
991 #ifdef KR_headers
992 f_OPNUM_ASL(e) expr_n *e;
993 #else
994 f_OPNUM_ASL(expr_n *e)
995 #endif
996 {
997 #ifdef _WIN32	/* Work around a Microsoft linker bug... */
998 		/* Without the following test, f_OPNUM gets confused */
999 		/* with f_OPVARVAL.  Both get mapped to the same address */
1000 		/* in the r_ops_ASL array defined in fg_read.c. */
1001 	if (!e) {
1002 		printf("f_OPNUM(e) has e = 0\n");
1003 		return 0.;
1004 		}
1005 #endif
1006 	return e->v;
1007 	}
1008 
1009  void
1010 #ifdef KR_headers
1011 No_derivs_ASL(who) char *who;
1012 #else
1013 No_derivs_ASL(const char *who)
1014 #endif
1015 {
1016 	fprintf(Stderr, "\nBUG: %s called with want_derivs == 0.\n", who);
1017 	exit(1);
1018 	}
1019 
1020  void
1021 #ifdef KR_headers
1022 suf_declare_ASL(asl, sd, n) ASL *asl; SufDecl *sd; int n;
1023 #else
1024 suf_declare_ASL(ASL *asl, SufDecl *sd, int n)
1025 #endif
1026 {
1027 	SufDesc *d, *dnext[4];
1028 	SufDecl *sde;
1029 	int i, j;
1030 
1031 	if (!asl)
1032 		badasl_ASL(asl, 0, "suf_declare");
1033 	asl->i.nsuffixes = 0;
1034 	if (n > 0) {
1035 		asl->i.nsuffixes = n;
1036 		d = (SufDesc*)M1alloc(n*sizeof(SufDesc));
1037 		memset(asl->i.nsuff, 0, 4*sizeof(int));
1038 		for(i = 0; i < n; i++)
1039 			asl->i.nsuff[sd[i].kind & ASL_Sufkind_mask]++;
1040 		for(i = 0; i < 4; i++)
1041 			if (j = asl->i.nsuff[i])
1042 				asl->i.suffixes[i] = d += j;
1043 		memset(dnext, 0, 4*sizeof(SufDesc*));
1044 		for(sde = sd + n; sd < sde; sd++) {
1045 			d = --asl->i.suffixes[i = sd->kind & ASL_Sufkind_mask];
1046 			d->next = dnext[i];
1047 			dnext[i] = d;
1048 			d->sufname = sd->name;
1049 			d->table = sd->table;
1050 			d->kind = sd->kind & ~ASL_Sufkind_input;
1051 			d->nextra = sd->nextra;
1052 			d->u.i = 0;
1053 			d->u.r = 0;
1054 			}
1055 		}
1056 	}
1057 
1058  SufDesc *
1059 #ifdef KR_headers
1060 suf_get_ASL(asl, name, kind) ASL *asl; char *name; int kind;
1061 #else
1062 suf_get_ASL(ASL *asl, const char *name, int kind)
1063 #endif
1064 {
1065 	SufDesc *d, *de;
1066 	int ifread;
1067 
1068 	if (!asl)
1069 		badasl_ASL(asl, 0, "suf_get");
1070 	ifread = kind & ASL_Sufkind_input;
1071 	d = asl->i.suffixes[kind &= ASL_Sufkind_mask];
1072 	de = d + asl->i.nsuff[kind];
1073 	for(;; d++) {
1074 		if (d >= de) {
1075 			fprintf(Stderr, "suf_get(\"%s\") fails!\n", name);
1076 			exit(1);
1077 			}
1078 		if (!strcmp(name, d->sufname))
1079 			break;
1080 		}
1081 	if (ifread && !(d->kind & ASL_Sufkind_input))
1082 		d = 0;
1083 	return d;
1084 	}
1085 
1086  SufDesc *
1087 #ifdef KR_headers
1088 suf_iput_ASL(asl, name, kind, I) ASL *asl; char *name; int kind, *I;
1089 #else
1090 suf_iput_ASL(ASL *asl, const char *name, int kind, int *I)
1091 #endif
1092 {
1093 	SufDesc *d = suf_get_ASL(asl, name, kind);
1094 	d->u.i = I;
1095 	d->kind &= ~ASL_Sufkind_real;
1096 	d->kind |= ASL_Sufkind_output;
1097 	return d;
1098 	}
1099 
1100  SufDesc *
1101 #ifdef KR_headers
1102 suf_rput_ASL(asl, name, kind, R) ASL *asl; char *name; int kind; real *R;
1103 #else
1104 suf_rput_ASL(ASL *asl, const char *name, int kind, real *R)
1105 #endif
1106 {
1107 	SufDesc *d = suf_get_ASL(asl, name, kind);
1108 	d->u.r = R;
1109 	d->kind |= ASL_Sufkind_output | ASL_Sufkind_real;
1110 	return d;
1111 	}
1112 
1113 #ifdef __cplusplus
1114 }
1115 #endif
1116