001:       REAL             FUNCTION SLAMCH( CMACH )
002: *
003: *  -- PLASMA auxiliary routine (version 2.1.0) --
004: *     Based on LAPACK SLAMCH but with Fortran 95 query functions
005: *     See: http://www.cs.utk.edu/~luszczek/lapack/lamch.html
006: *     and  http://www.netlib.org/lapack-dev/lapack-coding/program-style.html#id2537289
007: *     November 15th 2009
008: *
009: *     .. Scalar Arguments ..
010:       CHARACTER          CMACH
011: *     ..
012: *
013: *  Purpose
014: *  =======
015: *
016: *  SLAMCH determines single precision machine parameters.
017: *
018: *  Arguments
019: *  =========
020: *
021: *  CMACH   (input) CHARACTER*1
022: *          Specifies the value to be returned by SLAMCH:
023: *          = 'E' or 'e',   SLAMCH := eps
024: *          = 'S' or 's ,   SLAMCH := sfmin
025: *          = 'B' or 'b',   SLAMCH := base
026: *          = 'P' or 'p',   SLAMCH := eps*base
027: *          = 'N' or 'n',   SLAMCH := t
028: *          = 'R' or 'r',   SLAMCH := rnd
029: *          = 'M' or 'm',   SLAMCH := emin
030: *          = 'U' or 'u',   SLAMCH := rmin
031: *          = 'L' or 'l',   SLAMCH := emax
032: *          = 'O' or 'o',   SLAMCH := rmax
033: *
034: *          where
035: *
036: *          eps   = relative machine precision
037: *          sfmin = safe minimum, such that 1/sfmin does not overflow
038: *          base  = base of the machine
039: *          prec  = eps*base
040: *          t     = number of (base) digits in the mantissa
041: *          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
042: *          emin  = minimum exponent before (gradual) underflow
043: *          rmin  = underflow threshold - base**(emin-1)
044: *          emax  = largest exponent before overflow
045: *          rmax  = overflow threshold  - (base**emax)*(1-eps)
046: *
047: * =====================================================================
048: *
049: *     .. Parameters ..
050:       REAL               ONE, ZERO
051:       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
052: *     ..
053: *     .. Local Scalars ..
054:       REAL               RND, EPS, SFMIN, SMALL, RMACH
055: *     ..
056: *     .. External Functions ..
057:       LOGICAL            LSAME
058:       EXTERNAL           LSAME
059: *     ..
060: *     .. Intrinsic Functions ..
061:       INTRINSIC          DIGITS, EPSILON, HUGE, MAXEXPONENT,
062:      $                   MINEXPONENT, RADIX, TINY
063: *     ..
064: *     .. Executable Statements ..
065: *
066: *
067: *     Assume rounding, not chopping. Always.
068: *
069:       RND = ONE
070: *
071:       IF( ONE.EQ.RND ) THEN
072:          EPS = EPSILON(ZERO) * 0.5
073:       ELSE
074:          EPS = EPSILON(ZERO)
075:       END IF
076: *
077:       IF( LSAME( CMACH, 'E' ) ) THEN
078:          RMACH = EPS
079:       ELSE IF( LSAME( CMACH, 'S' ) ) THEN
080:          SFMIN = TINY(ZERO)
081:          SMALL = ONE / HUGE(ZERO)
082:          IF( SMALL.GE.SFMIN ) THEN
083: *
084: *           Use SMALL plus a bit, to avoid the possibility of rounding
085: *           causing overflow when computing  1/sfmin.
086: *
087:             SFMIN = SMALL*( ONE+EPS )
088:          END IF
089:          RMACH = SFMIN
090:       ELSE IF( LSAME( CMACH, 'B' ) ) THEN
091:          RMACH = RADIX(ZERO)
092:       ELSE IF( LSAME( CMACH, 'P' ) ) THEN
093:          RMACH = EPS * RADIX(ZERO)
094:       ELSE IF( LSAME( CMACH, 'N' ) ) THEN
095:          RMACH = DIGITS(ZERO)
096:       ELSE IF( LSAME( CMACH, 'R' ) ) THEN
097:          RMACH = RND
098:       ELSE IF( LSAME( CMACH, 'M' ) ) THEN
099:          RMACH = MINEXPONENT(ZERO)
100:       ELSE IF( LSAME( CMACH, 'U' ) ) THEN
101:          RMACH = tiny(zero)
102:       ELSE IF( LSAME( CMACH, 'L' ) ) THEN
103:          RMACH = MAXEXPONENT(ZERO)
104:       ELSE IF( LSAME( CMACH, 'O' ) ) THEN
105:          RMACH = HUGE(ZERO)
106:       ELSE
107:          RMACH = ZERO
108:       END IF
109: *
110:       SLAMCH = RMACH
111:       RETURN
112: *
113: *     End of SLAMCH
114: *
115:       END
116: