![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to libF77.st0 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.st0 CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: ./ ADD NAME=libF77/README TIME=627343162
2: If your system lacks onexit() and you are not using an ANSI C
3: compiler, then you should compile main.c with NO_ONEXIT defined.
4: See the comments about onexit in the makefile.
5:
6: If your system lacks a _cleanup routine (which is called just
7: before abort(), e.g. to flush buffers), just add a dummy, i.e.,
8: _cleanup() {}
9: to libF77.
10: ./ ADD NAME=libF77/makefile TIME=627748011
11: .SUFFIXES: .c .o
12: # compile, then strip unnecessary symbols
13: .c.o:
14: cc -O -c $*.c
15: ld -r -x $*.o
16: mv a.out $*.o
17:
18: MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\
19: signal_.o s_stop.o s_paus.o system_.o cabs.o\
20: derf_.o derfc_.o erf_.o erfc_.o
21: 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
22: CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o
23: DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o
24: REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\
25: r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\
26: r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\
27: r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o
28: DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\
29: d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\
30: d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\
31: d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\
32: d_sqrt.o d_tan.o d_tanh.o
33: 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
34: 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
35: 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
36: EFL = ef1asc_.o ef1cmc_.o
37: CHAR = s_cat.o s_cmp.o s_copy.o
38:
39: libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \
40: $(HALF) $(CMP) $(EFL) $(CHAR)
41: ar r libF77.a $?
42: ranlib libF77.a
43:
44: Version.o: Version.c
45: cc -c Version.c
46:
47: # If your system lacks onexit() and you are not using an
48: # ANSI C compiler, then you should uncomment the following
49: # two lines (for compiling main.o):
50: #main.o: main.c
51: # cc -c -DNO_ONEXIT main.c
52: # On at least some Sun systems, it is more appropriate to
53: # uncomment the following two lines:
54: #main.o: main.c
55: # cc -c -Donexit=on_exit main.c
56:
57: install: libF77.a
58: mv libF77.a /usr/lib
59:
60: clean:
61: rm -f libF77.a *.o
62: ./ ADD NAME=libF77/Version.c TIME=628430639
63: static char junk[] = "\n@(#)LIBF77 VERSION 2.01 30 Nov. 1989\n";
64:
65: /*
66: 2.00 11 June 1980. File version.c added to library.
67: 2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed
68: [ d]erf[c ] added
69: 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c
70: 29 Nov. 1989: s_cmp returns long (for f2c).
71: 30 Nov. 1989: arg types from argtypes.h
72: */
73: ./ ADD NAME=libF77/abort_.c TIME=628474861
74: #include "stdio.h"
75: #include "f2c.h"
76:
77: extern VOID abort();
78:
79: VOID abort_()
80: {
81: fprintf(stderr, "Fortran abort routine called\n");
82: _cleanup();
83: abort();
84: }
85: ./ ADD NAME=libF77/c_abs.c TIME=628437500
86: #include "f2c.h"
87:
88: double c_abs(z)
89: complex *z;
90: {
91: double cabs();
92:
93: return( cabs( z->r, z->i ) );
94: }
95: ./ ADD NAME=libF77/c_cos.c TIME=628437500
96: #include "f2c.h"
97:
98: VOID c_cos(r, z)
99: complex *r, *z;
100: {
101: double sin(), cos(), sinh(), cosh();
102:
103: r->r = cos(z->r) * cosh(z->i);
104: r->i = - sin(z->r) * sinh(z->i);
105: }
106: ./ ADD NAME=libF77/c_div.c TIME=628437671
107: #include "f2c.h"
108:
109: VOID c_div(c, a, b)
110: complex *a, *b, *c;
111: {
112: double ratio, den;
113: double abr, abi;
114:
115: if( (abr = b->r) < 0.)
116: abr = - abr;
117: if( (abi = b->i) < 0.)
118: abi = - abi;
119: if( abr <= abi )
120: {
121: if(abi == 0)
122: abort(); /* fatal("complex division by zero"); */
123: ratio = b->r / b->i ;
124: den = b->i * (1 + ratio*ratio);
125: c->r = (a->r*ratio + a->i) / den;
126: c->i = (a->i*ratio - a->r) / den;
127: }
128:
129: else
130: {
131: ratio = b->i / b->r ;
132: den = b->r * (1 + ratio*ratio);
133: c->r = (a->r + a->i*ratio) / den;
134: c->i = (a->i - a->r*ratio) / den;
135: }
136: }
137: ./ ADD NAME=libF77/c_exp.c TIME=628437500
138: #include "f2c.h"
139:
140: VOID c_exp(r, z)
141: complex *r, *z;
142: {
143: double expx;
144: double exp(), cos(), sin();
145:
146: expx = exp(z->r);
147: r->r = expx * cos(z->i);
148: r->i = expx * sin(z->i);
149: }
150: ./ ADD NAME=libF77/c_log.c TIME=628437500
151: #include "f2c.h"
152:
153: VOID c_log(r, z)
154: complex *r, *z;
155: {
156: double log(), cabs(), atan2();
157:
158: r->i = atan2(z->i, z->r);
159: r->r = log( cabs(z->r, z->i) );
160: }
161: ./ ADD NAME=libF77/c_sin.c TIME=628437501
162: #include "f2c.h"
163:
164: VOID c_sin(r, z)
165: complex *r, *z;
166: {
167: double sin(), cos(), sinh(), cosh();
168:
169: r->r = sin(z->r) * cosh(z->i);
170: r->i = cos(z->r) * sinh(z->i);
171: }
172: ./ ADD NAME=libF77/c_sqrt.c TIME=628437501
173: #include "f2c.h"
174:
175: VOID c_sqrt(r, z)
176: complex *r, *z;
177: {
178: double mag, sqrt(), cabs();
179:
180: if( (mag = cabs(z->r, z->i)) == 0.)
181: r->r = r->i = 0.;
182: else if(z->r > 0)
183: {
184: r->r = sqrt(0.5 * (mag + z->r) );
185: r->i = z->i / r->r / 2;
186: }
187: else
188: {
189: r->i = sqrt(0.5 * (mag - z->r) );
190: if(z->i < 0)
191: r->i = - r->i;
192: r->r = z->i / r->i /2;
193: }
194: }
195: ./ ADD NAME=libF77/cabs.c TIME=379733534
196: double cabs(real, imag)
197: double real, imag;
198: {
199: double temp, sqrt();
200:
201: if(real < 0)
202: real = -real;
203: if(imag < 0)
204: imag = -imag;
205: if(imag > real){
206: temp = real;
207: real = imag;
208: imag = temp;
209: }
210: if((real+imag) == real)
211: return(real);
212:
213: temp = imag/real;
214: temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/
215: return(temp);
216: }
217: ./ ADD NAME=libF77/argtypes.h TIME=628436547
218: typedef long integer;
219: typedef short shortint;
220: typedef double doublereal;
221: typedef float real;
222: typedef struct { float real, imag; } complex;
223: typedef struct { double dreal, dimag; } dcomplex;
224: typedef void VOID;
225: /* VOID can be int on systems that do not recognize void */
226: ./ ADD NAME=libF77/d_abs.c TIME=628437501
227: #include "f2c.h"
228:
229: double d_abs(x)
230: doublereal *x;
231: {
232: if(*x >= 0)
233: return(*x);
234: return(- *x);
235: }
236: ./ ADD NAME=libF77/d_acos.c TIME=628437502
237: #include "f2c.h"
238:
239: double d_acos(x)
240: doublereal *x;
241: {
242: double acos();
243: return( acos(*x) );
244: }
245: ./ ADD NAME=libF77/d_asin.c TIME=628437502
246: #include "f2c.h"
247:
248: double d_asin(x)
249: doublereal *x;
250: {
251: double asin();
252: return( asin(*x) );
253: }
254: ./ ADD NAME=libF77/d_atan.c TIME=628437502
255: #include "f2c.h"
256:
257: double d_atan(x)
258: doublereal *x;
259: {
260: double atan();
261: return( atan(*x) );
262: }
263: ./ ADD NAME=libF77/d_atn2.c TIME=628437502
264: #include "f2c.h"
265:
266: double d_atn2(x,y)
267: doublereal *x, *y;
268: {
269: double atan2();
270: return( atan2(*x,*y) );
271: }
272: ./ ADD NAME=libF77/d_cnjg.c TIME=628437502
273: #include "f2c.h"
274:
275: d_cnjg(r, z)
276: doublecomplex *r, *z;
277: {
278: r->r = z->r;
279: r->i = - z->i;
280: }
281: ./ ADD NAME=libF77/d_cos.c TIME=628437502
282: #include "f2c.h"
283:
284: double d_cos(x)
285: doublereal *x;
286: {
287: double cos();
288: return( cos(*x) );
289: }
290: ./ ADD NAME=libF77/d_cosh.c TIME=628437503
291: #include "f2c.h"
292:
293: double d_cosh(x)
294: doublereal *x;
295: {
296: double cosh();
297: return( cosh(*x) );
298: }
299: ./ ADD NAME=libF77/d_dim.c TIME=628437503
300: #include "f2c.h"
301:
302: double d_dim(a,b)
303: doublereal *a, *b;
304: {
305: return( *a > *b ? *a - *b : 0);
306: }
307: ./ ADD NAME=libF77/d_exp.c TIME=628437503
308: #include "f2c.h"
309:
310: double d_exp(x)
311: doublereal *x;
312: {
313: double exp();
314: return( exp(*x) );
315: }
316: ./ ADD NAME=libF77/d_imag.c TIME=628437503
317: #include "f2c.h"
318:
319: double d_imag(z)
320: doublecomplex *z;
321: {
322: return(z->i);
323: }
324: ./ ADD NAME=libF77/d_int.c TIME=628437503
325: #include "f2c.h"
326:
327: double d_int(x)
328: doublereal *x;
329: {
330: double floor();
331:
332: return( (*x>0) ? floor(*x) : -floor(- *x) );
333: }
334: ./ ADD NAME=libF77/d_lg10.c TIME=628437503
335: #include "f2c.h"
336:
337: #define log10e 0.43429448190325182765
338:
339: double d_lg10(x)
340: doublereal *x;
341: {
342: double log();
343:
344: return( log10e * log(*x) );
345: }
346: ./ ADD NAME=libF77/d_log.c TIME=628437503
347: #include "f2c.h"
348:
349: double d_log(x)
350: doublereal *x;
351: {
352: double log();
353: return( log(*x) );
354: }
355: ./ ADD NAME=libF77/d_mod.c TIME=628437503
356: #include "f2c.h"
357:
358: double d_mod(x,y)
359: doublereal *x, *y;
360: {
361: double floor(), quotient;
362: if( (quotient = *x / *y) >= 0)
363: quotient = floor(quotient);
364: else
365: quotient = -floor(-quotient);
366: return(*x - (*y) * quotient );
367: }
368: ./ ADD NAME=libF77/d_nint.c TIME=628437504
369: #include "f2c.h"
370:
371: double d_nint(x)
372: doublereal *x;
373: {
374: double floor();
375:
376: return( (*x)>=0 ?
377: floor(*x + .5) : -floor(.5 - *x) );
378: }
379: ./ ADD NAME=libF77/d_prod.c TIME=628437504
380: #include "f2c.h"
381:
382: double d_prod(x,y)
383: real *x, *y;
384: {
385: return( (*x) * (*y) );
386: }
387: ./ ADD NAME=libF77/d_sign.c TIME=628437504
388: #include "f2c.h"
389:
390: double d_sign(a,b)
391: doublereal *a, *b;
392: {
393: double x;
394: x = (*a >= 0 ? *a : - *a);
395: return( *b >= 0 ? x : -x);
396: }
397: ./ ADD NAME=libF77/d_sin.c TIME=628437504
398: #include "f2c.h"
399:
400: double d_sin(x)
401: doublereal *x;
402: {
403: double sin();
404: return( sin(*x) );
405: }
406: ./ ADD NAME=libF77/d_sinh.c TIME=628437504
407: #include "f2c.h"
408:
409: double d_sinh(x)
410: doublereal *x;
411: {
412: double sinh();
413: return( sinh(*x) );
414: }
415: ./ ADD NAME=libF77/d_sqrt.c TIME=628437504
416: #include "f2c.h"
417:
418: double d_sqrt(x)
419: doublereal *x;
420: {
421: double sqrt();
422: return( sqrt(*x) );
423: }
424: ./ ADD NAME=libF77/d_tan.c TIME=628437504
425: #include "f2c.h"
426:
427: double d_tan(x)
428: doublereal *x;
429: {
430: double tan();
431: return( tan(*x) );
432: }
433: ./ ADD NAME=libF77/d_tanh.c TIME=628437504
434: #include "f2c.h"
435:
436: double d_tanh(x)
437: doublereal *x;
438: {
439: double tanh();
440: return( tanh(*x) );
441: }
442: ./ ADD NAME=libF77/derf_.c TIME=628437505
443: #include "f2c.h"
444:
445: double derf_(x)
446: doublereal *x;
447: {
448: double erf();
449:
450: return( erf(*x) );
451: }
452: ./ ADD NAME=libF77/derfc_.c TIME=628437505
453: #include "f2c.h"
454:
455: double derfc_(x)
456: doublereal *x;
457: {
458: double erfc();
459:
460: return( erfc(*x) );
461: }
462: ./ ADD NAME=libF77/ef1asc_.c TIME=628437505
463: /* EFL support routine to copy string b to string a */
464:
465: #include "f2c.h"
466:
467: extern VOID s_copy();
468:
469: #define M ( (long) (sizeof(long) - 1) )
470: #define EVEN(x) ( ( (x)+ M) & (~M) )
471:
472: VOID ef1asc_(a, la, b, lb)
473: int *a, *b;
474: long int *la, *lb;
475: {
476: s_copy( (char *)a, (char *)b, EVEN(*la), *lb );
477: }
478: ./ ADD NAME=libF77/ef1cmc_.c TIME=628437505
479: /* EFL support routine to compare two character strings */
480:
481: #include "f2c.h"
482:
483: extern integer s_cmp();
484:
485: integer ef1cmc_(a, la, b, lb)
486: integer *a, *b;
487: integer *la, *lb;
488: {
489: return( s_cmp( (char *)a, (char *)b, *la, *lb) );
490: }
491: ./ ADD NAME=libF77/erf_.c TIME=628437505
492: #include "f2c.h"
493:
494: double erf_(x)
495: real *x;
496: {
497: double erf();
498:
499: return( erf(*x) );
500: }
501: ./ ADD NAME=libF77/erfc_.c TIME=628437505
502: #include "f2c.h"
503:
504: double erfc_(x)
505: real *x;
506: {
507: double erfc();
508:
509: return( erfc(*x) );
510: }
511: ./ ADD NAME=libF77/getarg_.c TIME=628437505
512: #include "f2c.h"
513:
514: /*
515: * subroutine getarg(k, c)
516: * returns the kth unix command argument in fortran character
517: * variable argument c
518: */
519:
520: VOID getarg_(n, s, ls)
521: long int *n;
522: register char *s;
523: long int ls;
524: {
525: extern int xargc;
526: extern char **xargv;
527: register char *t;
528: register int i;
529:
530: if(*n>=0 && *n<xargc)
531: t = xargv[*n];
532: else
533: t = "";
534: for(i = 0; i<ls && *t!='\0' ; ++i)
535: *s++ = *t++;
536: for( ; i<ls ; ++i)
537: *s++ = ' ';
538: }
539: ./ ADD NAME=libF77/getenv_.c TIME=628437505
540: #include "f2c.h"
541:
542: /*
543: * getenv - f77 subroutine to return environment variables
544: *
545: * called by:
546: * call getenv (ENV_NAME, char_var)
547: * where:
548: * ENV_NAME is the name of an environment variable
549: * char_var is a character variable which will receive
550: * the current value of ENV_NAME, or all blanks
551: * if ENV_NAME is not defined
552: */
553:
554: VOID getenv_(fname, value, flen, vlen)
555: char *value, *fname;
556: long int vlen, flen;
557: {
558: extern char **environ;
559: register char *ep, *fp, *flast;
560: register char **env = environ;
561:
562: flast = fname + flen;
563: for(fp = fname ; fp < flast ; ++fp)
564: if(*fp == ' ')
565: {
566: flast = fp;
567: break;
568: }
569:
570: while (ep = *env++)
571: {
572: for(fp = fname; fp<flast ; )
573: if(*fp++ != *ep++)
574: goto endloop;
575:
576: if(*ep++ == '=') /* copy right hand side */
577: while( *ep && --vlen>=0 )
578: *value++ = *ep++;
579:
580: goto blank;
581:
582: endloop: ;
583: }
584:
585: blank:
586: while( --vlen >= 0 )
587: *value++ = ' ';
588: }
589: ./ ADD NAME=libF77/h_abs.c TIME=628437506
590: #include "f2c.h"
591:
592: extern integer s_cmp();
593:
594: shortint h_abs(x)
595: shortint *x;
596: {
597: if(*x >= 0)
598: return(*x);
599: return(- *x);
600: }
601: ./ ADD NAME=libF77/h_dim.c TIME=628437506
602: #include "f2c.h"
603:
604: extern integer s_cmp();
605:
606: shortint h_dim(a,b)
607: shortint *a, *b;
608: {
609: return( *a > *b ? *a - *b : 0);
610: }
611: ./ ADD NAME=libF77/h_dnnt.c TIME=628437506
612: #include "f2c.h"
613:
614: extern integer s_cmp();
615:
616: shortint h_dnnt(x)
617: doublereal *x;
618: {
619: double floor();
620:
621: return( (*x)>=0 ?
622: floor(*x + .5) : -floor(.5 - *x) );
623: }
624: ./ ADD NAME=libF77/h_indx.c TIME=628437506
625: #include "f2c.h"
626:
627: extern integer s_cmp();
628:
629: shortint h_indx(a, b, la, lb)
630: char *a, *b;
631: long int la, lb;
632: {
633: int i, n;
634: char *s, *t, *bend;
635:
636: n = la - lb + 1;
637: bend = b + lb;
638:
639: for(i = 0 ; i < n ; ++i)
640: {
641: s = a + i;
642: t = b;
643: while(t < bend)
644: if(*s++ != *t++)
645: goto no;
646: return(i+1);
647: no: ;
648: }
649: return(0);
650: }
651: ./ ADD NAME=libF77/h_len.c TIME=628437506
652: #include "f2c.h"
653:
654: extern integer s_cmp();
655:
656: shortint h_len(s, n)
657: char *s;
658: long int n;
659: {
660: return(n);
661: }
662: ./ ADD NAME=libF77/h_mod.c TIME=628437506
663: #include "f2c.h"
664:
665: extern integer s_cmp();
666:
667: shortint h_mod(a,b)
668: short *a, *b;
669: {
670: return( *a % *b);
671: }
672: ./ ADD NAME=libF77/h_nint.c TIME=628437506
673: #include "f2c.h"
674:
675: extern integer s_cmp();
676:
677: shortint h_nint(x)
678: real *x;
679: {
680: double floor();
681:
682: return( (*x)>=0 ?
683: floor(*x + .5) : -floor(.5 - *x) );
684: }
685: ./ ADD NAME=libF77/h_sign.c TIME=628437507
686: #include "f2c.h"
687:
688: extern integer s_cmp();
689:
690: shortint h_sign(a,b)
691: shortint *a, *b;
692: {
693: shortint x;
694: x = (*a >= 0 ? *a : - *a);
695: return( *b >= 0 ? x : -x);
696: }
697: ./ ADD NAME=libF77/hl_ge.c TIME=628437507
698: #include "f2c.h"
699:
700: extern integer s_cmp();
701:
702: shortint hl_ge(a,b,la,lb)
703: char *a, *b;
704: long int la, lb;
705: {
706: return(s_cmp(a,b,la,lb) >= 0);
707: }
708: ./ ADD NAME=libF77/hl_gt.c TIME=628437507
709: #include "f2c.h"
710:
711: extern integer s_cmp();
712:
713: shortint hl_gt(a,b,la,lb)
714: char *a, *b;
715: long int la, lb;
716: {
717: return(s_cmp(a,b,la,lb) > 0);
718: }
719: ./ ADD NAME=libF77/hl_le.c TIME=628437507
720: #include "f2c.h"
721:
722: extern integer s_cmp();
723:
724: shortint hl_le(a,b,la,lb)
725: char *a, *b;
726: long int la, lb;
727: {
728: return(s_cmp(a,b,la,lb) <= 0);
729: }
730: ./ ADD NAME=libF77/hl_lt.c TIME=628437507
731: #include "f2c.h"
732:
733: extern integer s_cmp();
734:
735: shortint hl_lt(a,b,la,lb)
736: char *a, *b;
737: long int la, lb;
738: {
739: return(s_cmp(a,b,la,lb) < 0);
740: }
741: ./ ADD NAME=libF77/i_abs.c TIME=628437507
742: #include "f2c.h"
743:
744: integer i_abs(x)
745: integer *x;
746: {
747: if(*x >= 0)
748: return(*x);
749: return(- *x);
750: }
751: ./ ADD NAME=libF77/i_dim.c TIME=628437507
752: #include "f2c.h"
753:
754: integer i_dim(a,b)
755: integer *a, *b;
756: {
757: return( *a > *b ? *a - *b : 0);
758: }
759: ./ ADD NAME=libF77/i_dnnt.c TIME=628437507
760: #include "f2c.h"
761:
762: integer i_dnnt(x)
763: doublereal *x;
764: {
765: double floor();
766:
767: return( (*x)>=0 ?
768: floor(*x + .5) : -floor(.5 - *x) );
769: }
770: ./ ADD NAME=libF77/i_indx.c TIME=628437507
771: #include "f2c.h"
772:
773: integer i_indx(a, b, la, lb)
774: char *a, *b;
775: long int la, lb;
776: {
777: long int i, n;
778: char *s, *t, *bend;
779:
780: n = la - lb + 1;
781: bend = b + lb;
782:
783: for(i = 0 ; i < n ; ++i)
784: {
785: s = a + i;
786: t = b;
787: while(t < bend)
788: if(*s++ != *t++)
789: goto no;
790: return(i+1);
791: no: ;
792: }
793: return(0);
794: }
795: ./ ADD NAME=libF77/i_len.c TIME=628437508
796: #include "f2c.h"
797:
798: integer i_len(s, n)
799: char *s;
800: long int n;
801: {
802: return(n);
803: }
804: ./ ADD NAME=libF77/i_mod.c TIME=628437508
805: #include "f2c.h"
806:
807: integer i_mod(a,b)
808: integer *a, *b;
809: {
810: return( *a % *b);
811: }
812: ./ ADD NAME=libF77/i_nint.c TIME=628437508
813: #include "f2c.h"
814:
815: integer i_nint(x)
816: real *x;
817: {
818: double floor();
819:
820: return( (*x)>=0 ?
821: floor(*x + .5) : -floor(.5 - *x) );
822: }
823: ./ ADD NAME=libF77/i_sign.c TIME=628437508
824: #include "f2c.h"
825:
826: integer i_sign(a,b)
827: integer *a, *b;
828: {
829: integer x;
830: x = (*a >= 0 ? *a : - *a);
831: return( *b >= 0 ? x : -x);
832: }
833: ./ ADD NAME=libF77/iargc_.c TIME=628437508
834: #include "f2c.h"
835:
836: integer iargc_()
837: {
838: extern int xargc;
839: return ( xargc - 1 );
840: }
841: ./ ADD NAME=libF77/l_ge.c TIME=628437508
842: #include "f2c.h"
843:
844: extern integer s_cmp();
845:
846: integer l_ge(a,b,la,lb)
847: char *a, *b;
848: long int la, lb;
849: {
850: return(s_cmp(a,b,la,lb) >= 0);
851: }
852: ./ ADD NAME=libF77/l_gt.c TIME=628437508
853: #include "f2c.h"
854:
855: extern integer s_cmp();
856:
857: integer l_gt(a,b,la,lb)
858: char *a, *b;
859: long int la, lb;
860: {
861: return(s_cmp(a,b,la,lb) > 0);
862: }
863: ./ ADD NAME=libF77/l_le.c TIME=628437508
864: #include "f2c.h"
865:
866: extern integer s_cmp();
867:
868: integer l_le(a,b,la,lb)
869: char *a, *b;
870: long int la, lb;
871: {
872: return(s_cmp(a,b,la,lb) <= 0);
873: }
874: ./ ADD NAME=libF77/l_lt.c TIME=628437509
875: #include "f2c.h"
876:
877: integer l_lt(a,b,la,lb)
878: char *a, *b;
879: long la, lb;
880: {
881: return(s_cmp(a,b,la,lb) < 0);
882: }
883: ./ ADD NAME=libF77/main.c TIME=628524317
884: /* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */
885:
886: #include "stdio.h"
887: #include "signal.h"
888:
889: #ifndef SIGIOT
890: #define SIGIOT SIGABRT
891: #endif
892:
893: #ifdef NO__STDC
894: #define ONEXIT onexit
895: extern void f_exit();
896: #else
897: #ifdef __STDC__
898: #include "stdlib.h"
899: extern void f_exit(void);
900: #ifndef NO_ONEXIT
901: #define ONEXIT atexit
902: extern int atexit(void (*)(void));
903: #endif
904: #else
905: #ifndef NO_ONEXIT
906: #define ONEXIT onexit
907: extern void f_exit();
908: #endif
909: #endif
910: #endif
911:
912: static void sigdie(s, kill)
913: register char *s;
914: int kill;
915: {
916: /* print error message, then clear buffers */
917: fflush(stderr);
918: fprintf(stderr, "%s\n", s);
919: f_exit();
920: fflush(stderr);
921:
922: if(kill)
923: {
924: /* now get a core */
925: signal(SIGIOT, 0);
926: abort();
927: }
928: else
929: exit(1);
930: }
931:
932: static void sigfdie(n)
933: {
934: sigdie("Floating Exception", 1);
935: }
936:
937:
938:
939: static void sigidie(n)
940: {
941: sigdie("IOT Trap", 1);
942: }
943:
944:
945: static void sigqdie(n)
946: {
947: sigdie("Quit signal", 1);
948: }
949:
950:
951:
952: static void sigindie(n)
953: {
954: sigdie("Interrupt", 0);
955: }
956:
957:
958:
959: static void sigtdie(n)
960: {
961: sigdie("Killed", 0);
962: }
963:
964:
965: int xargc;
966: char **xargv;
967:
968: main(argc, argv)
969: int argc;
970: char **argv;
971: {
972: xargc = argc;
973: xargv = argv;
974: signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */
975: signal(SIGIOT, sigidie);
976: #ifdef SIGQUIT
977: if( (int)signal(SIGQUIT,sigqdie) & 01) signal(SIGQUIT, SIG_IGN);
978: #endif
979: if( (int)signal(SIGINT, sigindie) & 01) signal(SIGINT, SIG_IGN);
980: signal(SIGTERM,sigtdie);
981:
982: #ifdef pdp11
983: ldfps(01200); /* detect overflow as an exception */
984: #endif
985:
986: f_init();
987: #ifndef NO_ONEXIT
988: ONEXIT(f_exit);
989: #endif
990: MAIN__();
991: #ifdef NO_ONEXIT
992: f_exit();
993: #endif
994: }
995: ./ ADD NAME=libF77/pow_ci.c TIME=628438069
996: #include "f2c.h"
997:
998: VOID pow_ci(p, a, b) /* p = a**b */
999: complex *p, *a;
1000: integer *b;
1001: {
1002: doublecomplex p1, a1;
1003:
1004: a1.r = a->r;
1005: a1.i = a->i;
1006:
1007: pow_zi(&p1, &a1, b);
1008:
1009: p->r = p1.r;
1010: p->i = p1.i;
1011: }
1012: ./ ADD NAME=libF77/pow_dd.c TIME=628437509
1013: #include "f2c.h"
1014:
1015: double pow_dd(ap, bp)
1016: doublereal *ap, *bp;
1017: {
1018: double pow();
1019:
1020: return(pow(*ap, *bp) );
1021: }
1022: ./ ADD NAME=libF77/pow_di.c TIME=628437509
1023: #include "f2c.h"
1024:
1025: double pow_di(ap, bp)
1026: doublereal *ap;
1027: integer *bp;
1028: {
1029: double pow, x;
1030: integer n;
1031:
1032: pow = 1;
1033: x = *ap;
1034: n = *bp;
1035:
1036: if(n != 0)
1037: {
1038: if(n < 0)
1039: {
1040: if(x == 0)
1041: {
1042: return(pow);
1043: }
1044: n = -n;
1045: x = 1/x;
1046: }
1047: for( ; ; )
1048: {
1049: if(n & 01)
1050: pow *= x;
1051: if(n >>= 1)
1052: x *= x;
1053: else
1054: break;
1055: }
1056: }
1057: return(pow);
1058: }
1059: ./ ADD NAME=libF77/pow_hh.c TIME=628437509
1060: #include "f2c.h"
1061:
1062: shortint pow_hh(ap, bp)
1063: shortint *ap, *bp;
1064: {
1065: shortint pow, x, n;
1066:
1067: pow = 1;
1068: x = *ap;
1069: n = *bp;
1070:
1071: if(n < 0)
1072: { }
1073: else if(n > 0)
1074: for( ; ; )
1075: {
1076: if(n & 01)
1077: pow *= x;
1078: if(n >>= 1)
1079: x *= x;
1080: else
1081: break;
1082: }
1083: return(pow);
1084: }
1085: ./ ADD NAME=libF77/pow_ii.c TIME=628437509
1086: #include "f2c.h"
1087:
1088: integer pow_ii(ap, bp)
1089: integer *ap, *bp;
1090: {
1091: integer pow, x, n;
1092:
1093: pow = 1;
1094: x = *ap;
1095: n = *bp;
1096:
1097: if(n < 0)
1098: { }
1099: else if(n > 0)
1100: for( ; ; )
1101: {
1102: if(n & 01)
1103: pow *= x;
1104: if(n >>= 1)
1105: x *= x;
1106: else
1107: break;
1108: }
1109: return(pow);
1110: }
1111: ./ ADD NAME=libF77/pow_ri.c TIME=628437509
1112: #include "f2c.h"
1113:
1114: double pow_ri(ap, bp)
1115: real *ap;
1116: integer *bp;
1117: {
1118: double pow, x;
1119: integer n;
1120:
1121: pow = 1;
1122: x = *ap;
1123: n = *bp;
1124:
1125: if(n != 0)
1126: {
1127: if(n < 0)
1128: {
1129: if(x == 0)
1130: {
1131: return(pow);
1132: }
1133: n = -n;
1134: x = 1/x;
1135: }
1136: for( ; ; )
1137: {
1138: if(n & 01)
1139: pow *= x;
1140: if(n >>= 1)
1141: x *= x;
1142: else
1143: break;
1144: }
1145: }
1146: return(pow);
1147: }
1148: ./ ADD NAME=libF77/pow_zi.c TIME=628438134
1149: #include "f2c.h"
1150:
1151: VOID pow_zi(p, a, b) /* p = a**b */
1152: doublecomplex *p, *a;
1153: integer *b;
1154: {
1155: integer n;
1156: double t;
1157: doublecomplex x;
1158: static doublecomplex one = {1.0, 0.0};
1159:
1160: n = *b;
1161: p->r = 1;
1162: p->i = 0;
1163:
1164: if(n == 0)
1165: return;
1166: if(n < 0)
1167: {
1168: n = -n;
1169: z_div(&x, &one, a);
1170: }
1171: else
1172: {
1173: x.r = a->r;
1174: x.i = a->i;
1175: }
1176:
1177: for( ; ; )
1178: {
1179: if(n & 01)
1180: {
1181: t = p->r * x.r - p->i * x.i;
1182: p->i = p->r * x.i + p->i * x.r;
1183: p->r = t;
1184: }
1185: if(n >>= 1)
1186: {
1187: t = x.r * x.r - x.i * x.i;
1188: x.i = 2 * x.r * x.i;
1189: x.r = t;
1190: }
1191: else
1192: break;
1193: }
1194: }
1195: ./ ADD NAME=libF77/pow_zz.c TIME=628437510
1196: #include "f2c.h"
1197:
1198: VOID pow_zz(r,a,b)
1199: doublecomplex *r, *a, *b;
1200: {
1201: double logr, logi, x, y;
1202: double log(), exp(), cos(), sin(), atan2(), cabs();
1203:
1204: logr = log( cabs(a->r, a->i) );
1205: logi = atan2(a->i, a->r);
1206:
1207: x = exp( logr * b->r - logi * b->i );
1208: y = logr * b->i + logi * b->r;
1209:
1210: r->r = x * cos(y);
1211: r->i = x * sin(y);
1212: }
1213: ./ ADD NAME=libF77/r_abs.c TIME=628437510
1214: #include "f2c.h"
1215:
1216: double r_abs(x)
1217: real *x;
1218: {
1219: if(*x >= 0)
1220: return(*x);
1221: return(- *x);
1222: }
1223: ./ ADD NAME=libF77/r_acos.c TIME=628437510
1224: #include "f2c.h"
1225:
1226: double r_acos(x)
1227: real *x;
1228: {
1229: double acos();
1230: return( acos(*x) );
1231: }
1232: ./ ADD NAME=libF77/r_asin.c TIME=628437510
1233: #include "f2c.h"
1234:
1235: double r_asin(x)
1236: real *x;
1237: {
1238: double asin();
1239: return( asin(*x) );
1240: }
1241: ./ ADD NAME=libF77/r_atan.c TIME=628437510
1242: #include "f2c.h"
1243:
1244: double r_atan(x)
1245: real *x;
1246: {
1247: double atan();
1248: return( atan(*x) );
1249: }
1250: ./ ADD NAME=libF77/r_atn2.c TIME=628437510
1251: #include "f2c.h"
1252:
1253: double r_atn2(x,y)
1254: real *x, *y;
1255: {
1256: double atan2();
1257: return( atan2(*x,*y) );
1258: }
1259: ./ ADD NAME=libF77/r_cnjg.c TIME=628437511
1260: #include "f2c.h"
1261:
1262: VOID r_cnjg(r, z)
1263: complex *r, *z;
1264: {
1265: r->r = z->r;
1266: r->i = - z->i;
1267: }
1268: ./ ADD NAME=libF77/r_cos.c TIME=628437511
1269: #include "f2c.h"
1270:
1271: double r_cos(x)
1272: real *x;
1273: {
1274: double cos();
1275: return( cos(*x) );
1276: }
1277: ./ ADD NAME=libF77/r_cosh.c TIME=628437511
1278: #include "f2c.h"
1279:
1280: double r_cosh(x)
1281: real *x;
1282: {
1283: double cosh();
1284: return( cosh(*x) );
1285: }
1286: ./ ADD NAME=libF77/r_dim.c TIME=628437511
1287: #include "f2c.h"
1288:
1289: double r_dim(a,b)
1290: real *a, *b;
1291: {
1292: return( *a > *b ? *a - *b : 0);
1293: }
1294: ./ ADD NAME=libF77/r_exp.c TIME=628437511
1295: #include "f2c.h"
1296:
1297: double r_exp(x)
1298: real *x;
1299: {
1300: double exp();
1301: return( exp(*x) );
1302: }
1303: ./ ADD NAME=libF77/r_imag.c TIME=628437511
1304: #include "f2c.h"
1305:
1306: double r_imag(z)
1307: complex *z;
1308: {
1309: return(z->i);
1310: }
1311: ./ ADD NAME=libF77/r_int.c TIME=628437511
1312: #include "f2c.h"
1313:
1314: double r_int(x)
1315: real *x;
1316: {
1317: double floor();
1318:
1319: return( (*x>0) ? floor(*x) : -floor(- *x) );
1320: }
1321: ./ ADD NAME=libF77/r_lg10.c TIME=628437511
1322: #include "f2c.h"
1323:
1324: #define log10e 0.43429448190325182765
1325:
1326: double r_lg10(x)
1327: real *x;
1328: {
1329: double log();
1330:
1331: return( log10e * log(*x) );
1332: }
1333: ./ ADD NAME=libF77/r_log.c TIME=628437511
1334: #include "f2c.h"
1335:
1336: double r_log(x)
1337: real *x;
1338: {
1339: double log();
1340: return( log(*x) );
1341: }
1342: ./ ADD NAME=libF77/r_mod.c TIME=628437512
1343: #include "f2c.h"
1344:
1345: double r_mod(x,y)
1346: real *x, *y;
1347: {
1348: double floor(), quotient;
1349: if( (quotient = *x / *y) >= 0)
1350: quotient = floor(quotient);
1351: else
1352: quotient = -floor(-quotient);
1353: return(*x - (*y) * quotient );
1354: }
1355: ./ ADD NAME=libF77/r_nint.c TIME=628437512
1356: #include "f2c.h"
1357:
1358: double r_nint(x)
1359: real *x;
1360: {
1361: double floor();
1362:
1363: return( (*x)>=0 ?
1364: floor(*x + .5) : -floor(.5 - *x) );
1365: }
1366: ./ ADD NAME=libF77/r_sign.c TIME=628437512
1367: #include "f2c.h"
1368:
1369: double r_sign(a,b)
1370: real *a, *b;
1371: {
1372: double x;
1373: x = (*a >= 0 ? *a : - *a);
1374: return( *b >= 0 ? x : -x);
1375: }
1376: ./ ADD NAME=libF77/r_sin.c TIME=628437512
1377: #include "f2c.h"
1378:
1379: double r_sin(x)
1380: real *x;
1381: {
1382: double sin();
1383: return( sin(*x) );
1384: }
1385: ./ ADD NAME=libF77/r_sinh.c TIME=628437512
1386: #include "f2c.h"
1387:
1388: double r_sinh(x)
1389: real *x;
1390: {
1391: double sinh();
1392: return( sinh(*x) );
1393: }
1394: ./ ADD NAME=libF77/r_sqrt.c TIME=628437512
1395: #include "f2c.h"
1396:
1397: double r_sqrt(x)
1398: real *x;
1399: {
1400: double sqrt();
1401: return( sqrt(*x) );
1402: }
1403: ./ ADD NAME=libF77/r_tan.c TIME=628437512
1404: #include "f2c.h"
1405:
1406: double r_tan(x)
1407: real *x;
1408: {
1409: double tan();
1410: return( tan(*x) );
1411: }
1412: ./ ADD NAME=libF77/r_tanh.c TIME=628437512
1413: #include "f2c.h"
1414:
1415: double r_tanh(x)
1416: real *x;
1417: {
1418: double tanh();
1419: return( tanh(*x) );
1420: }
1421: ./ ADD NAME=libF77/s_cat.c TIME=628437513
1422: #include "f2c.h"
1423:
1424: VOID s_cat(lp, rpp, rnp, np, ll)
1425: char *lp, *rpp[];
1426: #ifdef f2c_i2
1427: short int rnp[], *np, ll;
1428: #else
1429: long int rnp[], *np, ll;
1430: #endif
1431: {
1432: int i, n, nc;
1433: char *rp;
1434:
1435: n = *np;
1436: for(i = 0 ; i < n ; ++i)
1437: {
1438: nc = ll;
1439: if(rnp[i] < nc)
1440: nc = rnp[i];
1441: ll -= nc;
1442: rp = rpp[i];
1443: while(--nc >= 0)
1444: *lp++ = *rp++;
1445: }
1446: while(--ll >= 0)
1447: *lp++ = ' ';
1448: }
1449: ./ ADD NAME=libF77/s_cmp.c TIME=628437513
1450: #include "f2c.h"
1451:
1452: integer s_cmp(a, b, la, lb) /* compare two strings */
1453: register char *a, *b;
1454: long int la, lb;
1455: {
1456: register char *aend, *bend;
1457: aend = a + la;
1458: bend = b + lb;
1459:
1460: if(la <= lb)
1461: {
1462: while(a < aend)
1463: if(*a != *b)
1464: return( *a - *b );
1465: else
1466: { ++a; ++b; }
1467:
1468: while(b < bend)
1469: if(*b != ' ')
1470: return( ' ' - *b );
1471: else ++b;
1472: }
1473:
1474: else
1475: {
1476: while(b < bend)
1477: if(*a == *b)
1478: { ++a; ++b; }
1479: else
1480: return( *a - *b );
1481: while(a < aend)
1482: if(*a != ' ')
1483: return(*a - ' ');
1484: else ++a;
1485: }
1486: return(0);
1487: }
1488: ./ ADD NAME=libF77/s_copy.c TIME=628437513
1489: #include "f2c.h"
1490:
1491: VOID s_copy(a, b, la, lb) /* assign strings: a = b */
1492: char *a, *b;
1493: long int la, lb;
1494: {
1495: char *aend, *bend;
1496:
1497: aend = a + la;
1498:
1499: if(la <= lb)
1500: while(a < aend)
1501: *a++ = *b++;
1502:
1503: else
1504: {
1505: bend = b + lb;
1506: while(b < bend)
1507: *a++ = *b++;
1508: while(a < aend)
1509: *a++ = ' ';
1510: }
1511: }
1512: ./ ADD NAME=libF77/s_paus.c TIME=628474922
1513: #include "stdio.h"
1514: #include "f2c.h"
1515: #define PAUSESIG 15
1516:
1517: static waitpause()
1518: {
1519: return;
1520: }
1521:
1522: VOID s_paus(s, n)
1523: char *s;
1524: long int n;
1525: {
1526: int i;
1527:
1528: fprintf(stderr, "PAUSE ");
1529: if(n > 0)
1530: for(i = 0; i<n ; ++i)
1531: putc(*s++, stderr);
1532: fprintf(stderr, " statement executed\n");
1533: if( isatty(fileno(stdin)) )
1534: {
1535: fprintf(stderr, "To resume execution, type go. Any other input will terminate job.\n");
1536: fflush(stderr);
1537: if( getchar()!='g' || getchar()!='o' || getchar()!='\n' )
1538: {
1539: fprintf(stderr, "STOP\n");
1540: f_exit();
1541: exit(0);
1542: }
1543: }
1544: else
1545: {
1546: fprintf(stderr, "To resume execution, execute a kill -%d %d command\n",
1547: PAUSESIG, getpid() );
1548: signal(PAUSESIG, waitpause);
1549: fflush(stderr);
1550: pause();
1551: }
1552: fprintf(stderr, "Execution resumes after PAUSE.\n");
1553: }
1554: ./ ADD NAME=libF77/s_rnge.c TIME=626022810
1555: #include <stdio.h>
1556:
1557: /* called when a subscript is out of range */
1558:
1559: s_rnge(varn, offset, procn, line)
1560: char *varn, *procn;
1561: long int offset;
1562: int line;
1563: {
1564: register int i;
1565:
1566: fprintf(stderr, "Subscript out of range on file line %d, procedure ", line);
1567: for(i = 0 ; i < 8 && *procn!='_' ; ++i)
1568: putc(*procn++, stderr);
1569: fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1);
1570: for(i = 0 ; i < 8 && *varn!=' ' ; ++i)
1571: putc(*varn++, stderr);
1572: fprintf(stderr, ".\n");
1573: _cleanup();
1574: abort();
1575: }
1576: ./ ADD NAME=libF77/s_stop.c TIME=628474936
1577: #include "stdio.h"
1578: #include "f2c.h"
1579:
1580: VOID s_stop(s, n)
1581: char *s;
1582: long int n;
1583: {
1584: int i;
1585:
1586: if(n > 0)
1587: {
1588: fprintf(stderr, "STOP ");
1589: for(i = 0; i<n ; ++i)
1590: putc(*s++, stderr);
1591: fprintf(stderr, " statement executed\n");
1592: }
1593: f_exit();
1594: exit(0);
1595: }
1596: ./ ADD NAME=libF77/signal_.c TIME=628437513
1597: #include "f2c.h"
1598:
1599: typedef int (*sig_type)();
1600: extern sig_type signal();
1601:
1602: integer signal_(sigp, procp)
1603: integer *sigp, *procp;
1604: {
1605: int sig;
1606: sig_type proc;
1607: sig = *sigp;
1608: proc = *(sig_type *)procp;
1609:
1610: return (integer)signal(sig, proc);
1611: }
1612: ./ ADD NAME=libF77/system_.c TIME=628437513
1613: /* f77 interface to system routine */
1614:
1615: #include "f2c.h"
1616:
1617: system_(s, n)
1618: register char *s;
1619: long int n;
1620: {
1621: char buff[1000];
1622: register char *bp, *blast;
1623:
1624: blast = buff + (n < 1000 ? n : 1000);
1625:
1626: for(bp = buff ; bp<blast && *s!='\0' ; )
1627: *bp++ = *s++;
1628: *bp = '\0';
1629: system(buff);
1630: }
1631: ./ ADD NAME=libF77/z_abs.c TIME=628438260
1632: #include "f2c.h"
1633:
1634: double z_abs(z)
1635: doublecomplex *z;
1636: {
1637: double cabs();
1638:
1639: return( cabs( z->r, z->i ) );
1640: }
1641: ./ ADD NAME=libF77/z_cos.c TIME=628437514
1642: #include "f2c.h"
1643:
1644: VOID z_cos(r, z)
1645: doublecomplex *r, *z;
1646: {
1647: double sin(), cos(), sinh(), cosh();
1648:
1649: r->r = cos(z->r) * cosh(z->i);
1650: r->i = - sin(z->r) * sinh(z->i);
1651: }
1652: ./ ADD NAME=libF77/z_div.c TIME=628437514
1653: #include "f2c.h"
1654:
1655: VOID z_div(c, a, b)
1656: doublecomplex *a, *b, *c;
1657: {
1658: double ratio, den;
1659: double abr, abi;
1660:
1661: if( (abr = b->r) < 0.)
1662: abr = - abr;
1663: if( (abi = b->i) < 0.)
1664: abi = - abi;
1665: if( abr <= abi )
1666: {
1667: if(abi == 0)
1668: abort(); /* fatal("complex division by zero"); */
1669: ratio = b->r / b->i ;
1670: den = b->i * (1 + ratio*ratio);
1671: c->r = (a->r*ratio + a->i) / den;
1672: c->i = (a->i*ratio - a->r) / den;
1673: }
1674:
1675: else
1676: {
1677: ratio = b->i / b->r ;
1678: den = b->r * (1 + ratio*ratio);
1679: c->r = (a->r + a->i*ratio) / den;
1680: c->i = (a->i - a->r*ratio) / den;
1681: }
1682:
1683: }
1684: ./ ADD NAME=libF77/z_exp.c TIME=628437514
1685: #include "f2c.h"
1686:
1687: VOID z_exp(r, z)
1688: doublecomplex *r, *z;
1689: {
1690: double expx;
1691: double exp(), cos(), sin();
1692:
1693: expx = exp(z->r);
1694: r->r = expx * cos(z->i);
1695: r->i = expx * sin(z->i);
1696: }
1697: ./ ADD NAME=libF77/z_log.c TIME=628437514
1698: #include "f2c.h"
1699:
1700: VOID z_log(r, z)
1701: doublecomplex *r, *z;
1702: {
1703: double log(), cabs(), atan2();
1704:
1705: r->i = atan2(z->i, z->r);
1706: r->r = log( cabs( z->r, z->i ) );
1707: }
1708: ./ ADD NAME=libF77/z_sin.c TIME=628437514
1709: #include "f2c.h"
1710:
1711: VOID z_sin(r, z)
1712: doublecomplex *r, *z;
1713: {
1714: double sin(), cos(), sinh(), cosh();
1715:
1716: r->r = sin(z->r) * cosh(z->i);
1717: r->i = cos(z->r) * sinh(z->i);
1718: }
1719: ./ ADD NAME=libF77/z_sqrt.c TIME=628437514
1720: #include "f2c.h"
1721:
1722: VOID z_sqrt(r, z)
1723: doublecomplex *r, *z;
1724: {
1725: double mag, sqrt(), cabs();
1726:
1727: if( (mag = cabs(z->r, z->i)) == 0.)
1728: r->r = r->i = 0.;
1729: else if(z->r > 0)
1730: {
1731: r->r = sqrt(0.5 * (mag + z->r) );
1732: r->i = z->i / r->r / 2;
1733: }
1734: else
1735: {
1736: r->i = sqrt(0.5 * (mag - z->r) );
1737: if(z->i < 0)
1738: z->i = - z->i;
1739: r->r = z->i / r->i / 2;
1740: }
1741: }
1742: ./ ENDUP
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.