slamchf77.f

Go to the documentation of this file.

*> \brief \b SLAMCHF77 deprecated
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*      REAL FUNCTION SLAMCH( CMACH )
*
*     .. Scalar Arguments ..
*      CHARACTER          CMACH
*     ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLAMCH determines single precision machine parameters.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] CMACH
*> \verbatim
*>          Specifies the value to be returned by SLAMCH:
*>          = 'E' or 'e',   SLAMCH := eps
*>          = 'S' or 's ,   SLAMCH := sfmin
*>          = 'B' or 'b',   SLAMCH := base
*>          = 'P' or 'p',   SLAMCH := eps*base
*>          = 'N' or 'n',   SLAMCH := t
*>          = 'R' or 'r',   SLAMCH := rnd
*>          = 'M' or 'm',   SLAMCH := emin
*>          = 'U' or 'u',   SLAMCH := rmin
*>          = 'L' or 'l',   SLAMCH := emax
*>          = 'O' or 'o',   SLAMCH := rmax
*>          where
*>          eps   = relative machine precision
*>          sfmin = safe minimum, such that 1/sfmin does not overflow
*>          base  = base of the machine
*>          prec  = eps*base
*>          t     = number of (base) digits in the mantissa
*>          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*>          emin  = minimum exponent before (gradual) underflow
*>          rmin  = underflow threshold - base**(emin-1)
*>          emax  = largest exponent before overflow
*>          rmax  = overflow threshold  - (base**emax)*(1-eps)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      REAL function slamch( cmach )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          cmach
*     ..
*     .. Parameters ..
      REAL               one, zero
      parameter( one = 1.0e+0, zero = 0.0e+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            first, lrnd
      INTEGER            beta, imax, imin, it
      REAL               base, emax, emin, eps, prec, rmach, rmax, rmin,
     $                   rnd, sfmin, small, t
*     ..
*     .. External Functions ..
      LOGICAL            lsame
      EXTERNAL           lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           slamc2
*     ..
*     .. Save statement ..
      SAVE               first, eps, sfmin, base, t, rnd, emin, rmin,
     $                   emax, rmax, prec
*     ..
*     .. Data statements ..
      DATA               first / .true. /
*     ..
*     .. Executable Statements ..
*
      IF( first ) THEN
         CALL slamc2( beta, it, lrnd, eps, imin, rmin, imax, rmax )
         base = beta
         t = it
         IF( lrnd ) THEN
            rnd = one
            eps = ( base**( 1-it ) ) / 2
         ELSE
            rnd = zero
            eps = base**( 1-it )
         END IF
         prec = eps*base
         emin = imin
         emax = imax
         sfmin = rmin
         small = one / rmax
         IF( small.GE.sfmin ) THEN
*
*           Use SMALL plus a bit, to avoid the possibility of rounding
*           causing overflow when computing  1/sfmin.
*
            sfmin = small*( one+eps )
         END IF
      END IF
*
      IF( lsame( cmach, 'E' ) ) THEN
         rmach = eps
      ELSE IF( lsame( cmach, 'S' ) ) THEN
         rmach = sfmin
      ELSE IF( lsame( cmach, 'B' ) ) THEN
         rmach = base
      ELSE IF( lsame( cmach, 'P' ) ) THEN
         rmach = prec
      ELSE IF( lsame( cmach, 'N' ) ) THEN
         rmach = t
      ELSE IF( lsame( cmach, 'R' ) ) THEN
         rmach = rnd
      ELSE IF( lsame( cmach, 'M' ) ) THEN
         rmach = emin
      ELSE IF( lsame( cmach, 'U' ) ) THEN
         rmach = rmin
      ELSE IF( lsame( cmach, 'L' ) ) THEN
         rmach = emax
      ELSE IF( lsame( cmach, 'O' ) ) THEN
         rmach = rmax
      END IF
*
      slamch = rmach
      first  = .false.
      RETURN
*
*     End of SLAMCH
*
      END
*
************************************************************************
*
*> \brief \b SLAMC1
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC1 determines the machine parameters given by BETA, T, RND, and
*> IEEE1.
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*>          The base of the machine.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          The number of ( BETA ) digits in the mantissa.
*> \endverbatim
*>
*> \param[out] RND
*> \verbatim
*>          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.
*> \endverbatim
*>
*> \param[out] IEEE1
*> \verbatim
*>          Specifies whether rounding appears to be done in the IEEE
*>          'round to nearest' style.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \ingroup auxOTHERauxiliary
*>
*> \details \b Further \b Details
*> \verbatim
*>
*>  The routine is based on the routine  ENVRON  by Malcolm and
*>  incorporates suggestions by Gentleman and Marovich. See
*>
*>     Malcolm M. A. (1972) Algorithms to reveal properties of
*>        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
*>
*>     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
*>        that reveal properties of floating point arithmetic units.
*>        Comms. of the ACM, 17, 276-277.
*> \endverbatim
*>
      SUBROUTINE slamc1( BETA, T, RND, IEEE1 )
*
*  -- LAPACK auxiliary routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
*     ..
* =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      REAL               A, B, C, F, ONE, QTR, SAVEC, T1, T2
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           slamc3
*     ..
*     .. Save statement ..
      SAVE               first, lieee1, lbeta, lrnd, lt
*     ..
*     .. Data statements ..
      DATA               first / .true. /
*     ..
*     .. Executable Statements ..
*
      IF( first ) THEN
         one = 1
*
*        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
*        IEEE1, T and RND.
*
*        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.
*
*        Compute  a = 2.0**m  with the  smallest positive integer m such
*        that
*
*           fl( a + 1.0 ) = a.
*
         a = 1
         c = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( c.EQ.one ) THEN
            a = 2*a
            c = slamc3( a, one )
            c = slamc3( c, -a )
            GO TO 10
         END IF
*+       END WHILE
*
*        Now compute  b = 2.0**m  with the smallest positive integer m
*        such that
*
*           fl( a + b ) .gt. a.
*
         b = 1
         c = slamc3( a, b )
*
*+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( c.EQ.a ) THEN
            b = 2*b
            c = slamc3( a, b )
            GO TO 20
         END IF
*+       END WHILE
*
*        Now compute the base.  a and c  are neighbouring floating point
*        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
*        their difference is beta. Adding 0.25 to c is to ensure that it
*        is truncated to beta and not ( beta - 1 ).
*
         qtr = one / 4
         savec = c
         c = slamc3( c, -a )
         lbeta = c + qtr
*
*        Now determine whether rounding or chopping occurs,  by adding a
*        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
*
         b = lbeta
         f = slamc3( b / 2, -b / 100 )
         c = slamc3( f, a )
         IF( c.EQ.a ) THEN
            lrnd = .true.
         ELSE
            lrnd = .false.
         END IF
         f = slamc3( b / 2, b / 100 )
         c = slamc3( f, a )
         IF( ( lrnd ) .AND. ( c.EQ.a ) )
     $      lrnd = .false.
*
*        Try and decide whether rounding is done in the  IEEE  'round to
*        nearest' style. B/2 is half a unit in the last place of the two
*        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
*        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
*        A, but adding B/2 to SAVEC should change SAVEC.
*
         t1 = slamc3( b / 2, a )
         t2 = slamc3( b / 2, savec )
         lieee1 = ( t1.EQ.a ) .AND. ( t2.GT.savec ) .AND. lrnd
*
*        Now find  the  mantissa, t.  It should  be the  integer part of
*        log to the base beta of a,  however it is safer to determine  t
*        by powering.  So we find t as the smallest positive integer for
*        which
*
*           fl( beta**t + 1.0 ) = 1.0.
*
         lt = 0
         a = 1
         c = 1
*
*+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( c.EQ.one ) THEN
            lt = lt + 1
            a = a*lbeta
            c = slamc3( a, one )
            c = slamc3( c, -a )
            GO TO 30
         END IF
*+       END WHILE
*
      END IF
*
      beta = lbeta
      t = lt
      rnd = lrnd
      ieee1 = lieee1
      first = .false.
      RETURN
*
*     End of SLAMC1
*
      END
*
************************************************************************
*
*> \brief \b SLAMC2
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC2 determines the machine parameters specified in its argument
*> list.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \ingroup auxOTHERauxiliary
*>
*> \param[out] BETA
*> \verbatim
*>          The base of the machine.
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          The number of ( BETA ) digits in the mantissa.
*> \endverbatim
*>
*> \param[out] RND
*> \verbatim
*>          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.
*> \endverbatim
*>
*> \param[out] EPS
*> \verbatim
*>          The smallest positive number such that
*>             fl( 1.0 - EPS ) .LT. 1.0,
*>          where fl denotes the computed value.
*> \endverbatim
*>
*> \param[out] EMIN
*> \verbatim
*>          The minimum exponent before (gradual) underflow occurs.
*> \endverbatim
*>
*> \param[out] RMIN
*> \verbatim
*>          The smallest normalized number for the machine, given by
*>          BASE**( EMIN - 1 ), where  BASE  is the floating point value
*>          of BETA.
*> \endverbatim
*>
*> \param[out] EMAX
*> \verbatim
*>          The maximum exponent before overflow occurs.
*> \endverbatim
*>
*> \param[out] RMAX
*> \verbatim
*>          The largest positive number for the machine, given by
*>          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
*>          value of BETA.
*> \endverbatim
*>
*> \details \b Further \b Details
*> \verbatim
*>
*>  The computation of  EPS  is based on a routine PARANOIA by
*>  W. Kahan of the University of California at Berkeley.
*> \endverbatim
      SUBROUTINE slamc2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*
*     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      REAL               EPS, RMAX, RMIN
*     ..
* =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
     $                   NGNMIN, NGPMIN
      REAL               A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
     $                   SIXTH, SMALL, THIRD, TWO, ZERO
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           slamc3
*     ..
*     .. External Subroutines ..
      EXTERNAL           slamc1, slamc4, slamc5
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, min
*     ..
*     .. Save statement ..
      SAVE               first, iwarn, lbeta, lemax, lemin, leps, lrmax,
     $                   lrmin, lt
*     ..
*     .. Data statements ..
      DATA               first / .true. / , iwarn / .false. /
*     ..
*     .. Executable Statements ..
*
      IF( first ) THEN
         zero = 0
         one = 1
         two = 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 )
*
*        Start to find EPS.
*
         b = lbeta
         a = b**( -lt )
         leps = a
*
*        Try some tricks to see whether or not this is the correct  EPS.
*
         b = two / 3
         half = one / 2
         sixth = slamc3( b, -half )
         third = slamc3( sixth, sixth )
         b = slamc3( third, -half )
         b = slamc3( b, sixth )
         b = abs( b )
         IF( b.LT.leps )
     $      b = leps
*
         leps = 1
*
*+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( leps.GT.b ) .AND. ( b.GT.zero ) ) THEN
            leps = b
            c = slamc3( half*leps, ( two**5 )*( leps**2 ) )
            c = slamc3( half, -c )
            b = slamc3( half, c )
            c = slamc3( half, -b )
            b = slamc3( half, c )
            GO TO 10
         END IF
*+       END WHILE
*
         IF( a.LT.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
         DO 20 i = 1, 3
            small = slamc3( small*rbase, zero )
   20    CONTINUE
         a = slamc3( one, small )
         CALL slamc4( ngpmin, one, lbeta )
         CALL slamc4( ngnmin, -one, lbeta )
         CALL slamc4( gpmin, a, lbeta )
         CALL slamc4( gnmin, -a, lbeta )
         ieee = .false.
*
         IF( ( ngpmin.EQ.ngnmin ) .AND. ( gpmin.EQ.gnmin ) ) THEN
            IF( ngpmin.EQ.gpmin ) THEN
               lemin = ngpmin
*            ( Non twos-complement machines, no gradual underflow;
*              e.g.,  VAX )
            ELSE IF( ( gpmin-ngpmin ).EQ.3 ) THEN
               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.
            END IF
*
         ELSE IF( ( ngpmin.EQ.gpmin ) .AND. ( ngnmin.EQ.gnmin ) ) THEN
            IF( abs( ngpmin-ngnmin ).EQ.1 ) THEN
               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.
            END IF
*
         ELSE IF( ( abs( ngpmin-ngnmin ).EQ.1 ) .AND.
     $            ( gpmin.EQ.gnmin ) ) THEN
            IF( ( gpmin-min( ngpmin, ngnmin ) ).EQ.3 ) THEN
               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.
            END IF
*
         ELSE
            lemin = min( ngpmin, ngnmin, gpmin, gnmin )
*         ( A guess; no known machine )
            iwarn = .true.
         END IF
         first = .false.
***
* Comment out this if block if EMIN is ok
         IF( iwarn ) THEN
            first = .true.
            WRITE( 6, fmt = 9999 )lemin
         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
*
*        Compute  RMIN by successive division by  BETA. We could compute
*        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
*        this computation.
*
         lrmin = 1
         DO 30 i = 1, 1 - lemin
            lrmin = slamc3( lrmin*rbase, zero )
   30    CONTINUE
*
*        Finally, call SLAMC5 to compute EMAX and RMAX.
*
         CALL slamc5( lbeta, lt, lemin, ieee, lemax, lrmax )
      END IF
*
      beta = lbeta
      t = lt
      rnd = lrnd
      eps = leps
      emin = lemin
      rmin = lrmin
      emax = lemax
      rmax = lrmax
*
      RETURN
*
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
     $      '  EMIN = ', i8, /
     $      ' If, after inspection, the value EMIN looks',
     $      ' acceptable please comment out ',
     $      / ' the IF block as marked within the code of routine',
     $      ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
*
*     End of SLAMC2
*
      END
*
************************************************************************
*
*> \brief \b SLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC3  is intended to force  A  and  B  to be stored prior to doing
*> the addition of  A  and  B ,  for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*>
*> \param[in] A
*>
*> \param[in] B
*> \verbatim
*>          The values A and B.
*> \endverbatim
 
      REAL function slamc3( a, b )
*
*  -- LAPACK auxiliary routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*
*     .. Scalar Arguments ..
      REAL               a, b
*     ..
* =====================================================================
*
*     .. Executable Statements ..
*
      slamc3 = a + b
*
      RETURN
*
*     End of SLAMC3
*
      END
*
************************************************************************
*
*> \brief \b SLAMC4
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC4 is a service routine for SLAMC2.
*> \endverbatim
*>
*> \param[out] EMIN
*> \verbatim
*>          The minimum exponent before (gradual) underflow, computed by
*>          setting A = START and dividing by BASE until the previous A
*>          can not be recovered.
*> \endverbatim
*>
*> \param[in] START
*> \verbatim
*>          The starting point for determining EMIN.
*> \endverbatim
*>
*> \param[in] BASE
*> \verbatim
*>          The base of the machine.
*> \endverbatim
*>
      SUBROUTINE slamc4( EMIN, START, BASE )
*
*  -- LAPACK auxiliary routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*
*     .. Scalar Arguments ..
      INTEGER            BASE
      INTEGER            EMIN
      REAL               START
*     ..
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I
      REAL               A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           slamc3
*     ..
*     .. Executable Statements ..
*
      a = start
      one = 1
      rbase = one / base
      zero = 0
      emin = 1
      b1 = slamc3( a*rbase, zero )
      c1 = a
      c2 = a
      d1 = a
      d2 = a
*+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
*    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( c1.EQ.a ) .AND. ( c2.EQ.a ) .AND. ( d1.EQ.a ) .AND.
     $    ( d2.EQ.a ) ) THEN
         emin = emin - 1
         a = b1
         b1 = slamc3( a / base, zero )
         c1 = slamc3( b1*base, zero )
         d1 = zero
         DO 20 i = 1, base
            d1 = d1 + b1
   20    CONTINUE
         b2 = slamc3( a*rbase, zero )
         c2 = slamc3( b2 / rbase, zero )
         d2 = zero
         DO 30 i = 1, base
            d2 = d2 + b2
   30    CONTINUE
         GO TO 10
      END IF
*+    END WHILE
*
      RETURN
*
*     End of SLAMC4
*
      END
*
************************************************************************
*
*> \brief \b SLAMC5
*> \details
*> \b Purpose:
*> \verbatim
*> SLAMC5 attempts to compute RMAX, the largest machine floating-point
*> number, without overflow.  It assumes that EMAX + abs(EMIN) sum
*> approximately to a power of 2.  It will fail on machines where this
*> assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
*> EMAX = 28718).  It will also fail if the value supplied for EMIN is
*> too large (i.e. too close to zero), probably with overflow.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          The base of floating-point arithmetic.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          The number of base BETA digits in the mantissa of a
*>          floating-point value.
*> \endverbatim
*>
*> \param[in] EMIN
*> \verbatim
*>          The minimum exponent before (gradual) underflow.
*> \endverbatim
*>
*> \param[in] IEEE
*> \verbatim
*>          A logical flag specifying whether or not the arithmetic
*>          system is thought to comply with the IEEE standard.
*> \endverbatim
*>
*> \param[out] EMAX
*> \verbatim
*>          The largest exponent before overflow
*> \endverbatim
*>
*> \param[out] RMAX
*> \verbatim
*>          The largest machine floating-point number.
*> \endverbatim
*>
      SUBROUTINE slamc5( BETA, P, EMIN, IEEE, EMAX, RMAX )
*
*  -- LAPACK auxiliary routine --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*
*     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      REAL               RMAX
*     ..
* =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e0, one = 1.0e0 )
*     ..
*     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      REAL               OLDY, RECBAS, Y, Z
*     ..
*     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           slamc3
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          mod
*     ..
*     .. Executable Statements ..
*
*     First compute LEXP and UEXP, two powers of 2 that bound
*     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
*     approximately to the bound that is closest to abs(EMIN).
*     (EMAX is the exponent of the required number RMAX).
*
      lexp = 1
      exbits = 1
   10 CONTINUE
      try = lexp*2
      IF( try.LE.( -emin ) ) THEN
         lexp = try
         exbits = exbits + 1
         GO TO 10
      END IF
      IF( lexp.EQ.-emin ) THEN
         uexp = lexp
      ELSE
         uexp = try
         exbits = exbits + 1
      END IF
*
*     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
*     than or equal to EMIN. EXBITS is the number of bits needed to
*     store the exponent.
*
      IF( ( uexp+emin ).GT.( -lexp-emin ) ) THEN
         expsum = 2*lexp
      ELSE
         expsum = 2*uexp
      END IF
*
*     EXPSUM is the exponent range, approximately equal to
*     EMAX - EMIN + 1 .
*
      emax = expsum + emin - 1
      nbits = 1 + exbits + p
*
*     NBITS is the total number of bits needed to store a
*     floating-point number.
*
      IF( ( mod( nbits, 2 ).EQ.1 ) .AND. ( beta.EQ.2 ) ) THEN
*
*        Either there are an odd number of bits used to store a
*        floating-point number, which is unlikely, or some bits are
*        not used in the representation of numbers, which is possible,
*        (e.g. Cray machines) or the mantissa has an implicit bit,
*        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
*        most likely. We have to assume the last alternative.
*        If this is true, then we need to reduce EMAX by one because
*        there must be some way of representing zero in an implicit-bit
*        system. On machines like Cray, we are reducing EMAX by one
*        unnecessarily.
*
         emax = emax - 1
      END IF
*
      IF( ieee ) THEN
*
*        Assume we are on an IEEE machine which reserves one exponent
*        for infinity and NaN.
*
         emax = emax - 1
      END IF
*
*     Now create RMAX, the largest machine number, which should
*     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
*
*     First compute 1.0 - BETA**(-P), being careful that the
*     result is less than 1.0 .
*
      recbas = one / beta
      z = beta - one
      y = zero
      DO 20 i = 1, p
         z = z*recbas
         IF( y.LT.one )
     $      oldy = y
         y = slamc3( y, z )
   20 CONTINUE
      IF( y.GE.one )
     $   y = oldy
*
*     Now multiply by BETA**EMAX to get RMAX.
*
      DO 30 i = 1, emax
         y = slamc3( y*beta, zero )
   30 CONTINUE
*
      rmax = y
      RETURN
*
*     End of SLAMC5
*
      END