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 "ENTIX/.XENT" DOUBLE PRECISION ENTIER ROUTINE (DLB) 
      NAM ENTIX,6 24998-1X189 REV.2001 750701 
      ENT ENTIX,.XENT 
      EXT .ZPRV,.ENTP 
      SPC 1 
* 
*  THIS ROUTINE WILL PRODUCE THE LARGEST INTERGER (NO FRACTIONAL BITS)
*  NOT ALGEBRAICALLY EXCEEDING X.  WHERE Y = ENTIX (X) IN FTN4. 
*  CALLABLE:
*            JSB ENTIX
*            DEF *+3
*            DEF Y
*            DEF X
*            <RETURN> 
*  WHERE: 
*            X = DOUBLE PRECISION (3 WORD) PARAMETER
*            Y = ENTIER (X) 
*            A-REG CONTAINS LEAST BIT OF X.(1=ODD, 0=EVEN),(DLOG) 
*            B-REG = 0 IF X=Y ON RETURN (NO-TRUNKCATION DONE),(DDINT) 
*  TIME:
*            APPROX. TIME IS ABOUT 110 TO 140  2100 MACHINE CYCLE 
*            PLUS THE TIME TO EXECUTE ".ENTP" & PRIVLEGED PROCESSING. 
      SPC 1 
XDEF  NOP          ADDRESS OF RESULTS 
YDEF  NOP          ADDRESS OF SOURCE
ENTIX NOP          .ENTR STYLE ENTRY
.XENT EQU ENTIX 
      JSB .ZPRV    DO THE PRIVLEGDGE THING
      DEF LIBX
      JSB .ENTP    GET ADDRESSES
      DEF XDEF
      SPC 1 
*      GET EXPONENT 
      SPC 1 
      LDA D2       GET PRAM OFFSET
      ADA YDEF     GET ADDRESS OF EXPONENT
      LDA A,I      GET LO-MAN + EXPONENT WORD 
      AND O377     MASK TO GET EXPONENT 
      CLB           PREPARE NEG. EXP FLAG 
O73   CLE,SLA,RAR  FORM 16 BIT EXP. WORD
      CLA,RSS      FORCE NEG. CASE TO BE 0
      CLB,INB       NOT NEG. MAKE FLAG = 1
      STB NFLAG     SET FLAG IF NOT NEG. EXP. 
      LDB DM40     GET NEG MAX EXP
      ADB A        NOW TEST FOR EXP => 40 
      CLB,SEZ      IF EXP. > 39 ALREADY INTEGERIZED 
      LDA O73      GET # SUCH  3 = NUMB/16
      STB BITS     INITIALIZE FLAG
      STB EV/OD    INITIALIZE FLAG
      SPC 1 
*     NOW CALCULATEMASK AND WORD NUMBER 
      SPC 1 
      DIV D16      A=WORD# & B=BIT# 
      STA STORE    SAVE WORD NUMBER OF MASK 
      CLE,ERB      B-REG. = BIT NUMBER TO TRUNK.
      ADB MTBL     POINT TO MASK TABLE
      LDA B,I      PICK UP MASK 
      CMA,SEZ,CCE  INVERT MASK & TAKE ADVANTAGE 
      ARS          OF TRICK TO HAVE 1/2 SIZE TABLE
      STA MASK     SAVE FOR LATER USE 
      ELA          NOW FORM "LEAST BIT MASK"
      XOR MASK     FOR TESTING EVEN/ODD NUMB
      STA LESBT    AND SAVE FOR LATER USE 
      SPC 1 
*     NOW GO MASK THE DOUBLE NUMBER 
      SPC 1 
      LDB DM3      GET PRAM LENGTH-1
      LDA STORE    GET WORD # OF MASK 
      CMA,INA      MAKE NEG. TO INDEX BACKWARD
      ADA DALG0    ADD POINTER TO LAST ALG. 
      JMP A,I      JUMP TO CORRECT ALG
DALG0 DEF ALG0
ALG3  JSB STORE    MOVE FIRST WORD TO OUTPUT BUFF 
ALG2  JSB STORE    ONLY 3 OF THESE SUBS. WILL BE
ALG1  JSB STORE    EXECUTED 
ALG0  JSB MASKB    MASK HI-MANTISSA 
      JSB CLRBT    CLEAR MID-MANTISSA 
      JSB CLRBT    CLEAR LO-MANTISSA
      SPC 1 
MASKB NOP          MASKING ROUTINE
      LDA YDEF,I   GET WORD TO MASKWORD 
      AND MASK     MASK OFF SIGNIFICANT BITS. 
      INB,SZB,RSS  LAST PASS = LO-MAN + EXP.
      AND OM400    MASK OF EXPONENT 
      SZA          AND BITS LEFT? 
      ISZ BITS     YES, SET FLAG
      XOR YDEF,I   NOW RESTORE LO-MAN + EXPON - MASKED BITS 
      STA XDEF,I   AND PUT
      AND LESBT    NOW TEST IF NUMB. EVEN/ODD 
      STA EV/OD    AND SET/CLEAR FLAG 
      ISZ YDEF     BUMP TO NEXT PRAM
      ISZ XDEF     DITTO
      SZB          DONE?
      JMP MASKB,I  RETURN 
      JMP OUT      DONE 
      SPC 1 
STORE NOP          ENTRY ADVANCE PRAMETER 
      LDA YDEF,I   GET CONTENTS 
      STA XDEF,I   AND PUT
      ISZ YDEF     BUMP ADDRESS 
      ISZ XDEF     BUMP DESTIONATION ADDRESS
      INB,SZB      BUMP COUNTER 
      JMP STORE,I  RETURN 
      JMP OUT       DONE
      SPC 1 
CLRBT NOP          CLEAR BITS ROUTINE 
      LDA YDEF,I   GET PRAM 
      INB,SZB,RSS  LAST PASS = LO-MAN + EXP.
      AND OM400    CLEAR ONLY MANTISSA BITS 
      SZA          ANY BITS STRIPED?
      ISZ BITS     YES
      XOR YDEF,I   PRODUCE EXPONENT OR 0
      CPB NFLAG     IF LAST & EXP = 0 THEN = 0
      CLA           EXPONENT = ZER0 
      STA XDEF,I   PUT
      ISZ YDEF     BUMP TO NEXT WORD
      ISZ XDEF     DITTO
      SZB          DONE 
      JMP CLRBT,I  RETURN 
      SPC 1 
OUT   LDA EV/OD    GET EVEN/ODD FLAG
      LDB BITS     GET CHANGED NUMBER FLAG
      SZA          SET? 
      CLA,INA      YES (FOR THE "DSIN" ROUTINE) 
LIBX  JMP ENTIX,I  RETURN DONE
      DEF ENTIX 
      SPC 1 
MTBL  DEF *+1 
      OCT 100000
      OCT 160000
      OCT 174000
      OCT 177000
      OCT 177600
      OCT 177740
      OCT 177770
      OCT 177776
D2    DEC 2 
DM3   DEC -3
DM40  DEC -40 
MASK  NOP 
NFLAG NOP 
BITS  NOP 
EV/OD NOP 
LESBT NOP 
D16   DEC 16
O377  OCT 377 
OM400 OCT -400
A     EQU 0 
B     EQU 1 
      END 
* 
                                                                                                                                                                          