/*< SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) >*/
/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
eps, integer *emin, real *rmin, integer *emax, real *rmax)
{
/* Initialized data */
static logical first = TRUE_; /* runtime-initialized constant */
static logical iwarn = FALSE_; /* runtime-initialized constant */
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
real a, b, c__;
integer i__;
static integer lt; /* runtime-initialized constant */
real one, two;
logical ieee;
real half;
logical lrnd = 0; //variable 'lrnd' is used uninitialized whenever 'if' condition is false [-Wsometimes-uninitialized]
static real leps; /* runtime-initialized constant */
real zero;
static integer lbeta; /* runtime-initialized constant */
real rbase;
static integer lemin, lemax; /* runtime-initialized constant */
integer gnmin;
real small;
integer gpmin;
real third;
static real lrmin, lrmax; /* runtime-initialized constant */
real sixth;
logical lieee1;
extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
logical *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
slamc5_(integer *, integer *, integer *, logical *, integer *,
real *);
integer ngnmin, ngpmin;
/* -- LAPACK auxiliary routine (version 1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* October 31, 1992 */
/* .. Scalar Arguments .. */
/*< LOGICAL RND >*/
/*< INTEGER BETA, EMAX, EMIN, T >*/
/*< REAL EPS, RMAX, RMIN >*/
/* .. */
/* Purpose */
/* ======= */
/* SLAMC2 determines the machine parameters specified in its argument */
/* list. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
/* be a reliable guide to the way in which the machine performs */
/* its arithmetic. */
/* EPS (output) REAL */
/* The smallest positive number such that */
/* fl( 1.0 - EPS ) .LT. 1.0, */
/* where fl denotes the computed value. */
/* EMIN (output) INTEGER */
/* The minimum exponent before (gradual) underflow occurs. */
/* RMIN (output) REAL */
/* The smallest normalized number for the machine, given by */
/* BASE**( EMIN - 1 ), where BASE is the floating point value */
/* of BETA. */
/* EMAX (output) INTEGER */
/* The maximum exponent before overflow occurs. */
/* RMAX (output) REAL */
/* The largest positive number for the machine, given by */
/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
/* value of BETA. */
/* Further Details */
/* =============== */
/* The computation of EPS is based on a routine PARANOIA by */
/* W. Kahan of the University of California at Berkeley. */
/* ===================================================================== */
/* .. Local Scalars .. */
/*< LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND >*/
/*< >*/
/*< >*/
/* .. */
/* .. External Functions .. */
/*< REAL SLAMC3 >*/
/*< EXTERNAL SLAMC3 >*/
/* .. */
/* .. External Subroutines .. */
/*< EXTERNAL SLAMC1, SLAMC4, SLAMC5 >*/
/* .. */
/* .. Intrinsic Functions .. */
/*< INTRINSIC ABS, MAX, MIN >*/
/* .. */
/* .. Save statement .. */
/*< >*/
/* .. */
/* .. Data statements .. */
/*< DATA FIRST / .TRUE. / , IWARN / .FALSE. / >*/
/* .. */
/* .. Executable Statements .. */
/*< IF( FIRST ) THEN >*/
if (first) {
/*< FIRST = .FALSE. >*/
first = FALSE_;
/*< ZERO = 0 >*/
zero = (float)0.;
/*< ONE = 1 >*/
one = (float)1.;
/*< TWO = 2 >*/
two = (float)2.;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
/* BETA, T, RND, EPS, EMIN and RMIN. */
/* Throughout this routine we use the function SLAMC3 to ensure */
/* that relevant values are stored and not held in registers, or */
/* are not affected by optimizers. */
/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
/*< CALL SLAMC1( LBETA, LT, LRND, LIEEE1 ) >*/
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
/*< B = LBETA >*/
b = (real) lbeta;
/*< A = B**( -LT ) >*/
i__1 = -lt;
a = pow_ri(&b, &i__1);
/*< LEPS = A >*/
leps = a;
/* Try some tricks to see whether or not this is the correct EPS. */
/*< B = TWO / 3 >*/
b = two / 3;
/*< HALF = ONE / 2 >*/
half = one / 2;
/*< SIXTH = SLAMC3( B, -HALF ) >*/
r__1 = -half;
sixth = slamc3_(&b, &r__1);
/*< THIRD = SLAMC3( SIXTH, SIXTH ) >*/
third = slamc3_(&sixth, &sixth);
/*< B = SLAMC3( THIRD, -HALF ) >*/
r__1 = -half;
b = slamc3_(&third, &r__1);
/*< B = SLAMC3( B, SIXTH ) >*/
b = slamc3_(&b, &sixth);
/*< B = ABS( B ) >*/
b = dabs(b);
/*< >*/
if (b < leps) {
b = leps;
}
/*< LEPS = 1 >*/
leps = (float)1.;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
/*< 10 CONTINUE >*/
L10:
/*< IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN >*/
if (leps > b && b > zero) {
/*< LEPS = B >*/
leps = b;
/*< C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) >*/
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c__ = slamc3_(&r__1, &r__2);
/*< C = SLAMC3( HALF, -C ) >*/
r__1 = -c__;
c__ = slamc3_(&half, &r__1);
/*< B = SLAMC3( HALF, C ) >*/
b = slamc3_(&half, &c__);
/*< C = SLAMC3( HALF, -B ) >*/
r__1 = -b;
c__ = slamc3_(&half, &r__1);
/*< B = SLAMC3( HALF, C ) >*/
b = slamc3_(&half, &c__);
/*< GO TO 10 >*/
goto L10;
/*< END IF >*/
}
/* + END WHILE */
/*< >*/
if (a < leps) {
leps = a;
}
/* Computation of EPS complete. */
/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
/* Keep dividing A by BETA until (gradual) underflow occurs. This */
/* is detected when we cannot recover the previous A. */
/*< RBASE = ONE / LBETA >*/
rbase = one / lbeta;
/*< SMALL = ONE >*/
small = one;
/*< DO 20 I = 1, 3 >*/
for (i__ = 1; i__ <= 3; ++i__) {
/*< SMALL = SLAMC3( SMALL*RBASE, ZERO ) >*/
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/*< 20 CONTINUE >*/
/* L20: */
}
/*< A = SLAMC3( ONE, SMALL ) >*/
a = slamc3_(&one, &small);
/*< CALL SLAMC4( NGPMIN, ONE, LBETA ) >*/
slamc4_(&ngpmin, &one, &lbeta);
/*< CALL SLAMC4( NGNMIN, -ONE, LBETA ) >*/
r__1 = -one;
slamc4_(&ngnmin, &r__1, &lbeta);
/*< CALL SLAMC4( GPMIN, A, LBETA ) >*/
slamc4_(&gpmin, &a, &lbeta);
/*< CALL SLAMC4( GNMIN, -A, LBETA ) >*/
r__1 = -a;
slamc4_(&gnmin, &r__1, &lbeta);
/*< IEEE = .FALSE. >*/
ieee = FALSE_;
/*< IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN >*/
if (ngpmin == ngnmin && gpmin == gnmin) {
/*< IF( NGPMIN.EQ.GPMIN ) THEN >*/
if (ngpmin == gpmin) {
/*< LEMIN = NGPMIN >*/
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual underflow; */
/* e.g., VAX ) */
/*< ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN >*/
} else if (gpmin - ngpmin == 3) {
/*< LEMIN = NGPMIN - 1 + LT >*/
lemin = ngpmin - 1 + lt;
/*< IEEE = .TRUE. >*/
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual underflow; */
/* e.g., IEEE standard followers ) */
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, GPMIN ) >*/
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/*< ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN >*/
} else if (ngpmin == gpmin && ngnmin == gnmin) {
/*< IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN >*/
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
/*< LEMIN = MAX( NGPMIN, NGNMIN ) >*/
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow; */
/* e.g., CYBER 205 ) */
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, NGNMIN ) >*/
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/*< >*/
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
/*< IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN >*/
if (gpmin - min(ngpmin,ngnmin) == 3) {
/*< LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT >*/
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflow; */
/* no known machine ) */
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, NGNMIN ) >*/
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/*< ELSE >*/
} else {
/*< LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) >*/
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
/*< IWARN = .TRUE. >*/
iwarn = TRUE_;
/*< END IF >*/
}
/* ** */
/* Comment out this if block if EMIN is ok */
/*< IF( IWARN ) THEN >*/
if (iwarn) {
/*< FIRST = .TRUE. >*/
first = TRUE_;
/*< WRITE( 6, FMT = 9999 )LEMIN >*/
printf("\n\n WARNING. The value EMIN may be incorrect: - ");
printf("EMIN = %8li\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf(" please comment out\n the IF block as marked within the");
printf(" code of routine SLAMC2,\n otherwise supply EMIN");
printf(" explicitly.\n");
/*< END IF >*/
}
/* ** */
/* Assume IEEE arithmetic if we found denormalised numbers above, */
/* or if arithmetic seems to round in the IEEE style, determined */
/* in routine SLAMC1. A true IEEE machine should have both things */
/* true; however, faulty machines may have one or the other. */
/*< IEEE = IEEE .OR. LIEEE1 >*/
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could compute */
/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
/* this computation. */
/*< LRMIN = 1 >*/
lrmin = (float)1.;
/*< DO 30 I = 1, 1 - LEMIN >*/
i__1 = 1 - lemin;
for (i__ = 1; i__ <= i__1; ++i__) {
/*< LRMIN = SLAMC3( LRMIN*RBASE, ZERO ) >*/
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/*< 30 CONTINUE >*/
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
/*< CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) >*/
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
/*< END IF >*/
}
/*< BETA = LBETA >*/
*beta = lbeta;
/*< T = LT >*/
*t = lt;
/*< RND = LRND >*/
*rnd = lrnd;
/*< EPS = LEPS >*/
*eps = leps;
/*< EMIN = LEMIN >*/
*emin = lemin;
/*< RMIN = LRMIN >*/
*rmin = lrmin;
/*< EMAX = LEMAX >*/
*emax = lemax;
/*< RMAX = LRMAX >*/
*rmax = lrmax;
/*< RETURN >*/
return 0;
/*< 9 >*/
/* End of SLAMC2 */
/*< END >*/
} /* slamc2_ */
/*! \brief
<pre>
Purpose
=======
SLAMC2 determines the machine parameters specified in its argument
list.
Arguments
=========
BETA (output) INT
The base of the machine.
T (output) INT
The number of ( BETA ) digits in the mantissa.
RND (output) INT
Specifies whether proper rounding ( RND = .TRUE. ) or
chopping ( RND = .FALSE. ) occurs in addition. This may not
be a reliable guide to the way in which the machine performs
its arithmetic.
EPS (output) FLOAT
The smallest positive number such that
fl( 1.0 - EPS ) .LT. 1.0,
where fl denotes the computed value.
EMIN (output) INT
The minimum exponent before (gradual) underflow occurs.
RMIN (output) FLOAT
The smallest normalized number for the machine, given by
BASE**( EMIN - 1 ), where BASE is the floating point value
of BETA.
EMAX (output) INT
The maximum exponent before overflow occurs.
RMAX (output) FLOAT
The largest positive number for the machine, given by
BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
value of BETA.
Further Details
===============
The computation of EPS is based on a routine PARANOIA by
W. Kahan of the University of California at Berkeley.
=====================================================================
</pre>
*/
int slamc2_(int *beta, int *t, int *rnd, float *
eps, int *emin, float *rmin, int *emax, float *rmax)
{
/* Table of constant values */
static int c__1 = 1;
/* Initialized data */
static int first = TRUE_;
static int iwarn = FALSE_;
/* System generated locals */
int i__1;
float r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(float *, int *);
/* Local variables */
static int ieee;
static float half;
static int lrnd;
static float leps, zero, a, b, c;
static int i, lbeta;
static float rbase;
static int lemin, lemax, gnmin;
static float small;
static int gpmin;
static float third, lrmin, lrmax, sixth;
static int lieee1;
extern /* Subroutine */ int slamc1_(int *, int *, int *,
int *);
extern double slamc3_(float *, float *);
extern /* Subroutine */ int slamc4_(int *, float *, int *),
slamc5_(int *, int *, int *, int *, int *,
float *);
static int lt, ngnmin, ngpmin;
static float one, two;
if (first) {
first = FALSE_;
zero = 0.f;
one = 1.f;
two = 2.f;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values
of
BETA, T, RND, EPS, EMIN and RMIN.
Throughout this routine we use the function SLAMC3 to ens
ure
that relevant values are stored and not held in registers,
or
are not affected by optimizers.
SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*/
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (float) lbeta;
i__1 = -lt;
a = pow_ri(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct E
PS. */
b = two / 3;
half = one / 2;
r__1 = -(double)half;
sixth = slamc3_(&b, &r__1);
third = slamc3_(&sixth, &sixth);
r__1 = -(double)half;
b = slamc3_(&third, &r__1);
b = slamc3_(&b, &sixth);
b = dabs(b);
if (b < leps) {
b = leps;
}
leps = 1.f;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c = slamc3_(&r__1, &r__2);
r__1 = -(double)c;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
r__1 = -(double)b;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete.
Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3
)).
Keep dividing A by BETA until (gradual) underflow occurs. T
his
is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i = 1; i <= 3; ++i) {
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/* L20: */
}
a = slamc3_(&one, &small);
slamc4_(&ngpmin, &one, &lbeta);
r__1 = -(double)one;
slamc4_(&ngnmin, &r__1, &lbeta);
slamc4_(&gpmin, &a, &lbeta);
r__1 = -(double)a;
slamc4_(&gnmin, &r__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual under
flow;
e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual und
erflow;
e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow
;
e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflo
w;
no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
/* **
Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
printf("\n\n WARNING. The value EMIN may be incorrect:- ");
printf("EMIN = %8i\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf("please comment out \n the IF block as marked within the");
printf("code of routine SLAMC2, \n otherwise supply EMIN");
printf("explicitly.\n");
}
/* **
Assume IEEE arithmetic if we found denormalised numbers abo
ve,
or if arithmetic seems to round in the IEEE style, determi
ned
in routine SLAMC1. A true IEEE machine should have both thi
ngs
true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could comp
ute
RMIN as BASE**( EMIN - 1 ), but some machines underflow dur
ing
this computation. */
lrmin = 1.f;
i__1 = 1 - lemin;
for (i = 1; i <= 1-lemin; ++i) {
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of SLAMC2 */
} /* slamc2_ */
/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
eps, integer *emin, real *rmin, integer *emax, real *rmax)
{
/* -- LAPACK auxiliary routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
SLAMC2 determines the machine parameters specified in its argument
list.
Arguments
=========
BETA (output) INTEGER
The base of the machine.
T (output) INTEGER
The number of ( BETA ) digits in the mantissa.
RND (output) LOGICAL
Specifies whether proper rounding ( RND = .TRUE. ) or
chopping ( RND = .FALSE. ) occurs in addition. This may not
be a reliable guide to the way in which the machine performs
its arithmetic.
EPS (output) REAL
The smallest positive number such that
fl( 1.0 - EPS ) .LT. 1.0,
where fl denotes the computed value.
EMIN (output) INTEGER
The minimum exponent before (gradual) underflow occurs.
RMIN (output) REAL
The smallest normalized number for the machine, given by
BASE**( EMIN - 1 ), where BASE is the floating point value
of BETA.
EMAX (output) INTEGER
The maximum exponent before overflow occurs.
RMAX (output) REAL
The largest positive number for the machine, given by
BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
value of BETA.
Further Details
===============
The computation of EPS is based on a routine PARANOIA by
W. Kahan of the University of California at Berkeley.
=====================================================================
*/
/* Table of constant values */
static integer c__1 = 1;
/* Initialized data */
static logical first = TRUE_;
static logical iwarn = FALSE_;
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(real *, integer *);
/* Local variables */
static logical ieee;
static real half;
static logical lrnd;
static real leps, zero, a, b, c;
static integer i, lbeta;
static real rbase;
static integer lemin, lemax, gnmin;
static real small;
static integer gpmin;
static real third, lrmin, lrmax, sixth;
static logical lieee1;
extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
logical *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
slamc5_(integer *, integer *, integer *, logical *, integer *,
real *);
static integer lt, ngnmin, ngpmin;
static real one, two;
if (first) {
first = FALSE_;
zero = 0.f;
one = 1.f;
two = 2.f;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values
of
BETA, T, RND, EPS, EMIN and RMIN.
Throughout this routine we use the function SLAMC3 to ens
ure
that relevant values are stored and not held in registers,
or
are not affected by optimizers.
SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
*/
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (real) lbeta;
i__1 = -lt;
a = pow_ri(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct E
PS. */
b = two / 3;
half = one / 2;
r__1 = -(doublereal)half;
sixth = slamc3_(&b, &r__1);
third = slamc3_(&sixth, &sixth);
r__1 = -(doublereal)half;
b = slamc3_(&third, &r__1);
b = slamc3_(&b, &sixth);
b = dabs(b);
if (b < leps) {
b = leps;
}
leps = 1.f;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c = slamc3_(&r__1, &r__2);
r__1 = -(doublereal)c;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
r__1 = -(doublereal)b;
c = slamc3_(&half, &r__1);
b = slamc3_(&half, &c);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete.
Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3
)).
Keep dividing A by BETA until (gradual) underflow occurs. T
his
is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i = 1; i <= 3; ++i) {
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/* L20: */
}
a = slamc3_(&one, &small);
slamc4_(&ngpmin, &one, &lbeta);
r__1 = -(doublereal)one;
slamc4_(&ngnmin, &r__1, &lbeta);
slamc4_(&gpmin, &a, &lbeta);
r__1 = -(doublereal)a;
slamc4_(&gnmin, &r__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual under
flow;
e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual und
erflow;
e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow
;
e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflo
w;
no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
/* **
Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
printf("\n\n WARNING. The value EMIN may be incorrect:- ");
printf("EMIN = %8i\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf("please comment out \n the IF block as marked within the");
printf("code of routine SLAMC2, \n otherwise supply EMIN");
printf("explicitly.\n");
}
/* **
Assume IEEE arithmetic if we found denormalised numbers abo
ve,
or if arithmetic seems to round in the IEEE style, determi
ned
in routine SLAMC1. A true IEEE machine should have both thi
ngs
true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could comp
ute
RMIN as BASE**( EMIN - 1 ), but some machines underflow dur
ing
this computation. */
lrmin = 1.f;
i__1 = 1 - lemin;
for (i = 1; i <= 1-lemin; ++i) {
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of SLAMC2 */
} /* slamc2_ */
/* Subroutine */ int slamc2_(integer *beta, integer *t, logical *rnd, real *
eps, integer *emin, real *rmin, integer *emax, real *rmax)
{
/* Initialized data */
static logical first = TRUE_;
static logical iwarn = FALSE_;
/* Format strings */
static char fmt_9999[] = "(//\002 WARNING. The value EMIN may be incorre"
"ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"
"lue EMIN looks\002,\002 acceptable please comment out \002,/\002"
" the IF block as marked within the code of routine\002,\002 SLAM"
"C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)";
/* System generated locals */
integer i__1;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double pow_ri(real *, integer *);
//integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
real a, b, c__;
integer i__;
static integer lt;
real one, two;
logical ieee;
real half;
logical lrnd;
static real leps;
real zero;
static integer lbeta;
real rbase;
static integer lemin, lemax;
integer gnmin;
real small;
integer gpmin;
real third;
static real lrmin, lrmax;
real sixth;
logical lieee1;
extern /* Subroutine */ int slamc1_(integer *, integer *, logical *,
logical *);
extern doublereal slamc3_(real *, real *);
extern /* Subroutine */ int slamc4_(integer *, real *, integer *),
slamc5_(integer *, integer *, integer *, logical *, integer *,
real *);
integer ngnmin, ngpmin;
/* Fortran I/O blocks */
static cilist io___58 = { 0, 6, 0, fmt_9999, 0 };
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLAMC2 determines the machine parameters specified in its argument */
/* list. */
/* Arguments */
/* ========= */
/* BETA (output) INTEGER */
/* The base of the machine. */
/* T (output) INTEGER */
/* The number of ( BETA ) digits in the mantissa. */
/* RND (output) LOGICAL */
/* Specifies whether proper rounding ( RND = .TRUE. ) or */
/* chopping ( RND = .FALSE. ) occurs in addition. This may not */
/* be a reliable guide to the way in which the machine performs */
/* its arithmetic. */
/* EPS (output) REAL */
/* The smallest positive number such that */
/* fl( 1.0 - EPS ) .LT. 1.0, */
/* where fl denotes the computed value. */
/* EMIN (output) INTEGER */
/* The minimum exponent before (gradual) underflow occurs. */
/* RMIN (output) REAL */
/* The smallest normalized number for the machine, given by */
/* BASE**( EMIN - 1 ), where BASE is the floating point value */
/* of BETA. */
/* EMAX (output) INTEGER */
/* The maximum exponent before overflow occurs. */
/* RMAX (output) REAL */
/* The largest positive number for the machine, given by */
/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */
/* value of BETA. */
/* Further Details */
/* =============== */
/* The computation of EPS is based on a routine PARANOIA by */
/* W. Kahan of the University of California at Berkeley. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Save statement .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
if (first) {
zero = 0.f;
one = 1.f;
two = 2.f;
/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */
/* BETA, T, RND, EPS, EMIN and RMIN. */
/* Throughout this routine we use the function SLAMC3 to ensure */
/* that relevant values are stored and not held in registers, or */
/* are not affected by optimizers. */
/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */
slamc1_(&lbeta, <, &lrnd, &lieee1);
/* Start to find EPS. */
b = (real) lbeta;
i__1 = -lt;
a = pow_ri(&b, &i__1);
leps = a;
/* Try some tricks to see whether or not this is the correct EPS. */
b = two / 3;
half = one / 2;
r__1 = -half;
sixth = slamc3_(&b, &r__1);
third = slamc3_(&sixth, &sixth);
r__1 = -half;
b = slamc3_(&third, &r__1);
b = slamc3_(&b, &sixth);
b = dabs(b);
if (b < leps) {
b = leps;
}
leps = 1.f;
/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */
L10:
if (leps > b && b > zero) {
leps = b;
r__1 = half * leps;
/* Computing 5th power */
r__3 = two, r__4 = r__3, r__3 *= r__3;
/* Computing 2nd power */
r__5 = leps;
r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
c__ = slamc3_(&r__1, &r__2);
r__1 = -c__;
c__ = slamc3_(&half, &r__1);
b = slamc3_(&half, &c__);
r__1 = -b;
c__ = slamc3_(&half, &r__1);
b = slamc3_(&half, &c__);
goto L10;
}
/* + END WHILE */
if (a < leps) {
leps = a;
}
/* Computation of EPS complete. */
/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */
/* Keep dividing A by BETA until (gradual) underflow occurs. This */
/* is detected when we cannot recover the previous A. */
rbase = one / lbeta;
small = one;
for (i__ = 1; i__ <= 3; ++i__) {
r__1 = small * rbase;
small = slamc3_(&r__1, &zero);
/* L20: */
}
a = slamc3_(&one, &small);
slamc4_(&ngpmin, &one, &lbeta);
r__1 = -one;
slamc4_(&ngnmin, &r__1, &lbeta);
slamc4_(&gpmin, &a, &lbeta);
r__1 = -a;
slamc4_(&gnmin, &r__1, &lbeta);
ieee = FALSE_;
if (ngpmin == ngnmin && gpmin == gnmin) {
if (ngpmin == gpmin) {
lemin = ngpmin;
/* ( Non twos-complement machines, no gradual underflow; */
/* e.g., VAX ) */
} else if (gpmin - ngpmin == 3) {
lemin = ngpmin - 1 + lt;
ieee = TRUE_;
/* ( Non twos-complement machines, with gradual underflow; */
/* e.g., IEEE standard followers ) */
} else {
lemin = min(ngpmin,gpmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if (ngpmin == gpmin && ngnmin == gnmin) {
if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
lemin = max(ngpmin,ngnmin);
/* ( Twos-complement machines, no gradual underflow; */
/* e.g., CYBER 205 ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin)
{
if (gpmin - min(ngpmin,ngnmin) == 3) {
lemin = max(ngpmin,ngnmin) - 1 + lt;
/* ( Twos-complement machines with gradual underflow; */
/* no known machine ) */
} else {
lemin = min(ngpmin,ngnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
} else {
/* Computing MIN */
i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin);
lemin = min(i__1,gnmin);
/* ( A guess; no known machine ) */
iwarn = TRUE_;
}
first = FALSE_;
/* ** */
/* Comment out this if block if EMIN is ok */
if (iwarn) {
first = TRUE_;
printf("\n\n WARNING. The value EMIN may be incorrect:- ");
printf("EMIN = %8i\n",lemin);
printf("If, after inspection, the value EMIN looks acceptable");
printf("please comment out \n the IF block as marked within the");
printf("code of routine SLAMC2, \n otherwise supply EMIN");
printf("explicitly.\n");
/*
s_wsfe(&io___58);
do_fio(&c__1, (char *)&lemin, (ftnlen)sizeof(integer));
e_wsfe();
*/
}
/* ** */
/* Assume IEEE arithmetic if we found denormalised numbers above, */
/* or if arithmetic seems to round in the IEEE style, determined */
/* in routine SLAMC1. A true IEEE machine should have both things */
/* true; however, faulty machines may have one or the other. */
ieee = ieee || lieee1;
/* Compute RMIN by successive division by BETA. We could compute */
/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */
/* this computation. */
lrmin = 1.f;
i__1 = 1 - lemin;
for (i__ = 1; i__ <= i__1; ++i__) {
r__1 = lrmin * rbase;
lrmin = slamc3_(&r__1, &zero);
/* L30: */
}
/* Finally, call SLAMC5 to compute EMAX and RMAX. */
slamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax);
}
*beta = lbeta;
*t = lt;
*rnd = lrnd;
*eps = leps;
*emin = lemin;
*rmin = lrmin;
*emax = lemax;
*rmax = lrmax;
return 0;
/* End of SLAMC2 */
} /* slamc2_ */
