ASMB,R,L,C
* 
*  **************************************************************** 
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS      * 
*  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,       * 
*  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT * 
*  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.        * 
*  **************************************************************** 
* 
*   NAME: PART OF MATH LIBRARY
*   SOURCE:  24998-18XXX  SEE NAM FOR LAST THREE DIGITS 
*   RELOC: PART OF 24998-12001
*   PGMR: BG & JTS
* 
      HED "SNGM" DOUBLE PRECISION TO REAL WITHOUT ROUNDING (DLB)
      NAM SNGM,6 24998-1X150 REV.2001 750701
      ENT SNGM
      EXT .ZPRV 
      SPC 1 
* 
*   THIS ROUTINE WILL CONVERT A DOUBLE PRECISION NUMBER (3 WORDS) 
*   TO A REAL NUMBER (2 WORDS) WITHOUT ROUNDING.  THIS MEANS THAT 
*   THE ABSOLUTE VALUE OF THE RESULTANT NUMBER WILL BE EQUAL OR 
*   LESS THAN THE ORIGIONAL NUMBER. MAX ERROR WILL BE LESS THAN 
*   ONE BIT. (LEAST SIGNIFICANT BIT OF THE REAL NUMBER) 
*   CALLABLE: 
*            JSB SNGM 
*            DEF *+2
*            DEF X
*            <RETURN> 
*   WHERE:
*            X = DOUBLE PRECISION (3 WORD) PARAMETER
*            A-REG & B-REG = REAL (2 WORD) RESULTS
*            NO ERROR RETURNS 
*   NOTE:  ZERO IS RETURNED IF LESS THAN ABS((-1+2**-23)*(2**-128)) 
* 
*   TIME: 
*            APPROX. TIME IS 70  2100 MACHINE CYCLES (100 MAX)
*            PLUS THE TIME TO EXECUTE PRIVLEGED PROCESSING. 
      SPC 1 
SNGM  NOP          ENTRY A&B = SNGM (X) 
      JSB .ZPRV 
      DEF LIBX
      LDA SNGM,I   WE CAN BEAT .ENTR
      ISZ SNGM     BUMP TO P+2
      LDB SNGM
      STA SNGM     PUT BACK THE RETURN ADDRESS
      LDB B,I       PICK UP CONTENTS OF P+2 
      RBL,CLE,SLB,ERB INDIRECTS?
      JMP *-2       YES, TRY AGAIN
      LDA B,I       GET FIRST WORD OF X 
      STA Y1        SAVE INTERNALLY 
      CLE,INB       GO GET NEXT WORD OF X 
      LDA B,I 
      AND OM400     MASK OFF BITS 24-31 
      STA Y2        SAVE LO-MAN OF REAL NUMB
      CPA B,I       NUMBER CHANGED? 
      CCE           NO, SKIP SETTING THE CHANGE FLAG
      CME,INB       YES, SET FLAG TO MEAN TRUNK BITS
      LDA B,I       LAST WORD=LO-MAN + EXP. 
      AND O377      GET EXP.
      STA Y3        SAVE EXPONENT.
      CPA B,I       CHANGED?
      RSS           NO, SKIP SETTING THE CHANGE FLAG
      CCE           YES, SET FLAG TO MEAN TRUNKED BITS
      LDA Y1        PICK UP HI-MAN. 
      LDB Y2        PICK LO-MAN FOR REAL VALUE
      SEZ,CLE,SSA   IF NEG. & TRUNKED BITS INCREMENT
      ADB O400      TO DECREASE ABS(X) VALUE
      SEZ,RSS       PROPAGATED CARRY? 
      JMP DONE      NO, DONE
      INA           YES, BUMP HI-MAN. 
      CPA O140K     BUMPED HI-MAN TO .5?
      JMP SPECL     YES, SPECIAL CASE 
DONE  ADB Y3        MIRGE IN EXPONENT 
LIBX  JMP SNGM,I   RETURN 
      DEF SNGM
      SPC 1 
SPECL LDA Y3        GET EXP.(MANT=-1 OR 0 IF EXP=-200)
      SLA,RAR       POSITION EXP
      IOR OM200     MIRGE IN BITS IF NEG. 
      CPA OM200     EXP = -200? 
      CCA,CLE,RSS   YES, RETURN Y = 0 
      CMA,CCE,INA 
      CMA 
      RAL           POSITION EXPONENT BACK
      AND O377      MASK OF NEG. BITS 
      STA B         SAVE IN B-REG.
      CLA           SET A=100000B OR = 0
      ERA           FORM HI-MANTISSA = -1 OR 0
      JMP LIBX      DONE
      SPC 1 
OM400 OCT -400
OM200 OCT -200
O377  OCT 377 
O400  OCT 400 
O140K OCT 140000
Y1    NOP 
Y2    NOP 
Y3    NOP 
B     EQU 1 
      END 
* 
                                                                                                                                                                                                                        