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 "SNGL" DOUBLE PRECISION TO REAL WITH ROUNDING (DLB) 
      NAM SNGL,6 24998-1X190 REV.2001 750701
      ENT SNGL
      EXT .ZPRV 
      SPC 1 
* 
*   THIS ROUTINE WILL CONVERT A DOUBLE PRECISION NUMBER (3 WORDS) 
*   TO A REAL NUMBER (2 WORDS) WITH ROUNDING.  THIS MEANS THAT
*   THE ABSOLUTE VALUE OF THE RESULTANT NUMBER WILL HAVE 1/2 THE
*   LEAST SIGNIFICANT BIT ADDED AND THEN THE NUMBER WILL BE 
*   TRUNCATED. MAX ERROR FROM DOUBLE PRECISION WILL BE LESS THAN
*   1/2 THE LEAST SIGNIFICANT BIT.
* 
*   CALLABLE: 
*            JSB SNGL 
*            DEF *+2
*            DEF X
*            <RETURN> 
*   WHERE:
*            X = DOUBLE PRECISION (3 WORD) PARAMETER
*            A-REG & B-REG = REAL (2 WORD) RESULTS
* 
*   ERRORS: IF X=> 1*2**127, THEN Y = (1-2**-23)*2**127 
*           AND O-REG. WILL BE SET
* 
*   TIME: 
*            APPROX. TIME IS 70  2100 MACHINE CYCLES (100 MAX)
*            PLUS THE TIME TO EXECUTE PRIVLEGED PROCESSING. 
      SPC 1 
SNGL  NOP          ENTRY A&B = SNGL (X) 
      JSB .ZPRV 
      DEF LIBX
      LDA SNGL,I   WE CAN BEAT .ENTR
      ISZ SNGL     BUMP TO P+2
      LDB SNGL
      STA SNGL     PUT BACK THE RETURN ADDRESS
      LDB B,I       PICK UP CONTENTS OF P+2 
      RBL,CLE,SLB,ERB INDIRECTS?+ (CLE) 
      JMP *-2       YES, TRY AGAIN
      STB ADDR      SAVE ADDRESS OF X 
      LDB ADDR,I    GET X(1)
      ISZ ADDR      BUMP TO X(2)
      LDA ADDR,I    GET X(2)
      STA Y2        SAVE TEMPORARY
      ISZ ADDR      BUMP TO X(3)
      LDA ADDR,I    GET X(3)
      AND O377      GET EXPONENT
      STA Y3        SAVE TEMPORARY
      CPA ADDR,I    TRUNCATED ANY BITS? 
      CCE           NO, CLEAR TRUNK FLAG. 
      LDA O177      PREPARE FOR ROUNDING
      SEZ,CLE,SSB,RSS IF NEG & NO BITS TRUNK, SKIP
      INA           IF POSITIVE OR TRUNKED BITS A=200B
      ADA Y2        ROUND 
      AND OM400     MASK OFF LO-BITS
      IOR Y3        MIRGE IN EXPONENT 
      SEZ,RSS       ROUND UP INTO HI-MAN IF E SET 
      JMP SWAPR     SWAP REGISTERS AND RETURN 
      CPB PINF      CHECK IF ROUND MANT TO 1. 
      JMP SPECP     YES, MANT = .5, EXP = EXP+1 
      INB           BUMP UP HI-MANT 
      CPB O140K     CHECK IF ROUND MANT TO -.5
      JMP SPECM     YES, MANT = -1., EXP = EXP-1
SWAPR SWP           SWAP A&B REGISTERS
      CLO           RETURN O-REG = 0
LIBX  JMP SNGL,I   RETURN 
      DEF SNGL
      SPC 1 
SPECM CLB           INIT B=0
      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   DECREMENT EXPONENT
      ERB           SET B=0 OR 100000B
      CMA 
CONTU RAL           POSITION EXPONENT BACK
      AND O377      MASK OFF NEG. BITS
      JMP SWAPR     DONE
      SPC 1 
SPECP LDB O40K      SET B=.5
      LDA Y3        GET EXPONENT
      SLA,RAR       POSITION
      IOR OM200     MIRGE IN NEG. BITS IF NEG 
      CPA O177      ALREADY MAX EXP?
      JMP PLINF     YES, SET TO +INF
      INA           BUMP
      JMP CONTU     RETURN
      SPC 1 
PLINF LDA PINF
      LDB PINF+1
      STO           SET THE O-REG FOR PLUS INFINITY 
      JMP LIBX      RETURN PLUS INF 
      SPC 1 
ADDR  NOP 
OM400 OCT -400
OM200 OCT -200
O377  OCT 377 
O177  OCT 177 
O40K  OCT 40000 
O140K OCT 140000
PINF  OCT 77777 
      OCT 177776
Y2    NOP 
Y3    NOP 
B     EQU 1 
*ASMB,R,L,C 
*      HED "SNGL" ROUND DOUBLE TO SINGLE PRECISION VALUEION 
*      NAM SNGL,6  PRE-REL 7-15-75 (DLB)
*      ENT SNGL 
*      EXT .ZPRV,.XFER,.FLUN,.PACK
*      SPC 1
* 
*      THREE WORD EXTENDED PRECISION NUMBERS ARE ROUNDED TO 
*      TWO WORD FLOATING POINT QUANTITIES. THE RESULT IS
*      RETURNED IN THE A AND B REGISTERS
*      CALLING SEQUENCE:
*      JSB SNGL 
*      DEF *+2
*      DEF X    (ARGUMENT:3 WORDS)
*       (RESULT IN A AND B REGISTERS) 
*      SPC 1
*SNGL  NOP
*      JSB .ZPRV
*      DEF LIBX 
*      ISZ SNGL 
*      LDA SNGL,I    GET ADDRESS OF X 
*      ISZ SNGL 
*      LDB .X1
*      JSB .XFER     MOVE ARGUMENT IN 
*      LDB X3 
*      JSB .FLUN     EXTRACT EXPONENT 
*      STA X4 
*      LDA X1 
*      CLE,SZB
*      CCE           ADD ROUND FOR NEG. # 
*      LDB X2        GET DBL LO-MAN+EXP 
*      SLB,RSS       IF LEAST BIT SET, NO NEED TO 
*      RBR,ELB       PROPAGATE. ELSE SET LEAST BIT
*      JSB .PACK     PACK IN EXPONENT 
*X4    NOP
*LIBX  JMP SNGL,I 
*      DEF SNGL 
*X1    NOP
*X2    NOP
*X3    NOP
*.X1   DEF X1 
*      END
      END 
                                                                                                                              