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