LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ slamc2()

subroutine slamc2 ( integer  BETA,
integer  T,
logical  RND,
real  EPS,
integer  EMIN,
real  RMIN,
integer  EMAX,
real  RMAX 
)

SLAMC2

Purpose:

 SLAMC2 determines the machine parameters specified in its argument
 list.
Author
LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
Date
April 2012
Parameters
[out]BETA
          The base of the machine.
[out]T
          The number of ( BETA ) digits in the mantissa.
[out]RND
          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.
[out]EPS
          The smallest positive number such that
             fl( 1.0 - EPS ) .LT. 1.0,
          where fl denotes the computed value.
[out]EMIN
          The minimum exponent before (gradual) underflow occurs.
[out]RMIN
          The smallest normalized number for the machine, given by
          BASE**( EMIN - 1 ), where  BASE  is the floating point value
          of BETA.
[out]EMAX
          The maximum exponent before overflow occurs.
[out]RMAX
          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.

Definition at line 424 of file slamchf77.f.

424 *
425 * -- LAPACK auxiliary routine (version 3.7.0) --
426 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
427 * November 2010
428 *
429 * .. Scalar Arguments ..
430  LOGICAL rnd
431  INTEGER beta, emax, emin, t
432  REAL eps, rmax, rmin
433 * ..
434 * =====================================================================
435 *
436 * .. Local Scalars ..
437  LOGICAL first, ieee, iwarn, lieee1, lrnd
438  INTEGER gnmin, gpmin, i, lbeta, lemax, lemin, lt,
439  $ ngnmin, ngpmin
440  REAL a, b, c, half, leps, lrmax, lrmin, one, rbase,
441  $ sixth, small, third, two, zero
442 * ..
443 * .. External Functions ..
444  REAL slamc3
445  EXTERNAL slamc3
446 * ..
447 * .. External Subroutines ..
448  EXTERNAL slamc1, slamc4, slamc5
449 * ..
450 * .. Intrinsic Functions ..
451  INTRINSIC abs, max, min
452 * ..
453 * .. Save statement ..
454  SAVE first, iwarn, lbeta, lemax, lemin, leps, lrmax,
455  $ lrmin, lt
456 * ..
457 * .. Data statements ..
458  DATA first / .true. / , iwarn / .false. /
459 * ..
460 * .. Executable Statements ..
461 *
462  IF( first ) THEN
463  zero = 0
464  one = 1
465  two = 2
466 *
467 * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
468 * BETA, T, RND, EPS, EMIN and RMIN.
469 *
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.
473 *
474 * SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
475 *
476  CALL slamc1( lbeta, lt, lrnd, lieee1 )
477 *
478 * Start to find EPS.
479 *
480  b = lbeta
481  a = b**( -lt )
482  leps = a
483 *
484 * Try some tricks to see whether or not this is the correct EPS.
485 *
486  b = two / 3
487  half = one / 2
488  sixth = slamc3( b, -half )
489  third = slamc3( sixth, sixth )
490  b = slamc3( third, -half )
491  b = slamc3( b, sixth )
492  b = abs( b )
493  IF( b.LT.leps )
494  $ b = leps
495 *
496  leps = 1
497 *
498 *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
499  10 CONTINUE
500  IF( ( leps.GT.b ) .AND. ( b.GT.zero ) ) THEN
501  leps = b
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 )
507  GO TO 10
508  END IF
509 *+ END WHILE
510 *
511  IF( a.LT.leps )
512  $ leps = a
513 *
514 * Computation of EPS complete.
515 *
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.
519 *
520  rbase = one / lbeta
521  small = one
522  DO 20 i = 1, 3
523  small = slamc3( small*rbase, zero )
524  20 CONTINUE
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 )
530  ieee = .false.
531 *
532  IF( ( ngpmin.EQ.ngnmin ) .AND. ( gpmin.EQ.gnmin ) ) THEN
533  IF( ngpmin.EQ.gpmin ) THEN
534  lemin = ngpmin
535 * ( Non twos-complement machines, no gradual underflow;
536 * e.g., VAX )
537  ELSE IF( ( gpmin-ngpmin ).EQ.3 ) THEN
538  lemin = ngpmin - 1 + lt
539  ieee = .true.
540 * ( Non twos-complement machines, with gradual underflow;
541 * e.g., IEEE standard followers )
542  ELSE
543  lemin = min( ngpmin, gpmin )
544 * ( A guess; no known machine )
545  iwarn = .true.
546  END IF
547 *
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;
552 * e.g., CYBER 205 )
553  ELSE
554  lemin = min( ngpmin, ngnmin )
555 * ( A guess; no known machine )
556  iwarn = .true.
557  END IF
558 *
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;
564 * no known machine )
565  ELSE
566  lemin = min( ngpmin, ngnmin )
567 * ( A guess; no known machine )
568  iwarn = .true.
569  END IF
570 *
571  ELSE
572  lemin = min( ngpmin, ngnmin, gpmin, gnmin )
573 * ( A guess; no known machine )
574  iwarn = .true.
575  END IF
576  first = .false.
577 ***
578 * Comment out this if block if EMIN is ok
579  IF( iwarn ) THEN
580  first = .true.
581  WRITE( 6, fmt = 9999 )lemin
582  END IF
583 ***
584 *
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.
589 *
590  ieee = ieee .OR. lieee1
591 *
592 * Compute RMIN by successive division by BETA. We could compute
593 * RMIN as BASE**( EMIN - 1 ), but some machines underflow during
594 * this computation.
595 *
596  lrmin = 1
597  DO 30 i = 1, 1 - lemin
598  lrmin = slamc3( lrmin*rbase, zero )
599  30 CONTINUE
600 *
601 * Finally, call SLAMC5 to compute EMAX and RMAX.
602 *
603  CALL slamc5( lbeta, lt, lemin, ieee, lemax, lrmax )
604  END IF
605 *
606  beta = lbeta
607  t = lt
608  rnd = lrnd
609  eps = leps
610  emin = lemin
611  rmin = lrmin
612  emax = lemax
613  rmax = lrmax
614 *
615  RETURN
616 *
617  9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
618  $ ' EMIN = ', i8, /
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.', / )
623 *
624 * End of SLAMC2
625 *
subroutine slamc1(BETA, T, RND, IEEE1)
SLAMC1
Definition: slamchf77.f:211
subroutine slamc4(EMIN, START, BASE)
SLAMC4
Definition: slamchf77.f:694
real function slamc3(A, B)
SLAMC3
Definition: slamch.f:172
subroutine slamc5(BETA, P, EMIN, IEEE, EMAX, RMAX)
SLAMC5
Definition: slamchf77.f:802
Here is the call graph for this function:
Here is the caller graph for this function: