708
709
710
711
712
713
714
715 LOGICAL IEEE
716 INTEGER BETA, EMAX, EMIN, P
717 DOUBLE PRECISION RMAX
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
749
750
751
752
753
754
755
756 DOUBLE PRECISION ZERO, ONE
757 parameter( zero = 0.0d0, one = 1.0d0 )
758
759
760 INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
761 DOUBLE PRECISION OLDY, RECBAS, Y, Z
762
763
764 DOUBLE PRECISION DLAMC3
766
767
768 INTRINSIC mod
769
770
771
772
773
774
775
776
777 lexp = 1
778 exbits = 1
779 10 CONTINUE
780 try = lexp*2
781 IF( try.LE.( -emin ) ) THEN
782 lexp = try
783 exbits = exbits + 1
784 GO TO 10
785 END IF
786 IF( lexp.EQ.-emin ) THEN
787 uexp = lexp
788 ELSE
789 uexp = try
790 exbits = exbits + 1
791 END IF
792
793
794
795
796
797 IF( ( uexp+emin ).GT.( -lexp-emin ) ) THEN
798 expsum = 2*lexp
799 ELSE
800 expsum = 2*uexp
801 END IF
802
803
804
805
806 emax = expsum + emin - 1
807 nbits = 1 + exbits + p
808
809
810
811
812 IF( ( mod( nbits, 2 ).EQ.1 ) .AND. ( beta.EQ.2 ) ) THEN
813
814
815
816
817
818
819
820
821
822
823
824
825 emax = emax - 1
826 END IF
827
828 IF( ieee ) THEN
829
830
831
832
833 emax = emax - 1
834 END IF
835
836
837
838
839
840
841
842 recbas = one / beta
843 z = beta - one
844 y = zero
845 DO 20 i = 1, p
846 z = z*recbas
847 IF( y.LT.one )
848 $ oldy = y
850 20 CONTINUE
851 IF( y.GE.one )
852 $ y = oldy
853
854
855
856 DO 30 i = 1, emax
857 y =
dlamc3( y*beta, zero )
858 30 CONTINUE
859
860 rmax = y
861 RETURN
862
863
864