700
701
702
703
704
705
706
707 LOGICAL IEEE
708 INTEGER BETA, EMAX, EMIN, P
709 REAL RMAX
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748 REAL ZERO, ONE
749 parameter( zero = 0.0e0, one = 1.0e0 )
750
751
752 INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
753 REAL OLDY, RECBAS, Y, Z
754
755
756 REAL SLAMC3
758
759
760 INTRINSIC mod
761
762
763
764
765
766
767
768
769 lexp = 1
770 exbits = 1
771 10 CONTINUE
772 try = lexp*2
773 IF( try.LE.( -emin ) ) THEN
774 lexp = try
775 exbits = exbits + 1
776 GO TO 10
777 END IF
778 IF( lexp.EQ.-emin ) THEN
779 uexp = lexp
780 ELSE
781 uexp = try
782 exbits = exbits + 1
783 END IF
784
785
786
787
788
789 IF( ( uexp+emin ).GT.( -lexp-emin ) ) THEN
790 expsum = 2*lexp
791 ELSE
792 expsum = 2*uexp
793 END IF
794
795
796
797
798 emax = expsum + emin - 1
799 nbits = 1 + exbits + p
800
801
802
803
804 IF( ( mod( nbits, 2 ).EQ.1 ) .AND. ( beta.EQ.2 ) ) THEN
805
806
807
808
809
810
811
812
813
814
815
816
817 emax = emax - 1
818 END IF
819
820 IF( ieee ) THEN
821
822
823
824
825 emax = emax - 1
826 END IF
827
828
829
830
831
832
833
834 recbas = one / beta
835 z = beta - one
836 y = zero
837 DO 20 i = 1, p
838 z = z*recbas
839 IF( y.LT.one )
840 $ oldy = y
842 20 CONTINUE
843 IF( y.GE.one )
844 $ y = oldy
845
846
847
848 DO 30 i = 1, emax
849 y =
slamc3( y*beta, zero )
850 30 CONTINUE
851
852 rmax = y
853 RETURN
854
855
856