1 *> \brief \b SLAMCHF77 deprecated
3 * =========== DOCUMENTATION ===========
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
11 * REAL FUNCTION SLAMCH( CMACH )
13 * .. Scalar Arguments ..
23 *> SLAMCH determines single precision machine parameters.
31 *> Specifies the value to be returned by SLAMCH:
32 *> = 'E' or 'e', SLAMCH := eps
33 *> = 'S' or 's , SLAMCH := sfmin
34 *> = 'B' or 'b', SLAMCH := base
35 *> = 'P' or 'p', SLAMCH := eps*base
36 *> = 'N' or 'n', SLAMCH := t
37 *> = 'R' or 'r', SLAMCH := rnd
38 *> = 'M' or 'm', SLAMCH := emin
39 *> = 'U' or 'u', SLAMCH := rmin
40 *> = 'L' or 'l', SLAMCH := emax
41 *> = 'O' or 'o', SLAMCH := rmax
43 *> eps = relative machine precision
44 *> sfmin = safe minimum, such that 1/sfmin does not overflow
45 *> base = base of the machine
47 *> t = number of (base) digits in the mantissa
48 *> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
49 *> emin = minimum exponent before (gradual) underflow
50 *> rmin = underflow threshold - base**(emin-1)
51 *> emax = largest exponent before overflow
52 *> rmax = overflow threshold - (base**emax)*(1-eps)
58 *> \author Univ. of Tennessee
59 *> \author Univ. of California Berkeley
60 *> \author Univ. of Colorado Denver
65 *> \ingroup auxOTHERauxiliary
67 * =====================================================================
68 REAL FUNCTION SLAMCH( CMACH )
70 * -- LAPACK auxiliary routine (version 3.7.0) --
71 * -- LAPACK is a software package provided by Univ. of Tennessee, --
72 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
75 * .. Scalar Arguments ..
80 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
84 INTEGER BETA, IMAX, IMIN, IT
85 REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
86 $ RND, SFMIN, SMALL, T
88 * .. External Functions ..
92 * .. External Subroutines ..
95 * .. Save statement ..
96 SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
99 * .. Data statements ..
100 DATA FIRST / .TRUE. /
102 * .. Executable Statements ..
105 CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
110 EPS = ( BASE**( 1-IT ) ) / 2
120 IF( SMALL.GE.SFMIN ) THEN
122 * Use SMALL plus a bit, to avoid the possibility of rounding
123 * causing overflow when computing 1/sfmin.
125 SFMIN = SMALL*( ONE+EPS )
129 IF( LSAME( CMACH, 'E' ) ) THEN
131 ELSE IF( LSAME( CMACH, 'S' ) ) THEN
133 ELSE IF( LSAME( CMACH, 'B' ) ) THEN
135 ELSE IF( LSAME( CMACH, 'P' ) ) THEN
137 ELSE IF( LSAME( CMACH, 'N' ) ) THEN
139 ELSE IF( LSAME( CMACH, 'R' ) ) THEN
141 ELSE IF( LSAME( CMACH, 'M' ) ) THEN
143 ELSE IF( LSAME( CMACH, 'U' ) ) THEN
145 ELSE IF( LSAME( CMACH, 'L' ) ) THEN
147 ELSE IF( LSAME( CMACH, 'O' ) ) THEN
159 ************************************************************************
165 *> SLAMC1 determines the machine parameters given by BETA, T, RND, and
171 *> The base of the machine.
176 *> The number of ( BETA ) digits in the mantissa.
181 *> Specifies whether proper rounding ( RND = .TRUE. ) or
182 *> chopping ( RND = .FALSE. ) occurs in addition. This may not
183 *> be a reliable guide to the way in which the machine performs
189 *> Specifies whether rounding appears to be done in the IEEE
190 *> 'round to nearest' style.
192 *> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
194 *> \ingroup auxOTHERauxiliary
196 *> \details \b Further \b Details
199 *> The routine is based on the routine ENVRON by Malcolm and
200 *> incorporates suggestions by Gentleman and Marovich. See
202 *> Malcolm M. A. (1972) Algorithms to reveal properties of
203 *> floating-point arithmetic. Comms. of the ACM, 15, 949-951.
205 *> Gentleman W. M. and Marovich S. B. (1974) More on algorithms
206 *> that reveal properties of floating point arithmetic units.
207 *> Comms. of the ACM, 17, 276-277.
210 SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
212 * -- LAPACK auxiliary routine (version 3.7.0) --
213 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
216 * .. Scalar Arguments ..
220 * =====================================================================
222 * .. Local Scalars ..
223 LOGICAL FIRST, LIEEE1, LRND
225 REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2
227 * .. External Functions ..
231 * .. Save statement ..
232 SAVE FIRST, LIEEE1, LBETA, LRND, LT
234 * .. Data statements ..
235 DATA FIRST / .TRUE. /
237 * .. Executable Statements ..
242 * LBETA, LIEEE1, LT and LRND are the local values of BETA,
245 * Throughout this routine we use the function SLAMC3 to ensure
246 * that relevant values are stored and not held in registers, or
247 * are not affected by optimizers.
249 * Compute a = 2.0**m with the smallest positive integer m such
257 *+ WHILE( C.EQ.ONE )LOOP
267 * Now compute b = 2.0**m with the smallest positive integer m
270 * fl( a + b ) .gt. a.
275 *+ WHILE( C.EQ.A )LOOP
284 * Now compute the base. a and c are neighbouring floating point
285 * numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
286 * their difference is beta. Adding 0.25 to c is to ensure that it
287 * is truncated to beta and not ( beta - 1 ).
294 * Now determine whether rounding or chopping occurs, by adding a
295 * bit less than beta/2 and a bit more than beta/2 to a.
298 F = SLAMC3( B / 2, -B / 100 )
305 F = SLAMC3( B / 2, B / 100 )
307 IF( ( LRND ) .AND. ( C.EQ.A ) )
310 * Try and decide whether rounding is done in the IEEE 'round to
311 * nearest' style. B/2 is half a unit in the last place of the two
312 * numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
313 * zero, and SAVEC is odd. Thus adding B/2 to A should not change
314 * A, but adding B/2 to SAVEC should change SAVEC.
316 T1 = SLAMC3( B / 2, A )
317 T2 = SLAMC3( B / 2, SAVEC )
318 LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
320 * Now find the mantissa, t. It should be the integer part of
321 * log to the base beta of a, however it is safer to determine t
322 * by powering. So we find t as the smallest positive integer for
325 * fl( beta**t + 1.0 ) = 1.0.
331 *+ WHILE( C.EQ.ONE )LOOP
355 ************************************************************************
361 *> SLAMC2 determines the machine parameters specified in its argument
364 *> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
366 *> \ingroup auxOTHERauxiliary
370 *> The base of the machine.
375 *> The number of ( BETA ) digits in the mantissa.
380 *> Specifies whether proper rounding ( RND = .TRUE. ) or
381 *> chopping ( RND = .FALSE. ) occurs in addition. This may not
382 *> be a reliable guide to the way in which the machine performs
388 *> The smallest positive number such that
389 *> fl( 1.0 - EPS ) .LT. 1.0,
390 *> where fl denotes the computed value.
395 *> The minimum exponent before (gradual) underflow occurs.
400 *> The smallest normalized number for the machine, given by
401 *> BASE**( EMIN - 1 ), where BASE is the floating point value
407 *> The maximum exponent before overflow occurs.
412 *> The largest positive number for the machine, given by
413 *> BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
417 *> \details \b Further \b Details
420 *> The computation of EPS is based on a routine PARANOIA by
421 *> W. Kahan of the University of California at Berkeley.
423 SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
425 * -- LAPACK auxiliary routine (version 3.7.0) --
426 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
429 * .. Scalar Arguments ..
431 INTEGER BETA, EMAX, EMIN, T
434 * =====================================================================
436 * .. Local Scalars ..
437 LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
438 INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
440 REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
441 $ SIXTH, SMALL, THIRD, TWO, ZERO
443 * .. External Functions ..
447 * .. External Subroutines ..
448 EXTERNAL SLAMC1, SLAMC4, SLAMC5
450 * .. Intrinsic Functions ..
451 INTRINSIC ABS, MAX, MIN
453 * .. Save statement ..
454 SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
457 * .. Data statements ..
458 DATA FIRST / .TRUE. / , IWARN / .FALSE. /
460 * .. Executable Statements ..
467 * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
468 * BETA, T, RND, EPS, EMIN and RMIN.
470 * Throughout this routine we use the function SLAMC3 to ensure
471 * that relevant values are stored and not held in registers, or
472 * are not affected by optimizers.
474 * SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
476 CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
484 * Try some tricks to see whether or not this is the correct EPS.
488 SIXTH = SLAMC3( B, -HALF )
489 THIRD = SLAMC3( SIXTH, SIXTH )
490 B = SLAMC3( THIRD, -HALF )
491 B = SLAMC3( B, SIXTH )
498 *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
500 IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
502 C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
503 C = SLAMC3( HALF, -C )
504 B = SLAMC3( HALF, C )
505 C = SLAMC3( HALF, -B )
506 B = SLAMC3( HALF, C )
514 * Computation of EPS complete.
516 * Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
517 * Keep dividing A by BETA until (gradual) underflow occurs. This
518 * is detected when we cannot recover the previous A.
523 SMALL = SLAMC3( SMALL*RBASE, ZERO )
525 A = SLAMC3( ONE, SMALL )
526 CALL SLAMC4( NGPMIN, ONE, LBETA )
527 CALL SLAMC4( NGNMIN, -ONE, LBETA )
528 CALL SLAMC4( GPMIN, A, LBETA )
529 CALL SLAMC4( GNMIN, -A, LBETA )
532 IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
533 IF( NGPMIN.EQ.GPMIN ) THEN
535 * ( Non twos-complement machines, no gradual underflow;
537 ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
538 LEMIN = NGPMIN - 1 + LT
540 * ( Non twos-complement machines, with gradual underflow;
541 * e.g., IEEE standard followers )
543 LEMIN = MIN( NGPMIN, GPMIN )
544 * ( A guess; no known machine )
548 ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
549 IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
550 LEMIN = MAX( NGPMIN, NGNMIN )
551 * ( Twos-complement machines, no gradual underflow;
554 LEMIN = MIN( NGPMIN, NGNMIN )
555 * ( A guess; no known machine )
559 ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
560 $ ( GPMIN.EQ.GNMIN ) ) THEN
561 IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
562 LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
563 * ( Twos-complement machines with gradual underflow;
566 LEMIN = MIN( NGPMIN, NGNMIN )
567 * ( A guess; no known machine )
572 LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
573 * ( A guess; no known machine )
578 * Comment out this if block if EMIN is ok
581 WRITE( 6, FMT = 9999 )LEMIN
585 * Assume IEEE arithmetic if we found denormalised numbers above,
586 * or if arithmetic seems to round in the IEEE style, determined
587 * in routine SLAMC1. A true IEEE machine should have both things
588 * true; however, faulty machines may have one or the other.
590 IEEE = IEEE .OR. LIEEE1
592 * Compute RMIN by successive division by BETA. We could compute
593 * RMIN as BASE**( EMIN - 1 ), but some machines underflow during
597 DO 30 I = 1, 1 - LEMIN
598 LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
601 * Finally, call SLAMC5 to compute EMAX and RMAX.
603 CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
617 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
619 $ ' If, after inspection, the value EMIN looks',
620 $ ' acceptable please comment out ',
621 $ / ' the IF block as marked within the code of routine',
622 $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
628 ************************************************************************
634 *> SLAMC3 is intended to force A and B to be stored prior to doing
635 *> the addition of A and B , for use in situations where optimizers
636 *> might hold one of these in a register.
643 *> The values A and B.
646 REAL FUNCTION SLAMC3( A, B )
648 * -- LAPACK auxiliary routine (version 3.7.0) --
649 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
652 * .. Scalar Arguments ..
655 * =====================================================================
657 * .. Executable Statements ..
667 ************************************************************************
673 *> SLAMC4 is a service routine for SLAMC2.
678 *> The minimum exponent before (gradual) underflow, computed by
679 *> setting A = START and dividing by BASE until the previous A
680 *> can not be recovered.
685 *> The starting point for determining EMIN.
690 *> The base of the machine.
693 SUBROUTINE SLAMC4( EMIN, START, BASE )
695 * -- LAPACK auxiliary routine (version 3.7.0) --
696 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
699 * .. Scalar Arguments ..
704 * =====================================================================
706 * .. Local Scalars ..
708 REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
710 * .. External Functions ..
714 * .. Executable Statements ..
721 B1 = SLAMC3( A*RBASE, ZERO )
726 *+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
727 * $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
729 IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
733 B1 = SLAMC3( A / BASE, ZERO )
734 C1 = SLAMC3( B1*BASE, ZERO )
739 B2 = SLAMC3( A*RBASE, ZERO )
740 C2 = SLAMC3( B2 / RBASE, ZERO )
755 ************************************************************************
761 *> SLAMC5 attempts to compute RMAX, the largest machine floating-point
762 *> number, without overflow. It assumes that EMAX + abs(EMIN) sum
763 *> approximately to a power of 2. It will fail on machines where this
764 *> assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
765 *> EMAX = 28718). It will also fail if the value supplied for EMIN is
766 *> too large (i.e. too close to zero), probably with overflow.
771 *> The base of floating-point arithmetic.
776 *> The number of base BETA digits in the mantissa of a
777 *> floating-point value.
782 *> The minimum exponent before (gradual) underflow.
787 *> A logical flag specifying whether or not the arithmetic
788 *> system is thought to comply with the IEEE standard.
793 *> The largest exponent before overflow
798 *> The largest machine floating-point number.
801 SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
803 * -- LAPACK auxiliary routine (version 3.7.0) --
804 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
807 * .. Scalar Arguments ..
809 INTEGER BETA, EMAX, EMIN, P
812 * =====================================================================
816 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
818 * .. Local Scalars ..
819 INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
820 REAL OLDY, RECBAS, Y, Z
822 * .. External Functions ..
826 * .. Intrinsic Functions ..
829 * .. Executable Statements ..
831 * First compute LEXP and UEXP, two powers of 2 that bound
832 * abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
833 * approximately to the bound that is closest to abs(EMIN).
834 * (EMAX is the exponent of the required number RMAX).
840 IF( TRY.LE.( -EMIN ) ) THEN
845 IF( LEXP.EQ.-EMIN ) THEN
852 * Now -LEXP is less than or equal to EMIN, and -UEXP is greater
853 * than or equal to EMIN. EXBITS is the number of bits needed to
854 * store the exponent.
856 IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
862 * EXPSUM is the exponent range, approximately equal to
865 EMAX = EXPSUM + EMIN - 1
866 NBITS = 1 + EXBITS + P
868 * NBITS is the total number of bits needed to store a
869 * floating-point number.
871 IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
873 * Either there are an odd number of bits used to store a
874 * floating-point number, which is unlikely, or some bits are
875 * not used in the representation of numbers, which is possible,
876 * (e.g. Cray machines) or the mantissa has an implicit bit,
877 * (e.g. IEEE machines, Dec Vax machines), which is perhaps the
878 * most likely. We have to assume the last alternative.
879 * If this is true, then we need to reduce EMAX by one because
880 * there must be some way of representing zero in an implicit-bit
881 * system. On machines like Cray, we are reducing EMAX by one
889 * Assume we are on an IEEE machine which reserves one exponent
890 * for infinity and NaN.
895 * Now create RMAX, the largest machine number, which should
896 * be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
898 * First compute 1.0 - BETA**(-P), being careful that the
899 * result is less than 1.0 .
913 * Now multiply by BETA**EMAX to get RMAX.
916 Y = SLAMC3( Y*BETA, ZERO )