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 ".XMPY" EXTENDED PRECISION MULTIPLY 
      NAM .XMPY,6 24998-1X187 REV.2001 750701 
      ENT .XMPY 
      EXT .ZPRV 
      EXT .XPAK 
      SPC 1 
* 
*     THIS ROUTINE DOES AN EXTENDED PRECISION MULTIPLICATION
*     CALLING SEQUENCE: 
* 
*     JSB .XMPY 
*     DEF X 
*     DEF Y 
*     DEF Z 
*                    WHERE  X= Y * Z
      SPC 2 
X4    NOP 
X3    NOP 
X2    NOP 
X1    NOP 
Y1    NOP 
Y2    NOP 
Y3    NOP 
EXPY  NOP 
Z1    NOP 
Z2    NOP 
Z3    NOP 
EXPZ  NOP 
HIGH  NOP 
MID   NOP 
LOW   NOP 
SIGN  NOP 
TEMP  NOP 
X     NOP 
      SPC 1 
.XMPY NOP 
      JSB .ZPRV 
      DEF LIBX
      CLA 
      STA SIGN      INITIALIZE THE SIGN 
      SPC 1 
*  GET, UNPACK, AND COMPLEMENT (IF NECESSARY) Y & Z 
      SPC 1 
      JSB GETAD 
      STB X         SAVE FOR RETURN PARAM.
      LDB DEFY      GET ADDRESS OF Y1 
      JSB GETPM     GET PARAMS & UNPAK & MOVE 
      LDB DEFZ      GET ADDRESS OF Z1 
      JSB GETPM     GET PRAMS & UNPAK & MOVE TO Z1-4
      CLA           INITIALIZE PRODUCT
      STA X1
      STA X2
      STA X3
      STA X4
      LDA DEFX4       SET POINTER FOR 
      STA LOW        MULTIPLY LOOP
      INA 
      STA MID 
      INA 
      STA HIGH
      LDA Y3        COMPUTE CROSS-PRODUCTS
      LDB Z1
      JSB MPY       Z1 * Y3 
      LDA Y2
      LDB Z2         +
      JSB MPY       Z2 * Y2 
      LDA Y1
      LDB Z3         +
      JSB MPY       Z3 * Y1 
      ISZ LOW 
      ISZ MID       SHIFT FOR SECOND SET
      ISZ HIGH       OF CROSS-PRODUCTS
      LDA Y1
      LDB Z2         + 2**16 *
      JSB MPY       (Y1 * Z2
      LDA Y2
      LDB Z1         +
      JSB MPY       Y2 * Z1 
      ISZ LOW       SHIFT FOR FINAL PRODUCT 
      ISZ MID 
      LDA Y1         + 2**32 *
      LDB Z1
      JSB MPY       Y1 * Z1 
      LDA SIGN      CHECK IF SIGN CHANGE
      ERA           SAVE CHANGE IN E-REG
      SPC 1 
*    MOVE RESULTS TO X
      SPC 1 
      LDA X         GET X'S ADDRESS 
      STA TEMP      SAVE TEMPORARY
      LDA X1
      SEZ           COMPLEMENT IF SIGN CHANGE 
      CMA 
      STA X,I       PUT IN HI-MANTISSA
      LDA X2
      SEZ 
      CMA 
      LDB X3
      SEZ 
      CMB,INB,SZB   LO-MANTISSA & CHECK IF BUMP 
      JMP PACK      NO BUMP CONTINUE
      INA,SZA       BUMP MID-MANTISSA 
      JMP PACK      NO BUMP, CONTINUE 
      ISZ X,I       BUMP HI-MANTISSA
      NOP           POSSIBLE = 0
PACK  ISZ TEMP      NOW PUT IN CALLERS Z PARAM
      STA TEMP,I
      ISZ TEMP
      STB TEMP,I
      CLA,INA       CALCULATE EXPONENT
      ADA EXPY
      ADA EXPZ
      JSB .XPAK     PACK RESULT 
      DEF X,I       IN "X'S" PLACE
LIBX  JMP .XMPY,I 
      DEF .XMPY 
      DEC 0 
      SPC 1 
GETPM NOP           ENTRY B=ADDRESS OF DESTINATION PLACE
      STB X1        SAVE DEST ADDRESS 
      INB 
      STB X2
      INB 
      STB X3
      JSB GETAD     GET DIRECT ADDRESS
      STB TEMP      SAVE ADDRESS OF Y OR Z
      LDB TEMP,I    GET HI-MAN OF Y OR Z
      ISZ TEMP      BUMP
      LDA TEMP,I    GET MID-MANTISSA
      SSB           COMPLEMENT IF NEG.
      CMA 
      STA X2,I      SAVE
      ISZ TEMP      BUMP
      LDA TEMP,I    GET LO-MAN + EXPONENT 
      AND OM400     MASK OF EXPONENT
      SSB           COMPLEMENT IF NEG.
      CMA 
      STA X3,I      AND SAVE
      SSB           RESTORE IF CHANGED
      CMA 
      XOR TEMP,I    NOW GET EXPONENT
      SLA,RAR       POSITION EXPONENT 
      IOR OM200     MIRGE IF NEG. 
      SSB,RSS       CHECK FURTHER PROC. 
      JMP DONE      NONE, GET OUT 
      CMB           MAKE POSITIVE 
      ISZ SIGN      AND MARK THAT SIGN CHANGED
      ISZ X3,I      NOW DO THE INA'S
      JMP DONE
      ISZ X2,I      BUMP MID-MANTISSA 
      JMP DONE
      INB           BUMP HI-MANTISSA
      SSB,RSS       OVERFLOWED? 
      JMP DONE
      RBR           DIVIDE BY 2 AND 
      INA           BUMP EXPONENT 
DONE  ISZ X3        BUMP TO EXPONENT
      STA X3,I      SAVE EXPONENT 
      STB X1,I      SAVE HI-MANTISSA
      JMP GETPM,I   RETURN
      SPC 1 
GETAD NOP           ENTRY A=DEF OF DEF PRAM 
      LDB .XMPY     RETURN A-REG = A-REG+1 &
      LDB B,I       B-REG = DIRECT ADDRESS OF PRAM
      RBL,CLE,SLB,ERB  INDIRECT?
      JMP *-2       YES, TRY AGAIN
      ISZ .XMPY     BUMP TO NEXT PARAM
      JMP GETAD,I   RETURN
      SPC 1 
DEFY  DEF Y1
DEFZ  DEF Z1
DEFX4 DEF X4
OM200 OCT -200
OM400 OCT -400
      SPC 1 
*                 * 16-BIT INTEGER MULTIPLY * 
      SPC 1 
MPY  NOP            NOT 15 BIT MPY
      STB TEMP      COMPUTE A*B. RESULT: B=HIGH A=LOW 
      CLB           INITIALIZE PRODUCT TO ZERO
      CLE,SLA       SHIFT, TEST AND ADD SEQUENCE
      ADB TEMP
      ERB           1 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           2 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           3 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           4 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           5 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           6 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           7 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           8 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           9 
      ERA,CLE,SLA 
      ADB TEMP
      ERB           10
      ERA,CLE,SLA 
      ADB TEMP
      ERB           11
      ERA,CLE,SLA 
      ADB TEMP
      ERB           12
      ERA,CLE,SLA 
      ADB TEMP
      ERB           13
      ERA,CLE,SLA 
      ADB TEMP
      ERB           14
      ERA,CLE,SLA 
      ADB TEMP
      ERB           15
      ERA,CLE,SLA 
      ADB TEMP
      ERB           16
      ERA,CLE 
      CLO 
      ADA LOW,I 
      STA LOW,I 
      SEZ,CLE 
      INB 
      ADB MID,I 
      STB MID,I 
      SEZ,CLE 
      ISZ HIGH,I
      JMP MPY,I 
      SPC 1 
B     EQU 1 
      END 
* 
                                                                                                                