1 /* src/slamch.f -- translated by f2c (version 20050501).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
10 http://www.netlib.org/f2c/libf2c.zip
13 #include "sphinxbase/f2c.h"
16 #pragma warning (disable: 4244)
19 /* Table of constant values */
21 static integer c__1 = 1;
22 static real c_b32 = 0.f;
25 slamch_(char *cmach, ftnlen cmach_len)
27 /* Initialized data */
29 static logical first = TRUE_;
31 /* System generated locals */
35 /* Builtin functions */
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 /* Subroutine */ int slamc2_(integer *, integer *, logical *, real
50 *, integer *, real *, integer *,
54 /* -- LAPACK auxiliary routine (version 3.0) -- */
55 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
56 /* Courant Institute, Argonne National Lab, and Rice University */
57 /* October 31, 1992 */
59 /* .. Scalar Arguments .. */
65 /* SLAMCH determines single precision machine parameters. */
70 /* CMACH (input) CHARACTER*1 */
71 /* Specifies the value to be returned by SLAMCH: */
72 /* = 'E' or 'e', SLAMCH := eps */
73 /* = 'S' or 's , SLAMCH := sfmin */
74 /* = 'B' or 'b', SLAMCH := base */
75 /* = 'P' or 'p', SLAMCH := eps*base */
76 /* = 'N' or 'n', SLAMCH := t */
77 /* = 'R' or 'r', SLAMCH := rnd */
78 /* = 'M' or 'm', SLAMCH := emin */
79 /* = 'U' or 'u', SLAMCH := rmin */
80 /* = 'L' or 'l', SLAMCH := emax */
81 /* = 'O' or 'o', SLAMCH := rmax */
85 /* eps = relative machine precision */
86 /* sfmin = safe minimum, such that 1/sfmin does not overflow */
87 /* base = base of the machine */
89 /* t = number of (base) digits in the mantissa */
90 /* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */
91 /* emin = minimum exponent before (gradual) underflow */
92 /* rmin = underflow threshold - base**(emin-1) */
93 /* emax = largest exponent before overflow */
94 /* rmax = overflow threshold - (base**emax)*(1-eps) */
96 /* ===================================================================== */
98 /* .. Parameters .. */
100 /* .. Local Scalars .. */
102 /* .. External Functions .. */
104 /* .. External Subroutines .. */
106 /* .. Save statement .. */
108 /* .. Data statements .. */
110 /* .. Executable Statements .. */
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) {
134 /* Use SMALL plus a bit, to avoid the possibility of rounding */
135 /* causing overflow when computing 1/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)) {
180 /* *********************************************************************** */
183 slamc1_(integer * beta, integer * t, logical * rnd, logical * ieee1)
185 /* Initialized data */
187 static logical first = TRUE_;
189 /* System generated locals */
192 /* Local variables */
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 *);
203 /* -- LAPACK auxiliary routine (version 3.0) -- */
204 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
205 /* Courant Institute, Argonne National Lab, and Rice University */
206 /* October 31, 1992 */
208 /* .. Scalar Arguments .. */
214 /* SLAMC1 determines the machine parameters given by BETA, T, RND, and */
220 /* BETA (output) INTEGER */
221 /* The base of the machine. */
223 /* T (output) INTEGER */
224 /* The number of ( BETA ) digits in the mantissa. */
226 /* RND (output) LOGICAL */
227 /* Specifies whether proper rounding ( RND = .TRUE. ) or */
228 /* chopping ( RND = .FALSE. ) occurs in addition. This may not */
229 /* be a reliable guide to the way in which the machine performs */
230 /* its arithmetic. */
232 /* IEEE1 (output) LOGICAL */
233 /* Specifies whether rounding appears to be done in the IEEE */
234 /* 'round to nearest' style. */
236 /* Further Details */
237 /* =============== */
239 /* The routine is based on the routine ENVRON by Malcolm and */
240 /* incorporates suggestions by Gentleman and Marovich. See */
242 /* Malcolm M. A. (1972) Algorithms to reveal properties of */
243 /* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */
245 /* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */
246 /* that reveal properties of floating point arithmetic units. */
247 /* Comms. of the ACM, 17, 276-277. */
249 /* ===================================================================== */
251 /* .. Local Scalars .. */
253 /* .. External Functions .. */
255 /* .. Save statement .. */
257 /* .. Data statements .. */
259 /* .. Executable Statements .. */
265 /* LBETA, LIEEE1, LT and LRND are the local values of BETA, */
266 /* IEEE1, T and RND. */
268 /* Throughout this routine we use the function SLAMC3 to ensure */
269 /* that relevant values are stored and not held in registers, or */
270 /* are not affected by optimizers. */
272 /* Compute a = 2.0**m with the smallest positive integer m such */
275 /* fl( a + 1.0 ) = a. */
280 /* + WHILE( C.EQ.ONE )LOOP */
284 c__ = slamc3_(&a, &one);
286 c__ = slamc3_(&c__, &r__1);
291 /* Now compute b = 2.0**m with the smallest positive integer m */
294 /* fl( a + b ) .gt. a. */
297 c__ = slamc3_(&a, &b);
299 /* + WHILE( C.EQ.A )LOOP */
303 c__ = slamc3_(&a, &b);
308 /* Now compute the base. a and c are neighbouring floating point */
309 /* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */
310 /* their difference is beta. Adding 0.25 to c is to ensure that it */
311 /* is truncated to beta and not ( beta - 1 ). */
316 c__ = slamc3_(&c__, &r__1);
319 /* Now determine whether rounding or chopping occurs, by adding a */
320 /* bit less than beta/2 and a bit more than beta/2 to a. */
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) {
341 /* Try and decide whether rounding is done in the IEEE 'round to */
342 /* nearest' style. B/2 is half a unit in the last place of the two */
343 /* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */
344 /* zero, and SAVEC is odd. Thus adding B/2 to A should not change */
345 /* A, but adding B/2 to SAVEC should change SAVEC. */
348 t1 = slamc3_(&r__1, &a);
350 t2 = slamc3_(&r__1, &savec);
351 lieee1 = t1 == a && t2 > savec && lrnd;
353 /* Now find the mantissa, t. It should be the integer part of */
354 /* log to the base beta of a, however it is safer to determine t */
355 /* by powering. So we find t as the smallest positive integer for */
358 /* fl( beta**t + 1.0 ) = 1.0. */
364 /* + WHILE( C.EQ.ONE )LOOP */
369 c__ = slamc3_(&a, &one);
371 c__ = slamc3_(&c__, &r__1);
389 /* *********************************************************************** */
392 slamc2_(integer * beta, integer * t, logical * rnd, real *
393 eps, integer * emin, real * rmin, integer * emax, real * rmax)
395 /* Initialized data */
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,/)";
408 /* System generated locals */
410 real r__1, r__2, r__3, r__4, r__5;
412 /* Builtin functions */
413 double pow_ri(real *, integer *);
414 integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
417 /* Local variables */
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 /* Subroutine */ int slamc1_(integer *, integer *, logical *,
434 extern doublereal slamc3_(real *, real *);
435 extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
436 slamc5_(integer *, integer *, integer *, logical *, integer *,
438 static integer ngnmin, ngpmin;
440 /* Fortran I/O blocks */
441 static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
445 /* -- LAPACK auxiliary routine (version 3.0) -- */
446 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
447 /* Courant Institute, Argonne National Lab, and Rice University */
448 /* October 31, 1992 */
450 /* .. Scalar Arguments .. */
456 /* SLAMC2 determines the machine parameters specified in its argument */
462 /* BETA (output) INTEGER */
463 /* The base of the machine. */
465 /* T (output) INTEGER */
466 /* The number of ( BETA ) digits in the mantissa. */
468 /* RND (output) LOGICAL */
469 /* Specifies whether proper rounding ( RND = .TRUE. ) or */
470 /* chopping ( RND = .FALSE. ) occurs in addition. This may not */
471 /* be a reliable guide to the way in which the machine performs */
472 /* its arithmetic. */
474 /* EPS (output) REAL */
475 /* The smallest positive number such that */
477 /* fl( 1.0 - EPS ) .LT. 1.0, */
479 /* where fl denotes the computed value. */
481 /* EMIN (output) INTEGER */
482 /* The minimum exponent before (gradual) underflow occurs. */
484 /* RMIN (output) REAL */
485 /* The smallest normalized number for the machine, given by */
486 /* BASE**( EMIN - 1 ), where BASE is the floating point value */
489 /* EMAX (output) INTEGER */
490 /* The maximum exponent before overflow occurs. */
492 /* RMAX (output) REAL */
493 /* The largest positive number for the machine, given by */
494 /* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
497 /* Further Details */
498 /* =============== */
500 /* The computation of EPS is based on a routine PARANOIA by */
501 /* W. Kahan of the University of California at Berkeley. */
503 /* ===================================================================== */
505 /* .. Local Scalars .. */
507 /* .. External Functions .. */
509 /* .. External Subroutines .. */
511 /* .. Intrinsic Functions .. */
513 /* .. Save statement .. */
515 /* .. Data statements .. */
517 /* .. Executable Statements .. */
525 /* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
526 /* BETA, T, RND, EPS, EMIN and RMIN. */
528 /* Throughout this routine we use the function SLAMC3 to ensure */
529 /* that relevant values are stored and not held in registers, or */
530 /* are not affected by optimizers. */
532 /* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
534 slamc1_(&lbeta, <, &lrnd, &lieee1);
536 /* Start to find EPS. */
540 a = pow_ri(&b, &i__1);
543 /* Try some tricks to see whether or not this is the correct EPS. */
548 sixth = slamc3_(&b, &r__1);
549 third = slamc3_(&sixth, &sixth);
551 b = slamc3_(&third, &r__1);
552 b = slamc3_(&b, &sixth);
560 /* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
562 if (leps > b && b > zero) {
565 /* Computing 5th power */
566 r__3 = two, r__4 = r__3, r__3 *= r__3;
567 /* Computing 2nd power */
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__);
585 /* Computation of EPS complete. */
587 /* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
588 /* Keep dividing A by BETA until (gradual) underflow occurs. This */
589 /* is detected when we cannot recover the previous A. */
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) {
610 /* ( Non twos-complement machines, no gradual underflow; */
613 else if (gpmin - ngpmin == 3) {
614 lemin = ngpmin - 1 + lt;
616 /* ( Non twos-complement machines, with gradual underflow; */
617 /* e.g., IEEE standard followers ) */
620 lemin = min(ngpmin, gpmin);
621 /* ( A guess; no known machine ) */
626 else if (ngpmin == gpmin && ngnmin == gnmin) {
627 if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
628 lemin = max(ngpmin, ngnmin);
629 /* ( Twos-complement machines, no gradual underflow; */
630 /* e.g., CYBER 205 ) */
633 lemin = min(ngpmin, ngnmin);
634 /* ( A guess; no known machine ) */
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;
643 /* ( Twos-complement machines with gradual underflow; */
644 /* no known machine ) */
647 lemin = min(ngpmin, ngnmin);
648 /* ( A guess; no known machine ) */
655 i__1 = min(ngpmin, ngnmin), i__1 = min(i__1, gpmin);
656 lemin = min(i__1, gnmin);
657 /* ( A guess; no known machine ) */
661 /* Comment out this if block if EMIN is ok */
665 do_fio(&c__1, (char *) &lemin, (ftnlen) sizeof(integer));
670 /* Assume IEEE arithmetic if we found denormalised numbers above, */
671 /* or if arithmetic seems to round in the IEEE style, determined */
672 /* in routine SLAMC1. A true IEEE machine should have both things */
673 /* true; however, faulty machines may have one or the other. */
675 ieee = ieee || lieee1;
677 /* Compute RMIN by successive division by BETA. We could compute */
678 /* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
679 /* this computation. */
683 for (i__ = 1; i__ <= i__1; ++i__) {
684 r__1 = lrmin * rbase;
685 lrmin = slamc3_(&r__1, &zero);
689 /* Finally, call SLAMC5 to compute EMAX and RMAX. */
691 slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
711 /* *********************************************************************** */
714 slamc3_(real * a, real * b)
716 /* System generated locals */
720 /* -- LAPACK auxiliary routine (version 3.0) -- */
721 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
722 /* Courant Institute, Argonne National Lab, and Rice University */
723 /* October 31, 1992 */
725 /* .. Scalar Arguments .. */
731 /* SLAMC3 is intended to force A and B to be stored prior to doing */
732 /* the addition of A and B , for use in situations where optimizers */
733 /* might hold one of these in a register. */
738 /* A, B (input) REAL */
739 /* The values A and B. */
741 /* ===================================================================== */
743 /* .. Executable Statements .. */
754 /* *********************************************************************** */
757 slamc4_(integer * emin, real * start, integer * base)
759 /* System generated locals */
763 /* Local variables */
766 static real b1, b2, c1, c2, d1, d2, one, zero, rbase;
767 extern doublereal slamc3_(real *, real *);
770 /* -- LAPACK auxiliary routine (version 3.0) -- */
771 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
772 /* Courant Institute, Argonne National Lab, and Rice University */
773 /* October 31, 1992 */
775 /* .. Scalar Arguments .. */
781 /* SLAMC4 is a service routine for SLAMC2. */
786 /* EMIN (output) EMIN */
787 /* The minimum exponent before (gradual) underflow, computed by */
788 /* setting A = START and dividing by BASE until the previous A */
789 /* can not be recovered. */
791 /* START (input) REAL */
792 /* The starting point for determining EMIN. */
794 /* BASE (input) INTEGER */
795 /* The base of the machine. */
797 /* ===================================================================== */
799 /* .. Local Scalars .. */
801 /* .. External Functions .. */
803 /* .. Executable Statements .. */
811 b1 = slamc3_(&r__1, &zero);
816 /* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */
817 /* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */
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__) {
853 /* *********************************************************************** */
856 slamc5_(integer * beta, integer * p, integer * emin,
857 logical * ieee, integer * emax, real * rmax)
859 /* System generated locals */
863 /* Local variables */
866 static integer try__, lexp;
868 static integer uexp, nbits;
869 extern doublereal slamc3_(real *, real *);
871 static integer exbits, expsum;
874 /* -- LAPACK auxiliary routine (version 3.0) -- */
875 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
876 /* Courant Institute, Argonne National Lab, and Rice University */
877 /* October 31, 1992 */
879 /* .. Scalar Arguments .. */
885 /* SLAMC5 attempts to compute RMAX, the largest machine floating-point */
886 /* number, without overflow. It assumes that EMAX + abs(EMIN) sum */
887 /* approximately to a power of 2. It will fail on machines where this */
888 /* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */
889 /* EMAX = 28718). It will also fail if the value supplied for EMIN is */
890 /* too large (i.e. too close to zero), probably with overflow. */
895 /* BETA (input) INTEGER */
896 /* The base of floating-point arithmetic. */
898 /* P (input) INTEGER */
899 /* The number of base BETA digits in the mantissa of a */
900 /* floating-point value. */
902 /* EMIN (input) INTEGER */
903 /* The minimum exponent before (gradual) underflow. */
905 /* IEEE (input) LOGICAL */
906 /* A logical flag specifying whether or not the arithmetic */
907 /* system is thought to comply with the IEEE standard. */
909 /* EMAX (output) INTEGER */
910 /* The largest exponent before overflow */
912 /* RMAX (output) REAL */
913 /* The largest machine floating-point number. */
915 /* ===================================================================== */
917 /* .. Parameters .. */
919 /* .. Local Scalars .. */
921 /* .. External Functions .. */
923 /* .. Intrinsic Functions .. */
925 /* .. Executable Statements .. */
927 /* First compute LEXP and UEXP, two powers of 2 that bound */
928 /* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */
929 /* approximately to the bound that is closest to abs(EMIN). */
930 /* (EMAX is the exponent of the required number RMAX). */
936 if (try__ <= -(*emin)) {
941 if (lexp == -(*emin)) {
949 /* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */
950 /* than or equal to EMIN. EXBITS is the number of bits needed to */
951 /* store the exponent. */
953 if (uexp + *emin > -lexp - *emin) {
960 /* EXPSUM is the exponent range, approximately equal to */
961 /* EMAX - EMIN + 1 . */
963 *emax = expsum + *emin - 1;
964 nbits = exbits + 1 + *p;
966 /* NBITS is the total number of bits needed to store a */
967 /* floating-point number. */
969 if (nbits % 2 == 1 && *beta == 2) {
971 /* Either there are an odd number of bits used to store a */
972 /* floating-point number, which is unlikely, or some bits are */
973 /* not used in the representation of numbers, which is possible, */
974 /* (e.g. Cray machines) or the mantissa has an implicit bit, */
975 /* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */
976 /* most likely. We have to assume the last alternative. */
977 /* If this is true, then we need to reduce EMAX by one because */
978 /* there must be some way of representing zero in an implicit-bit */
979 /* system. On machines like Cray, we are reducing EMAX by one */
987 /* Assume we are on an IEEE machine which reserves one exponent */
988 /* for infinity and NaN. */
993 /* Now create RMAX, the largest machine number, which should */
994 /* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */
996 /* First compute 1.0 - BETA**(-P), being careful that the */
997 /* result is less than 1.0 . */
999 recbas = 1.f / *beta;
1003 for (i__ = 1; i__ <= i__1; ++i__) {
1008 y = slamc3_(&y, &z__);
1015 /* Now multiply by BETA**EMAX to get RMAX. */
1018 for (i__ = 1; i__ <= i__1; ++i__) {
1020 y = slamc3_(&r__1, &c_b32);