13 #include "sphinxbase/f2c.h"
16 #pragma warning (disable: 4244)
21 static integer c__1 = 1;
22 static real c_b32 = 0.f;
25 slamch_(
char *cmach, ftnlen cmach_len)
29 static logical first = TRUE_;
36 double pow_ri(real *, integer *);
41 static real rnd, eps, base;
43 static real emin, prec, emax;
44 static integer imin, imax;
46 static real rmin, rmax, rmach;
47 extern logical lsame_(
char *,
char *, ftnlen, ftnlen);
48 static real small, sfmin;
49 extern int slamc2_(integer *, integer *, logical *, real
50 *, integer *, real *, integer *,
114 slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
120 eps = pow_ri(&base, &i__1) / 2;
125 eps = pow_ri(&base, &i__1);
132 if (small >= sfmin) {
137 sfmin = small * (eps + 1.f);
141 if (lsame_(cmach,
"E", (ftnlen) 1, (ftnlen) 1)) {
144 else if (lsame_(cmach,
"S", (ftnlen) 1, (ftnlen) 1)) {
147 else if (lsame_(cmach,
"B", (ftnlen) 1, (ftnlen) 1)) {
150 else if (lsame_(cmach,
"P", (ftnlen) 1, (ftnlen) 1)) {
153 else if (lsame_(cmach,
"N", (ftnlen) 1, (ftnlen) 1)) {
156 else if (lsame_(cmach,
"R", (ftnlen) 1, (ftnlen) 1)) {
159 else if (lsame_(cmach,
"M", (ftnlen) 1, (ftnlen) 1)) {
162 else if (lsame_(cmach,
"U", (ftnlen) 1, (ftnlen) 1)) {
165 else if (lsame_(cmach,
"L", (ftnlen) 1, (ftnlen) 1)) {
168 else if (lsame_(cmach,
"O", (ftnlen) 1, (ftnlen) 1)) {
183 slamc1_(integer * beta, integer * t, logical * rnd, logical * ieee1)
187 static logical first = TRUE_;
193 static real a, b, c__, f, t1, t2;
195 static real one, qtr;
197 static integer lbeta;
199 static logical lieee1;
200 extern doublereal slamc3_(real *, real *);
284 c__ = slamc3_(&a, &one);
286 c__ = slamc3_(&c__, &r__1);
297 c__ = slamc3_(&a, &b);
303 c__ = slamc3_(&a, &b);
316 c__ = slamc3_(&c__, &r__1);
325 f = slamc3_(&r__1, &r__2);
326 c__ = slamc3_(&f, &a);
335 f = slamc3_(&r__1, &r__2);
336 c__ = slamc3_(&f, &a);
337 if (lrnd && c__ == a) {
348 t1 = slamc3_(&r__1, &a);
350 t2 = slamc3_(&r__1, &savec);
351 lieee1 = t1 == a && t2 > savec && lrnd;
369 c__ = slamc3_(&a, &one);
371 c__ = slamc3_(&c__, &r__1);
392 slamc2_(integer * beta, integer * t, logical * rnd, real *
393 eps, integer * emin, real * rmin, integer * emax, real * rmax)
397 static logical first = TRUE_;
398 static logical iwarn = FALSE_;
401 static char fmt_9999[] =
402 "(//\002 WARNING. The value EMIN may be incorre"
403 "ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"
404 "lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
405 " the IF block as marked within the code of routine\002,\002 SLAM"
406 "C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";
410 real r__1, r__2, r__3, r__4, r__5;
413 double pow_ri(real *, integer *);
414 integer s_wsfe(
cilist *), do_fio(integer *,
char *, ftnlen),
418 static real a, b, c__;
419 static integer i__, lt;
420 static real one, two;
424 static real leps, zero;
425 static integer lbeta;
427 static integer lemin, lemax, gnmin;
429 static integer gpmin;
430 static real third, lrmin, lrmax, sixth;
431 static logical lieee1;
432 extern int slamc1_(integer *, integer *, logical *,
434 extern doublereal slamc3_(real *, real *);
435 extern int slamc4_(integer *, real *, integer *),
436 slamc5_(integer *, integer *, integer *, logical *, integer *,
438 static integer ngnmin, ngpmin;
441 static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
534 slamc1_(&lbeta, <, &lrnd, &lieee1);
540 a = pow_ri(&b, &i__1);
548 sixth = slamc3_(&b, &r__1);
549 third = slamc3_(&sixth, &sixth);
551 b = slamc3_(&third, &r__1);
552 b = slamc3_(&b, &sixth);
562 if (leps > b && b > zero) {
566 r__3 = two, r__4 = r__3, r__3 *= r__3;
569 r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
570 c__ = slamc3_(&r__1, &r__2);
572 c__ = slamc3_(&half, &r__1);
573 b = slamc3_(&half, &c__);
575 c__ = slamc3_(&half, &r__1);
576 b = slamc3_(&half, &c__);
593 for (i__ = 1; i__ <= 3; ++i__) {
594 r__1 = small * rbase;
595 small = slamc3_(&r__1, &zero);
598 a = slamc3_(&one, &small);
599 slamc4_(&ngpmin, &one, &lbeta);
601 slamc4_(&ngnmin, &r__1, &lbeta);
602 slamc4_(&gpmin, &a, &lbeta);
604 slamc4_(&gnmin, &r__1, &lbeta);
607 if (ngpmin == ngnmin && gpmin == gnmin) {
608 if (ngpmin == gpmin) {
613 else if (gpmin - ngpmin == 3) {
614 lemin = ngpmin - 1 + lt;
620 lemin = min(ngpmin, gpmin);
626 else if (ngpmin == gpmin && ngnmin == gnmin) {
627 if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
628 lemin = max(ngpmin, ngnmin);
633 lemin = min(ngpmin, ngnmin);
639 else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1
641 if (gpmin - min(ngpmin, ngnmin) == 3) {
642 lemin = max(ngpmin, ngnmin) - 1 + lt;
647 lemin = min(ngpmin, ngnmin);
655 i__1 = min(ngpmin, ngnmin), i__1 = min(i__1, gpmin);
656 lemin = min(i__1, gnmin);
665 do_fio(&c__1, (
char *) &lemin, (ftnlen)
sizeof(integer));
675 ieee = ieee || lieee1;
683 for (i__ = 1; i__ <= i__1; ++i__) {
684 r__1 = lrmin * rbase;
685 lrmin = slamc3_(&r__1, &zero);
691 slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
714 slamc3_(real * a, real * b)
757 slamc4_(integer * emin, real * start, integer * base)
766 static real b1, b2, c1, c2, d1, d2, one, zero, rbase;
767 extern doublereal slamc3_(real *, real *);
811 b1 = slamc3_(&r__1, &zero);
819 if (c1 == a && c2 == a && d1 == a && d2 == a) {
823 b1 = slamc3_(&r__1, &zero);
825 c1 = slamc3_(&r__1, &zero);
828 for (i__ = 1; i__ <= i__1; ++i__) {
833 b2 = slamc3_(&r__1, &zero);
835 c2 = slamc3_(&r__1, &zero);
838 for (i__ = 1; i__ <= i__1; ++i__) {
856 slamc5_(integer * beta, integer * p, integer * emin,
857 logical * ieee, integer * emax, real * rmax)
866 static integer try__, lexp;
868 static integer uexp, nbits;
869 extern doublereal slamc3_(real *, real *);
871 static integer exbits, expsum;
936 if (try__ <= -(*emin)) {
941 if (lexp == -(*emin)) {
953 if (uexp + *emin > -lexp - *emin) {
963 *emax = expsum + *emin - 1;
964 nbits = exbits + 1 + *p;
969 if (nbits % 2 == 1 && *beta == 2) {
999 recbas = 1.f / *beta;
1003 for (i__ = 1; i__ <= i__1; ++i__) {
1008 y = slamc3_(&y, &z__);
1018 for (i__ = 1; i__ <= i__1; ++i__) {
1020 y = slamc3_(&r__1, &c_b32);