![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to libF77.st CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to libF77.st CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: ./ ADD NAME=libF77/Notice TIME=695663806
2: /****************************************************************
3: Copyright 1990, 1991, 1992 by AT&T Bell Laboratories and Bellcore.
4:
5: Permission to use, copy, modify, and distribute this software
6: and 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 names of AT&T Bell Laboratories or
11: Bellcore or any of their entities not be used in advertising or
12: publicity pertaining to distribution of the software without
13: specific, written prior permission.
14:
15: AT&T and Bellcore disclaim all warranties with regard to this
16: software, including all implied warranties of merchantability
17: and fitness. In no event shall AT&T or Bellcore be liable for
18: any 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: ./ ADD NAME=libF77/README TIME=714695815
26: If your compiler does not recognize ANSI C headers,
27: compile with KR_headers defined: either add -DKR_headers
28: to the definition of CFLAGS in the makefile, or insert
29:
30: #define KR_headers
31:
32: at the top of f2c.h .
33:
34:
35: If you use a C++ compiler, first create a local f2c.h by appending
36: f2ch.add to the usual f2c.h, e.g., by issuing the command
37: make f2c.h
38: which assumes f2c.h is installed in /usr/include .
39:
40: If your system lacks onexit() and you are not using an ANSI C
41: compiler, then you should compile main.c with NO_ONEXIT defined.
42: See the comments about onexit in the makefile.
43:
44: If your system has a double drem() function such that drem(a,b)
45: is the IEEE remainder function (with double a, b), then you may
46: wish to compile r_mod.c and d_mod.c with IEEE_drem defined.
47:
48: To check for transmission errors, issue the command
49: make check
50: This assumes you have the xsum program whose source, xsum.c,
51: is distributed as part of "all from f2c/src". If you do not
52: have xsum, you can obtain xsum.c by sending the following E-mail
53: message to [email protected]
54: send xsum.c from f2c/src
55:
56: The makefile assumes you have installed f2c.h in a standard
57: place (and does not cause recompilation when f2c.h is changed);
58: f2c.h comes with "all from f2c" (the source for f2c) and is
59: available separately ("f2c.h from f2c").
60:
61: Most of the routines in libF77 are support routines for Fortran
62: intrinsic functions or for operations that f2c chooses not
63: to do "in line". There are a few exceptions, summarized below --
64: functions and subroutines that appear to your program as ordinary
65: external Fortran routines.
66:
67: 1. CALL ABORT prints a message and causes a core dump.
68:
69: 2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION
70: error functions (with x REAL and d DOUBLE PRECISION);
71: DERF must be declared DOUBLE PRECISION in your program.
72: Both ERF and DERF assume your C library provides the
73: underlying erf() function (which not all systems do).
74:
75: 3. ERFC(r) and DERFC(d) are the complementary error functions:
76: ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d)
77: (except that their results may be more accurate than
78: explicitly evaluating the above formulae would give).
79: Again, ERFC and r are REAL, and DERFC and d are DOUBLE
80: PRECISION (and must be declared as such in your program),
81: and ERFC and DERFC rely on your system's erfc().
82:
83: 4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER
84: variable, sets s to the n-th command-line argument (or to
85: all blanks if there are fewer than n command-line arguments);
86: CALL GETARG(0,s) sets s to the name of the program (on systems
87: that support this feature). See IARGC below.
88:
89: 5. CALL GETENV(name, value), where name and value are of type
90: CHARACTER, sets value to the environment value, $name, of
91: name (or to blanks if $name has not been set).
92:
93: 6. NARGS = IARGC() sets NARGS to the number of command-line
94: arguments (an INTEGER value).
95:
96: 7. CALL SIGNAL(n,func), where n is an INTEGER and func is an
97: EXTERNAL procedure, arranges for func to be invoked when
98: signal n occurs (on systems where this makes sense).
99:
100: 8. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes
101: cmd to the system's command processor (on systems where
102: this can be done).
103: ./ ADD NAME=libF77/Version.c TIME=719849949
104: static char junk[] = "\n@(#)LIBF77 VERSION 2.01 23 Oct. 1992\n";
105:
106: /*
107: 2.00 11 June 1980. File version.c added to library.
108: 2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed
109: [ d]erf[c ] added
110: 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c
111: 29 Nov. 1989: s_cmp returns long (for f2c)
112: 30 Nov. 1989: arg types from f2c.h
113: 12 Dec. 1989: s_rnge allows long names
114: 19 Dec. 1989: getenv_ allows unsorted environment
115: 28 Mar. 1990: add exit(0) to end of main()
116: 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main
117: 17 Oct. 1990: abort() calls changed to sig_die(...,1)
118: 22 Oct. 1990: separate sig_die from main
119: 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die
120: 31 May 1991: make system_ return status
121: 18 Dec. 1991: change long to ftnlen (for -i2) many places
122: 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer)
123: 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c
124: and m**n in pow_hh.c and pow_ii.c;
125: catch SIGTRAP in main() for error msg before abort
126: 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined
127: 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg);
128: change Cabs to f__cabs.
129: */
130: ./ ADD NAME=libF77/abort_.c TIME=708871716
131: #include "stdio.h"
132: #include "f2c.h"
133:
134: #ifdef KR_headers
135: extern VOID sig_die();
136:
137: VOID abort_()
138: #else
139: extern void sig_die(char*,int);
140:
141: void abort_(void)
142: #endif
143: {
144: sig_die("Fortran abort routine called", 1);
145: }
146: ./ ADD NAME=libF77/c_abs.c TIME=719848057
147: #include "f2c.h"
148:
149: #ifdef KR_headers
150: extern double f__cabs();
151:
152: double c_abs(z) complex *z;
153: #else
154: extern double f__cabs(double, double);
155:
156: double c_abs(complex *z)
157: #endif
158: {
159: return( f__cabs( z->r, z->i ) );
160: }
161: ./ ADD NAME=libF77/c_cos.c TIME=708889712
162: #include "f2c.h"
163:
164: #ifdef KR_headers
165: extern double sin(), cos(), sinh(), cosh();
166:
167: VOID c_cos(r, z) complex *r, *z;
168: #else
169: #undef abs
170: #include "math.h"
171:
172: void c_cos(complex *r, complex *z)
173: #endif
174: {
175: r->r = cos(z->r) * cosh(z->i);
176: r->i = - sin(z->r) * sinh(z->i);
177: }
178: ./ ADD NAME=libF77/c_div.c TIME=708872168
179: #include "f2c.h"
180:
181: #ifdef KR_headers
182: extern VOID sig_die();
183: VOID c_div(c, a, b)
184: complex *a, *b, *c;
185: #else
186: extern void sig_die(char*,int);
187: void c_div(complex *c, complex *a, complex *b)
188: #endif
189: {
190: double ratio, den;
191: double abr, abi;
192:
193: if( (abr = b->r) < 0.)
194: abr = - abr;
195: if( (abi = b->i) < 0.)
196: abi = - abi;
197: if( abr <= abi )
198: {
199: if(abi == 0)
200: sig_die("complex division by zero", 1);
201: ratio = (double)b->r / b->i ;
202: den = b->i * (1 + ratio*ratio);
203: c->r = (a->r*ratio + a->i) / den;
204: c->i = (a->i*ratio - a->r) / den;
205: }
206:
207: else
208: {
209: ratio = (double)b->i / b->r ;
210: den = b->r * (1 + ratio*ratio);
211: c->r = (a->r + a->i*ratio) / den;
212: c->i = (a->i - a->r*ratio) / den;
213: }
214: }
215: ./ ADD NAME=libF77/c_exp.c TIME=708889712
216: #include "f2c.h"
217:
218: #ifdef KR_headers
219: extern double exp(), cos(), sin();
220:
221: VOID c_exp(r, z) complex *r, *z;
222: #else
223: #undef abs
224: #include "math.h"
225:
226: void c_exp(complex *r, complex *z)
227: #endif
228: {
229: double expx;
230:
231: expx = exp(z->r);
232: r->r = expx * cos(z->i);
233: r->i = expx * sin(z->i);
234: }
235: ./ ADD NAME=libF77/c_log.c TIME=719848057
236: #include "f2c.h"
237:
238: #ifdef KR_headers
239: extern double log(), f__cabs(), atan2();
240: VOID c_log(r, z) complex *r, *z;
241: #else
242: #undef abs
243: #include "math.h"
244: extern double f__cabs(double, double);
245:
246: void c_log(complex *r, complex *z)
247: #endif
248: {
249: r->i = atan2(z->i, z->r);
250: r->r = log( f__cabs(z->r, z->i) );
251: }
252: ./ ADD NAME=libF77/c_sin.c TIME=708889712
253: #include "f2c.h"
254:
255: #ifdef KR_headers
256: extern double sin(), cos(), sinh(), cosh();
257:
258: VOID c_sin(r, z) complex *r, *z;
259: #else
260: #undef abs
261: #include "math.h"
262:
263: void c_sin(complex *r, complex *z)
264: #endif
265: {
266: r->r = sin(z->r) * cosh(z->i);
267: r->i = cos(z->r) * sinh(z->i);
268: }
269: ./ ADD NAME=libF77/c_sqrt.c TIME=719848058
270: #include "f2c.h"
271:
272: #ifdef KR_headers
273: extern double sqrt(), f__cabs();
274:
275: VOID c_sqrt(r, z) complex *r, *z;
276: #else
277: #undef abs
278: #include "math.h"
279: extern double f__cabs(double, double);
280:
281: void c_sqrt(complex *r, complex *z)
282: #endif
283: {
284: double mag, t;
285:
286: if( (mag = f__cabs(z->r, z->i)) == 0.)
287: r->r = r->i = 0.;
288: else if(z->r > 0)
289: {
290: r->r = t = sqrt(0.5 * (mag + z->r) );
291: t = z->i / t;
292: r->i = 0.5 * t;
293: }
294: else
295: {
296: t = sqrt(0.5 * (mag - z->r) );
297: if(z->i < 0)
298: t = -t;
299: r->i = t;
300: t = z->i / t;
301: r->r = 0.5 * t;
302: }
303: }
304: ./ ADD NAME=libF77/cabs.c TIME=719848058
305: #ifdef KR_headers
306: extern double sqrt();
307: double f__cabs(real, imag) double real, imag;
308: #else
309: #undef abs
310: #include "math.h"
311: double f__cabs(double real, double imag)
312: #endif
313: {
314: double temp;
315:
316: if(real < 0)
317: real = -real;
318: if(imag < 0)
319: imag = -imag;
320: if(imag > real){
321: temp = real;
322: real = imag;
323: imag = temp;
324: }
325: if((real+imag) == real)
326: return(real);
327:
328: temp = imag/real;
329: temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/
330: return(temp);
331: }
332: ./ ADD NAME=libF77/d_abs.c TIME=708873064
333: #include "f2c.h"
334:
335: #ifdef KR_headers
336: double d_abs(x) doublereal *x;
337: #else
338: double d_abs(doublereal *x)
339: #endif
340: {
341: if(*x >= 0)
342: return(*x);
343: return(- *x);
344: }
345: ./ ADD NAME=libF77/d_acos.c TIME=708889712
346: #include "f2c.h"
347:
348: #ifdef KR_headers
349: double acos();
350: double d_acos(x) doublereal *x;
351: #else
352: #undef abs
353: #include "math.h"
354: double d_acos(doublereal *x)
355: #endif
356: {
357: return( acos(*x) );
358: }
359: ./ ADD NAME=libF77/d_asin.c TIME=708889712
360: #include "f2c.h"
361:
362: #ifdef KR_headers
363: double asin();
364: double d_asin(x) doublereal *x;
365: #else
366: #undef abs
367: #include "math.h"
368: double d_asin(doublereal *x)
369: #endif
370: {
371: return( asin(*x) );
372: }
373: ./ ADD NAME=libF77/d_atan.c TIME=708889712
374: #include "f2c.h"
375:
376: #ifdef KR_headers
377: double atan();
378: double d_atan(x) doublereal *x;
379: #else
380: #undef abs
381: #include "math.h"
382: double d_atan(doublereal *x)
383: #endif
384: {
385: return( atan(*x) );
386: }
387: ./ ADD NAME=libF77/d_atn2.c TIME=708889712
388: #include "f2c.h"
389:
390: #ifdef KR_headers
391: double atan2();
392: double d_atn2(x,y) doublereal *x, *y;
393: #else
394: #undef abs
395: #include "math.h"
396: double d_atn2(doublereal *x, doublereal *y)
397: #endif
398: {
399: return( atan2(*x,*y) );
400: }
401: ./ ADD NAME=libF77/d_cnjg.c TIME=708873825
402: #include "f2c.h"
403:
404: VOID
405: #ifdef KR_headers
406: d_cnjg(r, z) doublecomplex *r, *z;
407: #else
408: d_cnjg(doublecomplex *r, doublecomplex *z)
409: #endif
410: {
411: r->r = z->r;
412: r->i = - z->i;
413: }
414: ./ ADD NAME=libF77/d_cos.c TIME=708889712
415: #include "f2c.h"
416:
417: #ifdef KR_headers
418: double cos();
419: double d_cos(x) doublereal *x;
420: #else
421: #undef abs
422: #include "math.h"
423: double d_cos(doublereal *x)
424: #endif
425: {
426: return( cos(*x) );
427: }
428: ./ ADD NAME=libF77/d_cosh.c TIME=708889712
429: #include "f2c.h"
430:
431: #ifdef KR_headers
432: double cosh();
433: double d_cosh(x) doublereal *x;
434: #else
435: #undef abs
436: #include "math.h"
437: double d_cosh(doublereal *x)
438: #endif
439: {
440: return( cosh(*x) );
441: }
442: ./ ADD NAME=libF77/d_dim.c TIME=708874152
443: #include "f2c.h"
444:
445: #ifdef KR_headers
446: double d_dim(a,b) doublereal *a, *b;
447: #else
448: double d_dim(doublereal *a, doublereal *b)
449: #endif
450: {
451: return( *a > *b ? *a - *b : 0);
452: }
453: ./ ADD NAME=libF77/d_exp.c TIME=708889712
454: #include "f2c.h"
455:
456: #ifdef KR_headers
457: double exp();
458: double d_exp(x) doublereal *x;
459: #else
460: #undef abs
461: #include "math.h"
462: double d_exp(doublereal *x)
463: #endif
464: {
465: return( exp(*x) );
466: }
467: ./ ADD NAME=libF77/d_imag.c TIME=708874254
468: #include "f2c.h"
469:
470: #ifdef KR_headers
471: double d_imag(z) doublecomplex *z;
472: #else
473: double d_imag(doublecomplex *z)
474: #endif
475: {
476: return(z->i);
477: }
478: ./ ADD NAME=libF77/d_int.c TIME=708889712
479: #include "f2c.h"
480:
481: #ifdef KR_headers
482: double floor();
483: double d_int(x) doublereal *x;
484: #else
485: #undef abs
486: #include "math.h"
487: double d_int(doublereal *x)
488: #endif
489: {
490: return( (*x>0) ? floor(*x) : -floor(- *x) );
491: }
492: ./ ADD NAME=libF77/d_lg10.c TIME=708889712
493: #include "f2c.h"
494:
495: #define log10e 0.43429448190325182765
496:
497: #ifdef KR_headers
498: double log();
499: double d_lg10(x) doublereal *x;
500: #else
501: #undef abs
502: #include "math.h"
503: double d_lg10(doublereal *x)
504: #endif
505: {
506: return( log10e * log(*x) );
507: }
508: ./ ADD NAME=libF77/d_log.c TIME=708889712
509: #include "f2c.h"
510:
511: #ifdef KR_headers
512: double log();
513: double d_log(x) doublereal *x;
514: #else
515: #undef abs
516: #include "math.h"
517: double d_log(doublereal *x)
518: #endif
519: {
520: return( log(*x) );
521: }
522: ./ ADD NAME=libF77/d_mod.c TIME=708889713
523: #include "f2c.h"
524:
525: #ifdef KR_headers
526: #ifdef IEEE_drem
527: double drem();
528: #else
529: double floor();
530: #endif
531: double d_mod(x,y) doublereal *x, *y;
532: #else
533: #ifdef IEEE_drem
534: double drem(double, double);
535: #else
536: #undef abs
537: #include "math.h"
538: #endif
539: double d_mod(doublereal *x, doublereal *y)
540: #endif
541: {
542: #ifdef IEEE_drem
543: double xa, ya, z;
544: if ((ya = *y) < 0.)
545: ya = -ya;
546: z = drem(xa = *x, ya);
547: if (xa > 0) {
548: if (z < 0)
549: z += ya;
550: }
551: else if (z > 0)
552: z -= ya;
553: return z;
554: #else
555: double quotient;
556: if( (quotient = *x / *y) >= 0)
557: quotient = floor(quotient);
558: else
559: quotient = -floor(-quotient);
560: return(*x - (*y) * quotient );
561: #endif
562: }
563: ./ ADD NAME=libF77/d_nint.c TIME=708889713
564: #include "f2c.h"
565:
566: #ifdef KR_headers
567: double floor();
568: double d_nint(x) doublereal *x;
569: #else
570: #undef abs
571: #include "math.h"
572: double d_nint(doublereal *x)
573: #endif
574: {
575: return( (*x)>=0 ?
576: floor(*x + .5) : -floor(.5 - *x) );
577: }
578: ./ ADD NAME=libF77/d_prod.c TIME=708874891
579: #include "f2c.h"
580:
581: #ifdef KR_headers
582: double d_prod(x,y) real *x, *y;
583: #else
584: double d_prod(real *x, real *y)
585: #endif
586: {
587: return( (*x) * (*y) );
588: }
589: ./ ADD NAME=libF77/d_sign.c TIME=708874925
590: #include "f2c.h"
591:
592: #ifdef KR_headers
593: double d_sign(a,b) doublereal *a, *b;
594: #else
595: double d_sign(doublereal *a, doublereal *b)
596: #endif
597: {
598: double x;
599: x = (*a >= 0 ? *a : - *a);
600: return( *b >= 0 ? x : -x);
601: }
602: ./ ADD NAME=libF77/d_sin.c TIME=708889713
603: #include "f2c.h"
604:
605: #ifdef KR_headers
606: double sin();
607: double d_sin(x) doublereal *x;
608: #else
609: #undef abs
610: #include "math.h"
611: double d_sin(doublereal *x)
612: #endif
613: {
614: return( sin(*x) );
615: }
616: ./ ADD NAME=libF77/d_sinh.c TIME=708889713
617: #include "f2c.h"
618:
619: #ifdef KR_headers
620: double sinh();
621: double d_sinh(x) doublereal *x;
622: #else
623: #undef abs
624: #include "math.h"
625: double d_sinh(doublereal *x)
626: #endif
627: {
628: return( sinh(*x) );
629: }
630: ./ ADD NAME=libF77/d_sqrt.c TIME=708889713
631: #include "f2c.h"
632:
633: #ifdef KR_headers
634: double sqrt();
635: double d_sqrt(x) doublereal *x;
636: #else
637: #undef abs
638: #include "math.h"
639: double d_sqrt(doublereal *x)
640: #endif
641: {
642: return( sqrt(*x) );
643: }
644: ./ ADD NAME=libF77/d_tan.c TIME=708889713
645: #include "f2c.h"
646:
647: #ifdef KR_headers
648: double tan();
649: double d_tan(x) doublereal *x;
650: #else
651: #undef abs
652: #include "math.h"
653: double d_tan(doublereal *x)
654: #endif
655: {
656: return( tan(*x) );
657: }
658: ./ ADD NAME=libF77/d_tanh.c TIME=708889713
659: #include "f2c.h"
660:
661: #ifdef KR_headers
662: double tanh();
663: double d_tanh(x) doublereal *x;
664: #else
665: #undef abs
666: #include "math.h"
667: double d_tanh(doublereal *x)
668: #endif
669: {
670: return( tanh(*x) );
671: }
672: ./ ADD NAME=libF77/derf_.c TIME=708875112
673: #include "f2c.h"
674:
675: #ifdef KR_headers
676: double erf();
677: double derf_(x) doublereal *x;
678: #else
679: extern double erf(double);
680: double derf_(doublereal *x)
681: #endif
682: {
683: return( erf(*x) );
684: }
685: ./ ADD NAME=libF77/derfc_.c TIME=708873008
686: #include "f2c.h"
687:
688: #ifdef KR_headers
689: extern double erfc();
690:
691: double derfc_(x) doublereal *x;
692: #else
693: extern double erfc(double);
694:
695: double derfc_(doublereal *x)
696: #endif
697: {
698: return( erfc(*x) );
699: }
700: ./ ADD NAME=libF77/ef1asc_.c TIME=708875832
701: /* EFL support routine to copy string b to string a */
702:
703: #include "f2c.h"
704:
705:
706: #define M ( (long) (sizeof(long) - 1) )
707: #define EVEN(x) ( ( (x)+ M) & (~M) )
708:
709: #ifdef KR_headers
710: extern VOID s_copy();
711: VOID ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
712: #else
713: extern void s_copy(char*,char*,ftnlen,ftnlen);
714: void ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
715: #endif
716: {
717: s_copy( (char *)a, (char *)b, EVEN(*la), *lb );
718: }
719: ./ ADD NAME=libF77/ef1cmc_.c TIME=708876086
720: /* EFL support routine to compare two character strings */
721:
722: #include "f2c.h"
723:
724: #ifdef KR_headers
725: extern integer s_cmp();
726: integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb;
727: #else
728: extern integer s_cmp(char*,char*,ftnlen,ftnlen);
729: integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb)
730: #endif
731: {
732: return( s_cmp( (char *)a, (char *)b, *la, *lb) );
733: }
734: ./ ADD NAME=libF77/erf_.c TIME=708875594
735: #include "f2c.h"
736:
737: #ifdef KR_headers
738: double erf();
739: double erf_(x) real *x;
740: #else
741: extern double erf(double);
742: double erf_(real *x)
743: #endif
744: {
745: return( erf(*x) );
746: }
747: ./ ADD NAME=libF77/erfc_.c TIME=708875664
748: #include "f2c.h"
749:
750: #ifdef KR_headers
751: double erfc();
752: double erfc_(x) real *x;
753: #else
754: extern double erfc(double);
755: double erfc_(real *x)
756: #endif
757: {
758: return( erfc(*x) );
759: }
760: ./ ADD NAME=libF77/f2ch.add TIME=711900222
761: /* If you are using a C++ compiler, append the following to f2c.h
762: for compiling libF77 */
763:
764: #ifdef __cplusplus
765: extern "C" {
766: extern void abort_(void);
767: extern double c_abs(complex *);
768: extern void c_cos(complex *, complex *);
769: extern void c_div(complex *, complex *, complex *);
770: extern void c_exp(complex *, complex *);
771: extern void c_log(complex *, complex *);
772: extern void c_sin(complex *, complex *);
773: extern void c_sqrt(complex *, complex *);
774: extern double d_abs(double *);
775: extern double d_acos(double *);
776: extern double d_asin(double *);
777: extern double d_atan(double *);
778: extern double d_atn2(double *, double *);
779: extern void d_cnjg(doublecomplex *, doublecomplex *);
780: extern double d_cos(double *);
781: extern double d_cosh(double *);
782: extern double d_dim(double *, double *);
783: extern double d_exp(double *);
784: extern double d_imag(doublecomplex *);
785: extern double d_int(double *);
786: extern double d_lg10(double *);
787: extern double d_log(double *);
788: extern double d_mod(double *, double *);
789: extern double d_nint(double *);
790: extern double d_prod(float *, float *);
791: extern double d_sign(double *, double *);
792: extern double d_sin(double *);
793: extern double d_sinh(double *);
794: extern double d_sqrt(double *);
795: extern double d_tan(double *);
796: extern double d_tanh(double *);
797: extern double derf_(double *);
798: extern double derfc_(double *);
799: extern void ef1asc_(long int *, long int *, long int *, long int *);
800: extern long int ef1cmc_(long int *, long int *, long int *, long int *);
801: extern double erf(double);
802: extern double erf_(float *);
803: extern double erfc(double);
804: extern double erfc_(float *);
805: extern void getarg_(long int *, char *, long int);
806: extern void getenv_(char *, char *, long int, long int);
807: extern int getpid(void);
808: extern short h_abs(short *);
809: extern short h_dim(short *, short *);
810: extern short h_dnnt(double *);
811: extern short h_indx(char *, char *, long int, long int);
812: extern short h_len(char *, long int);
813: extern short h_mod(short *, short *);
814: extern short h_nint(float *);
815: extern short h_sign(short *, short *);
816: extern short hl_ge(char *, char *, long int, long int);
817: extern short hl_gt(char *, char *, long int, long int);
818: extern short hl_le(char *, char *, long int, long int);
819: extern short hl_lt(char *, char *, long int, long int);
820: extern long int i_abs(long int *);
821: extern long int i_dim(long int *, long int *);
822: extern long int i_dnnt(double *);
823: extern long int i_indx(char *, char *, long int, long int);
824: extern long int i_len(char *, long int);
825: extern long int i_mod(long int *, long int *);
826: extern long int i_nint(float *);
827: extern long int i_sign(long int *, long int *);
828: extern long int iargc_(void);
829: extern long int l_ge(char *, char *, long int, long int);
830: extern long int l_gt(char *, char *, long int, long int);
831: extern long int l_le(char *, char *, long int, long int);
832: extern long int l_lt(char *, char *, long int, long int);
833: extern int main(int, char **);
834: extern int pause(void);
835: extern void pow_ci(complex *, complex *, long int *);
836: extern double pow_dd(double *, double *);
837: extern double pow_di(double *, long int *);
838: extern short pow_hh(short *, short *);
839: extern long int pow_ii(long int *, long int *);
840: extern double pow_ri(float *, long int *);
841: extern void pow_zi(doublecomplex *, doublecomplex *, long int *);
842: extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *);
843: extern double r_abs(float *);
844: extern double r_acos(float *);
845: extern double r_asin(float *);
846: extern double r_atan(float *);
847: extern double r_atn2(float *, float *);
848: extern void r_cnjg(complex *, complex *);
849: extern double r_cos(float *);
850: extern double r_cosh(float *);
851: extern double r_dim(float *, float *);
852: extern double r_exp(float *);
853: extern double r_imag(complex *);
854: extern double r_int(float *);
855: extern double r_lg10(float *);
856: extern double r_log(float *);
857: extern double r_mod(float *, float *);
858: extern double r_nint(float *);
859: extern double r_sign(float *, float *);
860: extern double r_sin(float *);
861: extern double r_sinh(float *);
862: extern double r_sqrt(float *);
863: extern double r_tan(float *);
864: extern double r_tanh(float *);
865: extern void s_cat(char *, char **, long int *, long int *, long int);
866: extern long int s_cmp(char *, char *, long int, long int);
867: extern void s_copy(char *, char *, long int, long int);
868: extern void s_paus(char *, long int);
869: extern void s_rnge(char *, long int, char *, long int);
870: extern void s_stop(char *, long int);
871: extern void sig_die(char *, int);
872: extern long int signal_(long int *, void *);
873: extern int system_(char *, long int);
874: extern double z_abs(doublecomplex *);
875: extern void z_cos(doublecomplex *, doublecomplex *);
876: extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
877: extern void z_exp(doublecomplex *, doublecomplex *);
878: extern void z_log(doublecomplex *, doublecomplex *);
879: extern void z_sin(doublecomplex *, doublecomplex *);
880: extern void z_sqrt(doublecomplex *, doublecomplex *);
881: }
882: #endif
883: ./ ADD NAME=libF77/getarg_.c TIME=708888157
884: #include "f2c.h"
885:
886: /*
887: * subroutine getarg(k, c)
888: * returns the kth unix command argument in fortran character
889: * variable argument c
890: */
891:
892: #ifdef KR_headers
893: VOID getarg_(n, s, ls) ftnint *n; register char *s; ftnlen ls;
894: #else
895: void getarg_(ftnint *n, register char *s, ftnlen ls)
896: #endif
897: {
898: extern int xargc;
899: extern char **xargv;
900: register char *t;
901: register int i;
902:
903: if(*n>=0 && *n<xargc)
904: t = xargv[*n];
905: else
906: t = "";
907: for(i = 0; i<ls && *t!='\0' ; ++i)
908: *s++ = *t++;
909: for( ; i<ls ; ++i)
910: *s++ = ' ';
911: }
912: ./ ADD NAME=libF77/getenv_.c TIME=708888060
913: #include "f2c.h"
914:
915: /*
916: * getenv - f77 subroutine to return environment variables
917: *
918: * called by:
919: * call getenv (ENV_NAME, char_var)
920: * where:
921: * ENV_NAME is the name of an environment variable
922: * char_var is a character variable which will receive
923: * the current value of ENV_NAME, or all blanks
924: * if ENV_NAME is not defined
925: */
926:
927: #ifdef KR_headers
928: VOID getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen;
929: #else
930: void getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen)
931: #endif
932: {
933: extern char **environ;
934: register char *ep, *fp, *flast;
935: register char **env = environ;
936:
937: flast = fname + flen;
938: for(fp = fname ; fp < flast ; ++fp)
939: if(*fp == ' ')
940: {
941: flast = fp;
942: break;
943: }
944:
945: while (ep = *env++)
946: {
947: for(fp = fname; fp<flast ; )
948: if(*fp++ != *ep++)
949: goto endloop;
950:
951: if(*ep++ == '=') { /* copy right hand side */
952: while( *ep && --vlen>=0 )
953: *value++ = *ep++;
954:
955: goto blank;
956: }
957: endloop: ;
958: }
959:
960: blank:
961: while( --vlen >= 0 )
962: *value++ = ' ';
963: }
964: ./ ADD NAME=libF77/h_abs.c TIME=708876130
965: #include "f2c.h"
966:
967: #ifdef KR_headers
968: shortint h_abs(x) shortint *x;
969: #else
970: shortint h_abs(shortint *x)
971: #endif
972: {
973: if(*x >= 0)
974: return(*x);
975: return(- *x);
976: }
977: ./ ADD NAME=libF77/h_dim.c TIME=708876178
978: #include "f2c.h"
979:
980: #ifdef KR_headers
981: shortint h_dim(a,b) shortint *a, *b;
982: #else
983: shortint h_dim(shortint *a, shortint *b)
984: #endif
985: {
986: return( *a > *b ? *a - *b : 0);
987: }
988: ./ ADD NAME=libF77/h_dnnt.c TIME=708889713
989: #include "f2c.h"
990:
991: #ifdef KR_headers
992: double floor();
993: shortint h_dnnt(x) doublereal *x;
994: #else
995: #undef abs
996: #include "math.h"
997: shortint h_dnnt(doublereal *x)
998: #endif
999: {
1000: return( (*x)>=0 ?
1001: floor(*x + .5) : -floor(.5 - *x) );
1002: }
1003: ./ ADD NAME=libF77/h_indx.c TIME=708876294
1004: #include "f2c.h"
1005:
1006: #ifdef KR_headers
1007: shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb;
1008: #else
1009: shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb)
1010: #endif
1011: {
1012: int i, n;
1013: char *s, *t, *bend;
1014:
1015: n = la - lb + 1;
1016: bend = b + lb;
1017:
1018: for(i = 0 ; i < n ; ++i)
1019: {
1020: s = a + i;
1021: t = b;
1022: while(t < bend)
1023: if(*s++ != *t++)
1024: goto no;
1025: return(i+1);
1026: no: ;
1027: }
1028: return(0);
1029: }
1030: ./ ADD NAME=libF77/h_len.c TIME=708876334
1031: #include "f2c.h"
1032:
1033: #ifdef KR_headers
1034: shortint h_len(s, n) char *s; ftnlen n;
1035: #else
1036: shortint h_len(char *s, ftnlen n)
1037: #endif
1038: {
1039: return(n);
1040: }
1041: ./ ADD NAME=libF77/h_mod.c TIME=708876382
1042: #include "f2c.h"
1043:
1044: #ifdef KR_headers
1045: shortint h_mod(a,b) short *a, *b;
1046: #else
1047: shortint h_mod(short *a, short *b)
1048: #endif
1049: {
1050: return( *a % *b);
1051: }
1052: ./ ADD NAME=libF77/h_nint.c TIME=708889713
1053: #include "f2c.h"
1054:
1055: #ifdef KR_headers
1056: double floor();
1057: shortint h_nint(x) real *x;
1058: #else
1059: #undef abs
1060: #include "math.h"
1061: shortint h_nint(real *x)
1062: #endif
1063: {
1064: return( (*x)>=0 ?
1065: floor(*x + .5) : -floor(.5 - *x) );
1066: }
1067: ./ ADD NAME=libF77/h_sign.c TIME=708876507
1068: #include "f2c.h"
1069:
1070: #ifdef KR_headers
1071: shortint h_sign(a,b) shortint *a, *b;
1072: #else
1073: shortint h_sign(shortint *a, shortint *b)
1074: #endif
1075: {
1076: shortint x;
1077: x = (*a >= 0 ? *a : - *a);
1078: return( *b >= 0 ? x : -x);
1079: }
1080: ./ ADD NAME=libF77/hl_ge.c TIME=708875517
1081: #include "f2c.h"
1082:
1083: #ifdef KR_headers
1084: extern integer s_cmp();
1085: shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb;
1086: #else
1087: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1088: shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb)
1089: #endif
1090: {
1091: return(s_cmp(a,b,la,lb) >= 0);
1092: }
1093: ./ ADD NAME=libF77/hl_gt.c TIME=708875484
1094: #include "f2c.h"
1095:
1096: #ifdef KR_headers
1097: extern integer s_cmp();
1098: shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb;
1099: #else
1100: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1101: shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb)
1102: #endif
1103: {
1104: return(s_cmp(a,b,la,lb) > 0);
1105: }
1106: ./ ADD NAME=libF77/hl_le.c TIME=708875449
1107: #include "f2c.h"
1108:
1109: #ifdef KR_headers
1110: extern integer s_cmp();
1111: shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb;
1112: #else
1113: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1114: shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb)
1115: #endif
1116: {
1117: return(s_cmp(a,b,la,lb) <= 0);
1118: }
1119: ./ ADD NAME=libF77/hl_lt.c TIME=708875277
1120: #include "f2c.h"
1121:
1122: #ifdef KR_headers
1123: extern integer s_cmp();
1124: shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb;
1125: #else
1126: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1127: shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb)
1128: #endif
1129: {
1130: return(s_cmp(a,b,la,lb) < 0);
1131: }
1132: ./ ADD NAME=libF77/i_abs.c TIME=708877760
1133: #include "f2c.h"
1134:
1135: #ifdef KR_headers
1136: integer i_abs(x) integer *x;
1137: #else
1138: integer i_abs(integer *x)
1139: #endif
1140: {
1141: if(*x >= 0)
1142: return(*x);
1143: return(- *x);
1144: }
1145: ./ ADD NAME=libF77/i_dim.c TIME=708877832
1146: #include "f2c.h"
1147:
1148: #ifdef KR_headers
1149: integer i_dim(a,b) integer *a, *b;
1150: #else
1151: integer i_dim(integer *a, integer *b)
1152: #endif
1153: {
1154: return( *a > *b ? *a - *b : 0);
1155: }
1156: ./ ADD NAME=libF77/i_dnnt.c TIME=708889713
1157: #include "f2c.h"
1158:
1159: #ifdef KR_headers
1160: double floor();
1161: integer i_dnnt(x) doublereal *x;
1162: #else
1163: #undef abs
1164: #include "math.h"
1165: integer i_dnnt(doublereal *x)
1166: #endif
1167: {
1168: return( (*x)>=0 ?
1169: floor(*x + .5) : -floor(.5 - *x) );
1170: }
1171: ./ ADD NAME=libF77/i_indx.c TIME=708877932
1172: #include "f2c.h"
1173:
1174: #ifdef KR_headers
1175: integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb;
1176: #else
1177: integer i_indx(char *a, char *b, ftnlen la, ftnlen lb)
1178: #endif
1179: {
1180: ftnlen i, n;
1181: char *s, *t, *bend;
1182:
1183: n = la - lb + 1;
1184: bend = b + lb;
1185:
1186: for(i = 0 ; i < n ; ++i)
1187: {
1188: s = a + i;
1189: t = b;
1190: while(t < bend)
1191: if(*s++ != *t++)
1192: goto no;
1193: return(i+1);
1194: no: ;
1195: }
1196: return(0);
1197: }
1198: ./ ADD NAME=libF77/i_len.c TIME=708877965
1199: #include "f2c.h"
1200:
1201: #ifdef KR_headers
1202: integer i_len(s, n) char *s; ftnlen n;
1203: #else
1204: integer i_len(char *s, ftnlen n)
1205: #endif
1206: {
1207: return(n);
1208: }
1209: ./ ADD NAME=libF77/i_mod.c TIME=708878002
1210: #include "f2c.h"
1211:
1212: #ifdef KR_headers
1213: integer i_mod(a,b) integer *a, *b;
1214: #else
1215: integer i_mod(integer *a, integer *b)
1216: #endif
1217: {
1218: return( *a % *b);
1219: }
1220: ./ ADD NAME=libF77/i_nint.c TIME=708889713
1221: #include "f2c.h"
1222:
1223: #ifdef KR_headers
1224: double floor();
1225: integer i_nint(x) real *x;
1226: #else
1227: #undef abs
1228: #include "math.h"
1229: integer i_nint(real *x)
1230: #endif
1231: {
1232: return( (*x)>=0 ?
1233: floor(*x + .5) : -floor(.5 - *x) );
1234: }
1235: ./ ADD NAME=libF77/i_sign.c TIME=708878100
1236: #include "f2c.h"
1237:
1238: #ifdef KR_headers
1239: integer i_sign(a,b) integer *a, *b;
1240: #else
1241: integer i_sign(integer *a, integer *b)
1242: #endif
1243: {
1244: integer x;
1245: x = (*a >= 0 ? *a : - *a);
1246: return( *b >= 0 ? x : -x);
1247: }
1248: ./ ADD NAME=libF77/iargc_.c TIME=708877715
1249: #include "f2c.h"
1250:
1251: #ifdef KR_headers
1252: ftnint iargc_()
1253: #else
1254: ftnint iargc_(void)
1255: #endif
1256: {
1257: extern int xargc;
1258: return ( xargc - 1 );
1259: }
1260: ./ ADD NAME=libF77/l_ge.c TIME=708878341
1261: #include "f2c.h"
1262:
1263: #ifdef KR_headers
1264: extern integer s_cmp();
1265: logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb;
1266: #else
1267: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1268: logical l_ge(char *a, char *b, ftnlen la, ftnlen lb)
1269: #endif
1270: {
1271: return(s_cmp(a,b,la,lb) >= 0);
1272: }
1273: ./ ADD NAME=libF77/l_gt.c TIME=708878405
1274: #include "f2c.h"
1275:
1276: #ifdef KR_headers
1277: extern integer s_cmp();
1278: logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb;
1279: #else
1280: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1281: logical l_gt(char *a, char *b, ftnlen la, ftnlen lb)
1282: #endif
1283: {
1284: return(s_cmp(a,b,la,lb) > 0);
1285: }
1286: ./ ADD NAME=libF77/l_le.c TIME=708878439
1287: #include "f2c.h"
1288:
1289: #ifdef KR_headers
1290: extern integer s_cmp();
1291: logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb;
1292: #else
1293: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1294: logical l_le(char *a, char *b, ftnlen la, ftnlen lb)
1295: #endif
1296: {
1297: return(s_cmp(a,b,la,lb) <= 0);
1298: }
1299: ./ ADD NAME=libF77/l_lt.c TIME=708878471
1300: #include "f2c.h"
1301:
1302: #ifdef KR_headers
1303: extern integer s_cmp();
1304: logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb;
1305: #else
1306: extern integer s_cmp(char *, char *, ftnlen, ftnlen);
1307: logical l_lt(char *a, char *b, ftnlen la, ftnlen lb)
1308: #endif
1309: {
1310: return(s_cmp(a,b,la,lb) < 0);
1311: }
1312: ./ ADD NAME=libF77/main.c TIME=711899452
1313: /* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
1314:
1315: #include "stdio.h"
1316: #include "signal.h"
1317:
1318: #ifndef SIGIOT
1319: #define SIGIOT SIGABRT
1320: #endif
1321:
1322: #ifndef KR_headers
1323: #include "stdlib.h"
1324: #endif
1325: #ifdef __cplusplus
1326: extern "C" {
1327: #endif
1328:
1329: #ifdef NO__STDC
1330: #define ONEXIT onexit
1331: extern void f_exit();
1332: #else
1333: #ifndef KR_headers
1334: extern void f_exit(void);
1335: #ifndef NO_ONEXIT
1336: #define ONEXIT atexit
1337: extern int atexit(void (*)(void));
1338: #endif
1339: #else
1340: #ifndef NO_ONEXIT
1341: #define ONEXIT onexit
1342: extern void f_exit();
1343: #endif
1344: #endif
1345: #endif
1346:
1347: #ifdef KR_headers
1348: extern void f_init(), sig_die();
1349: extern int MAIN__();
1350: #define Int /* int */
1351: #else
1352: extern void f_init(void), sig_die(char*, int);
1353: extern int MAIN__(void);
1354: #define Int int
1355: #endif
1356:
1357: static void sigfdie(Int n)
1358: {
1359: sig_die("Floating Exception", 1);
1360: }
1361:
1362:
1363: static void sigidie(Int n)
1364: {
1365: sig_die("IOT Trap", 1);
1366: }
1367:
1368: #ifdef SIGQUIT
1369: static void sigqdie(Int n)
1370: {
1371: sig_die("Quit signal", 1);
1372: }
1373: #endif
1374:
1375:
1376: static void sigindie(Int n)
1377: {
1378: sig_die("Interrupt", 0);
1379: }
1380:
1381: static void sigtdie(Int n)
1382: {
1383: sig_die("Killed", 0);
1384: }
1385:
1386: #ifdef SIGTRAP
1387: static void sigtrdie(Int n)
1388: {
1389: sig_die("Trace trap", 1);
1390: }
1391: #endif
1392:
1393:
1394: int xargc;
1395: char **xargv;
1396:
1397: #ifdef KR_headers
1398: main(argc, argv) int argc; char **argv;
1399: #else
1400: main(int argc, char **argv)
1401: #endif
1402: {
1403: xargc = argc;
1404: xargv = argv;
1405: signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
1406: signal(SIGIOT, sigidie);
1407: #ifdef SIGTRAP
1408: signal(SIGTRAP, sigtrdie);
1409: #endif
1410: #ifdef SIGQUIT
1411: if(signal(SIGQUIT,sigqdie) == SIG_IGN)
1412: signal(SIGQUIT, SIG_IGN);
1413: #endif
1414: if(signal(SIGINT, sigindie) == SIG_IGN)
1415: signal(SIGINT, SIG_IGN);
1416: signal(SIGTERM,sigtdie);
1417:
1418: #ifdef pdp11
1419: ldfps(01200); /* detect overflow as an exception */
1420: #endif
1421:
1422: f_init();
1423: #ifndef NO_ONEXIT
1424: ONEXIT(f_exit);
1425: #endif
1426: MAIN__();
1427: #ifdef NO_ONEXIT
1428: f_exit();
1429: #endif
1430: exit(0); /* exit(0) rather than return(0) to bypass Cray bug */
1431: return 0; /* For compilers that complain of missing return values; */
1432: /* others will complain that this is unreachable code. */
1433: }
1434: #ifdef __cplusplus
1435: }
1436: #endif
1437: ./ ADD NAME=libF77/makefile TIME=711901802
1438: .SUFFIXES: .c .o
1439: CC = cc
1440: SHELL = /bin/sh
1441:
1442: # compile, then strip unnecessary symbols
1443: .c.o:
1444: $(CC) -O -c -DSkip_f2c_Undefs $*.c
1445: ld -r -x -o $*.xxx $*.o
1446: mv $*.xxx $*.o
1447:
1448: MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\
1449: signal_.o s_stop.o s_paus.o system_.o cabs.o\
1450: derf_.o derfc_.o erf_.o erfc_.o sig_die.o
1451: POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o
1452: CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
1453: DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
1454: REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
1455: r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
1456: r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
1457: r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
1458: DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
1459: d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
1460: d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
1461: d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
1462: d_sqrt.o d_tan.o d_tanh.o
1463: INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o
1464: HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o
1465: CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o
1466: EFL = ef1asc_.o ef1cmc_.o
1467: CHAR = s_cat.o s_cmp.o s_copy.o
1468:
1469: libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
1470: $(HALF) $(CMP) $(EFL) $(CHAR)
1471: ar r libF77.a $?
1472: ranlib libF77.a
1473:
1474: Version.o: Version.c
1475: $(CC) -c Version.c
1476:
1477: # To compile with C++, first "make f2c.h"
1478: f2c.h: f2ch.add
1479: cat /usr/include/f2c.h f2ch.add >f2c.h
1480:
1481: # If your system lacks onexit() and you are not using an
1482: # ANSI C compiler, then you should uncomment the following
1483: # two lines (for compiling main.o):
1484: #main.o: main.c
1485: # $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c
1486: # On at least some Sun systems, it is more appropriate to
1487: # uncomment the following two lines:
1488: #main.o: main.c
1489: # $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c
1490:
1491: install: libF77.a
1492: mv libF77.a /usr/lib
1493:
1494: clean:
1495: rm -f libF77.a *.o
1496:
1497: check:
1498: xsum Notice README Version.c abort_.c c_abs.c c_cos.c c_div.c \
1499: c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \
1500: d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \
1501: d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \
1502: d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \
1503: derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c f2ch.add \
1504: getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \
1505: h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \
1506: i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \
1507: i_sign.c iargc_.c l_ge.c l_gt.c l_le.c l_lt.c main.c makefile \
1508: pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_ri.c pow_zi.c \
1509: pow_zz.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c r_cnjg.c \
1510: r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \
1511: r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \
1512: r_tan.c r_tanh.c s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c \
1513: s_stop.c sig_die.c signal_.c system_.c z_abs.c z_cos.c z_div.c \
1514: z_exp.c z_log.c z_sin.c z_sqrt.c >zap
1515: cmp zap libF77.xsum && rm zap || diff libF77.xsum zap
1516: ./ ADD NAME=libF77/pow_ci.c TIME=708964413
1517: #include "f2c.h"
1518:
1519: #ifdef KR_headers
1520: VOID pow_ci(p, a, b) /* p = a**b */
1521: complex *p, *a; integer *b;
1522: #else
1523: extern void pow_zi(doublecomplex*, doublecomplex*, integer*);
1524: void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */
1525: #endif
1526: {
1527: doublecomplex p1, a1;
1528:
1529: a1.r = a->r;
1530: a1.i = a->i;
1531:
1532: pow_zi(&p1, &a1, b);
1533:
1534: p->r = p1.r;
1535: p->i = p1.i;
1536: }
1537: ./ ADD NAME=libF77/pow_dd.c TIME=708889713
1538: #include "f2c.h"
1539:
1540: #ifdef KR_headers
1541: double pow();
1542: double pow_dd(ap, bp) doublereal *ap, *bp;
1543: #else
1544: #undef abs
1545: #include "math.h"
1546: double pow_dd(doublereal *ap, doublereal *bp)
1547: #endif
1548: {
1549: return(pow(*ap, *bp) );
1550: }
1551: ./ ADD NAME=libF77/pow_di.c TIME=711435914
1552: #include "f2c.h"
1553:
1554: #ifdef KR_headers
1555: double pow_di(ap, bp) doublereal *ap; integer *bp;
1556: #else
1557: double pow_di(doublereal *ap, integer *bp)
1558: #endif
1559: {
1560: double pow, x;
1561: integer n;
1562:
1563: pow = 1;
1564: x = *ap;
1565: n = *bp;
1566:
1567: if(n != 0)
1568: {
1569: if(n < 0)
1570: {
1571: n = -n;
1572: x = 1/x;
1573: }
1574: for( ; ; )
1575: {
1576: if(n & 01)
1577: pow *= x;
1578: if(n >>= 1)
1579: x *= x;
1580: else
1581: break;
1582: }
1583: }
1584: return(pow);
1585: }
1586: ./ ADD NAME=libF77/pow_hh.c TIME=711457981
1587: #include "f2c.h"
1588:
1589: #ifdef KR_headers
1590: shortint pow_hh(ap, bp) shortint *ap, *bp;
1591: #else
1592: shortint pow_hh(shortint *ap, shortint *bp)
1593: #endif
1594: {
1595: shortint pow, x, n;
1596:
1597: x = *ap;
1598: n = *bp;
1599:
1600: if (n <= 0) {
1601: if (n == 0 || x == 1)
1602: return 1;
1603: if (x != -1)
1604: return x == 0 ? 1/x : 0;
1605: n = -n;
1606: }
1607: for(pow = 1; ; )
1608: {
1609: if(n & 01)
1610: pow *= x;
1611: if(n >>= 1)
1612: x *= x;
1613: else
1614: break;
1615: }
1616: return(pow);
1617: }
1618: ./ ADD NAME=libF77/pow_ii.c TIME=711457952
1619: #include "f2c.h"
1620:
1621: #ifdef KR_headers
1622: integer pow_ii(ap, bp) integer *ap, *bp;
1623: #else
1624: integer pow_ii(integer *ap, integer *bp)
1625: #endif
1626: {
1627: integer pow, x, n;
1628:
1629: x = *ap;
1630: n = *bp;
1631:
1632: if (n <= 0) {
1633: if (n == 0 || x == 1)
1634: return 1;
1635: if (x != -1)
1636: return x == 0 ? 1/x : 0;
1637: n = -n;
1638: }
1639: for(pow = 1; ; )
1640: {
1641: if(n & 01)
1642: pow *= x;
1643: if(n >>= 1)
1644: x *= x;
1645: else
1646: break;
1647: }
1648: return(pow);
1649: }
1650: ./ ADD NAME=libF77/pow_ri.c TIME=711435914
1651: #include "f2c.h"
1652:
1653: #ifdef KR_headers
1654: double pow_ri(ap, bp) real *ap; integer *bp;
1655: #else
1656: double pow_ri(real *ap, integer *bp)
1657: #endif
1658: {
1659: double pow, x;
1660: integer n;
1661:
1662: pow = 1;
1663: x = *ap;
1664: n = *bp;
1665:
1666: if(n != 0)
1667: {
1668: if(n < 0)
1669: {
1670: n = -n;
1671: x = 1/x;
1672: }
1673: for( ; ; )
1674: {
1675: if(n & 01)
1676: pow *= x;
1677: if(n >>= 1)
1678: x *= x;
1679: else
1680: break;
1681: }
1682: }
1683: return(pow);
1684: }
1685: ./ ADD NAME=libF77/pow_zi.c TIME=708879685
1686: #include "f2c.h"
1687:
1688: #ifdef KR_headers
1689: VOID pow_zi(p, a, b) /* p = a**b */
1690: doublecomplex *p, *a; integer *b;
1691: #else
1692: extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*);
1693: void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */
1694: #endif
1695: {
1696: integer n;
1697: double t;
1698: doublecomplex x;
1699: static doublecomplex one = {1.0, 0.0};
1700:
1701: n = *b;
1702: p->r = 1;
1703: p->i = 0;
1704:
1705: if(n == 0)
1706: return;
1707: if(n < 0)
1708: {
1709: n = -n;
1710: z_div(&x, &one, a);
1711: }
1712: else
1713: {
1714: x.r = a->r;
1715: x.i = a->i;
1716: }
1717:
1718: for( ; ; )
1719: {
1720: if(n & 01)
1721: {
1722: t = p->r * x.r - p->i * x.i;
1723: p->i = p->r * x.i + p->i * x.r;
1724: p->r = t;
1725: }
1726: if(n >>= 1)
1727: {
1728: t = x.r * x.r - x.i * x.i;
1729: x.i = 2 * x.r * x.i;
1730: x.r = t;
1731: }
1732: else
1733: break;
1734: }
1735: }
1736: ./ ADD NAME=libF77/pow_zz.c TIME=719848069
1737: #include "f2c.h"
1738:
1739: #ifdef KR_headers
1740: double log(), exp(), cos(), sin(), atan2(), f__cabs();
1741: VOID pow_zz(r,a,b) doublecomplex *r, *a, *b;
1742: #else
1743: #undef abs
1744: #include "math.h"
1745: extern double f__cabs(double,double);
1746: void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b)
1747: #endif
1748: {
1749: double logr, logi, x, y;
1750:
1751: logr = log( f__cabs(a->r, a->i) );
1752: logi = atan2(a->i, a->r);
1753:
1754: x = exp( logr * b->r - logi * b->i );
1755: y = logr * b->i + logi * b->r;
1756:
1757: r->r = x * cos(y);
1758: r->i = x * sin(y);
1759: }
1760: ./ ADD NAME=libF77/r_abs.c TIME=708880224
1761: #include "f2c.h"
1762:
1763: #ifdef KR_headers
1764: double r_abs(x) real *x;
1765: #else
1766: double r_abs(real *x)
1767: #endif
1768: {
1769: if(*x >= 0)
1770: return(*x);
1771: return(- *x);
1772: }
1773: ./ ADD NAME=libF77/r_acos.c TIME=708889713
1774: #include "f2c.h"
1775:
1776: #ifdef KR_headers
1777: double acos();
1778: double r_acos(x) real *x;
1779: #else
1780: #undef abs
1781: #include "math.h"
1782: double r_acos(real *x)
1783: #endif
1784: {
1785: return( acos(*x) );
1786: }
1787: ./ ADD NAME=libF77/r_asin.c TIME=708889713
1788: #include "f2c.h"
1789:
1790: #ifdef KR_headers
1791: double asin();
1792: double r_asin(x) real *x;
1793: #else
1794: #undef abs
1795: #include "math.h"
1796: double r_asin(real *x)
1797: #endif
1798: {
1799: return( asin(*x) );
1800: }
1801: ./ ADD NAME=libF77/r_atan.c TIME=708889713
1802: #include "f2c.h"
1803:
1804: #ifdef KR_headers
1805: double atan();
1806: double r_atan(x) real *x;
1807: #else
1808: #undef abs
1809: #include "math.h"
1810: double r_atan(real *x)
1811: #endif
1812: {
1813: return( atan(*x) );
1814: }
1815: ./ ADD NAME=libF77/r_atn2.c TIME=708889713
1816: #include "f2c.h"
1817:
1818: #ifdef KR_headers
1819: double atan2();
1820: double r_atn2(x,y) real *x, *y;
1821: #else
1822: #undef abs
1823: #include "math.h"
1824: double r_atn2(real *x, real *y)
1825: #endif
1826: {
1827: return( atan2(*x,*y) );
1828: }
1829: ./ ADD NAME=libF77/r_cnjg.c TIME=708885238
1830: #include "f2c.h"
1831:
1832: #ifdef KR_headers
1833: VOID r_cnjg(r, z) complex *r, *z;
1834: #else
1835: VOID r_cnjg(complex *r, complex *z)
1836: #endif
1837: {
1838: r->r = z->r;
1839: r->i = - z->i;
1840: }
1841: ./ ADD NAME=libF77/r_cos.c TIME=708889713
1842: #include "f2c.h"
1843:
1844: #ifdef KR_headers
1845: double cos();
1846: double r_cos(x) real *x;
1847: #else
1848: #undef abs
1849: #include "math.h"
1850: double r_cos(real *x)
1851: #endif
1852: {
1853: return( cos(*x) );
1854: }
1855: ./ ADD NAME=libF77/r_cosh.c TIME=708889714
1856: #include "f2c.h"
1857:
1858: #ifdef KR_headers
1859: double cosh();
1860: double r_cosh(x) real *x;
1861: #else
1862: #undef abs
1863: #include "math.h"
1864: double r_cosh(real *x)
1865: #endif
1866: {
1867: return( cosh(*x) );
1868: }
1869: ./ ADD NAME=libF77/r_dim.c TIME=708885323
1870: #include "f2c.h"
1871:
1872: #ifdef KR_headers
1873: double r_dim(a,b) real *a, *b;
1874: #else
1875: double r_dim(real *a, real *b)
1876: #endif
1877: {
1878: return( *a > *b ? *a - *b : 0);
1879: }
1880: ./ ADD NAME=libF77/r_exp.c TIME=708889714
1881: #include "f2c.h"
1882:
1883: #ifdef KR_headers
1884: double exp();
1885: double r_exp(x) real *x;
1886: #else
1887: #undef abs
1888: #include "math.h"
1889: double r_exp(real *x)
1890: #endif
1891: {
1892: return( exp(*x) );
1893: }
1894: ./ ADD NAME=libF77/r_imag.c TIME=708885387
1895: #include "f2c.h"
1896:
1897: #ifdef KR_headers
1898: double r_imag(z) complex *z;
1899: #else
1900: double r_imag(complex *z)
1901: #endif
1902: {
1903: return(z->i);
1904: }
1905: ./ ADD NAME=libF77/r_int.c TIME=708889714
1906: #include "f2c.h"
1907:
1908: #ifdef KR_headers
1909: double floor();
1910: double r_int(x) real *x;
1911: #else
1912: #undef abs
1913: #include "math.h"
1914: double r_int(real *x)
1915: #endif
1916: {
1917: return( (*x>0) ? floor(*x) : -floor(- *x) );
1918: }
1919: ./ ADD NAME=libF77/r_lg10.c TIME=708889714
1920: #include "f2c.h"
1921:
1922: #define log10e 0.43429448190325182765
1923:
1924: #ifdef KR_headers
1925: double log();
1926: double r_lg10(x) real *x;
1927: #else
1928: #undef abs
1929: #include "math.h"
1930: double r_lg10(real *x)
1931: #endif
1932: {
1933: return( log10e * log(*x) );
1934: }
1935: ./ ADD NAME=libF77/r_log.c TIME=708889714
1936: #include "f2c.h"
1937:
1938: #ifdef KR_headers
1939: double log();
1940: double r_log(x) real *x;
1941: #else
1942: #undef abs
1943: #include "math.h"
1944: double r_log(real *x)
1945: #endif
1946: {
1947: return( log(*x) );
1948: }
1949: ./ ADD NAME=libF77/r_mod.c TIME=708889714
1950: #include "f2c.h"
1951:
1952: #ifdef KR_headers
1953: #ifdef IEEE_drem
1954: double drem();
1955: #else
1956: double floor();
1957: #endif
1958: double r_mod(x,y) real *x, *y;
1959: #else
1960: #ifdef IEEE_drem
1961: double drem(double, double);
1962: #else
1963: #undef abs
1964: #include "math.h"
1965: #endif
1966: double r_mod(real *x, real *y)
1967: #endif
1968: {
1969: #ifdef IEEE_drem
1970: double xa, ya, z;
1971: if ((ya = *y) < 0.)
1972: ya = -ya;
1973: z = drem(xa = *x, ya);
1974: if (xa > 0) {
1975: if (z < 0)
1976: z += ya;
1977: }
1978: else if (z > 0)
1979: z -= ya;
1980: return z;
1981: #else
1982: double quotient;
1983: if( (quotient = (double)*x / *y) >= 0)
1984: quotient = floor(quotient);
1985: else
1986: quotient = -floor(-quotient);
1987: return(*x - (*y) * quotient );
1988: #endif
1989: }
1990: ./ ADD NAME=libF77/r_nint.c TIME=708889714
1991: #include "f2c.h"
1992:
1993: #ifdef KR_headers
1994: double floor();
1995: double r_nint(x) real *x;
1996: #else
1997: #undef abs
1998: #include "math.h"
1999: double r_nint(real *x)
2000: #endif
2001: {
2002: return( (*x)>=0 ?
2003: floor(*x + .5) : -floor(.5 - *x) );
2004: }
2005: ./ ADD NAME=libF77/r_sign.c TIME=708885772
2006: #include "f2c.h"
2007:
2008: #ifdef KR_headers
2009: double r_sign(a,b) real *a, *b;
2010: #else
2011: double r_sign(real *a, real *b)
2012: #endif
2013: {
2014: double x;
2015: x = (*a >= 0 ? *a : - *a);
2016: return( *b >= 0 ? x : -x);
2017: }
2018: ./ ADD NAME=libF77/r_sin.c TIME=708889714
2019: #include "f2c.h"
2020:
2021: #ifdef KR_headers
2022: double sin();
2023: double r_sin(x) real *x;
2024: #else
2025: #undef abs
2026: #include "math.h"
2027: double r_sin(real *x)
2028: #endif
2029: {
2030: return( sin(*x) );
2031: }
2032: ./ ADD NAME=libF77/r_sinh.c TIME=708889714
2033: #include "f2c.h"
2034:
2035: #ifdef KR_headers
2036: double sinh();
2037: double r_sinh(x) real *x;
2038: #else
2039: #undef abs
2040: #include "math.h"
2041: double r_sinh(real *x)
2042: #endif
2043: {
2044: return( sinh(*x) );
2045: }
2046: ./ ADD NAME=libF77/r_sqrt.c TIME=708889714
2047: #include "f2c.h"
2048:
2049: #ifdef KR_headers
2050: double sqrt();
2051: double r_sqrt(x) real *x;
2052: #else
2053: #undef abs
2054: #include "math.h"
2055: double r_sqrt(real *x)
2056: #endif
2057: {
2058: return( sqrt(*x) );
2059: }
2060: ./ ADD NAME=libF77/r_tan.c TIME=708890521
2061: #include "f2c.h"
2062:
2063: #ifdef KR_headers
2064: double tan();
2065: double r_tan(x) real *x;
2066: #else
2067: #undef abs
2068: #include "math.h"
2069: double r_tan(real *x)
2070: #endif
2071: {
2072: return( tan(*x) );
2073: }
2074: ./ ADD NAME=libF77/r_tanh.c TIME=708889714
2075: #include "f2c.h"
2076:
2077: #ifdef KR_headers
2078: double tanh();
2079: double r_tanh(x) real *x;
2080: #else
2081: #undef abs
2082: #include "math.h"
2083: double r_tanh(real *x)
2084: #endif
2085: {
2086: return( tanh(*x) );
2087: }
2088: ./ ADD NAME=libF77/s_cat.c TIME=719848074
2089: #include "f2c.h"
2090:
2091: #ifdef KR_headers
2092: VOID s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll;
2093: #else
2094: VOID s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll)
2095: #endif
2096: {
2097: int i, n, nc;
2098: char *f__rp;
2099:
2100: n = *np;
2101: for(i = 0 ; i < n ; ++i)
2102: {
2103: nc = ll;
2104: if(rnp[i] < nc)
2105: nc = rnp[i];
2106: ll -= nc;
2107: f__rp = rpp[i];
2108: while(--nc >= 0)
2109: *lp++ = *f__rp++;
2110: }
2111: while(--ll >= 0)
2112: *lp++ = ' ';
2113: }
2114: ./ ADD NAME=libF77/s_cmp.c TIME=708887238
2115: #include "f2c.h"
2116:
2117: /* compare two strings */
2118:
2119: #ifdef KR_headers
2120: integer s_cmp(a, b, la, lb) register char *a, *b; ftnlen la, lb;
2121: #else
2122: integer s_cmp(register char *a, register char *b, ftnlen la, ftnlen lb)
2123: #endif
2124: {
2125: register char *aend, *bend;
2126: aend = a + la;
2127: bend = b + lb;
2128:
2129: if(la <= lb)
2130: {
2131: while(a < aend)
2132: if(*a != *b)
2133: return( *a - *b );
2134: else
2135: { ++a; ++b; }
2136:
2137: while(b < bend)
2138: if(*b != ' ')
2139: return( ' ' - *b );
2140: else ++b;
2141: }
2142:
2143: else
2144: {
2145: while(b < bend)
2146: if(*a == *b)
2147: { ++a; ++b; }
2148: else
2149: return( *a - *b );
2150: while(a < aend)
2151: if(*a != ' ')
2152: return(*a - ' ');
2153: else ++a;
2154: }
2155: return(0);
2156: }
2157: ./ ADD NAME=libF77/s_copy.c TIME=708887356
2158: #include "f2c.h"
2159:
2160: /* assign strings: a = b */
2161:
2162: #ifdef KR_headers
2163: VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb;
2164: #else
2165: void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb)
2166: #endif
2167: {
2168: register char *aend, *bend;
2169:
2170: aend = a + la;
2171:
2172: if(la <= lb)
2173: while(a < aend)
2174: *a++ = *b++;
2175:
2176: else
2177: {
2178: bend = b + lb;
2179: while(b < bend)
2180: *a++ = *b++;
2181: while(a < aend)
2182: *a++ = ' ';
2183: }
2184: }
2185: ./ ADD NAME=libF77/s_paus.c TIME=708917853
2186: #include "stdio.h"
2187: #include "f2c.h"
2188: #define PAUSESIG 15
2189:
2190: #ifdef KR_headers
2191: #define Void /* void */
2192: #define Int /* int */
2193: #else
2194: #define Void void
2195: #define Int int
2196: #undef abs
2197: #include "stdlib.h"
2198: #include "signal.h"
2199: extern int getpid(void), isatty(int), pause(void);
2200: #endif
2201:
2202: #ifdef __cplusplus
2203: extern "C" void f_exit(void);
2204: #else
2205: extern VOID f_exit(Void);
2206: #endif
2207:
2208: static VOID waitpause(Int n)
2209: {
2210: return;
2211: }
2212:
2213: #ifdef KR_headers
2214: VOID s_paus(s, n) char *s; ftnlen n;
2215: #else
2216: void s_paus(char *s, ftnlen n)
2217: #endif
2218: {
2219: int i;
2220:
2221: fprintf(stderr, "PAUSE ");
2222: if(n > 0)
2223: for(i = 0; i<n ; ++i)
2224: putc(*s++, stderr);
2225: fprintf(stderr, " statement executed\n");
2226: if( isatty(fileno(stdin)) )
2227: {
2228: fprintf(stderr, "To resume execution, type go. Any other input will terminate job.\n");
2229: fflush(stderr);
2230: if( getchar()!='g' || getchar()!='o' || getchar()!='\n' )
2231: {
2232: fprintf(stderr, "STOP\n");
2233: f_exit();
2234: exit(0);
2235: }
2236: }
2237: else
2238: {
2239: fprintf(stderr, "To resume execution, execute a kill -%d %d command\n",
2240: PAUSESIG, getpid() );
2241: signal(PAUSESIG, waitpause);
2242: fflush(stderr);
2243: pause();
2244: }
2245: fprintf(stderr, "Execution resumes after PAUSE.\n");
2246: }
2247: ./ ADD NAME=libF77/s_rnge.c TIME=708887851
2248: #include "stdio.h"
2249: #include "f2c.h"
2250:
2251: /* called when a subscript is out of range */
2252:
2253: #ifdef KR_headers
2254: extern VOID sig_die();
2255: VOID s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line;
2256: #else
2257: extern VOID sig_die(char*,int);
2258: void s_rnge(char *varn, ftnint offset, char *procn, ftnint line)
2259: #endif
2260: {
2261: register int i;
2262:
2263: fprintf(stderr, "Subscript out of range on file line %ld, procedure ", line);
2264: while((i = *procn) && i != '_' && i != ' ')
2265: putc(*procn++, stderr);
2266: fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1);
2267: while((i = *varn) && i != ' ')
2268: putc(*varn++, stderr);
2269: sig_die(".", 1);
2270: }
2271: ./ ADD NAME=libF77/s_stop.c TIME=708971439
2272: #include "stdio.h"
2273: #include "f2c.h"
2274:
2275: #ifdef KR_headers
2276: extern void f_exit();
2277: VOID s_stop(s, n) char *s; ftnlen n;
2278: #else
2279: #undef abs
2280: #include "stdlib.h"
2281: #ifdef __cplusplus
2282: extern "C" void f_exit(void);
2283: #else
2284: extern void f_exit(void);
2285: #endif
2286: void s_stop(char *s, ftnlen n)
2287: #endif
2288: {
2289: int i;
2290:
2291: if(n > 0)
2292: {
2293: fprintf(stderr, "STOP ");
2294: for(i = 0; i<n ; ++i)
2295: putc(*s++, stderr);
2296: fprintf(stderr, " statement executed\n");
2297: }
2298: f_exit();
2299: exit(0);
2300: }
2301: ./ ADD NAME=libF77/sig_die.c TIME=708905928
2302: #include "stdio.h"
2303: #include "signal.h"
2304:
2305: #ifndef SIGIOT
2306: #define SIGIOT SIGABRT
2307: #endif
2308:
2309: #ifdef __cplusplus
2310: extern "C" {
2311: #endif
2312: #ifdef KR_headers
2313: void sig_die(s, kill) register char *s; int kill;
2314: #else
2315: #include "stdlib.h"
2316: extern void f_exit(void);
2317:
2318: void sig_die(register char *s, int kill)
2319: #endif
2320: {
2321: /* print error message, then clear buffers */
2322: fprintf(stderr, "%s\n", s);
2323: fflush(stderr);
2324: f_exit();
2325: fflush(stderr);
2326:
2327: if(kill)
2328: {
2329: /* now get a core */
2330: signal(SIGIOT, SIG_DFL);
2331: abort();
2332: }
2333: else
2334: exit(1);
2335: }
2336: #ifdef __cplusplus
2337: }
2338: #endif
2339: ./ ADD NAME=libF77/signal_.c TIME=719847775
2340: #include "f2c.h"
2341:
2342: #ifdef KR_headers
2343: typedef int (*sig_type)();
2344: extern sig_type signal();
2345:
2346: ftnint signal_(sigp, procp) ftnint *sigp; sig_type proc;
2347: #else
2348: #include "signal.h"
2349: typedef void (*sig_type)(int);
2350:
2351: ftnint signal_(ftnint *sigp, sig_type proc)
2352: #endif
2353: {
2354: int sig;
2355: sig = *sigp;
2356:
2357: return (ftnint)signal(sig, proc);
2358: }
2359: ./ ADD NAME=libF77/system_.c TIME=708886771
2360: /* f77 interface to system routine */
2361:
2362: #include "f2c.h"
2363:
2364: #ifdef KR_headers
2365: system_(s, n) register char *s; ftnlen n;
2366: #else
2367: #undef abs
2368: #include "stdlib.h"
2369: system_(register char *s, ftnlen n)
2370: #endif
2371: {
2372: char buff[1000];
2373: register char *bp, *blast;
2374:
2375: blast = buff + (n < 1000 ? n : 1000);
2376:
2377: for(bp = buff ; bp<blast && *s!='\0' ; )
2378: *bp++ = *s++;
2379: *bp = '\0';
2380: return system(buff);
2381: }
2382: ./ ADD NAME=libF77/z_abs.c TIME=719848075
2383: #include "f2c.h"
2384:
2385: #ifdef KR_headers
2386: double f__cabs();
2387: double z_abs(z) doublecomplex *z;
2388: #else
2389: double f__cabs(double, double);
2390: double z_abs(doublecomplex *z)
2391: #endif
2392: {
2393: return( f__cabs( z->r, z->i ) );
2394: }
2395: ./ ADD NAME=libF77/z_cos.c TIME=708889714
2396: #include "f2c.h"
2397:
2398: #ifdef KR_headers
2399: double sin(), cos(), sinh(), cosh();
2400: VOID z_cos(r, z) doublecomplex *r, *z;
2401: #else
2402: #undef abs
2403: #include "math.h"
2404: void z_cos(doublecomplex *r, doublecomplex *z)
2405: #endif
2406: {
2407: r->r = cos(z->r) * cosh(z->i);
2408: r->i = - sin(z->r) * sinh(z->i);
2409: }
2410: ./ ADD NAME=libF77/z_div.c TIME=708886308
2411: #include "f2c.h"
2412:
2413: #ifdef KR_headers
2414: extern void sig_die();
2415: VOID z_div(c, a, b) doublecomplex *a, *b, *c;
2416: #else
2417: extern void sig_die(char*, int);
2418: void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b)
2419: #endif
2420: {
2421: double ratio, den;
2422: double abr, abi;
2423:
2424: if( (abr = b->r) < 0.)
2425: abr = - abr;
2426: if( (abi = b->i) < 0.)
2427: abi = - abi;
2428: if( abr <= abi )
2429: {
2430: if(abi == 0)
2431: sig_die("complex division by zero", 1);
2432: ratio = b->r / b->i ;
2433: den = b->i * (1 + ratio*ratio);
2434: c->r = (a->r*ratio + a->i) / den;
2435: c->i = (a->i*ratio - a->r) / den;
2436: }
2437:
2438: else
2439: {
2440: ratio = b->i / b->r ;
2441: den = b->r * (1 + ratio*ratio);
2442: c->r = (a->r + a->i*ratio) / den;
2443: c->i = (a->i - a->r*ratio) / den;
2444: }
2445:
2446: }
2447: ./ ADD NAME=libF77/z_exp.c TIME=708889714
2448: #include "f2c.h"
2449:
2450: #ifdef KR_headers
2451: double exp(), cos(), sin();
2452: VOID z_exp(r, z) doublecomplex *r, *z;
2453: #else
2454: #undef abs
2455: #include "math.h"
2456: void z_exp(doublecomplex *r, doublecomplex *z)
2457: #endif
2458: {
2459: double expx;
2460:
2461: expx = exp(z->r);
2462: r->r = expx * cos(z->i);
2463: r->i = expx * sin(z->i);
2464: }
2465: ./ ADD NAME=libF77/z_log.c TIME=719848076
2466: #include "f2c.h"
2467:
2468: #ifdef KR_headers
2469: double log(), f__cabs(), atan2();
2470: VOID z_log(r, z) doublecomplex *r, *z;
2471: #else
2472: #undef abs
2473: #include "math.h"
2474: extern double f__cabs(double, double);
2475: void z_log(doublecomplex *r, doublecomplex *z)
2476: #endif
2477: {
2478:
2479: r->i = atan2(z->i, z->r);
2480: r->r = log( f__cabs( z->r, z->i ) );
2481: }
2482: ./ ADD NAME=libF77/z_sin.c TIME=708889714
2483: #include "f2c.h"
2484:
2485: #ifdef KR_headers
2486: double sin(), cos(), sinh(), cosh();
2487: VOID z_sin(r, z) doublecomplex *r, *z;
2488: #else
2489: #undef abs
2490: #include "math.h"
2491: void z_sin(doublecomplex *r, doublecomplex *z)
2492: #endif
2493: {
2494: r->r = sin(z->r) * cosh(z->i);
2495: r->i = cos(z->r) * sinh(z->i);
2496: }
2497: ./ ADD NAME=libF77/z_sqrt.c TIME=719848076
2498: #include "f2c.h"
2499:
2500: #ifdef KR_headers
2501: double sqrt(), f__cabs();
2502: VOID z_sqrt(r, z) doublecomplex *r, *z;
2503: #else
2504: #undef abs
2505: #include "math.h"
2506: extern double f__cabs(double, double);
2507: void z_sqrt(doublecomplex *r, doublecomplex *z)
2508: #endif
2509: {
2510: double mag;
2511:
2512: if( (mag = f__cabs(z->r, z->i)) == 0.)
2513: r->r = r->i = 0.;
2514: else if(z->r > 0)
2515: {
2516: r->r = sqrt(0.5 * (mag + z->r) );
2517: r->i = z->i / r->r / 2;
2518: }
2519: else
2520: {
2521: r->i = sqrt(0.5 * (mag - z->r) );
2522: if(z->i < 0)
2523: r->i = - r->i;
2524: r->r = z->i / r->i / 2;
2525: }
2526: }
2527: ./ ENDUP
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.