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 "AINT" REAL TO REAL TRUNCATION
      NAM AINT,6 24998-1X134 REV.2001 750701
      ENT AINT
      EXT .ZPRV 
      SPC 2 
* 
*     CALLING SEQUENCE
*     DLD Y (REAL NUMBER) 
*     JSB AINT
*     (RESULT IN A AND B) 
      SPC 2 
X1    NOP 
X2    NOP 
AINT  NOP 
      JSB .ZPRV 
      DEF LIBX
      STA X1
      STB X2        SAVE POS. VALUE 
      LDA B 
      AND O377      MASK DOWN TO EXPONENT 
      CLE,SLA,RAR   FORM EXPONENT 
      JMP ZERO      NEG. EXP ANS = 0
      LDB =D-23     TEST IF EXP > 22
      ADB A 
      CLB,SEZ,CLE   EXP > 22, ALREADY INTEGER 
      JMP EXIT
      DIV D16 
      CLE,ERB       DIV BY 2 AND E=EVEN/ODD FLAG
      ADB MTBL      POINT TO MASK 
      LDB B,I       GET MASK
      CMB,SEZ,CLE   NEED TO BE ODD MASK?
      BRS           OF TRICK TO HAVE 1/2 SIZE TABLE 
      SLA           MASK 1ST OR 2ND WORD? 
      JMP SECND     JUST SECONE 
      LDA X1        GET HI-MANTISSA 
      AND B         MASK IT 
      SZA           ANY BITS SET? 
      CCE           YES, SET FLAG 
      XOR X1        MAKE HI-MANTISSA
      STA X1
      CCB           SET MASK FULL 
SECND LDA X2        GET LO-MAN+EXPONENT 
      AND OM400     MASK OF EXPONENT
      AND B         MASK LEAST BITS 
      SZA           ANY BITS SET? 
      CCE           YES SET FLAG
      XOR X2        MAKE LO-MANTISSA+EXP
      STA X2        AND PUT IN B-REG
EXIT  LDB X2        RESTORE REGS. 
      LDA X1        RESTORE A&B REG.
      SEZ           NEED POSSIBLE BUMP? 
      SSA,RSS       YES, BUT ONLY OF NEG. 
      JMP LIBX      RETURN DONE 
      FAD =F1.0     ADD ONE.
LIBX  JMP AINT,I
      DEF AINT
      SPC 1 
ZERO  CLB 
      CLA           RETURN A&B = 0
      JMP LIBX
      SPC 1 
MTBL  DEF *+1 
      OCT 100000
      OCT 160000
      OCT 174000
      OCT 177000
      OCT 177600
      OCT 177740
      OCT 177770
      OCT 177776
      SPC 1 
O377  OCT 377 
OM400 OCT -400
D16   DEC 16
A     EQU 0 
B     EQU 1 
      END 
* 
                                                                                                                                                                                                  