*DECK QU2KOD
          IDENT  QU2KOD      CONVERTS SINGLE OR DOUBLE PRECISION F.P. TO
          COMMENT  SINGLE + DOUBLE PRECISION TO CHARACTER -E- FORMAT
          ENTRY  QU2KOD      CHARACTER MODE IN E-FORMAT.
          ENTRY  BSTATUS
          EXT    EXPONEN
************************************************************************
*                            * Q U 2 K O D *                           *
*                                                                      *
*  EXPECTS FOLLOWING INPUT VALUES IN THE CCONVERT COMMON AREA:         *
*         REQUEST CONTAINS 45B IF DOUBLE PRECISION INPUT               *
*         SOURCEW CONTAINS ADDRESS OF BINARY SOURCE                    *
*         SINKLENG CONTAINS SIZE OF RESULT IN CHARACTERS               *
*                                                                      *
*  RETURNS FOLLOWING OUTPUT VALUES:                                    *
*         EXPONEN CONTAINS BINARY VALUE OF EXPONENT (POWER OF 10)      *
*         SCRATCH CONTAINS RESULT AS A CHARACTER STRING                *
*         RETURNS ADDRESS OF BSTATUS AS FORMAL PARAMETER               *
*                                                                      *
************************************************************************
 QU2KOD   DATA   0
          SX6    BSTATUS
          SA6    X1          STORE ADDRESS OF BSTATUS IN CALLING ROUTINE
          SB6    1
          SX6    55B
          SA5    SOURCEW
          SA1    X5          UPPER PART IF DOUBLE PREC, ELSE SINGLE WORD
          SA3    A1+1        LOWER PART IF DOUBLE PREC. 
          ID     X1,INDEF    TEST FOR INDEFINITE OR OUT OF RANGE
          OR     X1,RANGE 
          SX7    1RE
          SA4    REQUEST
          MX2    0
          SX5    X4-45B 
          NZ     X5,SP      JMP IF NOT DOUBLE PREC
          ID     X3,INDEF 
          OR     X3,RANGE 
          SX7    1RD
          DX2    X1+X3
          FX1    X1+X3
 SP       SA7    BSTATUS     SAVE E OR D
          PL     X1,POS      JMP IF DATA POSITIVE 
          SX6    46B         SET MINUS CODE 
          BX3    X2 
          AX2    73B
          BX1    -X1         COMPLEMENT DATA
          BX2    X2-X3
 POS      NX1    B5,X1       BEGIN SCALING DATA 
          SA6    SGN         STORE SIGN CODE
          MX0    70B
          ZR     X1,ZROS     JMP IF DATA ZERO 
          SA4    LG102       UN-NORMALIZED LOG BASE 10 OF 2 
          UX3    B5,X1       EXPONENT TO B5 
          SX5    B5+57B 
          PX3    X5          PACK EXPONENT AS INTEGER 
          FX6    X4*X3
          SB4    X6          SET INITIAL EXPONENT OF 10 
          SA4    BIG10-1     START OF POSITIVE POWERS 
          SX6    -B4
          PL     X6,POSX     JMP IF EXPONENT IS POSITIVE
          BX3    -X0
          IX7    X3-X6
          SA4    LIL10-1     START OF NEGATIVE POWERS 
          BX6    X7-X3
 POSX     BX7    -X0*X6      FOR SMALL POSITIVE SCALING 
          AX6    4           FOR LARGE SCALING
          SB1    X7+TEN0
          SB5    X6 
          SX3    B0 
          ZR     X6,SDONE    JMP IF NO LARGE SCALING
 SLOOP    SX4    B6 
          BX7    X4*X6       MASK OFF NEXT POWER OF 10 BIT
          AX6    1
          SA4    A4+B6       FETCH UPPER PART BU
          ZR     X7,SLOOP    LOOP IF BIT IS ZERO
          SA5    A4+5        FETCH MIDDLE PART BM 
          SB5    X6 
          FX0    X4*X3        1. BU*AL   SINGLE LOWER 
          DX6    X5*X1        2. BM*AU   DOUBLE LOWER 
          FX7    X0+X6        3. 1 + 2   SL 
          DX3    X4*X2        4. BU*AM   DL 
          FX0    X5*X2        5. BM*AM   SL 
          FX6    X3+X0        6. 4 + 5   SL 
          FX3    X4*X2        7. BU*AM   SINGLE MIDDLE
          FX0    X5*X1        8. AM*BU   SM 
          SA5    A5+5           FETCH BL
          RX2    X7+X6        9. 3 + 6   SL 
          FX6    X5*X1       10. BL*AU   SL 
          DX7    X3+X0       11. 7 + 8   DL 
          RX5    X2+X6       12. 9+10    SL 
          DX6    X4*X1       13. AU*BU   DOUBLE MIDDLE
          FX2    X3+X0       14. 7 + 8   SM 
          FX3    X4*X1       15. AU*BU   SINGLE UPPER 
          RX0    X7+X5       16. 11+12   SL 
          DX4    X6+X2       17. 13+14   DL 
          FX5    X6+X2       18. 13+14   SM 
          RX7    X0+X4       19. 16+17   SL 
          FX4    X5+X7       20. 18+19   SM 
          DX6    X5+X7       21. 18+19   DL 
          FX1    X3+X4       22. 15+20   SU 
          DX5    X3+X4       23. 15+20   DM 
          FX2    X6+X5       24. 21+23   SM 
          DX3    X6+X5       25. 21+23   DL 
          SX6    B5 
 SDONE    NZ     X6,SLOOP    LOOP FOR FURTHER SCALING 
          SA4    B1          FETCH 10**N S
          FX6    X4*X3        1.  S*AL   SL 
 SMORE    DX0    X4*X2        2.  S*AM   DL 
          RX3    X0+X6        3. 1 + 2   SL 
          DX7    X4*X1        4.  S*AU   DM 
          FX2    X4*X2        5.  S*AM   SM 
          DX5    X7+X2        6. 4 + 5   DL 
          RX0    X3+X5        7. 3 + 6   SL 
          FX3    X7+X2        8. 4 + 5   SM 
          FX6    X0+X3        9. 7 + 8   SM 
          FX7    X4*X1       10.  S*AU   SU 
          DX5    X0+X3       11. 7 + 8   DL 
          FX1    X7+X6       12. 10+9    SU 
          DX4    X7+X6       13. 10+9    DM 
          FX2    X4+X5       14. 13+11   SM 
          DX3    X4+X5       15. 13+11   DL 
          SA4    TEN0+1      FETCH 10**1
          SA5    A4-B6       FETCH 10**0
          IX6    X1-X4
          NG     X6,LT10     JMP IF RESULT LT 10
          SB1    TEN0+15     SET FOR 10**15 
          SA4    LIL10-1     SET FOR NEGATIVE SCALING 
          SX6    B6 
          SB4    B4+B6       INCREMENT EXPONENT OF 10 
          EQ     SLOOP       LOOP TO CONTINUE SCALING 
 LT10     IX6    X1-X5
          PL     X6,GE1      JMP IF RESULT GE 1 
          FX6    X4*X3
          ZR     X1,ZROS     JMP IF RESULT IS ZERO
          SB4    B4-B6
          EQ     SMORE       LOOP TO CONTINUE SCALING 
 GE1      UX1    B5,X1       REPOSITION 108+ HIGH BITS OF X1,X2,X3
          SB1    B5+66B      X1 WILL CONTAIN 54+ HIGH BITS
          MX0    6           RIGHT JUSTIFIED
          LX1    B1,X1       X2 WILL CONTAIN 54 LOW BITS
          SB1    B5+102B     LEFT JUSTIFIED 
          UX2    B0,X2
          LX2    B1,X2
          MX7    60B
          BX4    -X7*X2 
          IX1    X1+X4
          UX3    B0,X3
          BX2    X7*X2
          SB1    B5+22B 
          LX3    B1,X3
          MX7    66B
          BX3    X3*X7
          IX2    X2+X3       SCALING COMPLETED
          SB7    B4+B6       N FOR .XXXX*10**N
          SA4    SINKLENG    OUTPUT FIELD WIDTH DESIRED 
          SB3    SCRATCH-5   FWA+1 - 5 EXPONENT PLACES AND SIGN POSITION
          SB3    B3+X4       B3 = LWA+1 - 5 PLACES
          SB1    X4-7        NUMBER OF SIGNIFICANT DIGITS PUT OUT 
          SA3    SGN         FETCH SIGN 
          SA0    SCRATCH     OUTPUT TEMPORARY STORAGE 
          BX6    X3 
          SA6    A0          STORE SIGN 
          SX6    57B         (.)
          SA6    A6+B6       STORE DECIMAL PT 
          SA0    A6+B6
          RJ     DPCH        CONVERT AND STORE FRACTION STRING
          AX1    66B         ROUND THE DATA 
          SA3    A0-B6       FETCH LAST CHAR
          SX2    X1-5 
          NG     X2,NXP3     JMP IF NO ROUND
          SB4    33B
 RNA      SX6    X3+B6
          SB5    X3-44B 
          SA6    A3          STORE INCREMENTED CHAR 
          NG     B5,NXP3     JMP IF LAST WAS NOT 9
          SX6    B4 
          SA3    A3-B6       FETCH NEXT CHAR
 RNB      SA6    A6          OVER-STORE ZERO OR DECIMAL PT
          ZR     B5,RNA      LOOP TO CONTINUE CARRY ON 9
          SB5    B5-13B 
          SX6    57B         SET CHAR TO DECIMAL PT 
          ZR     B5,RNB      LOOP IF CHAR WAS DECIMAL PT
          SB5    B5+12B 
          SB7    B7+B6       INCREMENT EXPONENT 
          SA3    A6+B6
          SX6    B5+45B 
          SA6    A6          RESTORE SIGN 
          SB5    X3-45B 
          SX6    B4+B6       SET 1 CODE OR *
          NG     B5,RNF      JMP IF NUMBER CODE 
          SA3    A3+B6       STEP BACK ONE CHAR 
 RNF      SA6    A3          STORE 1 CODE OR *
 NXP3     SB3    B3+5        RESET LWA+1
          SA4    BSTATUS     BEGIN CODING EXPONENT STRING 
          SX7    45B         SET SIGN + 
          BX6    X4 
          SX1    B7 
          SA6    A0          STORE E OR D CODE
          SA2    TENMU
          BX6    X1 
          PL     B7,NXQ      JMP IF EXPONENT IS POSITIVE
          BX1    -X1
          SX7    X7+B6       SET SIGN - 
 NXQ      SA3    A2+B6
          PX1    X1 
          SA6    EXPONEN     SAVE EXPONENT AS A BINARY VALUE
          DX4    X2*X1
          FX1    X2*X1       QUOTIENT E/10 = E1 
          SB4    33B
          FX5    X4*X3       REMAINDER E/10 
          DX4    X2*X1
          FX1    X2*X1       QUOTIENT E1/10 = E2
          FX0    X4*X3       REMAINDER E1/10
          SA7    A0+B6       STORE SIGN OF EXPONENT 
          DX4    X2*X1
          SX7    X1+B4
          SX6    X0+B4
          SA7    A7+B6       STORE SIGN OR 100S DIGIT 
          SA6    A7+B6       STORE 10S DIGIT
          SX7    X5+B4
          SA7    A6+B6       STORE 1S DIGIT 
          EQ     CDONE
 ZROS     SA3    SINKLENG    DATA IS ZERO 
          SA5    SGN         FETCH SIGN 
          SX6    57B
          SB3    SCRATCH
          SX7    33B
          SA6    B3+B6       STORE DECIMAL POINT
          BX6    X5 
          SA7    A6+B6       STORE ZERO 
          SA6    B3          STORE SIGN 
          MX6    0
          SB1    X3-3 
          SA6    EXPONEN     SAVE EXPONENT OF ZERO
 ZLOOP    SA7    A7+B6       LOOP, STORING ZEROS
          SB1    B1-B6
          GE     B1,B0,ZLOOP
          EQ     CDONE
 INDEF    SX7    11B         DATA IS INDEFINITE 
          EQ     RAA
 RANGE    SX7    22B         DATA IS OUT OF RANGE 
 RAA      SB5    SCRATCH
          SA4    SINKLENG 
          SB3    B5+X4
 RAB      SA6    B5          STORE BLANK
          SB5    B5+B6
          LT     B5,B3,RAB   LOOP TILL FIELD COMPLETE 
          SA7    A6          STORE I OR R 
          MX6    0
          SA6    EXPONEN     SAVE EXPONENT OF ZERO
          EQ     CDONE
 DPCH     BSS    1           CONVERT B1 DIGITS TO DISPLAY CODE
          MX7    54 
 DPC      LX4    B6,X2       2*LOWER
          BX5    -X0*X1      MASK OFF DIGIT 
          AX1    66B         POSITION DIGIT 
          LX2    3           8*LOWER
          SX6    X1+33B      DISPLAY CODE OF DIGIT
          IX3    X2+X4       10*LOWER 
          LX4    B6,X5       2*UPPER
          BX2    X7*X3       REMOVE CARRY FROM LOWER
          LX5    3           8*UPPER
          SA6    A0          STORE CHARACTER
          BX3    -X7*X3      CARRY FROM LOWER 
          IX1    X5+X4       10*UPPER 
          SB1    B1-B6       DECREMENT COUNT
          SA0    A0+B6       ADVANCE POSITION IN OUTPUT STRING
          IX1    X1+X3       10*UPPER+CARRY 
          LT     B0,B1,DPC   LOOP 
          EQ     DPCH        RETURN 
 CDONE    SA0    SCRATCH     PACK CHARS FOR OUTPUT
          SB7    60          NR BITS PER WORD 
          SB2    6           NR BITS PER CHAR 
          SB5    B2          SHIFT CONTROL
          MX6    0           ZERO OUTPUT WORD 
          SA4    SINKLENG 
          SB3    B0          OUTPUT CHAR COUNTER
          SB4    X4          NR OUTPUT CHARS DESIRED
          SX4    BSTATUS+1
 PLOOP    SA1    A0+B3       PICK UP CHAR 
          SB1    B7-B5       CALCULATE SHIFT REQUIRED 
          LX1    B1,X1       POSITION CHAR
          IX6    X1+X6       ADD CHAR 
          SB3    B3+B6       INCR OUTPUT CHAR COUNTER 
          EQ     B3,B4,STORE RETURN IF DONE PACKING 
          SB5    B5+B2       INCR SHIFT CONTROL 
          LE     B5,B7,PLOOP LOOP FILLING OUTPUT WORD 
          SB5    B2          RESET SHIFT CONTROL
          SA6    X4          STORE OUTPUT WORD
          SX4    X4+B6       NEXT OUTPUT WORD 
          MX6    0           ZERO OUTPUT WORD 
          EQ     PLOOP       CONTINUE PACKING 
 STORE    SA6    X4          STORE LAST OUTPUT WORD 
          EQ     QU2KOD 
 SGN      BSS    1
          BSS    1
 BSTATUS  BSS    1
 SCRATCH  BSS    37 
 LG102    DATA   17172321011520476750B
 TENMU    DATA   17170631463146314632B
          DATA   20000000000000000012B
          SPACE  4,8
**        POWER OF TEN CONVERSION TABLES. 
* 
*         TEN0 - POWERS OF TEN UP TO 10 ** 15.
* 
*         BIG10 - TRIPLE PRECISION POWERS OF 10 TO POWERS OF 2
* 
*         LIL10 - TRIPLE PRECISION POWERS OF 10 TO NEGATIVE POWERS OF 2 
  
  
          USE    /QU2KOD/ 
 TEN0     DATA   1.E0                                                   000110
          DATA   1.E1                                                   000120
          DATA   1.E2                                                   000130
          DATA   1.E3                                                   000140
          DATA   1.E4                                                   000150
          DATA   1.E5                                                   000160
          DATA   1.E6                                                   000170
          DATA   1.E7                                                   000180
          DATA   1.E8                                                   000190
          DATA   1.E9                                                   000200
          DATA   1.E10                                                  000210
          DATA   1.E11                                                  000220
          DATA   1.E12                                                  000230
          DATA   1.E13                                                  000240
          DATA   1.E14                                                  000250
          DATA   1.E15                                                  000260
  
  
  
 BIG10    DATA      20064341571157602000B    1.EEE16   PART 1 
          DATA      20734734265552025560B    1.EEE32   PART 1 
          DATA      22456047403722377717B    1.EEE64   PART 1 
          DATA      25724473510762300351B    1.EEE128  PART 1 
          DATA      34435247735376716771B    1.EEE256  PART 1 
  
          DATA      17250000000000000000B    1.EEE16   PART 2 
          DATA      20135531676010000000B    1.EEE32   PART 2 
          DATA      21655155247457665561B    1.EEE64   PART 2 
          DATA      25124315770633631554B    1.EEE128  PART 2 
          DATA      33636750673556710033B    1.EEE256  PART 2 
  
          DATA      16450000000000000000B    1.EEE16   PART 3 
          DATA      17320000000000000000B    1.EEE32   PART 3 
          DATA      21056166544576650371B    1.EEE64   PART 3 
          DATA      24321553040115601065B    1.EEE128  PART 3 
          DATA      33034617735255702437B    1.EEE256  PART 3 
  
  
  
 LIL10    DATA      16327151262457542115B    1.EEE-16  PART 1 
          DATA      15456373043653242471B    1.EEE-32  PART 1 
          DATA      13735207775211722471B    1.EEE-64  PART 1 
          DATA      10466735010637062274B    1.EEE-128 PART 1 
          DATA      01756003050311261572B    1.EEE-256 PART 1 
  
          DATA      15527025551413537150B    1.EEE-16  PART 2 
          DATA      14654513514767414355B    1.EEE-32  PART 2 
          DATA      13137232247710714327B    1.EEE-64  PART 2 
          DATA      07667112025437131766B    1.EEE-128 PART 2 
          DATA      01150623477244210525B    1.EEE-256 PART 2 
  
          DATA      14723630465154737562B    1.EEE-16  PART 3 
          DATA      14055130051274405534B    1.EEE-32  PART 3 
          DATA      12332173154211025040B    1.EEE-64  PART 3 
          DATA      07066405673367561155B    1.EEE-128 PART 3 
          DATA      00357757552302121101B    1.EEE-256 PART 3 
  
  
  
          USE    /CCONVER/
 REQUEST  BSS    1
 SOURCEB  BSS    1
 SOURCEW  BSS    1
 SOURCELE BSS    1
          BSS    1
 SINKBYTE BSS    1
 SINKWORD BSS    1
 SINKLENG BSS    1
          BSS    4
          END 
