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 ".XPAK" EXTENDED PRECISION PACKING ROUTINE
      NAM .XPAK,6 24998-1X195 REV.2001 750701 
      ENT .XPAK 
      EXT .ZPRV 
      SPC 1 
* 
*     THIS ROUTINE NORMALIZES AND PACKS EXTENDED PRECISION NUMBERS. 
*     CALLING SEQUENCE: 
*         LDA (EXPONENT)
*         JSB .XPAK 
*         DEF X (MANTISSA, 3 WORDS) 
*     RETURN: X CONTAINS THE RESULT 
      SPC 1 
X1    NOP 
X2    NOP 
X3    NOP 
EXPON NOP 
SCNT  NOP 
.XPAK NOP 
      JSB .ZPRV 
      DEF LIBX
      STA EXPON     SAVE EXPONENT 
      CLA 
      STA SCNT      SET SHIFT COUNT = 0 
      LDA .XPAK     GET P+1 DIRECT ADDRESS
      LDA A,I       AND SAVE IN X1,X2,X3
      RAL,CLE,SLA,ERA INDIRECT? 
      JMP *-2       YES, TRY NEXT LEVEL 
      STA X1        NO, SAVE AS POINTER 
      INA 
      STA X2
      INA 
      STA X3        SAVE POINTERS FOR ALL 3 
      LDA X1,I
      LDB X2,I      IF THE MANTISSA = 0 
      SZA,RSS        THEN RETURN IMMEDIATELY
      SZB 
      JMP NORML     OTHERWISE, NORMALIZE
      LDA X3,I
      SZA,RSS 
      JMP RETRN 
      RSS 
      SPC 1 
*                  * NORMALIZING SECTION *
      SPC 1 
SHIFT ISZ SCNT      COUNT THE # OF LEFT SHIFTS
NORML LDA X3,I      TRIPLE REGISTER E LEFT ROTATE 
      CLE,ELA 
      ELB 
      STA X3,I
      LDA X1,I
      ELA 
      STA X1,I
      SEZ,SSA,RSS   TEST ORIGINAL 2 HIGH BITS 
      JMP SHIFT     BOTH WERE 0 - # WAS POS. UNNORM.
      SEZ,SSA 
      JMP SHIFT      BOTH WERE 1 - # WAS NEG. UNNORM. 
      ERA            UNDO SHIFT LEAVING 
      STA X1,I        NORMALIZED MANTISSA.
      LDA X3,I
      ERB 
      ERA,CLE 
      SPC 1 
*                 * ROUNDING SECTION *
      SPC 1 
      ADA =B177     ADD IN SUFFICIENT ROUND FOR -#'S
      STB X2,I      SAVE MID-MANTISSA 
      LDB X1,I
      SSB,RSS       IF POSITIVE, ADD 1 MORE 
      INA 
      LDB X2,I      RESTORE MID-MANTISSA
      STA X3,I
      SEZ,RSS       TEST FOR OVF OUT OF LOW-MANT. 
      JMP DONE      NO, NUMBER IS NOW ROUNDED 
      LDA X1,I
      CLE,INB       ADD CARRY TO MID-MANTISSA 
      STB X2,I
      CLO 
      SEZ           TEST FOR CARRY THROUGH
      CLE,INA,RSS   YES, BUMP HIGH MANTISSA 
      JMP DONE      NO, DONE
      STA X1,I
      SOS 
      JMP NORML     TEST FOR RESULT = 110...0 
      RAR           RESULT WAS 10...0, SHIFT RIGHT
      ISZ EXPON      AND BUMP EXPONENT
      NOP 
      STA X1,I
      SPC 1 
*                   AT THIS POINT THE MANTISSA IS NORMALIZED AND
*                   THE EXPONENT = EXPON - SCNT 
      SPC 1 
DONE  LDA X3,I
      AND =B177400  STRIP OFF LOW 8 BITS OF LOW-MANT
      STA B 
      LDA SCNT
      CMA,INA 
      ADA EXPON     A = TRUE EXPONENT 
      ADA =B200     CHECK FOR UNDERFLOW 
      SSA 
      JMP XUNDR 
      ADA =B177400  CHECK FOR OVERFLOW
      SSA,RSS 
      JMP XOVER 
      ADA =B200     RESTORE EXPONENT
      RAL           POSITION IT 
      AND =B377 
      ADA B         PACK IT 
      STA X3,I
      JMP RETRN     RETURN
      SKP 
XUNDR CLA           UNDERFLOW - 
      STA X1,I       SET RESULT = 0 
      STA X2,I       AND OVFF = 1 
      JMP STORT     RETURN O=1
      SPC 1 
XOVER LDA X1,I      GET SIGN OF X1NFINITY 
      ELA           SAVE IN E-REG.
      LDA =B77777   GET POS INF.
      SEZ 
      CMA           MAKE NEG. INF 
      STA X1,I
      CLA,SEZ,RSS   MID MANTISSA
      CCA 
      STA X2,I
      LDA =B376 
      SEZ,RSS 
      IOR =B177400  MIRGE IF POS. 
STORT STA X3,I
      STO           SET O-REG FOR UNDER/OVERFLOW
      RSS 
      SPC 1 
RETRN CLO           CLEAR OVERFLOW
      ISZ .XPAK 
LIBX  JMP .XPAK,I 
      DEF .XPAK 
      SPC 1 
A     EQU 0 
B     EQU 1 
      END 
* 
                                                                                                                                                                                                                                          