./ ADD NAME=libF77/README TIME=627343162 If your system lacks onexit() and you are not using an ANSI C compiler, then you should compile main.c with NO_ONEXIT defined. See the comments about onexit in the makefile. If your system lacks a _cleanup routine (which is called just before abort(), e.g. to flush buffers), just add a dummy, i.e., _cleanup() {} to libF77. ./ ADD NAME=libF77/makefile TIME=627748011 .SUFFIXES: .c .o # compile, then strip unnecessary symbols .c.o: cc -O -c $*.c ld -r -x $*.o mv a.out $*.o MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\ signal_.o s_stop.o s_paus.o system_.o cabs.o\ derf_.o derfc_.o erf_.o erfc_.o 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 CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ d_sqrt.o d_tan.o d_tanh.o 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 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 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 EFL = ef1asc_.o ef1cmc_.o CHAR = s_cat.o s_cmp.o s_copy.o libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ $(HALF) $(CMP) $(EFL) $(CHAR) ar r libF77.a $? ranlib libF77.a Version.o: Version.c cc -c Version.c # If your system lacks onexit() and you are not using an # ANSI C compiler, then you should uncomment the following # two lines (for compiling main.o): #main.o: main.c # cc -c -DNO_ONEXIT main.c # On at least some Sun systems, it is more appropriate to # uncomment the following two lines: #main.o: main.c # cc -c -Donexit=on_exit main.c install: libF77.a mv libF77.a /usr/lib clean: rm -f libF77.a *.o ./ ADD NAME=libF77/Version.c TIME=628430639 static char junk[] = "\n@(#)LIBF77 VERSION 2.01 30 Nov. 1989\n"; /* 2.00 11 June 1980. File version.c added to library. 2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed [ d]erf[c ] added 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c 29 Nov. 1989: s_cmp returns long (for f2c). 30 Nov. 1989: arg types from argtypes.h */ ./ ADD NAME=libF77/abort_.c TIME=628474861 #include "stdio.h" #include "f2c.h" extern VOID abort(); VOID abort_() { fprintf(stderr, "Fortran abort routine called\n"); _cleanup(); abort(); } ./ ADD NAME=libF77/c_abs.c TIME=628437500 #include "f2c.h" double c_abs(z) complex *z; { double cabs(); return( cabs( z->r, z->i ) ); } ./ ADD NAME=libF77/c_cos.c TIME=628437500 #include "f2c.h" VOID c_cos(r, z) complex *r, *z; { double sin(), cos(), sinh(), cosh(); r->r = cos(z->r) * cosh(z->i); r->i = - sin(z->r) * sinh(z->i); } ./ ADD NAME=libF77/c_div.c TIME=628437671 #include "f2c.h" VOID c_div(c, a, b) complex *a, *b, *c; { double ratio, den; double abr, abi; if( (abr = b->r) < 0.) abr = - abr; if( (abi = b->i) < 0.) abi = - abi; if( abr <= abi ) { if(abi == 0) abort(); /* fatal("complex division by zero"); */ ratio = b->r / b->i ; den = b->i * (1 + ratio*ratio); c->r = (a->r*ratio + a->i) / den; c->i = (a->i*ratio - a->r) / den; } else { ratio = b->i / b->r ; den = b->r * (1 + ratio*ratio); c->r = (a->r + a->i*ratio) / den; c->i = (a->i - a->r*ratio) / den; } } ./ ADD NAME=libF77/c_exp.c TIME=628437500 #include "f2c.h" VOID c_exp(r, z) complex *r, *z; { double expx; double exp(), cos(), sin(); expx = exp(z->r); r->r = expx * cos(z->i); r->i = expx * sin(z->i); } ./ ADD NAME=libF77/c_log.c TIME=628437500 #include "f2c.h" VOID c_log(r, z) complex *r, *z; { double log(), cabs(), atan2(); r->i = atan2(z->i, z->r); r->r = log( cabs(z->r, z->i) ); } ./ ADD NAME=libF77/c_sin.c TIME=628437501 #include "f2c.h" VOID c_sin(r, z) complex *r, *z; { double sin(), cos(), sinh(), cosh(); r->r = sin(z->r) * cosh(z->i); r->i = cos(z->r) * sinh(z->i); } ./ ADD NAME=libF77/c_sqrt.c TIME=628437501 #include "f2c.h" VOID c_sqrt(r, z) complex *r, *z; { double mag, sqrt(), cabs(); if( (mag = cabs(z->r, z->i)) == 0.) r->r = r->i = 0.; else if(z->r > 0) { r->r = sqrt(0.5 * (mag + z->r) ); r->i = z->i / r->r / 2; } else { r->i = sqrt(0.5 * (mag - z->r) ); if(z->i < 0) r->i = - r->i; r->r = z->i / r->i /2; } } ./ ADD NAME=libF77/cabs.c TIME=379733534 double cabs(real, imag) double real, imag; { double temp, sqrt(); if(real < 0) real = -real; if(imag < 0) imag = -imag; if(imag > real){ temp = real; real = imag; imag = temp; } if((real+imag) == real) return(real); temp = imag/real; temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ return(temp); } ./ ADD NAME=libF77/argtypes.h TIME=628436547 typedef long integer; typedef short shortint; typedef double doublereal; typedef float real; typedef struct { float real, imag; } complex; typedef struct { double dreal, dimag; } dcomplex; typedef void VOID; /* VOID can be int on systems that do not recognize void */ ./ ADD NAME=libF77/d_abs.c TIME=628437501 #include "f2c.h" double d_abs(x) doublereal *x; { if(*x >= 0) return(*x); return(- *x); } ./ ADD NAME=libF77/d_acos.c TIME=628437502 #include "f2c.h" double d_acos(x) doublereal *x; { double acos(); return( acos(*x) ); } ./ ADD NAME=libF77/d_asin.c TIME=628437502 #include "f2c.h" double d_asin(x) doublereal *x; { double asin(); return( asin(*x) ); } ./ ADD NAME=libF77/d_atan.c TIME=628437502 #include "f2c.h" double d_atan(x) doublereal *x; { double atan(); return( atan(*x) ); } ./ ADD NAME=libF77/d_atn2.c TIME=628437502 #include "f2c.h" double d_atn2(x,y) doublereal *x, *y; { double atan2(); return( atan2(*x,*y) ); } ./ ADD NAME=libF77/d_cnjg.c TIME=628437502 #include "f2c.h" d_cnjg(r, z) doublecomplex *r, *z; { r->r = z->r; r->i = - z->i; } ./ ADD NAME=libF77/d_cos.c TIME=628437502 #include "f2c.h" double d_cos(x) doublereal *x; { double cos(); return( cos(*x) ); } ./ ADD NAME=libF77/d_cosh.c TIME=628437503 #include "f2c.h" double d_cosh(x) doublereal *x; { double cosh(); return( cosh(*x) ); } ./ ADD NAME=libF77/d_dim.c TIME=628437503 #include "f2c.h" double d_dim(a,b) doublereal *a, *b; { return( *a > *b ? *a - *b : 0); } ./ ADD NAME=libF77/d_exp.c TIME=628437503 #include "f2c.h" double d_exp(x) doublereal *x; { double exp(); return( exp(*x) ); } ./ ADD NAME=libF77/d_imag.c TIME=628437503 #include "f2c.h" double d_imag(z) doublecomplex *z; { return(z->i); } ./ ADD NAME=libF77/d_int.c TIME=628437503 #include "f2c.h" double d_int(x) doublereal *x; { double floor(); return( (*x>0) ? floor(*x) : -floor(- *x) ); } ./ ADD NAME=libF77/d_lg10.c TIME=628437503 #include "f2c.h" #define log10e 0.43429448190325182765 double d_lg10(x) doublereal *x; { double log(); return( log10e * log(*x) ); } ./ ADD NAME=libF77/d_log.c TIME=628437503 #include "f2c.h" double d_log(x) doublereal *x; { double log(); return( log(*x) ); } ./ ADD NAME=libF77/d_mod.c TIME=628437503 #include "f2c.h" double d_mod(x,y) doublereal *x, *y; { double floor(), quotient; if( (quotient = *x / *y) >= 0) quotient = floor(quotient); else quotient = -floor(-quotient); return(*x - (*y) * quotient ); } ./ ADD NAME=libF77/d_nint.c TIME=628437504 #include "f2c.h" double d_nint(x) doublereal *x; { double floor(); return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } ./ ADD NAME=libF77/d_prod.c TIME=628437504 #include "f2c.h" double d_prod(x,y) real *x, *y; { return( (*x) * (*y) ); } ./ ADD NAME=libF77/d_sign.c TIME=628437504 #include "f2c.h" double d_sign(a,b) doublereal *a, *b; { double x; x = (*a >= 0 ? *a : - *a); return( *b >= 0 ? x : -x); } ./ ADD NAME=libF77/d_sin.c TIME=628437504 #include "f2c.h" double d_sin(x) doublereal *x; { double sin(); return( sin(*x) ); } ./ ADD NAME=libF77/d_sinh.c TIME=628437504 #include "f2c.h" double d_sinh(x) doublereal *x; { double sinh(); return( sinh(*x) ); } ./ ADD NAME=libF77/d_sqrt.c TIME=628437504 #include "f2c.h" double d_sqrt(x) doublereal *x; { double sqrt(); return( sqrt(*x) ); } ./ ADD NAME=libF77/d_tan.c TIME=628437504 #include "f2c.h" double d_tan(x) doublereal *x; { double tan(); return( tan(*x) ); } ./ ADD NAME=libF77/d_tanh.c TIME=628437504 #include "f2c.h" double d_tanh(x) doublereal *x; { double tanh(); return( tanh(*x) ); } ./ ADD NAME=libF77/derf_.c TIME=628437505 #include "f2c.h" double derf_(x) doublereal *x; { double erf(); return( erf(*x) ); } ./ ADD NAME=libF77/derfc_.c TIME=628437505 #include "f2c.h" double derfc_(x) doublereal *x; { double erfc(); return( erfc(*x) ); } ./ ADD NAME=libF77/ef1asc_.c TIME=628437505 /* EFL support routine to copy string b to string a */ #include "f2c.h" extern VOID s_copy(); #define M ( (long) (sizeof(long) - 1) ) #define EVEN(x) ( ( (x)+ M) & (~M) ) VOID ef1asc_(a, la, b, lb) int *a, *b; long int *la, *lb; { s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); } ./ ADD NAME=libF77/ef1cmc_.c TIME=628437505 /* EFL support routine to compare two character strings */ #include "f2c.h" extern integer s_cmp(); integer ef1cmc_(a, la, b, lb) integer *a, *b; integer *la, *lb; { return( s_cmp( (char *)a, (char *)b, *la, *lb) ); } ./ ADD NAME=libF77/erf_.c TIME=628437505 #include "f2c.h" double erf_(x) real *x; { double erf(); return( erf(*x) ); } ./ ADD NAME=libF77/erfc_.c TIME=628437505 #include "f2c.h" double erfc_(x) real *x; { double erfc(); return( erfc(*x) ); } ./ ADD NAME=libF77/getarg_.c TIME=628437505 #include "f2c.h" /* * subroutine getarg(k, c) * returns the kth unix command argument in fortran character * variable argument c */ VOID getarg_(n, s, ls) long int *n; register char *s; long int ls; { extern int xargc; extern char **xargv; register char *t; register int i; if(*n>=0 && *n<xargc) t = xargv[*n]; else t = ""; for(i = 0; i<ls && *t!='\0' ; ++i) *s++ = *t++; for( ; i<ls ; ++i) *s++ = ' '; } ./ ADD NAME=libF77/getenv_.c TIME=628437505 #include "f2c.h" /* * getenv - f77 subroutine to return environment variables * * called by: * call getenv (ENV_NAME, char_var) * where: * ENV_NAME is the name of an environment variable * char_var is a character variable which will receive * the current value of ENV_NAME, or all blanks * if ENV_NAME is not defined */ VOID getenv_(fname, value, flen, vlen) char *value, *fname; long int vlen, flen; { extern char **environ; register char *ep, *fp, *flast; register char **env = environ; flast = fname + flen; for(fp = fname ; fp < flast ; ++fp) if(*fp == ' ') { flast = fp; break; } while (ep = *env++) { for(fp = fname; fp<flast ; ) if(*fp++ != *ep++) goto endloop; if(*ep++ == '=') /* copy right hand side */ while( *ep && --vlen>=0 ) *value++ = *ep++; goto blank; endloop: ; } blank: while( --vlen >= 0 ) *value++ = ' '; } ./ ADD NAME=libF77/h_abs.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_abs(x) shortint *x; { if(*x >= 0) return(*x); return(- *x); } ./ ADD NAME=libF77/h_dim.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_dim(a,b) shortint *a, *b; { return( *a > *b ? *a - *b : 0); } ./ ADD NAME=libF77/h_dnnt.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_dnnt(x) doublereal *x; { double floor(); return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } ./ ADD NAME=libF77/h_indx.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_indx(a, b, la, lb) char *a, *b; long int la, lb; { int i, n; char *s, *t, *bend; n = la - lb + 1; bend = b + lb; for(i = 0 ; i < n ; ++i) { s = a + i; t = b; while(t < bend) if(*s++ != *t++) goto no; return(i+1); no: ; } return(0); } ./ ADD NAME=libF77/h_len.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_len(s, n) char *s; long int n; { return(n); } ./ ADD NAME=libF77/h_mod.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_mod(a,b) short *a, *b; { return( *a % *b); } ./ ADD NAME=libF77/h_nint.c TIME=628437506 #include "f2c.h" extern integer s_cmp(); shortint h_nint(x) real *x; { double floor(); return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } ./ ADD NAME=libF77/h_sign.c TIME=628437507 #include "f2c.h" extern integer s_cmp(); shortint h_sign(a,b) shortint *a, *b; { shortint x; x = (*a >= 0 ? *a : - *a); return( *b >= 0 ? x : -x); } ./ ADD NAME=libF77/hl_ge.c TIME=628437507 #include "f2c.h" extern integer s_cmp(); shortint hl_ge(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) >= 0); } ./ ADD NAME=libF77/hl_gt.c TIME=628437507 #include "f2c.h" extern integer s_cmp(); shortint hl_gt(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) > 0); } ./ ADD NAME=libF77/hl_le.c TIME=628437507 #include "f2c.h" extern integer s_cmp(); shortint hl_le(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) <= 0); } ./ ADD NAME=libF77/hl_lt.c TIME=628437507 #include "f2c.h" extern integer s_cmp(); shortint hl_lt(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) < 0); } ./ ADD NAME=libF77/i_abs.c TIME=628437507 #include "f2c.h" integer i_abs(x) integer *x; { if(*x >= 0) return(*x); return(- *x); } ./ ADD NAME=libF77/i_dim.c TIME=628437507 #include "f2c.h" integer i_dim(a,b) integer *a, *b; { return( *a > *b ? *a - *b : 0); } ./ ADD NAME=libF77/i_dnnt.c TIME=628437507 #include "f2c.h" integer i_dnnt(x) doublereal *x; { double floor(); return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } ./ ADD NAME=libF77/i_indx.c TIME=628437507 #include "f2c.h" integer i_indx(a, b, la, lb) char *a, *b; long int la, lb; { long int i, n; char *s, *t, *bend; n = la - lb + 1; bend = b + lb; for(i = 0 ; i < n ; ++i) { s = a + i; t = b; while(t < bend) if(*s++ != *t++) goto no; return(i+1); no: ; } return(0); } ./ ADD NAME=libF77/i_len.c TIME=628437508 #include "f2c.h" integer i_len(s, n) char *s; long int n; { return(n); } ./ ADD NAME=libF77/i_mod.c TIME=628437508 #include "f2c.h" integer i_mod(a,b) integer *a, *b; { return( *a % *b); } ./ ADD NAME=libF77/i_nint.c TIME=628437508 #include "f2c.h" integer i_nint(x) real *x; { double floor(); return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } ./ ADD NAME=libF77/i_sign.c TIME=628437508 #include "f2c.h" integer i_sign(a,b) integer *a, *b; { integer x; x = (*a >= 0 ? *a : - *a); return( *b >= 0 ? x : -x); } ./ ADD NAME=libF77/iargc_.c TIME=628437508 #include "f2c.h" integer iargc_() { extern int xargc; return ( xargc - 1 ); } ./ ADD NAME=libF77/l_ge.c TIME=628437508 #include "f2c.h" extern integer s_cmp(); integer l_ge(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) >= 0); } ./ ADD NAME=libF77/l_gt.c TIME=628437508 #include "f2c.h" extern integer s_cmp(); integer l_gt(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) > 0); } ./ ADD NAME=libF77/l_le.c TIME=628437508 #include "f2c.h" extern integer s_cmp(); integer l_le(a,b,la,lb) char *a, *b; long int la, lb; { return(s_cmp(a,b,la,lb) <= 0); } ./ ADD NAME=libF77/l_lt.c TIME=628437509 #include "f2c.h" integer l_lt(a,b,la,lb) char *a, *b; long la, lb; { return(s_cmp(a,b,la,lb) < 0); } ./ ADD NAME=libF77/main.c TIME=628524317 /* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ #include "stdio.h" #include "signal.h" #ifndef SIGIOT #define SIGIOT SIGABRT #endif #ifdef NO__STDC #define ONEXIT onexit extern void f_exit(); #else #ifdef __STDC__ #include "stdlib.h" extern void f_exit(void); #ifndef NO_ONEXIT #define ONEXIT atexit extern int atexit(void (*)(void)); #endif #else #ifndef NO_ONEXIT #define ONEXIT onexit extern void f_exit(); #endif #endif #endif static void sigdie(s, kill) register char *s; int kill; { /* print error message, then clear buffers */ fflush(stderr); fprintf(stderr, "%s\n", s); f_exit(); fflush(stderr); if(kill) { /* now get a core */ signal(SIGIOT, 0); abort(); } else exit(1); } static void sigfdie(n) { sigdie("Floating Exception", 1); } static void sigidie(n) { sigdie("IOT Trap", 1); } static void sigqdie(n) { sigdie("Quit signal", 1); } static void sigindie(n) { sigdie("Interrupt", 0); } static void sigtdie(n) { sigdie("Killed", 0); } int xargc; char **xargv; main(argc, argv) int argc; char **argv; { xargc = argc; xargv = argv; signal(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ signal(SIGIOT, sigidie); #ifdef SIGQUIT if( (int)signal(SIGQUIT,sigqdie) & 01) signal(SIGQUIT, SIG_IGN); #endif if( (int)signal(SIGINT, sigindie) & 01) signal(SIGINT, SIG_IGN); signal(SIGTERM,sigtdie); #ifdef pdp11 ldfps(01200); /* detect overflow as an exception */ #endif f_init(); #ifndef NO_ONEXIT ONEXIT(f_exit); #endif MAIN__(); #ifdef NO_ONEXIT f_exit(); #endif } ./ ADD NAME=libF77/pow_ci.c TIME=628438069 #include "f2c.h" VOID pow_ci(p, a, b) /* p = a**b */ complex *p, *a; integer *b; { doublecomplex p1, a1; a1.r = a->r; a1.i = a->i; pow_zi(&p1, &a1, b); p->r = p1.r; p->i = p1.i; } ./ ADD NAME=libF77/pow_dd.c TIME=628437509 #include "f2c.h" double pow_dd(ap, bp) doublereal *ap, *bp; { double pow(); return(pow(*ap, *bp) ); } ./ ADD NAME=libF77/pow_di.c TIME=628437509 #include "f2c.h" double pow_di(ap, bp) doublereal *ap; integer *bp; { double pow, x; integer n; pow = 1; x = *ap; n = *bp; if(n != 0) { if(n < 0) { if(x == 0) { return(pow); } n = -n; x = 1/x; } for( ; ; ) { if(n & 01) pow *= x; if(n >>= 1) x *= x; else break; } } return(pow); } ./ ADD NAME=libF77/pow_hh.c TIME=628437509 #include "f2c.h" shortint pow_hh(ap, bp) shortint *ap, *bp; { shortint pow, x, n; pow = 1; x = *ap; n = *bp; if(n < 0) { } else if(n > 0) for( ; ; ) { if(n & 01) pow *= x; if(n >>= 1) x *= x; else break; } return(pow); } ./ ADD NAME=libF77/pow_ii.c TIME=628437509 #include "f2c.h" integer pow_ii(ap, bp) integer *ap, *bp; { integer pow, x, n; pow = 1; x = *ap; n = *bp; if(n < 0) { } else if(n > 0) for( ; ; ) { if(n & 01) pow *= x; if(n >>= 1) x *= x; else break; } return(pow); } ./ ADD NAME=libF77/pow_ri.c TIME=628437509 #include "f2c.h" double pow_ri(ap, bp) real *ap; integer *bp; { double pow, x; integer n; pow = 1; x = *ap; n = *bp; if(n != 0) { if(n < 0) { if(x == 0) { return(pow); } n = -n; x = 1/x; } for( ; ; ) { if(n & 01) pow *= x; if(n >>= 1) x *= x; else break; } } return(pow); } ./ ADD NAME=libF77/pow_zi.c TIME=628438134 #include "f2c.h" VOID pow_zi(p, a, b) /* p = a**b */ doublecomplex *p, *a; integer *b; { integer n; double t; doublecomplex x; static doublecomplex one = {1.0, 0.0}; n = *b; p->r = 1; p->i = 0; if(n == 0) return; if(n < 0) { n = -n; z_div(&x, &one, a); } else { x.r = a->r; x.i = a->i; } for( ; ; ) { if(n & 01) { t = p->r * x.r - p->i * x.i; p->i = p->r * x.i + p->i * x.r; p->r = t; } if(n >>= 1) { t = x.r * x.r - x.i * x.i; x.i = 2 * x.r * x.i; x.r = t; } else break; } } ./ ADD NAME=libF77/pow_zz.c TIME=628437510 #include "f2c.h" VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; { double logr, logi, x, y; double log(), exp(), cos(), sin(), atan2(), cabs(); logr = log( cabs(a->r, a->i) ); logi = atan2(a->i, a->r); x = exp( logr * b->r - logi * b->i ); y = logr * b->i + logi * b->r; r->r = x * cos(y); r->i = x * sin(y); } ./ ADD NAME=libF77/r_abs.c TIME=628437510 #include "f2c.h" double r_abs(x) real *x; { if(*x >= 0) return(*x); return(- *x); } ./ ADD NAME=libF77/r_acos.c TIME=628437510 #include "f2c.h" double r_acos(x) real *x; { double acos(); return( acos(*x) ); } ./ ADD NAME=libF77/r_asin.c TIME=628437510 #include "f2c.h" double r_asin(x) real *x; { double asin(); return( asin(*x) ); } ./ ADD NAME=libF77/r_atan.c TIME=628437510 #include "f2c.h" double r_atan(x) real *x; { double atan(); return( atan(*x) ); } ./ ADD NAME=libF77/r_atn2.c TIME=628437510 #include "f2c.h" double r_atn2(x,y) real *x, *y; { double atan2(); return( atan2(*x,*y) ); } ./ ADD NAME=libF77/r_cnjg.c TIME=628437511 #include "f2c.h" VOID r_cnjg(r, z) complex *r, *z; { r->r = z->r; r->i = - z->i; } ./ ADD NAME=libF77/r_cos.c TIME=628437511 #include "f2c.h" double r_cos(x) real *x; { double cos(); return( cos(*x) ); } ./ ADD NAME=libF77/r_cosh.c TIME=628437511 #include "f2c.h" double r_cosh(x) real *x; { double cosh(); return( cosh(*x) ); } ./ ADD NAME=libF77/r_dim.c TIME=628437511 #include "f2c.h" double r_dim(a,b) real *a, *b; { return( *a > *b ? *a - *b : 0); } ./ ADD NAME=libF77/r_exp.c TIME=628437511 #include "f2c.h" double r_exp(x) real *x; { double exp(); return( exp(*x) ); } ./ ADD NAME=libF77/r_imag.c TIME=628437511 #include "f2c.h" double r_imag(z) complex *z; { return(z->i); } ./ ADD NAME=libF77/r_int.c TIME=628437511 #include "f2c.h" double r_int(x) real *x; { double floor(); return( (*x>0) ? floor(*x) : -floor(- *x) ); } ./ ADD NAME=libF77/r_lg10.c TIME=628437511 #include "f2c.h" #define log10e 0.43429448190325182765 double r_lg10(x) real *x; { double log(); return( log10e * log(*x) ); } ./ ADD NAME=libF77/r_log.c TIME=628437511 #include "f2c.h" double r_log(x) real *x; { double log(); return( log(*x) ); } ./ ADD NAME=libF77/r_mod.c TIME=628437512 #include "f2c.h" double r_mod(x,y) real *x, *y; { double floor(), quotient; if( (quotient = *x / *y) >= 0) quotient = floor(quotient); else quotient = -floor(-quotient); return(*x - (*y) * quotient ); } ./ ADD NAME=libF77/r_nint.c TIME=628437512 #include "f2c.h" double r_nint(x) real *x; { double floor(); return( (*x)>=0 ? floor(*x + .5) : -floor(.5 - *x) ); } ./ ADD NAME=libF77/r_sign.c TIME=628437512 #include "f2c.h" double r_sign(a,b) real *a, *b; { double x; x = (*a >= 0 ? *a : - *a); return( *b >= 0 ? x : -x); } ./ ADD NAME=libF77/r_sin.c TIME=628437512 #include "f2c.h" double r_sin(x) real *x; { double sin(); return( sin(*x) ); } ./ ADD NAME=libF77/r_sinh.c TIME=628437512 #include "f2c.h" double r_sinh(x) real *x; { double sinh(); return( sinh(*x) ); } ./ ADD NAME=libF77/r_sqrt.c TIME=628437512 #include "f2c.h" double r_sqrt(x) real *x; { double sqrt(); return( sqrt(*x) ); } ./ ADD NAME=libF77/r_tan.c TIME=628437512 #include "f2c.h" double r_tan(x) real *x; { double tan(); return( tan(*x) ); } ./ ADD NAME=libF77/r_tanh.c TIME=628437512 #include "f2c.h" double r_tanh(x) real *x; { double tanh(); return( tanh(*x) ); } ./ ADD NAME=libF77/s_cat.c TIME=628437513 #include "f2c.h" VOID s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; #ifdef f2c_i2 short int rnp[], *np, ll; #else long int rnp[], *np, ll; #endif { int i, n, nc; char *rp; n = *np; for(i = 0 ; i < n ; ++i) { nc = ll; if(rnp[i] < nc) nc = rnp[i]; ll -= nc; rp = rpp[i]; while(--nc >= 0) *lp++ = *rp++; } while(--ll >= 0) *lp++ = ' '; } ./ ADD NAME=libF77/s_cmp.c TIME=628437513 #include "f2c.h" integer s_cmp(a, b, la, lb) /* compare two strings */ register char *a, *b; long int la, lb; { register char *aend, *bend; aend = a + la; bend = b + lb; if(la <= lb) { while(a < aend) if(*a != *b) return( *a - *b ); else { ++a; ++b; } while(b < bend) if(*b != ' ') return( ' ' - *b ); else ++b; } else { while(b < bend) if(*a == *b) { ++a; ++b; } else return( *a - *b ); while(a < aend) if(*a != ' ') return(*a - ' '); else ++a; } return(0); } ./ ADD NAME=libF77/s_copy.c TIME=628437513 #include "f2c.h" VOID s_copy(a, b, la, lb) /* assign strings: a = b */ char *a, *b; long int la, lb; { char *aend, *bend; aend = a + la; if(la <= lb) while(a < aend) *a++ = *b++; else { bend = b + lb; while(b < bend) *a++ = *b++; while(a < aend) *a++ = ' '; } } ./ ADD NAME=libF77/s_paus.c TIME=628474922 #include "stdio.h" #include "f2c.h" #define PAUSESIG 15 static waitpause() { return; } VOID s_paus(s, n) char *s; long int n; { int i; fprintf(stderr, "PAUSE "); if(n > 0) for(i = 0; i<n ; ++i) putc(*s++, stderr); fprintf(stderr, " statement executed\n"); if( isatty(fileno(stdin)) ) { fprintf(stderr, "To resume execution, type go. Any other input will terminate job.\n"); fflush(stderr); if( getchar()!='g' || getchar()!='o' || getchar()!='\n' ) { fprintf(stderr, "STOP\n"); f_exit(); exit(0); } } else { fprintf(stderr, "To resume execution, execute a kill -%d %d command\n", PAUSESIG, getpid() ); signal(PAUSESIG, waitpause); fflush(stderr); pause(); } fprintf(stderr, "Execution resumes after PAUSE.\n"); } ./ ADD NAME=libF77/s_rnge.c TIME=626022810 #include <stdio.h> /* called when a subscript is out of range */ s_rnge(varn, offset, procn, line) char *varn, *procn; long int offset; int line; { register int i; fprintf(stderr, "Subscript out of range on file line %d, procedure ", line); for(i = 0 ; i < 8 && *procn!='_' ; ++i) putc(*procn++, stderr); fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1); for(i = 0 ; i < 8 && *varn!=' ' ; ++i) putc(*varn++, stderr); fprintf(stderr, ".\n"); _cleanup(); abort(); } ./ ADD NAME=libF77/s_stop.c TIME=628474936 #include "stdio.h" #include "f2c.h" VOID s_stop(s, n) char *s; long int n; { int i; if(n > 0) { fprintf(stderr, "STOP "); for(i = 0; i<n ; ++i) putc(*s++, stderr); fprintf(stderr, " statement executed\n"); } f_exit(); exit(0); } ./ ADD NAME=libF77/signal_.c TIME=628437513 #include "f2c.h" typedef int (*sig_type)(); extern sig_type signal(); integer signal_(sigp, procp) integer *sigp, *procp; { int sig; sig_type proc; sig = *sigp; proc = *(sig_type *)procp; return (integer)signal(sig, proc); } ./ ADD NAME=libF77/system_.c TIME=628437513 /* f77 interface to system routine */ #include "f2c.h" system_(s, n) register char *s; long int n; { char buff[1000]; register char *bp, *blast; blast = buff + (n < 1000 ? n : 1000); for(bp = buff ; bp<blast && *s!='\0' ; ) *bp++ = *s++; *bp = '\0'; system(buff); } ./ ADD NAME=libF77/z_abs.c TIME=628438260 #include "f2c.h" double z_abs(z) doublecomplex *z; { double cabs(); return( cabs( z->r, z->i ) ); } ./ ADD NAME=libF77/z_cos.c TIME=628437514 #include "f2c.h" VOID z_cos(r, z) doublecomplex *r, *z; { double sin(), cos(), sinh(), cosh(); r->r = cos(z->r) * cosh(z->i); r->i = - sin(z->r) * sinh(z->i); } ./ ADD NAME=libF77/z_div.c TIME=628437514 #include "f2c.h" VOID z_div(c, a, b) doublecomplex *a, *b, *c; { double ratio, den; double abr, abi; if( (abr = b->r) < 0.) abr = - abr; if( (abi = b->i) < 0.) abi = - abi; if( abr <= abi ) { if(abi == 0) abort(); /* fatal("complex division by zero"); */ ratio = b->r / b->i ; den = b->i * (1 + ratio*ratio); c->r = (a->r*ratio + a->i) / den; c->i = (a->i*ratio - a->r) / den; } else { ratio = b->i / b->r ; den = b->r * (1 + ratio*ratio); c->r = (a->r + a->i*ratio) / den; c->i = (a->i - a->r*ratio) / den; } } ./ ADD NAME=libF77/z_exp.c TIME=628437514 #include "f2c.h" VOID z_exp(r, z) doublecomplex *r, *z; { double expx; double exp(), cos(), sin(); expx = exp(z->r); r->r = expx * cos(z->i); r->i = expx * sin(z->i); } ./ ADD NAME=libF77/z_log.c TIME=628437514 #include "f2c.h" VOID z_log(r, z) doublecomplex *r, *z; { double log(), cabs(), atan2(); r->i = atan2(z->i, z->r); r->r = log( cabs( z->r, z->i ) ); } ./ ADD NAME=libF77/z_sin.c TIME=628437514 #include "f2c.h" VOID z_sin(r, z) doublecomplex *r, *z; { double sin(), cos(), sinh(), cosh(); r->r = sin(z->r) * cosh(z->i); r->i = cos(z->r) * sinh(z->i); } ./ ADD NAME=libF77/z_sqrt.c TIME=628437514 #include "f2c.h" VOID z_sqrt(r, z) doublecomplex *r, *z; { double mag, sqrt(), cabs(); if( (mag = cabs(z->r, z->i)) == 0.) r->r = r->i = 0.; else if(z->r > 0) { r->r = sqrt(0.5 * (mag + z->r) ); r->i = z->i / r->r / 2; } else { r->i = sqrt(0.5 * (mag - z->r) ); if(z->i < 0) z->i = - z->i; r->r = z->i / r->i / 2; } } ./ ENDUP