1 DOUBLE PRECISION FUNCTION dlamch( CMACH )
49 DOUBLE PRECISION one, zero
50 parameter( one = 1.0d+0, zero = 0.0d+0 )
54 INTEGER beta, imax, imin, it
55 DOUBLE PRECISION base, emax, emin, eps, prec, rmach, rmax, rmin,
56 $ rnd, sfmin, small, t
66 SAVE first, eps, sfmin, base, t, rnd, emin, rmin,
76 CALL dlamc2( beta, it, lrnd, eps, imin, rmin, imax, rmax )
81 eps = ( base**( 1-it ) ) / 2
91 IF( small.GE.sfmin )
THEN
96 sfmin = small*( one+eps )
100 IF(
lsame( cmach,
'E' ) )
THEN
102 ELSE IF(
lsame( cmach,
'S' ) )
THEN
104 ELSE IF(
lsame( cmach,
'B' ) )
THEN
106 ELSE IF(
lsame( cmach,
'P' ) )
THEN
108 ELSE IF(
lsame( cmach,
'N' ) )
THEN
110 ELSE IF(
lsame( cmach,
'R' ) )
THEN
112 ELSE IF(
lsame( cmach,
'M' ) )
THEN
114 ELSE IF(
lsame( cmach,
'U' ) )
THEN
116 ELSE IF(
lsame( cmach,
'L' ) )
THEN
118 ELSE IF(
lsame( cmach,
'O' ) )
THEN
184 LOGICAL FIRST, LIEEE1, LRND
186 DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
189 DOUBLE PRECISION DLAMC3
193 SAVE first, lieee1, lbeta, lrnd, lt
196 DATA first / .true. /
260 f = dlamc3( b / 2, -b / 100 )
267 f = dlamc3( b / 2, b / 100 )
269 IF( ( lrnd ) .AND. ( c.EQ.a ) )
278 t1 = dlamc3( b / 2, a )
279 t2 = dlamc3( b / 2, savec )
280 lieee1 = ( t1.EQ.a ) .AND. ( t2.GT.savec ) .AND. lrnd
318 SUBROUTINE dlamc2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
327 INTEGER BETA, EMAX, EMIN, T
328 DOUBLE PRECISION EPS, RMAX, RMIN
384 LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
385 INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
387 DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
388 $ SIXTH, SMALL, THIRD, TWO, ZERO
391 DOUBLE PRECISION DLAMC3
398 INTRINSIC abs, max, min
401 SAVE first, iwarn, lbeta, lemax, lemin, leps, lrmax,
405 DATA first / .true. / , iwarn / .false. /
424 CALL dlamc1( lbeta, lt, lrnd, lieee1 )
436 sixth = dlamc3( b, -half )
437 third = dlamc3( sixth, sixth )
438 b = dlamc3( third, -half )
439 b = dlamc3( b, sixth )
448 IF( ( leps.GT.b ) .AND. ( b.GT.zero ) )
THEN
450 c = dlamc3( half*leps, ( two**5 )*( leps**2 ) )
451 c = dlamc3( half, -c )
452 b = dlamc3( half, c )
453 c = dlamc3( half, -b )
454 b = dlamc3( half, c )
471 small = dlamc3( small*rbase, zero )
473 a = dlamc3( one, small )
474 CALL dlamc4( ngpmin, one, lbeta )
475 CALL dlamc4( ngnmin, -one, lbeta )
476 CALL dlamc4( gpmin, a, lbeta )
477 CALL dlamc4( gnmin, -a, lbeta )
480 IF( ( ngpmin.EQ.ngnmin ) .AND. ( gpmin.EQ.gnmin ) )
THEN
481 IF( ngpmin.EQ.gpmin )
THEN
485 ELSE IF( ( gpmin-ngpmin ).EQ.3 )
THEN
486 lemin = ngpmin - 1 + lt
491 lemin = min( ngpmin, gpmin )
496 ELSE IF( ( ngpmin.EQ.gpmin ) .AND. ( ngnmin.EQ.gnmin ) )
THEN
497 IF( abs( ngpmin-ngnmin ).EQ.1 )
THEN
498 lemin = max( ngpmin, ngnmin )
502 lemin = min( ngpmin, ngnmin )
507 ELSE IF( ( abs( ngpmin-ngnmin ).EQ.1 ) .AND.
508 $ ( gpmin.EQ.gnmin ) )
THEN
509 IF( ( gpmin-min( ngpmin, ngnmin ) ).EQ.3 )
THEN
510 lemin = max( ngpmin, ngnmin ) - 1 + lt
514 lemin = min( ngpmin, ngnmin )
520 lemin = min( ngpmin, ngnmin, gpmin, gnmin )
528 WRITE( 6, fmt = 9999 )lemin
537 ieee = ieee .OR. lieee1
544 DO 30 i = 1, 1 - lemin
545 lrmin = dlamc3( lrmin*rbase, zero )
550 CALL dlamc5( lbeta, lt, lemin, ieee, lemax, lrmax )
564 9999
FORMAT( / /
' WARNING. The value EMIN may be incorrect:-',
566 $
' If, after inspection, the value EMIN looks',
567 $
' acceptable please comment out ',
568 $ /
' the IF block as marked within the code of routine',
569 $
' DLAMC2,', /
' otherwise supply EMIN explicitly.', / )
585 DOUBLE PRECISION a, b
624 DOUBLE PRECISION START
650 DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
653 DOUBLE PRECISION DLAMC3
663 b1 = dlamc3( a*rbase, zero )
671 IF( ( c1.EQ.a ) .AND. ( c2.EQ.a ) .AND. ( d1.EQ.a ) .AND.
675 b1 = dlamc3( a / base, zero )
676 c1 = dlamc3( b1*base, zero )
681 b2 = dlamc3( a*rbase, zero )
682 c2 = dlamc3( b2 / rbase, zero )
699 SUBROUTINE dlamc5( BETA, P, EMIN, IEEE, EMAX, RMAX )
708 INTEGER BETA, EMAX, EMIN, P
709 DOUBLE PRECISION RMAX
748 DOUBLE PRECISION ZERO, ONE
749 parameter( zero = 0.0d0, one = 1.0d0 )
752 INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
753 DOUBLE PRECISION OLDY, RECBAS, Y, Z
756 DOUBLE PRECISION DLAMC3
773 IF( try.LE.( -emin ) )
THEN
778 IF( lexp.EQ.-emin )
THEN
789 IF( ( uexp+emin ).GT.( -lexp-emin ) )
THEN
798 emax = expsum + emin - 1
799 nbits = 1 + exbits + p
804 IF( ( mod( nbits, 2 ).EQ.1 ) .AND. ( beta.EQ.2 ) )
THEN
849 y = dlamc3( y*beta, zero )
double precision function dlamch(CMACH)
subroutine dlamc2(BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX)
subroutine dlamc5(BETA, P, EMIN, IEEE, EMAX, RMAX)
subroutine dlamc1(BETA, T, RND, IEEE1)
subroutine dlamc4(EMIN, START, BASE)
double precision function dlamc3(A, B)
logical function lsame(CA, CB)