diff options
Diffstat (limited to 'media/sphinxbase/src/libsphinxbase/util/f2c_lite.c')
| -rw-r--r-- | media/sphinxbase/src/libsphinxbase/util/f2c_lite.c | 551 |
1 files changed, 551 insertions, 0 deletions
diff --git a/media/sphinxbase/src/libsphinxbase/util/f2c_lite.c b/media/sphinxbase/src/libsphinxbase/util/f2c_lite.c new file mode 100644 index 000000000..58fbc4ee6 --- /dev/null +++ b/media/sphinxbase/src/libsphinxbase/util/f2c_lite.c @@ -0,0 +1,551 @@ +#include <math.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <assert.h> + +#include "sphinxbase/f2c.h" + +#ifdef _MSC_VER +#pragma warning (disable: 4244) +#endif + + +extern void +s_wsfe(cilist * f) +{; +} +extern void +e_wsfe(void) +{; +} +extern void +do_fio(integer * c, char *s, ftnlen l) +{; +} + +/* You'll want this if you redo the *_lite.c files with the -C option + * to f2c for checking array subscripts. (It's not suggested you do that + * for production use, of course.) */ +extern int +s_rnge(char *var, int index, char *routine, int lineno) +{ + fprintf(stderr, + "array index out-of-bounds for %s[%d] in routine %s:%d\n", var, + index, routine, lineno); + fflush(stderr); + assert(2+2 == 5); + return 0; +} + + +#ifdef KR_headers +extern double sqrt(); +float +f__cabs(real, imag) +float real, imag; +#else +#undef abs + +float +f__cabs(float real, float imag) +#endif +{ + float temp; + + if (real < 0) + real = -real; + if (imag < 0) + imag = -imag; + if (imag > real) { + temp = real; + real = imag; + imag = temp; + } + if ((imag + real) == real) + return ((float) real); + + temp = imag / real; + temp = real * sqrt(1.0 + temp * temp); /*overflow!! */ + return (temp); +} + + +VOID +#ifdef KR_headers +s_cnjg(r, z) +complex *r, *z; +#else +s_cnjg(complex * r, complex * z) +#endif +{ + r->r = z->r; + r->i = -z->i; +} + + +#ifdef KR_headers +float +r_imag(z) +complex *z; +#else +float +r_imag(complex * z) +#endif +{ + return (z->i); +} + + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +float +r_lg10(x) +real *x; +#else +#undef abs + +float +r_lg10(real * x) +#endif +{ + return (log10e * log(*x)); +} + + +#ifdef KR_headers +float +r_sign(a, b) +real *a, *b; +#else +float +r_sign(real * a, real * b) +#endif +{ + float x; + x = (*a >= 0 ? *a : -*a); + return (*b >= 0 ? x : -x); +} + + +#ifdef KR_headers +double floor(); +integer +i_dnnt(x) +real *x; +#else +#undef abs + +integer +i_dnnt(real * x) +#endif +{ + return ((*x) >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} + + +#ifdef KR_headers +double pow(); +double +pow_dd(ap, bp) +doublereal *ap, *bp; +#else +#undef abs + +double +pow_dd(doublereal * ap, doublereal * bp) +#endif +{ + return (pow(*ap, *bp)); +} + + +#ifdef KR_headers +float +pow_ri(ap, bp) +real *ap; +integer *bp; +#else +float +pow_ri(real * ap, integer * bp) +#endif +{ + float pow, x; + integer n; + unsigned long u; + + pow = 1; + x = *ap; + n = *bp; + + if (n != 0) { + if (n < 0) { + n = -n; + x = 1 / x; + } + for (u = n;;) { + if (u & 01) + pow *= x; + if (u >>= 1) + x *= x; + else + break; + } + } + return (pow); +} + +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ +#define NO_OVERWRITE + + +#ifndef NO_OVERWRITE + +#undef abs +#ifdef KR_headers +extern char *F77_aloc(); +extern void free(); +extern void exit_(); +#else + +extern char *F77_aloc(ftnlen, char *); +#endif + +#endif /* NO_OVERWRITE */ + +VOID +#ifdef KR_headers +s_cat(lp, rpp, rnp, np, ll) +char *lp, *rpp[]; +ftnlen rnp[], *np, ll; +#else +s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen * np, ftnlen ll) +#endif +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; + + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while (i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + break; + } + lp1 = lp; +#endif /* NO_OVERWRITE */ + 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++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memmove(lp0, lp1, L); + free(lp1); + } +#endif +} + + +/* compare two strings */ + +#ifdef KR_headers +integer +s_cmp(a0, b0, la, lb) +char *a0, *b0; +ftnlen la, lb; +#else +integer +s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +#endif +{ + register unsigned char *a, *aend, *b, *bend; + a = (unsigned char *) a0; + b = (unsigned char *) b0; + 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); +} + +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + + + +/* assign strings: a = b */ + +#ifdef KR_headers +VOID +s_copy(a, b, la, lb) +register char *a, *b; +ftnlen la, lb; +#else +void +s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +#endif +{ + register char *aend, *bend; + + aend = a + la; + + if (la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while (a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for (b += la; a < aend;) + *--aend = *--b; +#endif + + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while (b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while (b < bend) + *--a = *--bend; + a += lb; + } +#endif + while (a < aend) + *a++ = ' '; + } +} + + +#ifdef KR_headers +float f__cabs(); +float +z_abs(z) +complex *z; +#else +float f__cabs(float, float); +float +z_abs(complex * z) +#endif +{ + return (f__cabs(z->r, z->i)); +} + + +#ifdef KR_headers +extern void sig_die(); +VOID +z_div(c, a, b) +complex *a, *b, *c; +#else +extern void sig_die(char *, int); +void +z_div(complex * c, complex * a, complex * b) +#endif +{ + float ratio, den; + float abr, abi; + + if ((abr = b->r) < 0.) + abr = -abr; + if ((abi = b->i) < 0.) + abi = -abi; + if (abr <= abi) { + /*Let IEEE Infinties handle this ;( */ + /*if(abi == 0) + sig_die("complex division by zero", 1); */ + 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; + } + +} + + +#ifdef KR_headers +double sqrt(); +double f__cabs(); +VOID +z_sqrt(r, z) +complex *r, *z; +#else +#undef abs + +extern float f__cabs(float, float); +void +z_sqrt(complex * r, complex * z) +#endif +{ + float mag; + + if ((mag = f__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; + } +} + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers + integer pow_ii(ap, bp) integer *ap, *bp; +#else + integer pow_ii(integer * ap, integer * bp) +#endif + { + integer pow, x, n; + unsigned long u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x != 0 ? 1 / x : 0; + n = -n; + } u = n; + for (pow = 1;;) { + if (u & 01) + pow *= x; + if (u >>= 1) + x *= x; + else + break; + } + return (pow); + } +#ifdef __cplusplus +} +#endif + +#ifdef KR_headers +extern void f_exit(); +VOID +s_stop(s, n) +char *s; +ftnlen n; +#else +#undef abs +#undef min +#undef max +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus + extern "C" { +#endif + void f_exit(void); + + int s_stop(char *s, ftnlen n) +#endif + { + int i; + + if (n > 0) { + fprintf(stderr, "STOP "); + for (i = 0; i < n; ++i) + putc(*s++, stderr); + fprintf(stderr, " statement executed\n"); + } +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(0); + +/* We cannot avoid (useless) compiler diagnostics here: */ +/* some compilers complain if there is no return statement, */ +/* and others complain that this one cannot be reached. */ + + return 0; /* NOT REACHED */ + } +#ifdef __cplusplus + } +#endif +#ifdef __cplusplus +} +#endif |