ASMB
      HED .           "RASC"    REAL --> ASCII   TOM HIRATA  5/JUN/78 
      NAM RASC,7 . 92080-1X048 REV.2026  800515 
* 
*     SOURCE 92080-18048
* 
* 
**************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978.  ALL RIGHTS    *
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
* PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
**************************************************************
* 
* 
      EXT .FLUN,.CFER,.XPAK,IFIX,FLOAT,.ENTR
      ENT RASC
      SUP 
* 
**
**   THIS FORTRAN CALLABLE ROUTINE DOES THE CONVERSION FROM 
** FLOATING POINT TO ASCII. 
**   CALLING SEQUENCE : 
**      CALL RASC(VAL,IBUF,ICH,NFLD,ID) 
**         VAL   = FLOATING POINT NUMBER
**         IBUF  = BUFFER WHERE ASCII HAS TO BE STORED
**         ICH   = STARTING CHARACTER IN IBUF 
**         NFLD  = FIELD LENGTH (W FIELD) 
**         ID    = FRACTION LENGTH (D FIELD)
**                 (IF D = -1 : NO DECIMAL POINT IS PRINTED)
**   THE CONVERSION IS DONE IN FW.D FORMAT. 
**
**
**  NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY WIM ROELANDTS (HP
**        BRUSSELS, AUG'76). IN ORDER TO INCREASE THE ACCURACY OF 
**        THE CONVERSION FROM REAL TO ASCII, THE MAJORITY OF THE CODE 
**        WAS REPLACED BY THE FORMATTER CONVERSION ROUTINES OBTAINED
**        FROM BILL GIBBONS, DATA SYSTEMS. THESE MODIFICATIONS WERE 
**        DONE BY TOM HIRATA (DATA SYSTEMS, JUN'78).
* 
* 
ADX   NOP 
BUF   NOP 
ICH   NOP 
W     NOP 
D     NOP 
RASC  NOP 
      JSB .ENTR 
      DEF ADX 
* 
** SET POINTER AND COUNTERS 
* 
      LDA BUF       MAKE POINTER
      CLE,ELA 
      ADA ICH,I     ADD OFFSET
      ADA MIN1
      STA PIOB      SAVE POINTER
      STA PIOB$     SAVE IT FOR ERROR RETURN. 
      LDA W,I       SET FIELD LENGTH
      SZA           ZERO OR 
      SSA           NEGATIF ? 
      JMP ERR       YES, ERROR
      CMA,INA       NEGATIF 
      STA WS
      STA WS$       SAVE IT FOR ERROR RETURN. 
      LDA D,I       GET D LENGTH
      STA SAVED     SAVE D LENGTH 
      CMA           SET TO -D-1 
      SSA,RSS       POS ? 
      SZA,RSS       BUT NOT ZERO ?
      RSS 
      JMP ERR       YES, ERROR
      STA DS
      LDA MIN5      INIT CONSTANTS FOR FMTR 
      STA TEMP7     ROUTINES. 
      LDA ....2 
      STA TYPE
      STA LENTH 
      CLA 
      STA ALL9S     CLEAR ALL 9'S FLAG &
      STA RNFLG     ROUND-OFF FLAG. 
      STA ZERO      CLEAR ZERO FLAG.
      LDA MIN9      SET WHICH DIGIT 
      STA DGCTR     TO USE FOR ROUNDING OFF.
      STA SGCNT     SIGNIFICANT DIGITS CTR. 
* 
** TEST FOR ZERO
* 
      DLD ADX,I     GET THE NUMBER
      SZA           1ST WORD ZERO?
      JMP CON0      NO, IT ISN'T ZERO.
      SZB,RSS       2ND WORD ZERO?
      ISZ ZERO      YES, SET ZERO FLAG. 
* 
** SET BLANK COUNTER
* 
CON0  LDA DS        MAKE :
      CMA 
      ADA WS        W-D-1 
      CMA 
      STA BCNT      AS INITIAL BLANK COUNTER
* 
      JSB OUTPT     GO CONVERT THE REAL NO. WITH FMT ROUTINE. 
      LDA EXPON     SUBTRACT EXPONENT FROM THE BLANK
      STA SAVEX     (SAVE IT) 
      SSA           COUNTER (BCNT) ONLY IF IT IS POSITIVE.
      JMP CON1
      CMA,INA       NEGATE IT 
      ADA BCNT
      STA BCNT
CON1  LDB BCNT
      LDA SIGN      -1 IF NEGATIV 
      STA SAVES     SAVE THE SIGN.
      ADB A 
      SSB           NEG ? 
      JMP BUCKS     YES, FIELD OVERFLOW 
      CMB,INB       NEGATE IT 
      STB BCNT      SAVE NEG BLANK CTR
* 
      STB BCNTX     SAVE THESE CONSTANTS FOR
      LDA WS        THE ROUND-OFF ROUTINE.
      STA WSX 
      SZB,RSS       ANY BLANKS? 
      JMP CON4      NO BLANKS, GO OUTPUT THE NUMBER.
* 
CON5  LDA B40       GET A BLANK 
      JSB STOCH     SAVE IN OUTPUT BUFFER 
      ISZ BCNT      BUMP COUNTER
      JMP CON5      LOOP
CON4  ISZ SIGN      OUTPUT A MINUS ?
      JMP CON4A     NO, CONTINUE
      LDA B55       YES, DO IT
      JSB STOCH 
CON4A LDB WS        GET FIELD LENGTH
      LDA B56       GET PERIOD READY
      CPB DS        EQUAL ? 
      JMP CON7      YES, OUTPUT THE PERIOD
      JSB GETDG 
      LDB RNFLG     HAS THE ROUND-OFF 
      SZB           DIGIT BEEN REACHED YET? 
      JMP CON4B     YES, OUTPUT ONLY ZEROES.
      CPA ....9     IS IT A 9?
      RSS           YES 
      ISZ ALL9S     NO, SET THE NO 9 FLAG.
      ISZ DGCTR     INCREMENT THE ROUND-OFF CTR UNTIL 
      JMP CON4C     THE ROUND-OFF DIGIT IS REACHED. 
      STA RNDSV     THE ROUND-OFF DIGIT HAS BEEN REACHED, 
      ISZ RNFLG     SAVE IT & SET THE ROUND-OFF FLAG. 
      LDA PIOB      GET THE ROUND-OFF NO.'S ADDRESS 
      STA PIOBX     & SAVE IT.
      LDA WS        ADJUST THE NEG FIELD
      CMA,INA       WIDTH CTR TO IGNORE THE 
      ADA WSX       ZEROES THAT WILL
      STA WSX       BE PUT OUT. 
CON4B CLA           OUTPUT A ZERO.
CON4C ADA B60       MAKE ASCII
CON6  JSB STOCH     AND STORE 
      JMP CON4A 
* 
CON7  LDB EXPON     NEG EXPONENT MEANS THE
      SSB,RSS       NO. IS IN (0,1) 
      JMP CON6      NO. IS NOT IN (0,1) 
      JSB STOCH     STORE DECIMAL PT. 
CON8  LDA B60       GET "0" READY 
      JSB STOCH     STORE THE "0" 
      ISZ EXPON     DONE? 
      JMP CON8      NO, STORE ANOTHER "0" 
      JMP CON4A     YES, GO TO MAIN LOOP. 
BUCKS LDA B44       GET $ 
      JSB STOCH     TO OUTPUT BUFFER
      JMP BUCKS     UNTIL IT IS FULL
* 
** ERROR SERVICE
* 
ERR   LDA A$$ 
      STA BUF,I 
      JMP RASC,I    TERMINATE 
A$$   ASC 1,$$
* 
ERR$  LDA B44       GET $ 
      LDB PIOB$     GET FIELD ADDRS.
ERR$$ SBT           STORE $ 
      ISZ WS$       DONE? 
      JMP ERR$$     NO. 
      JMP RASC,I    YES, EXIT RASC. 
* 
** SUBROUTINES
* 
* 
** SUBROUTINE TO STORE A CHARACTER IN THE BUFFER
* 
STOCH NOP 
      LDB PIOB      GET POINTER 
      SBT           STORE THE BYTE
      ISZ PIOB      BUMP POINTER
      ISZ WS        BUMP FIELD LENGTH COUNTER 
      JMP STOCH,I   AND RETURN
* 
      LDA SAVED     GET ORIGINAL D FIELD LENGTH.
      INA,SZA       WAS IT -1?
      JMP STCH5     NO, CONTINUE TO ROUND-OFF ROUTINE.
      LDA ZERO      GET ZERO FLAG.
      SZA           ORIG NO. ZERO?
      JMP STCH3     YES,GO RETURN "0".
      CCA           DETERMINE IF ORIG NO .GE. 1 
      ADA SAVEX     BY TESTING ITS EXPON
      SSA,RSS       FOR > 0?
      JMP STCH5     YES, GO TO ROUND-OFF RTN. 
      ISZ SAVES     ORIG NO POSITIVE? 
      JMP STCH3     YES, GO RETURN "0". 
      STB HOLDB     NO, SAVE B-REG(ADDRS PTR) 
      DLD ADX,I     GET ORIG NO 
      SZB,RSS       2ND WORD 0? 
      JMP STCH1     YES, CHECK 1ST WORD.
      LDB HOLDB     NO, RESTORE ADDRS TO B
      JMP STCH3     & GO STORE "0". 
STCH1 LDB HOLDB     RESTORE ADDRS TO B. 
      CPA B100K     1ST WORD=100000B? 
      JMP STCH2     YES, RETURN "-1". 
      JMP STCH3     NO, RETURN "0". 
STCH2 LDA B61       GET "1" READY.
      RSS 
STCH3 LDA B60       GET "0" READY.
      ADB MIN1      STORE "0" OR "1" INTO OUTPUT
      SBT           BUFFER. 
      CPA B60       WAS "0" STORED? 
      JMP RASC,I    YES, EXIT.
      ADB MIN2      NO, MUST BACK UP PTR
      LDA B55       & STORE MINUS 
      SBT           SIGN BEFORE 
      JMP RASC,I    EXITING.
* 
STCH5 LDA RNFLG     GET THE ROUND-OFF FLAG. 
      SZA           WAS ROUND-OFF NUMBER REACHED? 
      JMP RND0      YES, ROUND-OFF VALUES ARE ALREADY SET.
* 
      STB PIOBX     NO, SET UP VALUES SO THAT 
      JSB GETDG     ROUND-OFF WILL BE DONE
      STA RNDSV     TO THE LAST DIGIT.
RND0  LDA RNDSV     GET THE ROUND-OFF DIGIT.
      ADA MIN5      DIGIT TO CHECK FOR ROUND-OFF. 
      SSA           EXIT IF IT IS < 5 OTHERWISE GO
      JMP RASC,I    INTO THE ROUND-OFF ROUTINE. 
* 
      LDA BCNTX 
      SZA           WAS THE BLANK COUNTER 0?
      JMP RND1      NO. 
      LDA ALL9S     YES. ERROR EXIT IF ALL DIGITS WERE
      SZA,RSS       9'S BECAUSE IT ISN'T POSSIBLE 
      JMP ERR$      TO ROUND OFF. 
* 
RND1  CCB           BACK UP THE OUTPUT BYTE PTR.
      ADB PIOBX 
      STB PIOBX 
      ISZ WSX       BUMP FIELD LENGTH COUNTER.
      RSS 
      JMP ERR       SOMETHING'S WRONG.
      LBT           GET LAST BYTE(DIGIT). 
      LDB PIOBX     RESTORE B TO CORRECT ADDRESS. 
      CPA B56       DECIMAL PT? 
      JMP RND1      YES, SKIP IT. 
      CPA B40       SPACE?
      JMP RND3      MUST INSERT A "1".
      CPA B55       MINUS SIGN? 
      JMP RND3      MUST INSERT A "1". WRONG. 
      INA           ROUND DIGIT UP BY ADDING 1 TO IT. 
      CPA B72       WAS IT A 9? 
      JMP RND4      YES.
RND2  SBT           NO, STORE IT BACK & 
      JMP RASC,I    WE'RE DONE. 
* 
RND3  STA HOLDA     SAVE THE CHARACTER. 
      LDA B61 
      SBT           STORE A "1" 
      LDA MIN2
      ADB A 
      LDA HOLDA     RESTORE THE CHARACTER & 
      JMP RND2      GO STORE IT.
* 
RND4  LDA B60       MAKE IT 0 & 
      SBT           STORE IT BACK.
      JMP RND1      GOT BACK 1 MORE DIGIT.
* 
** DATA 
* 
A     EQU 0 
B     EQU 1 
* 
PIOB  NOP 
DS    NOP 
BCNT  NOP 
* 
* 
* 
B40   OCT 40
B44   OCT 44
B55   OCT 55
B56   OCT 56
B60   OCT 60
B61   OCT 61
B72   OCT 72
B100K OCT 100000
ALL9S BSS 1         FLG, WILL BE NON-ZERO IF ANY NON-9 ENCOUNTERED
WSX   BSS 1         HOLD FIELD WIDTH CTR FOR ROUND-OFF ROUTINE
BCNTX BSS 1         HOLD BLANK CTR FOR ROUND-OFF ROUTINE
RNFLG BSS 1         ROUND-OFF FLAG(1=ROUND-OFF MAY BE NECESSARY)
RNDSV BSS 1         SAVE NINTH DIGIT FOR ROUND-OFF ROUTINE. 
DGCTR BSS 1         COUNTS NO. OF DIGITS
PIOBX BSS 1         SAVES ADDRS+1 OF LAST SIGNIFICANT DIGIT.
HOLDA BSS 1         TEMP HOLD OF A-REG. 
HOLDB BSS 1         TEMP HOLD OF B-REG. 
PIOB$ BSS 1         SAVES INITIAL FIELD PTR ADDRS FOR ERR$
WS$   BSS 1         SAVES INITIAL FIELD LENGTH FOR ERR$ 
ZERO  BSS 1         =1 IF INPUT NO. IS ZERO.
SAVED BSS 1         SAVES THE FRACTION LENGTH (D FIELD) 
SAVES BSS 1         SAVES SIGN OF ORIG NO.
SAVEX BSS 1         SAVES THE EXPONENT RETURNED FROM OUTPT. 
WS    BSS 1         FIELD WIDTH.
* 
      SPC 4 
*                   CONSTANTS.
* 
....1 DEC 1 
....2 DEC 2 
....4 DEC 4 
....5 DEC 5 
....9 DEC 9 
MIN9  DEC -9
MIN5  DEC -5
MIN4  DEC -4
MIN2  DEC -2
MIN1  DEC -1
* 
*                   ADDRESS CONSTANTS AND SHIFT INSTRUCTIONS. 
* 
AMANT DEF MANT
MULTZ DEF MULT
DIVDZ DEF DIVD
RRR16 RRR 16
RRL16 RRL 16
* 
*                   TEMPS.
* 
MULTA BSS 1 
MULTB BSS 1 
MULTC BSS 1 
MULTD BSS 1 
DIVDA EQU MULTA 
DIVDB EQU MULTB 
DIVDC EQU MULTC 
DIVDD EQU MULTD 
DIVDE BSS 1 
DIVDF BSS 1 
PTENA BSS 1 
PTENB BSS 1 
TEMP2 BSS 1 
TEMP3 BSS 1 
TEMP7 BSS  1
TEMP8 BSS 1 
* 
*                   LOCALS. 
* 
TYPE  BSS 1         TYPE. 
LENTH BSS 1         LENGTH. 
EXPON BSS 1         DECIMAL EXPONENT. 
MANT  BSS 5         MANTISSA
EXP   BSS 1         BINARY EXPONENT.
MANTP BSS 1         POINTER FWA USED MANTISSA.
MANTL BSS 1         POINTER LWA USED MANTISSA 
RND   BSS 1         ROUNDING DIGIT. 
SGCNT BSS 1         SIGNIFICANT DIGIT COUNT.
SIGN  BSS 1         SIGN
* 
*                   ROUTINE TO EXECUTE SHIFT INSTRUCTIONS.
* 
XEQ   NOP 
      NOP 
      JMP XEQ,I 
      SKP 
*     NORML - MANTISSA NORMALIZATION. 
*        THE MANTISSA AND EXPONENT ARE ADJUSTED SO THAT THEY
*        CONTAIN A NORMALIZED VALUE.  IT IS ASSUMED THAT THE
*        INITIAL STATE IS NOT UNNORMLIZED BY MORE THAN 31 BITS. 
NORML NOP 
      LDB MANT      SEE IF NORMALIZED.
      LDA MANT+1
      ASL 1 
      SOC 
      JMP NORML,I   YES, DONE.
      ASL 15        NO, SEE IF WORD SHIFT.
      SOC 
      JMP NORM1     NO. 
      SZB,RSS       YES, IS SECOND WORD ZERO TOO ?
      JMP NORM2     YES, IS ZERO. 
      STB MANT      NO, DO WORD SHIFT.
      LDB MANT+2
      STB MANT+1
      LDB MANT+3
      STB MANT+2
      LDB MANT+4
      STB MANT+3
      LDA EXP       ADJUST EXPONENT 
      ADA =D-16 
      STA EXP 
NORM1 LDA MANT      DETERMINE BIT SHIFT.
      JSB FLOAT     B = 30 - 2*SHIFT
      BRS           B = 15-SHIFT
      ADB =D-15     B = -SHIFT
      LDA B         SAVE SHIFT COUNT
      CMA,INA,SZA,RSS A = SHIFT.  IS IT ZERO ?
      JMP NORML,I   YES, DONE.
      ADB EXP       ADJUST EXPONENT.
      STB EXP 
      IOR RRL16     SET UP SHIFT. 
      STA XEQ+1 
      LDA MANT      BIT NORMALIZE.
      LDB MANT+1
      JSB XEQ 
      STA MANT
      LDA MANT+1
      LDB MANT+2
      JSB XEQ 
      STA MANT+1
      LDA MANT+2
      LDB MANT+3
      JSB XEQ 
      STA MANT+2
      LDA MANT+3
      CLB 
      JSB XEQ 
      STA MANT+3
      JMP NORML,I   EXIT. 
NORM2 STB EXP       ZERO, SET EXPONENT ZERO TOO.
      JMP NORML,I 
      SKP 
*     PTEN - SCALE NUMBER BY A POWER OF TEN.
* 
*     PTEN MULTIPLIES THE VALUE IN (MANT...MANT2) AND (EXP) 
*     BY 10**(A).  NO CHECK IS MADE FOR OVERFLOW/UNDERFLOW. 
* 
*     CALLING SEQUENCE: 
*                   LDA POWER 
*                   JSB PTEN
      SPC 2 
PTEN  NOP 
      LDB AMANT     SET UP MANTISSA POINTERS. 
      STB MANTP 
      LDB TYPE
      SZB 
      CPB ....1 
      ADB ....2     IF TYPE<2, USE EXTRA WORD.
      ADB MIN1      # WORDS PRECISION TO USE - 1
      ADB MANTP     LWA USED MANTISSA 
      STB MANTL 
      SZA,RSS       IF N=0, LEAVE ALONE.
      JMP PTEN,I
      SSA,RSS       N>0 ? 
      JMP PTEN1     YES.
      CMA,INA       NO, TAKE IABS(N)
      STA PTENA 
      LDA ....2     RIGHT SHIFT MANTISSA TWO BITS.
      JSB RSN 
      LDB DIVDZ     SET "DIVIDE"
      JMP PTEN2 
PTEN1 LDB MULTZ     SET "MULTIPLY"
      STA PTENA     PTENA = IABS(N) 
PTEN2 STB PTENB     PTENB = ADDR MULT OR DIVD 
PTEN3 LDA PTENA     A=N 
      ADA =D-6      N-6 
      CLE,SSA       N<6 ?   (E=0 FOR MULT)
      JMP PTEN4     YES, GO DO LAST ONE.
      STA PTENA     NO, MULT/DIV BY 10**6 
      LDA PWR1A+10
      LDB PWR1A+11
      JSB PTENB,I 
      JMP PTEN3     TRY AGAIN.
PTEN4 ADA ....5     A = N-1 
      RAL,CLE,SLA   N=0 ? 
      JMP PTEN5     YES, GO NORMALIZE.
      ADA PWR10     GET POWER OF TEN. (E=0 FOR MULT.) 
      DLD A,I 
      JSB PTENB,I   GO MPY DIV USING IT.
PTEN5 LDB MANT      NORMALIZE.
      ASL 1 
      SOC           THERE ? 
      JMP PTEN,I    YES.
      JSB LSONE     NO, LEFT SHIFT. 
      JMP PTEN5     AND TRY AGAIN.
      SKP 
*                   POWER OF TEN TABLE.  FIRST PART IS (10**I)/2
*                   FOR I=1,2,3.  SECOND SECTION IS IDENTICAL TO 2-WORD 
*                   FLOATING EXCEPT THE SECOND WORD HAS BEEN RIGHT
*                   SHIFTED ONE BIT.  VALUES ARE 1O**I FOR I=1,6. 
      SPC 2 
PWR10 DEF PWR1A     BASE ADDRESS. 
      DEC 5 
      DEC 50
      DEC 500 
PWR1A DEC 20480,4   10**1 
      DEC 25600,7   10**2 
      DEC 32000,10  10**3 
      DEC 20000,14  10**4 
      DEC 25000,17  10**5 
      DEC 31250,20  10**6 
      SPC 3 
*     INDIG - ADD INPUT DIGITS TO NUMBER. 
* 
*     INDIG TAKES 1-4 INPUT DIGITS AND COMBINES THEM WITH THE 
*     RUNNING MANTISSA TO FORM A NEW MANTISSA.  THE NEW 
*     MANTISSA IS NOT NORMALIZED AND THE EXPONENT IS INCREASED
*     BY 16.
* 
*     CALLING SEQUENCE: 
* 
*                   <TEMP2 = DIGITS, 0-9999>
*                   LDA <(10**I)/2, I = # DIGITS> 
*                   JSB INDIG 
      SPC 2 
INDIG NOP 
      LDB =D-16     MAKE ROOM.
      CMB,CCE,INB   B=16. 
      JSB MULT
      LDB MANTL     ADD DIGIT(S)
      ISZ MANTL 
      LDA B,I 
      CLE 
      ADA TEMP2 
      STA B,I 
      CCA,SEZ,RSS   CARRY ? 
      JMP INDIG,I   NO, DONE. 
INDI1 ADB A         PROPOGATE IT. 
      ISZ B,I 
      JMP INDIG,I 
      JMP INDI1 
      SKP 
*     GETDG - EXTRACT DIGITS FOR OUTPUT.
* 
*     GETDG EXTRACTS DIGITS FROM THE MANTISSA AND RETURNS THEM
*     FOR OUTPUT PURPOSES.  ONLY (SGCNT) DIGITS WILL BE RETURNED, 
*     ANY AFTER THAT ARE 0 OR 9 AS REQUIRED TO PRODUCE THE CORRECT
*     ROUNDING.  LESS PRECISION IS USED AS DIGITS ARE GENERATED.
      SPC 2 
GETDG NOP 
      CLA 
      LDB ZERO      GET THE ZERO FLAG.
      SZB           EXIT IF THE NO. IS ZERO.
      JMP GETDG,I 
      LDA SGCNT     TOO MANY DIGITS ? 
      CLE,SSA,RSS 
      JMP NOSIG     YES, SEND ROUNDING DIGIT. 
      ISZ TEMP7     ANY DIGITS LEFT ? 
      JMP GETD1     YES, GET ONE. 
      LDA =D5000    NO, GENERATE 4 MORE.
      JSB MULT
      ISZ MANTP     THEY'RE IN THE NEXT WORD. 
      LDA MIN4
      STA TEMP7 
GETD1 LDA TEMP7     A = - # DIGITS IN WORD. 
      ADA GETDA     GET POWER OF TEN FOR EXTRACTING DIGIT.
      STA TEMP8 
      LDA MANTP,I   DIGITS. 
      CLB 
      DIV TEMP8,I   A = NEW DIGIT, B = REST.
      STB MANTP,I 
      ISZ SGCNT     IS THIS FIRST AFTER LAST VALID DIGIT ?
      JMP GETDG,I   NO. 
      LDB ....9     YES. IF .GE. 5, RETURN NINES NOW. 
      ADA MIN5
      SSA 
      CLB           ELSE RETURN ZEROES. 
      STB RND 
NOSIG LDA RND       RETURN ROUNDING DIGIT (0 OR 9)
      JMP GETDG,I 
      SPC 2 
      DEC 1000
      DEC 100 
      DEC 10
      DEC 1 
GETDA DEF * 
      SKP 
*     RSN - RIGHT SHIFT MANTISSA BY N BITS, N IN [1,15].
* 
*     RSN RIGHT SHIFTS THE MANTISSA BY (A) BITS AND 
*     ADJUSTS THE EXPONENT ACCORDINGLY.  BITS SHIFTED 
*     OFF ARE LOST.  ZERO BITS ARE SHIFTED IN.
* 
*     CALLING SEQUENCE: 
*                   LDA N     A = SHIFT COUNT.
*                   JSB RSN 
      SPC 1 
RSN   NOP 
      LDB A         ADJUST EXPONENT.
      ADB EXP 
      STB EXP 
      IOR RRR16     SET UP SHIFT INSTRUCTION. 
      STA XEQ+1 
      LDA MANT+2    SHIFT.
      LDB MANT+3
      JSB XEQ 
      STB MANT+3
      LDA MANT+1
      LDB MANT+2
      JSB XEQ 
      STB MANT+2
      LDA MANT
      LDB MANT+1
      JSB XEQ 
      STB MANT+1
      CLA 
      LDB MANT
      JSB XEQ 
      STB MANT
      JMP RSN,I     EXIT
      SKP 
*     LSONE - LEFT SHIFT MANTISSA ONE BIT.
* 
*     LSONE LEFT SHIFTS THE MANTISSA BY ONE BIT AND ADJUSTS 
*     THE EXPONENT ACCORDINGLY.  THE LAST BIT BECOMES ZERO. 
* 
*     CALLING SEQUENCE: 
* 
*                   JSB LSONE 
      SPC 1 
LSONE NOP 
      LDA MANT+3    SHIFT.
      CLE,ELA 
      STA MANT+3
      LDA MANT+2
      ELA 
      STA MANT+2
      LDA MANT+1
      ELA 
      STA MANT+1
      LDA MANT
      ELA 
      STA MANT
      CCA           ADJUST EXP
      ADA EXP 
      STA EXP 
      JMP LSONE,I 
      SPC 4 
*     .XCOM - COMPLEMENT MANTISSA.  SINCE WE HAVE MORE PRECISION
*     THAN WE NEED, IT IS ONLY A COMPLEMENT, NOT A NEGATE.
      SPC 2 
.XCOM NOP 
      LDA MANT      COMPLEMENT MANTISSA.
      CMA 
      STA MANT
      LDA MANT+1
      CMA 
      STA MANT+1
      LDA MANT+2
      CMA 
      STA MANT+2
      LDA MANT+3
      CMA 
      STA MANT+3
      JMP .XCOM,I 
      SKP 
*     MULT - MULTIPLY THE MANTISSA BY A SCALAR. 
* 
*     MULT MULTIPLIES THE MANTISSA BY A 15-BIT SCALAR AND ADJUSTS THE 
*     EXPONENT.  THE RESULT IS AS IF AN INTEGER MULTIPLY OF THE MANTISSA
*     AND SCALAR WERE DONE FOLLOWED BY A RIGHT SHIFT 15.  THE RESULT
*     WILL NOT OVERFLOW BUT IT MAY BECOME UNNORMALIZED. 
* 
*     CALLING SEQUENCE: 
* 
*                   CLE/CCE      LAST WORD FLAG.
*                   LDA SCALAR   MULTIPLIER.
*                   LDB N        EXPONENT ADJUSTMENT. 
*                   JSB MULT
* 
*     WHERE E=1 INDICATES THAT THE LAST WORD OF THE CURRENT 
*     MANTISSA IS ZERO.  (INPUT CONVERSION).  FOR THIS
*     CASE, THE EXPONENT ADJUSTMENT MUST NOT CARRY OUT. 
      SPC 2 
MULT  NOP 
      STA MULTA     SAVE MULTIPLIER.
      RAL           AND 2*MULTIPLIER. 
      STA MULTD 
      CME           E=0 IFF INPUT 
      ADB EXP       ADJUST EXPONENT 
      STB EXP 
      LDB MANTL     CURRENT WORD ADDR 
      SEZ,RSS       INPUT ? 
      JMP MULT3     YES, SKIP FIRST MPY 
      STB MULTB 
      RAR           RESTORE MULTIPLIER. 
      MPY B,I 
      ASL 1 
      JMP MULT2 
MULT1 LDA MULTA     MULTIPLIER. 
      MPY B,I       * CURRENT WORD. 
      CLE,ELA       ALIGN.
      ELB,CLE 
      ADA MULTC,I   ADD LOWER TO CURRENT + 1
      STA MULTC,I 
      SEZ           PROPOGATE CARRY.
      INB 
MULT2 LDA MULTB,I   CORRECT FOR BIT 15. 
      SSA 
      ADB MULTD 
      STB MULTB,I 
      LDB MULTB     SEE IF DONE.
MULT3 CPB MANTP     I.E., IS CURRENT WORD THE START ? 
      JMP MULT,I    YES, DONE.
      STB MULTC     NO, UPDATE POINTERS.
      ADB MIN1
      STB MULTB 
      JMP MULT1     AND LOOP. 
      SKP 
*     DIVD - DIVIDE MANTISSA BY A SCALAR. 
* 
*     DIVD DIVIDES THE MANTISSA BY A SCALAR AND ADJUSTS THE 
*     EXPONENT ACCORDINGLY.  THE EFFECT IS AS IF THE TWO WERE 
*     INTEGERS AND THE DIVIDE WERE DONE, KEEPING 15 FRACTION
*     BITS, FOLLOWED BY A LEFT SHIFT 15.
*     OVERFLOW CAN OCCUR ONLY IF THE MANTISSA IS NORMALIZED 
*     OR THE DIVISOR IS LESS THAN 2**14.
* 
*     CALLING SEQUENCE: 
* 
*                   LDA SCALAR      15-BIT DIVISOR. 
*                   LDB N           EXPONENT ADJUSTMENT.
*                   JSB DIVD
      SPC 4 
DIVD  NOP 
      STA DIVDA     SAVE DIVISOR. 
      ARS           SAVE DIVISOR/2. 
      STA DIVDD 
      CMB,INB       CORRECT EXPONENT. 
      ADB EXP 
      STB EXP 
      LDA MANTP     SET UP POINTERS.
      STA DIVDB 
      STA DIVDC 
      LDB A,I       B = FIRST WORD. 
      CMA,INA       -MANTP
      ADA MANTL     MANTL-MANTP = # WDS - 1 
      CMA           - # WDS 
      STA DIVDE 
      CLA           BITS 15,14 FIRST WORD = 0 
      JMP DIVD2 
DIVD1 ISZ DIVDB 
      CLA           SAVE BIT 15 (IN E). 
      ELA,ELA 
      CMB           FORM REM - DIVISOR/2
      ADB DIVDD 
      CMB,CLE,SSB   POS ? 
      ADB DIVDD     NO, RESTORE REM & SET E.
      CME           SAVE BIT 14 (IN E). 
      ERA,RAR 
DIVD2 STA DIVDF     SAVE BITS 15,14.
      ISZ DIVDC 
      LDA DIVDC,I   A = NEXT WORD (LOW) 
      DIV DIVDA     DIVIDE. 
      CLE,ERA       SHIFT RIGHT, SAVE BIT 0 AS BIT 15.
      IOR DIVDF     ADD PREV BITS 15,14.
      STA DIVDB,I 
      ISZ DIVDE     DONE ?
      JMP DIVD1     NO, LOOP. 
      JMP DIVD,I    YES, EXIT.
      SKP 
*     OUTPT - SCALE NUMBER FOR OUTPUT.
* 
*     OUTPT COPIES A VARIABLE TO BE NUMERICALLY OUTPUT, PUTTING 
*     IT IN A STANDARD FORMAT (4 WORD MANTISSA, SEPARATE EXPONENT). 
*     THEN IT MULTIPLIES OR DIVIDES THE NUMBER BY A POWER OF TEN
*     TO THAT IT IS IN [1000,10000).  THE BINARY POINT IS PLACED
*     AFTER THE FIRST WORD SO THE FIRST 4 DIGITS ARE IN THAT WORD.
*     THE VALUE OF N S.T. (ORIGINAL #) * (10**(-N)) IS IN [.1,1)
*     IS STORED IN EXPON, I.E. NUMBER * 10**EXPON = ORIG NUMBER.
*     THE FOLLOWING APPROXIMATION IS USED:
* 
*  LOG10(X*(2**N)) = [((N*19729)/128)+((X*(2**15))*617)/(2**16)-290]/512
* 
*     WHERE X IS IN [0.5,1).  THE ERROR IS ALWAYS POSITIVE. 
      SPC 2 
*                   SET W & D, COPY NUMBER AND CONVERT IT.
* 
OUTPT NOP 
      JSB .CFER     COPY 4 WORDS. 
      DEF MANT
      DEF ADX,I 
      LDA TYPE      WHAT TYPE IS IT ? 
      ADA MIN2
      SSA,INA,RSS 
      JMP OUTPB     FLOATING. 
* 
*                   INTEGER.
* 
      SZA,RSS       INTEGER.  1 OR 2-WORD.
      JMP OUTPC     2-WORD. 
      LDA MANT      1-WORD.  FLOAT IT.
      JSB FLOAT 
      STA MANT      SET UP AS IF 2-WORD FLOATING. 
      STB MANT+1
      CLA 
      JMP OUTPB 
OUTPC STA MANT+2    2-WORD.  FLOAT TO 3-WD FLOATING.
      LDA =D31
      JSB .XPAK 
      DEF MANT
      CLA,INA       SET UP AS IF 3-WORD FLOATING. 
* 
*                   FLOATING. 
* 
OUTPB ADA AMANT     FORM ADDR LAST WORD 
      STA TEMP3 
      LDB A,I       UNPACK THAT WORD. 
      JSB .FLUN 
      STB TEMP3,I 
      STA EXP 
      SKP 
*                   REMEMBER SIGN, TAKE ABS VALUE, CHECK FOR ZERO.
* 
      LDA MANT      SET SIGN. 
      SSA 
      CCB,RSS 
      CLB 
      STB SIGN
      SZA,RSS       ZERO ?
      JMP OUTPT,I   YES, DON'T SCALE. 
      SSA           NEGATIVE ?
      JSB .XCOM     YES, TAKE ABS VALUE.
      JSB NORML     NORMALIZE.
* 
*                   SCALE TO [1000,10000).
* 
      LDA EXP       FORM N*19729
      MPY =D19729 
      ASR 7         (N*19729)/128 
      STA TEMP3 
      LDA MANT      X*(2**15) 
      MPY =D617     B = ((X*(2**15))*617)/(2**16) 
      ADB TEMP3     + (N*19729)/128 
      ADB =D222     -290+512
      ASR 9         B = FLOOR(LOG10(NUMBER))+1
      STB EXPON     = N.
      CMB,INB       DIVIDE NUMBER BY 10**(N-4)
      ADB ....4 
      LDA B 
      JSB PTEN
      LDA MANT      GET INTEGER PART. 
      LDB EXP 
      RBL 
      JSB IFIX
      ADA =D-1000   IS IT < 1000 ?
      SSA,RSS 
      JMP OUTPA     NO, O.K.
      LDA PWR1A     YES, MULTIPLY BY TEN. 
      LDB PWR1A+1 
      CLE           SET NON-INPUT MODE. 
      JSB MULT
      CCA           DECREMENT EXPONENT. 
      ADA EXPON 
      STA EXPON 
OUTPA LDA EXP       ADJUST EXP TO +15 
      ADA =D-15 
      CMA,INA 
      JSB RSN 
      LDA AMANT     RESET TO HIGHER ACCURACY. 
      ADA LENTH     FOR DIGIT PRODUCTION. 
      STA MANTL 
      JMP OUTPT,I   EXIT. 
      END