*DECK CONA
          IDENT  T8.CNA 
          TITLE  ROUTINES CONA.., GPTR, ECON, T3= 
 CONA..   TITLE  CONA.. - COMMON DESTINATION CONVERSION ROUTINES        064030
*                                                                       064040
**    CONA.. - ROUTINES TO STORE COMMON MODE DESTINATION FIELDS 
*                                                                       064060
*         INPUT  -  B1 = 1                                              064070
*                X1 = DESTINATION POINTER                               064080
*                B5 = RETURN ADDRESS                                    064090
*                OTHERS AS DEFINED BELOW                                064100
*                                                                       064110
*         OUTPUT -  NONE IN REGISTERS EXCEPT WHERE INDICATED BELOW      064120
*                                                                       064130
*         PRESERVED  --, --, --, --, --, --, --, --                     064140
*                    A0, --, --, --, --, --, --, --                     064150
*                        B1, --, --, --, --, --, --                     064160
*                                                                       064170
*         TEMPORARY CELLS USED                                          064180
*                T.NUM,+1,+2    SOURCE, A TRIPLE PRECISION NUMBER       064190
*                T.TEMP1     TEMPORARY                                  064200
*                T.TEMP2     TEMPORARY                                  064210
*                                                                       064220
*         NOTES..   THE ENTRIES BELOW ARE ALL NAMED -CONA..Q-,          064230
*                 WHERE -Q- IS A VALID DESTINATION TYPE.  HOWEVER,      064240
*                 CERTAIN ENTRIES ARE SPECIAL USE, AS DESCRIBED WITH    064250
*                 THE ENTRY.                                            064260
          SPACE  1
*                                                                       064270
*CALL COM2
          SPACE  4                                                      064290
*                                                                       064300
* BIT FIELDS.  B4 = FLAG (3=ONES COMPLEMENT, 1=TWOS COMPLEMENT)         064310
*                                                                       064320
 CONA..B  SA2    T.NUM       CHECK FOR 0, -0, INF, IND                  064330
          OR     X2,CNA.1    INF                                        064340
          ID     X2,CNA.1    IND                                        064350
          NZ     X2,CNA.4     REALLY A NUMBER                           064360
          PL     X2,CNA.2    +0                                         064370
 CNA.1    BX2    X2-X2       -0                                         064380
          ZR     B4,CNA.2                                               064390
          SX2    B0          USE +0 IF NOT ONES COMPLEMENT              064400
 CNA.2    BX6    X2                                                     064410
          SB6    CNA.3                                                  064420
          SX2    60                                                     064430
 CNA.3    NZ     X2,STBITS                                              064440
          JP     B5          EXIT                                       064450
*                                                                       064460
 CNA.4    BX7    X1          NUMBER.. ROUND                             064470
          LX1    X2                                                     064480
          SA2    A2+B1       PICK UP REST OF NUMBER                     064490
          SA3    A2+B1                                                  064500
          SA7    T.TEMP1                                                064510
          SB2    TEN.HLF     1/2                                        064520
          SB6    CNA.5                                                  064530
          EQ     T3=ADD1     ROUND                                      064540
*                                                                       064550
 CNA.5    NE     B4,B1,CNA.7 ADJUST NEGATIVE RESULT IF TWOS COMP        064560
          PL     X1,CNA.7                                               064570
          SB2    TEN.ONE     +1                                         064580
          SB6    CNA.6                                                  064590
          EQ     T3=ADD1                                                064600
 CNA.6    NG     X1,CNA.7                                               064610
          SA1    T.TEMP1     IF ZERO, WE WANT 111...1 AS A RESULT (-1)  064620
          BX2    X2-X2                                                  064630
          EQ     CNA.2                                                  064640
*                                                                       064650
 CNA.7    UX6    X1,B2       PACK UP BITS AND GET EXPONENT
          MX0    60-12                                                  064670
          SA6    T.TEMP2     SAVE SIGN                                  064680
          LX1    12                                                     064690
          BX1    X0*X1                                                  064700
          LX2    24                                                     064710
          BX7    -X0*X2                                                 064720
          MX4    60-24                                                  064730
          LX3    36                                                     064740
          IX7    X1+X7                                                  064750
          BX2    -X4*X2                                                 064760
          SA7    T.NUM       SAVE 144-BIT STRING                        064770
          BX6    X4*X3                                                  064780
          IX6    X2+X6                                                  064790
          BX7    X3                                                     064800
          SA6    A7+B1                                                  064810
          SA7    A6+B1                                                  064820
*                                                                       064830
          SA1    T.TEMP1     RESTORE POINTER                            064840
          SB7    B2+48       =E, NUMBER OF BITS IN SOURCE               064850
          GT     B7,B0,CNA.8
          SB7    B0          E=0 IF NEGATIVE                            064870
 CNA.8    SA3    T.TEMP2     SIGN                                       064880
          BX5    X1                                                     064890
          SX4    B7                                                     064900
          AX5    36          =F, DESTINATION FIELD WIDTH                064910
          BX6    X3                                                     064920
          SX7    B0                                                     064930
          IX5    X4-X5       E-F                                        064940
          AX6    59          EXTENDED SIGN                              064950
          NZ     B4,CNA.8A   JP 2-S COMP                                064960
          BX7    X6          1-S COMP., FILL WILL BE EXTENDED SIGN      064970
 CNA.8A   SA7    A3                                                     064980
          BX7    X1          X1 TO X7 IN CASE STBITS SKIPPED
*                                                                       064990
 CNA.8B   PL     X5,CNA.10   JP F .LE. E                                065000
          SX2    60                                                     065010
          SB6    CNA.9                                                  065020
          BX5    -X5                                                    065030
 CNA.9    ZR     X5,CNA.10   JP NO MORE BITS                            065040
          IX5    X5-X2                                                  065050
          PL     X5,STBITS   FILL 60                                    065060
          IX2    X5+X2                                                  065070
          SX5    B0                                                     065080
          EQ     STBITS      FILL REMAINDER (.LT. 60)                   065090
*                                                                       065100
 CNA.10   AX1    36          =F, DESTINATION FIELD WIDTH                065110
          SA7    A1          SAVE T.TEMP1 = DESTINATION POINTER         065120
          SB4    144         MAX. SOURCE BITS                           065130
          SB2    X1                                                     065140
          LT     B4,B7,CNA.10A
          SB4    B7          U = MIN(144,E)                             065160
 CNA.10A  SB2    B7-B2       E-F, = BITS TO SKIP IN SOURCE
          GE     B2,B4,CNA.14   JP IF ALL OF SOURCE SKIPPED             065180
          SX4    B2          BITS TO SKIP                               065190
          SX1    T.NUM                                                  065200
          SX3    60                                                     065210
          SX2    B4-B2       =RESIDUAL BITS IN SOURCE                   065220
 CNA.11   IX4    X4-X3       REDUCE X4 MODULO 60                        065230
          NG     X4,CNA.12                                              065240
          SX1    X1+B1                                                  065250
          EQ     CNA.11                                                 065260
 CNA.12   IX4    X4+X3       RESTORE                                    065270
          LX2    36                                                     065280
          BX1    X1+X2                                                  065290
          LX4    18                                                     065300
          BX1    X1+X4       POINTER TO SOURCE NOW IN X1                065310
          LX2    60-36                                                  065320
          SA3    T.TEMP1                                                065330
          SB6    CNA.13                                                 065340
          BX7    X3                                                     065350
          EQ     MVBITS      MOVE BITS                                  065360
 CNA.13   BX1    X7                                                     065370
          EQ     CNA.15                                                 065380
*                                                                       065390
 CNA.14   SA1    T.TEMP1                                                065400
 CNA.15   SA3    T.TEMP2     FILL OUT WITH SIGN OR ZEROES               065410
          SX2    60                                                     065420
          BX6    X3          FILL VALUE                                 065430
          SB6    CNA.16                                                 065440
 CNA.16   NZ     X2,STBITS                                              065450
*                                                                       065460
          JP     B5          EXIT                                       065470
          SPACE  2                                                      065480
*                                                                       065490
* CONVERT TO STRING FORM. X6=CHARACTER SIZE IN BITS (6,8,12)            065500
*                                                                       065510
 CONA..A  SB7    CNA.20      CONVERT TO ASCII                           065520
          EQ     CONA..X                                                065530
*                                                                       065540
 CONA..C  SB7    CNA.21      CONVERT TO EBCDIC                          065550
*         EQ     CONA..X                                                065560
*                                                                       065570
 CONA..X  SA6    T.TEMP2     SAVE SIZE                                  065580
          BX7    X1                                                     065590
          SX6    B0                                                     065600
          SA7    T.TEMP1     SAVE DESTINATION ADDRESS                   065610
          SA6    T.I2        SUB-TYPE = REAL                            065620
          EQ     ECON        CONVERT TO A DISPLAY CODE STRING           065630
*                                                                       065640
*                                                                       065650
 CNA.20   SX6    SPACE.A                                                065660
          SB7    CNA.24                                                 065670
          EQ     CONA.BL                                                065680
*                                                                       065690
 CNA.21   SX6    SPACE.C                                                065700
          SB7    CNA.25                                                 065710
*                                                                       065720
 CONA.BL  SA5    T.NBL       INSERT LEADING BLANKS (ENTRY POINT)        065730
          SA1    T.TEMP1
          SA2    T.TEMP2                                                065740
          SB6    CNA.22                                                 065750
 CNA.22   SX0    B1                                                     065760
          IX5    X5-X0                                                  065770
          PL     X5,STBITS   STORE BLANKS                               065780
*                                                                       065790
          SA2    T.M2        MAKE UP SOURCE POINTER FOR MOVE            065800
          SA3    T.NBL                                                  065810
          BX7    X1 
          SX1    T.STRING                                               065820
          IX2    X2-X3                                                  065830
          LX2    36+1                                                   065840
          IX3    X2+X2                                                  065850
          IX2    X2+X3                                                  065860
          BX1    X1+X2                                                  065870
          JP     B7                                                     065880
*                                                                       065890
*                                                                       065900
 CNA.24   SX5    TR.XTOA     ASCII TRANSLATION
          EQ     CNA.26                                                 065920
 CNA.25   SX5    TR.XTOC     EBCDIC TRANSLATION                         065930
 CNA.26   SA3    T.TEMP2     SIZE (DEST)                                065940
          SX2    SIZE.X      SIZE (SOURCE)                              065950
*         EQ     CNA..MV                                                065960
**
*  CNA..MV - SUBROUTINE TO MOVE WITH TRANSLATION                        065980
*                                                                       065990
*         INPUT  -  B1 = 1                                              066000
*                   X1 = SOURCE POINTER (CODE 1)                        066010
*                   X2 = SIZE OF (CODE 1) CHAR                          066020
*                   X3 = SIZE OF (CODE 2) CHAR                          066030
*                   X5 = CONV. TABLE POINTER                            066040
*                   X6 = SPACE CHAR (CODE 2)                            066050
*                   X7 = DESTINATION POINTER (CODE 2)                   066060
*                   B5 = RETURN ADDRESS                                 066070
*                                                                       066080
*         OUTPUT -  NONE IN REGISTERS                                   066090
*                                                                       066100
*         TEMPORARY CELLS USED..                                        066110
*                                                                       066120
*                T.TEMP1     HOLDS POINTERS                             066130
*                T.TEMP2     HOLDS -SPACE- CHARACTER                    066140
*                T.S1        HOLDS SIZE OF SOURCE CHARACTER             066150
*                T.S2        HOLDS SIZE OF DESTINATION CHARACTER        066160
*                                                                       066170
*         NOTES..   THE X5 VALUE POINTS TO A TRANSLATION DESCRIPTOR.    066180
*                 TWO TRANSLATIONS MAY BE SPECIFIED.  THE FIRST         066190
*                 POINTER IS IN BITS (0-17), THE SECOND IN BITS (30-47).
*                 THE FIRST POINTER MAY BE ZERO.  THE SECOND            066210
*                 MUST BE ZERO IF NO SECOND TRANSLATION IS TO BE DONE.  066220
*                                                                       066230
          SPACE  2                                                      066250
 CNA..MV  SA7    T.TEMP1     SAVE DESTINATION POINTER                   066260
          SA6    T.TEMP2     SAVE -SPACE- CHARACTER                     066270
          BX7    X2                                                     066280
          LX6    X3                                                     066290
          SA7    T.S1        SIZE OF SOURCE CHAR                        066300
          SA6    T.S2        SIZE OF DEST. CHAR                         066310
          SB6    CNA.30                                                 066320
          EQ     NXBITS      GET A CHARACTER                            066330
*                                                                       066340
 CNA.30   SA1    T.TEMP1                                                066350
          ZR     X2,CNA.33   NO CHAR, BLANK FILL                        066360
          MX0    52 
          SA7    A1                                                     066380
          BX6    -X0*X6      ISOLATE 8 BIT CHR
          ZR     X5,CNA.31   JP NO TRANSLATION                          066400
          SA3    X5                                                     066410
          SB4    X6                                                     066420
          SA4    X3+B4       CHAR + BASE                                066430
          AX3    18                                                     066440
          SB4    X3                                                     066450
          AX6    X4,B4       SHIFT TO LOW END                           066460
          AX3    18                                                     066470
          BX6    X6*X3       AND MASK OFF                               066480
          LX5    60-30       LOOK FOR SECOND CONVERSION 
          SB4    X5                                                     066500
          ZR     B4,CNA.31   JP NO SECOND CONVERSION                    066510
          SA3    X5          CONVERT                                    066520
          SB4    X6                                                     066530
          SA4    X3+B4       CHAR+BASE                                  066540
          AX3    18                                                     066550
          SB4    X3                                                     066560
          AX6    X4,B4       SHIFT TO LOW END                           066570
          AX3    18                                                     066580
          BX6    X6*X3       AND MASK OFF                               066590
 CNA.31   SA2    T.S2        STORE DESTINATION CHAR                     066600
          SB6    CNA.32                                                 066610
          LX5    30          RESTORE X5 
          EQ     STBITS                                                 066630
*                                                                       066640
 CNA.32   BSS    0
          SA1    A1          NOT DONE, GET NEXT                         066670
          SA2    T.S1        SIZE                                       066680
          SB6    CNA.30                                                 066690
          SA7    A1          SAVE DEST. POINTER                         066700
          EQ     NXBITS                                                 066710
*                                                                       066720
 CNA.33   SA4    T.TEMP2     COME HERE WHEN SOURCE EMPTY, SPACE FILL    066730
          SA2    T.S2                                                   066740
          SA7    A1          SOURCE UPDATED-T.TEMP1 
          BX7    X1                                                     066750
          SB6    CNA.34                                                 066760
          BX6    X4                                                     066770
 CNA.34   AX7    36          STORE BLANKS TO END OF FIELD               066780
          NZ     X7,STBITS                                              066790
          BX7    X1 
*                                                                       066800
          JP     B5          EXIT 
*                                                                       066820
          SPACE  2                                                      066830
**    CONA.RN - SAVE X1 IN T.TEMP1 AND ROUND T.NUM,+1,+2 TO INTEGER 
*            FORM, LEAVING IT IN X1,X2,X3  -USES B6 AS LINK             066860
*                                                                       066870
 CONA.RN  BX7    X1                                                     066880
          SA1    T.NUM                                                  066890
          SA2    A1+B1                                                  066900
          SA7    T.TEMP1                                                066910
          SB2    TEN.HLF     1/2                                        066920
          SA3    A2+B1                                                  066930
          PL     X1,T3=ADD1  BR IF POSITIVE 
          SB2    TEN.MHF     MINUS ONE-HALF 
          EQ     T3=ADD1                                                066940
*                                                                       066950
          SPACE  2                                                      066960
**    CNA..MB - SUBROUTINE TO MOVE A CHARACTER FIELD TO A BIT FIELD 
*                                                                       066980
*         INPUT  -  B1 = 1                                              066990
*                   X5 = CODE FOR -ZERO- IN SOURCE                      067000
*                   B7 = SIZE OF SOURCE CHARACTER (BITS)                067010
*                                                                       067020
*                T.I1        POINTER TO SOURCE FIELD                    067030
*                T.I2        POINTER TO DESTINATION FIELD               067040
*                T.SAVEB6    RETURN ADDRESS                             067050
*                                                                       067060
          SPACE  2                                                      067080
*                                                                       067090
 CNA..MB  SX2    B7          PICK UP SOURCE CHARACTER                   067100
          SB6    CNA.40                                                 067110
          SA1    T.I1                                                   067120
          EQ     NXBITS                                                 067130
*                                                                       067140
 CNA.40   ZR     X2,CNA.43   JP NO MORE SOURCE                          067150
          MX0    52 
          BX6    -X0*X6      ISOLATE 8-BIT CHR
          IX6    X6-X5       REDUCE TO (0-1)                            067180
          SA7    A1          SAVE SOURCE POINTER                        067190
          SA1    T.I2                                                   067200
          NG     X6,CNA.E1   JP NOT (0-1) 
          SX2    B1                                                     067220
          IX7    X2-X6                                                  067230
          SB6    CNA.41                                                 067240
          PL     X7,STBITS                                              067250
          EQ     CNA.E1      JP NOT (0-1) 
*                                                                       067270
 CNA.41   SA7    A1          SAVE POINTER                               067280
          NZ     X2,CNA..MB   JP NOT DONE 
 CNA.42   SA5    T.SAVEB6    DONE                                       067300
          SB6    X5                                                     067310
          JP     B6                                                     067320
*                                                                       067330
 CNA.43   SA5    T.I2        SOURCE EMPTY, FILL OUT WITH ZEROES         067340
          BX1    X5                                                     067350
          SX6    B0                                                     067360
          SX2    60                                                     067370
          AX5    36          LEFT TO FILL                               067380
          SB6    CNA.44                                                 067390
 CNA.44   ZR     X5,CNA.42   DONE                                       067400
          IX5    X5-X2                                                  067410
          PL     X5,STBITS                                              067420
          IX2    X5+X2                                                  067430
          SX5    B0                                                     067440
          EQ     STBITS                                                 067450
          SPACE  2
**    ERROR ACTIONS 
*                                                                       067480
 CNA.E1   SA2    CNA.M1      CHARACTER NOT 0-1
          EQ     ERR.CON                                                067500
****
*                                                                       067520
 CNA.M1   VFD    12/0,18/E.CON,12/0,18/*+1
          DATA    C/SOURCE CHARACTER NOT 0 OR 1, TO BIT STRING/         067540
****
 GPTR     TITLE  GPTR -- FIXUP CONVERSION POINTERS                      067570
*                                                                       067580
**    GPTR - FIXUP CONVERSION POINTERS (SOURCE AND DESTINATION) 
*                                                                       067600
*         INPUT  -  B1 = 1                                              067610
*                   B5 = RETURN                                         067620
*                                                                       067630
* GS (ONLY)..    T.INREC     POINTER TO CURRENT POSITION IN SOURCE      067640
*                T.M1        M FIELD FOR SOURCE ITEM                    067650
*                                                                       067660
* GD (ONLY)..    T.OUTREC    CURRENT POINTER FOR DESTINATION            067670
*                T.M2        M FIELD FOR DESTINATION ITEM               067680
*                                                                       067690
*         OUTPUT -                                                      067700
*                                                                       067710
* GS (ONLY)..    T.SAVEB6    ENTRY CONTENTS OF B6                       067720
*                T.INREC     POINTER TO NEXT FIELD                      067730
*                T.I1        POINTER TO CURRENT FIELD                   067740
*                                                                       067750
* GD (ONLY)..    T.OUTREC    POINTER TO NEXT FIELD                      067760
*                T.I2        POINTER TO CURRENT FIELD                   067770
*                                                                       067780
*         PRESERVED  --, --, --, --, --, --, --, --                     067790
*                    A0, --, --, --, --, --, --, --                     067800
*                        B1, --, --, --, --, --, B7                     067810
*                                                                       067820
*         NOTES..   ENTRY POINTS ARE NAMED -GS... OR -GD... DEPENDING   067830
*                 ON WHETHER THE SOURCE OR DESTINATION POINTER IS TO    067840
*                 BE ADJUSTED..                                         067850
*                                                                       067860
*         GSBX, GSB, GDB     - BIT FIELD              (M( 
*         GS6X, GS6, GD6     - 6-BIT CHARACTER FIELD  (M) 
  
*         GS8X, GS8, GD8     - 8-BIT CHARACTER FIELD  (M) 
*         GSCX, GSC, GDC     - 12-BIT CHARACTER FIELD (M) 
*               GSH, GDH     - 16-BIT FIELD                             067910
*               GSW, GDW     - 32-BIT FIELD                             067920
*               GSE, GDE     - 60-BIT FIELD                             067930
*               GSG, GDG     - 64-BIT FIELD                             067940
*               GSD, GDD     - 120-BIT FIELD                            067950
*               GSL, GDL     - 128-BIT FIELD                            067960
*                                                                       067970
*         GS-X ROUTINES ADJUST (M) COUNTS IF THE FIELD EXTENDS PAST THE 
*              END OF RECORD
* 
*                   DESTINATION FIELDS ARE ZEROED BY THIS ROUTINE       067980
*                                                                       067990
          SPACE  4                                                      068010
*                                                                       068020
* FOLLOWING ARE THE ENTRY POINTS TO THIS ROUTINE (EXCEPT -B-)           068030
*                                                                       068040
 .1       ECHO   ,Q=(S,D)                                               068050
          SPACE  1                                                      068060
 .2       ECHO   ,R=(6,8,C),X=(6,8,12),T=(6,8,C)
 G_Q_R    SX2    X
          EQ     G_Q_.M_T                                               068090
          SPACE  1                                                      068100
 .2       ENDD                                                          068110
          SPACE  1                                                      068120
 .2       ECHO ,R=(H,W,E,G,D,L),X=(16,32,60,64,120,128),T=(8,8,6,8,6,8) 
 G_Q_R    SX2    X
          EQ     G_Q_.N_T                                               068150
          SPACE  1                                                      068160
 .2       ENDD                                                          068170
 .1       ENDD                                                          068180
*                                                                       068190
* FOLLOWING IS THE ACTUAL CODE TO DO THE WORK                           068200
*                                                                       068210
 GSBX     SA2    T.M1        DESIRED FIELD SIZE 
          SA1    T.INREC
          PL     X2,GSBX.1
          SX2    1
 GSBX.1   AX1    36          ACTUAL FIELD SIZE
          IX7    X1-X2
          PL     X7,GS1.     FITS 
          BX2    X1          TOO BIG, USE ACTUAL RECORD SIZE
          EQ     GS1. 
* 
 GSB      SA2    T.M1        BIT FIELD SIZE                             068220
          PL     X2,GS1.
          SX2    B1                                                     068240
          EQ     GS1. 
*                                                                       068260
* 
 GS6X     SX3    6
          SB2    GS6. 
          EQ     GS.X 
* 
 GS8X     SX3    8
          SB2    GS8. 
          EQ     GS.X 
* 
 GSCX     SX3    12 
          SB2    GSC. 
*         EQ     GS.X        (FALL THROUGH) 
* 
 GS.X     SA2    T.M1 
          SA1    T.INREC
          PL     X2,GS.X1 
          SX2    1
 GS.X1    AX1    36          ACTUAL FIELD SIZE
          IX2    X2*X3       DESIRED FIELD SIZE 
 GS.X2    IX7    X1-X2
          PL     X7,GS.XX    FIELD FITS 
          IX2    X2-X3       REDUCE FIELD IF TOO LARGE
          EQ     GS.X2
 GS.XX    JP     B2          CONTINUE ADJUSTING FIELD 
* 
* 
 GS.M6    SA1    T.M1        6 BIT ADJUSTMENT, USE M FIELD              068270
          PL     X1,GS.1                                                068280
          SX7    B1                                                     068290
          SX1    B1                                                     068300
          SA7    A1                                                     068310
 GS.1     IX2    X1*X2                                                  068320
          EQ     GS6. 
*                                                                       068340
 GS.M8    SA1    T.M1        8 BIT ADJUSTMENT, USE M FIELD              068350
          PL     X1,GS.2                                                068360
          SX7    B1                                                     068370
          SX1    B1                                                     068380
          SA7    A1                                                     068390
 GS.2     IX2    X1*X2                                                  068400
          EQ     GS8. 
*                                                                       068420
 GS.MC    SA1    T.M1        12 BIT ADJUSTMENT, USE M FIELD             068430
          PL     X1,GS.3                                                068440
          SX7    B1                                                     068450
          SX1    B1                                                     068460
          SA7    A1                                                     068470
 GS.3     IX2    X1*X2                                                  068480
          EQ     GSC. 
*                                                                       068500
 GS.N6    SA1    T.M1        6 BIT ADJUSTMENT, FIXED FIELD              068510
          NG     X1,GS6.
          EQ     GPTR.E1     M ILLEGAL                                  068530
*                                                                       068540
 GS.N8    SA1    T.M1        8 BIT ADJUSTMENT, FIXED FIELD              068550
          NG     X1,GS8.
          EQ     GPTR.E1     M ILLEGAL                                  068570
*                                                                       068580
*                                                                       068590
 GDB      SA2    T.M2        BIT FIELD SIZE                             068600
          PL     X2,GD1.
          SX2    B1                                                     068620
          EQ     GD1. 
*                                                                       068640
 GD.M6    SA1    T.M2        6 BIT ADJUSTMENT, USE M FIELD              068650
          PL     X1,GD.1                                                068660
          SX7    B1                                                     068670
          SX1    B1                                                     068680
          SA7    A1          SET M=1 IF NOT SPECIFIED                   068690
 GD.1     IX2    X1*X2                                                  068700
          EQ     GD6. 
*                                                                       068720
 GD.M8    SA1    T.M2        8 BIT ADJUSTMENT, USE M FIELD              068730
          PL     X1,GD.2                                                068740
          SX7    B1                                                     068750
          SX1    B1                                                     068760
          SA7    A1          SET M=1 IF NOT SPECIFIED                   068770
 GD.2     IX2    X1*X2                                                  068780
          EQ     GD8. 
* 
 GD.MC    SA1    T.M2        6 BIT ADJUST., 12-BIT CHRS 
          PL     X1,GD.3A 
          SX7    B1 
          SX1    B1 
          SA7    A1 
 GD.3A    IX2    X1*X2
          EQ     GD6. 
*                                                                       068800
 GD.N6    SA1    T.M2        6 BIT ADJUSTMENT, FIXED FIELD              068810
          NG     X1,GD6.
          EQ     GPTR.E2     M ILLEGAL                                  068830
*                                                                       068840
 GD.N8    SA1    T.M2        8 BIT ADJUSTMENT, FIXED FIELD              068850
          NG     X1,GD8.
          EQ     GPTR.E2     M ILLEGAL                                  068870
*                                                                       068880
          SPACE  2                                                      068890
*                                                                       068900
* SOURCE FIXUP                                                          068910
*                                                                       068920
 GS1.     SA1    T.INREC     1 BIT SOURCE 
          SX0    B0                                                     068940
          EQ     GS                                                     068950
*                                                                       068960
 GS6.     SA1    T.INREC     6 BIT SOURCE 
          BX7    X1                                                     068980
          AX7    18                                                     068990
          SX6    60                                                     069000
          SX7    X7                                                     069010
          IX6    X6-X7       BITS REMAINING IN WORD                     069020
          BX7    X6                                                     069030
          IX0    X7/X5,6     REMAINING CHARACTERS                       069040
          IX7    X0+X0       *2                                         069050
          LX0    2           *4                                         069060
          IX7    X0+X7       *6                                         069070
          IX0    X6-X7       EXCESS BITS                                069080
          EQ     GS                                                     069090
*                                                                       069100
 GS8.     SA1    T.INREC     8 BIT SOURCE 
          BX7    X1                                                     069120
          MX0    60-3                                                   069130
          AX7    36          REMAINING BITS                             069140
          BX0    -X0*X7      EXCESS BITS                                069150
          EQ     GS                                                     069160
*                                                                       069170
 GSC.     SA1    T.INREC     12 BIT SOURCE
          BX7    X1                                                     069190
          AX7    18                                                     069200
          SX6    60                                                     069210
          SX7    X7                                                     069220
          IX6    X6-X7       BITS REMAINING IN WORD                     069230
          BX7    X6                                                     069240
          IX0    X7/X5,12    REMAINING CHARACTERS                       069250
          IX7    X0+X0       *2                                         069260
          LX0    2           *4                                         069270
          LX7    2           *8                                         069280
          IX7    X0+X7       *12                                        069290
          IX0    X6-X7       EXCESS BITS                                069300
          EQ     GS                                                     069310
*                                                                       069320
 GS       SX6    B6                                                     069330
          SB4    B5          RETURN ADDRESS                             069340
          SA6    T.SAVEB6                                               069350
          SB2    T.I1                                                   069360
          NZ     X1,GPTR     FIX UP POINTER 
          BX7    X1          NULL INPUT FIELD (OUT OF RECORD) 
          SA7    A1          * CONSTRUCT USED BY FORM ONLY *
          SA7    B2 
          JP     B5 
*                                                                       069380
* DESTINATION FIXUP                                                     069390
*                                                                       069400
 GD1.     SA1    T.OUTREC    1 BIT DESTINATION
          SX0    B0                                                     069420
          EQ     GD                                                     069430
*                                                                       069440
 GD6.     SA1    T.OUTREC    6 BIT DESTINATION
          BX7    X1                                                     069460
          AX7    18 
          SX6    60 
          SX7    X7 
          IX7    X6-X7       BITS REMAINING IN WORD 
          BX6    X7                                                     069480
          IX0    X7/X5,6     REMAINING CHARACTERS                       069490
          IX7    X0+X0       *2 
          LX0    2           *4                                         069510
          IX7    X0+X7       *6                                         069520
          IX0    X6-X7       EXCESS BITS                                069530
          EQ     GD                                                     069540
*                                                                       069550
 GD8.     SA1    T.OUTREC    8 BIT DESTINATION
          BX7    X1                                                     069570
          MX0    60-3                                                   069580
          AX7    36          REMAINING BITS                             069590
          BX0    -X0*X7      EXCESS BITS                                069600
*                                                                       069610
 GD       SB4    GD.3        LOCAL RETURN                               069620
          SB2    T.I2                                                   069630
          EQ     GPTR        FIX UP POINTER                             069640
*                                                                       069650
 GD.3     SX2    60          ZERO THE DESTINATION FIELD                 069660
          SB6    GD.4                                                   069670
          BX5    X0          BITS TO ZERO                               069680
          SX6    B0                                                     069690
 GD.4     ZR     X5,GD.5     DONE                                       069700
          IX5    X5-X2                                                  069710
          PL     X5,STBITS   STORE 60 BITS                              069720
          IX2    X5+X2                                                  069730
          SB6    B5                                                     069740
          EQ     STBITS      STORE LAST CHUNK                           069750
*                                                                       069760
 GD.5     JP     B5          RETURN                                     069770
*                                                                       069780
          SPACE  2                                                      069790
**    MAIN WORKING ROUTINE, GPTR
*                                                                       069820
*         INPUT  -  B1 = 1                                              069830
*                   X0 = ALIGNMENT BITS TO PRE-SKIP 
*                   X1 = POINTER (ORIGINAL MAIN POINTER)                069840
*                   X2 = SIZE OF DATA FIELD 
*                   A1 = ADDRESS OF MAIN POINTER                        069850
*                   B2 = ADDRESS OF CURRENT (NEXT) POINTER              069860
*                   B4 = RETURN                                         069870
*                   B5 = MAIN RETURN (NOT USED HERE)                    069880
*                                                                       069890
 GPTR     SB3    GPTR.1                                                 069900
          EQ     GPTR.X      DO POINTER TO THIS FIELD                   069910
 GPTR.1   MX6    60-36                                                  069920
          LX2    36                                                     069930
          BX7    -X6*X7                                                 069940
          IX7    X7+X2       PUT FIELD SIZE IN POINTER                  069950
          LX2    60-36                                                  069960
          SA7    B2                                                     069970
          SB3    GPTR.2                                                 069980
          IX0    X0+X2                                                  069990
          EQ     GPTR.X      UPDATE MAIN POINTER                        070000
 GPTR.2   SA7    A1                                                     070010
          JP     B4          RETURN                                     070020
*                                                                       070030
*                                                                       070040
 GPTR.X   BX5    X1          DO ONE POINTER FROM X0,X1                  070050
          LX7    X1                                                     070060
          BX6    X1                                                     070070
          AX5    36          REMAINING BITS                             070080
          SX7    X7          WORD POINTER                               070090
          SX4    60                                                     070100
          AX6    18                                                     070110
          IX5    X5-X0       NEW RESIDUAL                               070120
          SX6    X6          OFFSET IN WORD                             070130
          NG     X5,GPTR.E3  OVERRUN END OF RECORD                      070140
          IX6    X6+X0                                                  070150
          LX5    36                                                     070160
 GPTR.3   IX3    X6-X4       REDUCE OFFSET MODULO 60                    070170
          NG     X3,GPTR.4                                              070180
          BX6    X3                                                     070190
          SX7    X7+B1                                                  070200
          EQ     GPTR.3                                                 070210
*                                                                       070220
 GPTR.4   IX7    X5+X7                                                  070230
          LX6    18                                                     070240
          BX7    X6+X7                                                  070250
          JP     B3                                                     070260
          SPACE  2                                                      070270
**    ERROR ACTIONS 
*                                                                       070300
 GPTR.E1  SA2    GPTR.M1     ILLEGAL SOURCE -M- FIELD                   070310
          EQ     ERR.CON                                                070320
 GPTR.E2  EQU    GPTR.E1     ILLEGAL DESTINATION -M- FIELD              070330
 GPTR.E3  SA2    GPTR.M3     RECORD OVERRUN                             070340
          EQ     ERR.CON                                                070350
****
*                                                                       070370
 GPTR.M1  VFD    12/0,18/E.CON,12/0,18/*+1
          DATA    C/M-SPECIFICATION ILLEGAL FOR DATA TYPE/              070390
 GPTR.M3  VFD    12/0,18/E.CON,12/0,18/*+1
          DATA   C/FIELD EXTENDS PAST END OF RECORD/
****
 ECON     TITLE  ECON - CONVERT A REAL NUMBER TO A STRING               029600
*                                                                       029610
**    ECON - CONVERT A TRIPLE PRECISION REAL NUMBER TO A DISPLAY-CODE 
*        CHARACTER STRING ACCORDING TO THE RULES GIVEN IN THE ERS.      029630
*                                                                       029640
*         INPUT  -  B1 = 1                                              029650
*                   B7 = RETURN ADDRESS                                 029660
*                                                                       029670
*         OUTPUT -  NONE IN REGISTERS                                   029680
*                                                                       029690
*         PRESERVED  --, --, --, --, --, --, --, --                     029700
*                    A0, --, --, --, --, --, --, --                     029710
*                        B1, --, --, --, B5, --, B7 
*                                                                       029730
*         TEMPORARY CELLS USED..                                        029740
*                                                                       029750
*          INPUT -  T.NUM,+1,+2  INPUT TRIPLE PRECISION NUMBER          029760
*                   T.M2     OUTPUT FIELD WIDTH (CHARACTERS)            029770
*                   T.P      NUMBER OF DECIMAL DIGITS OF PRECISION      029780
*                   T.I2     SUB-TYPE FLAG. 0=REAL, NON-0 = INTEGER     029790
*                                                                       029800
*          OUTPUT-  T.STRING     OUTPUT DATA AREA                       029810
*                   T.NBL    NUMBER OF LEADING BLANKS NEEDED IN OUTPUT  029820
*                   T.MSG    SIGN OF RESULT (0=+, NON-0=-)              029830
*                   T.IFLAG  INTERNALLY GENERATED INTEGER-TYPE FLAG     029840
*                   T.SPTR   POINTER TO FIRST GOOD CHARACTER IN T.STRING029850
*                                                                       029860
*         NOTES..   T.NBL WILL BE LESS THAN T.M2.   T.NBL + THE NUMBER  029870
*                OF CHARACTERS IN THE T.SPTR STRING WILL = T.M2.        029880
*                                                                       029890
*                   THE MAXIMUM NON-BLANK STRING LENGTH IS 10*L.STRING  029900
*                CHARACTERS.                                            029910
*                                                                       029920
*                   IF T.I2 IS NOT 0, INTEGER CONVERSION WILL BE        029930
*                FORCED, AND THE SIGN WILL NOT BE APPENDED, BUT WILL    029940
*                BE INDICATED IN T.MSG AT EXIT.  THIS IS FOR S,N,Z,P    029950
*                RECEIVING FIELDS.                                      029960
*                                                                       029970
          SPACE  4                                                      029990
 ECON     SA2    T.M2                                                   030000
          SA3    T.NUM                                                  030010
          SX6    B5                                                     0006   7
          SX7    B0                                                     0006   8
          SA6    T.SAVEB5                                               0006   9
          ZR     X2,ECON.Z   OUTPUT FIELD WIDTH IS ZERO                 030020
          OR     X3,ECON.X1  VALUE IS INFINITE                          030030
          ID     X3,ECON.X2  VALUE IS INDEFINITE                        030040
          PL     X3,ECON.1                                              030060
          SA4    A3+B1       NUMBER IS NEGATIVE, FLAG IT AND COMPLEMENT 030070
          BX6    -X3                                                    030080
          SA5    A4+B1                                                  030090
          SA6    A3                                                     030100
          BX7    -X4                                                    030110
          SA7    A4                                                     030120
          BX6    -X5                                                    030130
          SA6    A5                                                     030140
          SX7    B1                                                     030150
 ECON.1   SA7    T.MSG       SAVE SIGN FLAG                             030160
          SA1    A3                                                     030170
          ZR     X3,ECON.I0  JP QUANTITY ZERO                           030180
*                                                                       030190
          SA5    T.I2        CHECK FOR SOURCE FIELD INTEGER             030200
          UX4    X1,B4                                                  030210
          BX7    X5                                                     030220
          SA7    T.IFLAG                                                030230
          NZ     X5,ECON.1A  INTEGER BEING FORCED FROM ABOVE            030240
          SB3    -47                                                    030250
          GT     B3,B4,ECON.1A  VALUE TOO SMALL FOR INTEGER             030260
          SB3    96                                                     030270
          GT     B4,B3,ECON.1A  VALUE TOO LARGE FOR INTEGER             030280
          GE     B4,B0,ECON.01   JP IF ALL INTEGER                      030290
          LX5    X4,B4       CHECK FOR NON-ZERO FRACTION PART           030300
          AX5    X5,B4                                                  030310
          IX4    X4-X5                                                  030320
          NZ     X4,ECON.1A                                             030330
 ECON.01  SA4    A1+B1       CHECK SECOND WORD                          030340
          UX4    X4,B4                                                  030350
          GE     B4,B0,ECON.02   JP IF ALL INTEGER                      030360
          LX5    X4,B4                                                  030370
          AX5    X5,B4                                                  030380
          IX4    X4-X5                                                  030390
          NZ     X4,ECON.1A                                             030400
 ECON.02  SA4    A4+B1       CHECK THIRD WORD                           030410
          UX4    X4,B4                                                  030420
          LX5    X4,B4                                                  030430
          AX5    X4,B4                                                  030440
          IX4    X4-X5                                                  030450
          NZ     X4,ECON.1A                                             030460
          SX7    B1          SET INTEGER FLAG                           030470
          SA7    A7                                                     030480
*                                                                       030490
*  BEGIN SCALING                                                        030500
*                                                                       030510
 ECON.1A  SA4    TEN.LG2     UN-NORMALIZED LOG BASE 10 OF 2             030520
          MX0    60-4                                                   030530
          UX3    B5,X1       EXPONENT TO B5                             030540
          SA2    A1+B1                                                  030550
          SX5    B5+47D                                                 030560
          PX3    X5                                                     030570
          FX6    X4*X3                                                  030580
          SB4    X6          SET INITIAL EXP OF 10                      030590
          SB2    TEN.BIG-3   START OF POSITIVE POWERS                   030600
          SX6    -B4                                                    030610
          SB4    -B4
          PL     X6,ECON.2   JP POSITIVE SCALE                          030620
*                                                                       030630
          BX3    -X0         =15                                        030640
          IX7    X3-X6                                                  030650
          SB2    TEN.LIL-3   START OF NEGATIVE POWERS 
          BX6    X7-X3                                                  030670
*                                                                       030680
 ECON.2   BX7    -X0*X6      FOR SMALL POSITIVE SCALING                 030690
          AX6    4           FOR LARGE SCALING                          030700
          SB3    X7 
          SB5    X6                                                     030720
          SA3    A2+B1                                                  030730
*                                                                       030740
          SB6    ECON.3                                                 030750
 ECON.3   SX6    B5                                                     030760
          SX4    B1                                                     030770
          ZR     B5,ECON.4   DONE WITH LARGE SCALING                    030780
          BX7    X4*X6                                                  030790
          SB2    B2+3                                                   030800
          AX6    1                                                      030810
          SB5    X6                                                     030820
          ZR     X7,ECON.3   JP BIT ZERO                                030830
          EQ     T3=MUL3     FACTOR IN THIS POWER-OF-10                 030840
*                                                                       030850
 ECON.4   SB2    B3+TEN.ONE  SMALL FACTOR SCALING 
          SB6    ECON.5                                                 030870
          NZ     B3,T3=MUL1  FACTOR 
*                                                                       030890
 ECON.5   ZR     X1,ECON.I0   JP QUANTITY ZERO                          0003   5
          SA4    TEN.ONE     10**0 REFINE FACTORING                     0003   6
          SA5    TEN.M1      10**-1 (UPPER PART)                        030910
          IX6    X1-X4
          NG     X6,ECON.6   JP VALUE LESS THAN 1                       030930
          SB2    A5           RESCALE BY 1/10                           030940
          SB4    B4-B1       ADJUST CUMULATIVE SCALE FACTOR             030950
          EQ     T3=MUL3                                                030960
*                                                                       030970
 ECON.6   IX0    X1-X5                                                  030980
          NZ     X0,ECON.7                                              030990
          SA4    A5+B1       CHECK MIDDLE AND LOWER PARTS               031000
          SA5    A4+B1                                                  031010
          IX0    X2-X4                                                  031020
          NZ     X0,ECON.7                                              031030
          IX0    X3-X5                                                  031040
 ECON.7   PL     X0,ECON.8   DONE SCALING 
          SB2    TEN.ONE+1   NOT DONE, SCALE UP BY 10 
          SB4    B4+B1                                                  031070
          EQ     T3=MUL1                                                031080
*                                                                       031090
* DONE SCALING, B4 HAS (-S).  GENERATE ROUNDING FACTOR AND ROUND        031100
*                                                                       031110
 ECON.8   BX6    X1          SAVE SCALED VALUE                          031120
          SA6    A1                                                     031130
          BX7    X2                                                     031140
          SA7    A2                                                     031150
          BX6    X3                                                     031160
          SA6    A3                                                     031170
*                                                                       031180
          SA4    T.IFLAG     INTEGER TYPE FLAG                          031190
          SA5    T.P         PRECISION                                  031200
          ZR     X4,ECON.9   NOT INTEGER                                031210
          SA4    T.I2        FORCE-INTEGER FLAG                         031220
          NZ     X4,ECON.8A  FORCE                                      031230
          SX4    X5+B4       USE DISCRETION, INTEGER ONLY IF S .LE. P   031240
          PL     X4,ECON.8A  YES                                        031250
          SX7    0           NO, RESET TO REAL                          031260
          SA7    T.IFLAG                                                031270
          EQ     ECON.9                                                 031280
 ECON.8A  SX5    -B4         USE INTEGER, RESET P TO REFLECT S
*                                                                       031310
 ECON.9   MX0    60-4        GENERATE ROUNDING CONSTANT                 031320
          BX6    -X5                                                    031330
          SB2    TEN.BIG-3   START OF POSITIVE POWERS                   031340
          SB3    X5          PRECISION OF SOURCE VALUE (PRIOR TO ROUND) 031350
          PL     X6,ECON.10  JP POSITIVE SCALE                          031360
*                                                                       031370
          BX3    -X0         =15                                        031380
          IX7    X3-X6                                                  031390
          SB2    TEN.LIL-3   START OF NEGATIVE POWERS                   031400
          BX6    X7-X3                                                  031410
*                                                                       031420
 ECON.10  BX7    -X0*X6      FOR SMALL POSITIVE SCALING                 031430
          AX6    4                                                      031440
          SA1    X7+TEN.ONE 
          SB5    X6                                                     031460
          UX1    X1,B6                                                  031470
          SX2    B0                                                     031480
          SB6    B6-B1       EQUIVALENT TO MULTIPLYING BY 0.5           031490
          PX1    X1,B6                                                  031500
          DX2    X1+X2       FILL OUT TRIPLE PRECISION VALUE            031510
          DX3    X2+X2                                                  031520
*                                                                       031530
          SB6    ECON.11                                                031540
 ECON.11  SX6    B5                                                     031550
          SX4    B1                                                     031560
          ZR     B5,ECON.12  DONE SCALING                               031570
          BX7    X4*X6                                                  031580
          SB2    B2+3                                                   031590
          AX6    1                                                      031600
          SB5    X6                                                     031610
          ZR     X7,ECON.11  JP BIT ZERO                                031620
          EQ     T3=MUL3     FACTOR IN THIS POWER-OF-TEN                031630
*                                                                       031640
 ECON.12  SB6    ECON.13     ADD VALUE                                  031650
          SB2    T.NUM                                                  031660
          EQ     T3=ADD3                                                031670
 ECON.13  BX6    X1          SAVE RESULT                                031680
          SA6    B2                                                     031690
          BX7    X2                                                     031700
          SA7    A6+B1                                                  031710
          BX6    X3                                                     031720
          SA6    A7+B1                                                  031730
          UX4    X1,B6       CHECK FOR ROUNDING OVERFLOW                031740
          LX4    X4,B6                                                  031750
*                                                                       031760
          SB5    X4          0 OR 1, DEPENDING ON ROUNDING              031770
          SB4    B4-B5       REVISED SCALE FACTOR                       031780
          SB3    B3+B5       REVISED PRECISION                          031790
          SB2    T.STRING    LOCATION TO STORE RESULTS                  031800
*                                                                       031810
* STEPS A.4, A.5                                                        031820
*                                                                       031830
          SA5    T.I2 
          SA4    T.M2        -N- FIELD WIDTH
          NZ     X5,ECON.I2  FORCING INTEGER
          SA5    T.MSG
          IX4    X4-X5       WIDTH ADJUSTED FOR SIGN
          SA5    T.IFLAG
          ZR     X5,ECON.F1  GO TO -REAL- CONVERSION                    031910
*                                                                       031920
* STEP I.1                                                              031930
*                                                                       031940
          SX5    B3          DIGITS IN RESULT                           031950
          IX5    X4-X5                                                  031960
          NG     X5,ECON.F1  FIELD IS NOT WIDE ENOUGH                   031970
*                                                                       031980
* STEP I.2                                                              031990
*                                                                       032000
 ECON.I2  SB5    ECON.I2B 
          EQ     ECON.SET    SETUP NUMBER FOR CONVERSION                032020
 ECON.I2B NZ     B3,ECON.I2A
          SB3    B1          ALWAYS CONVERT AT LEAST ONE DIGIT
          SX1    B0          WHICH WILL BE ZERO, IN THIS CASE 
 ECON.I2A SX5    B3                                                     032030
          SA4    T.M2 
          IX7    X4-X5       IF D EXCEEDS N, THROW OUT D-N DIGITS       032040
          PL     X7,ECON.16  OK                                         032050
          SB3    B3-B1       LOSE A DIGIT                               032060
          SB4    B4+B1                                                  032070
          SB2    B0                                                     032080
          SB6    ECON.I2A 
          EQ     ECON.TEN                                               032090
*                                                                       032100
 ECON.16  SA7    T.NBL       N-D IS NUMBER OF LEADING BLANKS NEEDED     032110
          SB2    T.STRING                                               032120
          SA4    T.I2        FORCE-INTEGER FLAG                         032130
          SA5    T.MSG       SIGN                                       032140
          SX7    B0                                                     032150
          NZ     X4,ECON.17  FORCING, NO SIGN                           032160
          ZR     X5,ECON.17  +, NO SIGN                                 032170
          SA5    T.NBL
          SX7    X5-1 
          SA7    A5          REVISE LEADING BLANK COUNT 
          SX7    1R-         -, SIGN                                    032180
*                                                                       032190
 ECON.17  SB6    ECON.17     CONVERT (B3) DIGITS                        032200
          SB3    B3-B1                                                  032210
          GE     B3,B0,ECON.TEN                                         032220
*                                                                       032230
 ECON.END ZR     X7,ECON.19  CLEAN UP LAST WORD AND EXIT                032240
          MX5    6                                                      032250
 ECON.18  LX7    6                                                      032260
          BX6    X7*X5                                                  032270
          ZR     X6,ECON.18                                             032280
          ZR     B2,ECON.19                                             032290
          SA7    B2          LAST WORD STORED                           032300
*                                                                       032310
 ECON.19  SA4    T.M2        COMPUTE POINTER TO T.STRING                032320
          SA5    T.NBL                                                  032330
          IX6    X4-X5       NUMBER OF CHARACTERS IN T.STRING           032340
          SX7    X6-10D*L.STRING  MAXIMUM                               032350
          NG     X7,ECON.20  OK                                         032360
          SX6    10D*L.STRING  USE MAX                                  032370
          IX7    X4-X6       REVISE NBL                                 032380
          SA7    A5                                                     032390
 ECON.20  IX5    X6+X6       *2                                         032400
          LX6    2           *4                                         032410
          SA4    T.SAVEB5 
          SX7    T.STRING                                               032420
          IX6    X5+X6                                                  032430
          LX6    36                                                     032440
          BX6    X6+X7       FULL POINTER WORD                          032450
          SB5    X4 
          SA6    T.SPTR                                                 032460
          JP     B7          EXIT FROM ECON                             032470
*                                                                       032480
* *                                                                     032490
*                                                                       032500
* ECON.TEN - SUBROUTINE TO GET ONE MORE DIGIT                           032510
*                                                                       032520
 ECON.TEN BX6    X1                                                     032530
          AX6    60-12                                                  032540
          NZ     X6,ECON.21  SPECIAL CHECK, MAY GO ON FIRST TIME ONLY   032550
*                                                                       032560
          IX6    X3+X3       MULTIPLY BY 10                             032570
          LX3    3                                                      032580
          IX3    X3+X6                                                  032590
          IX6    X2+X2                                                  032600
          LX2    3                                                      032610
          IX2    X2+X6                                                  032620
          IX6    X1+X1                                                  032630
          LX1    3                                                      032640
          IX1    X1+X6                                                  032650
          BX6    X0*X3       CARRY OVERFLOW ACROSS                      032660
          AX6    60-12                                                  032670
          BX3    -X0*X3                                                 032680
          IX2    X2+X6                                                  032690
          BX6    X0*X2                                                  032700
          AX6    60-12                                                  032710
          BX2    -X0*X2                                                 032720
          IX1    X1+X6                                                  032730
          BX6    X0*X1                                                  032740
          AX6    60-12                                                  032750
 ECON.21  BX1    -X0*X1                                                 032760
          SX6    X6+1R0      CONVERT TO DISPLAY-CODE DIGIT              032770
*                                                                       032780
 ECON.PUT ZR     B2,ECON.22  ADD ONE CHARACTER TO X7                    032790
          LX7    6                                                      032800
          MX5    6                                                      032810
          BX7    X7+X6                                                  032820
          BX5    X5*X7                                                  032830
          ZR     X5,ECON.22  JP WORD NOT FILLED                         032840
          SA7    B2          STORE WORD                                 032850
          SX6    T.STRING+L.STRING+1
          SB2    B2+B1
          BX6    -X6
          SX7    B0 
          SX6    X6+B2
          NG     X6,ECON.22                                             032890
          SB2    B0          OVERFLOW, STOP STORING                     032900
 ECON.22  JP     B6          RETURN                                     032910
*                                                                       032920
* *                                                                     032930
*                                                                       032940
* ECON.SET - SETUP NUMBER FOR ECON.TEN                                  032950
*                                                                       032960
 ECON.SET SB6    ECON.14     DENORMALIZE TO STANDARD FORM               032970
          SB2    TEN.ZRO                                                032980
          EQ     T3=ADD1                                                032990
*                                                                       033000
 ECON.14  MX0    12          TRIPLE SHIFT LEFT ONE BIT                  033010
          BX1    -X0*X1                                                 033020
          LX1    1                                                      033030
          BX2    -X0*X2                                                 033040
          LX2    1                                                      033050
          BX3    -X0*X3                                                 033060
          LX3    1                                                      033070
          BX5    X2                                                     033080
          AX5    60-12                                                  033090
          BX2    -X0*X2                                                 033100
          IX1    X1+X5                                                  033110
          BX6    X3                                                     033120
          AX6    60-12                                                  033130
          BX3    -X0*X3                                                 033140
          IX2    X2+X6                                                  033150
          JP     B5          EXIT 
*                                                                       033160
* *                                                                     033170
*                                                                       033180
* STEP F.1, F.2                                                         033190
*                                                                       033200
 ECON.F1  ZR     B5,ECON.F1B                                            033210
          SB6    ECON.F1A    ADJUST VALUE IF .GE. 1.0                   033220
          SB2    TEN.M1                                                 033230
          SX7    X4          D SZ                                       0004   7
          SA7    T.NUM        SAVE X4                                   0004   8
          EQ     T3=MUL3                                                033240
 ECON.F1A SA4    T.NUM       RESTORE X4                                 0004  10
          BX6    X1                                                     0004  11
          LX7    X2                                                     033260
          SA6    T.NUM                                                  033270
          SA7    A6+B1                                                  033280
          BX6    X3                                                     033290
          SA6    A7+B1                                                  033300
*                                                                       033310
 ECON.F1B GE     B4,B0,ECON.23  COMPUTE -R- = MINIMUM DIGITS NEEDED     033320
          SB5    -B4         HERE IF VALUE .GE. 1 (SCALE .LT. 0)        033330
          EQ     ECON.25                                                033340
 ECON.23  SX5    X4-5        D-5                                        033350
          SX6    B3          -P-                                        033360
          IX6    X6-X5                                                  033370
          PL     X6,ECON.24                                             033380
          SX5    B3          MIN(P,D-5)                                 033390
 ECON.24  SB5    X5+B4       -R- = K-1 + MIN(P,D-5). K-1 = -S = (B4)    033400
 ECON.25  SB6    X4-1        D-1                                        033410
          GT     B5,B6,ECON.E1  CAN-T USE F, GO-TO E CONVERSION         033420
*                                                                       033430
* STEP F.3 (A) DETERMINE NUMBER OF SIGNIFICANT DIGITS TO OUTPUT         033440
*                                                                       033450
          SB2    B3          P                                          033460
          LT     B4,B0,ECON.25A   JP IF X.GE. 1.0                       033470
          SB2    B3+B4       K-1+P                                      033480
          SB6    B6+B4       D-K (WIDTH ADJUSTED FOR LEADING ZEROES)
 ECON.25A LE     B2,B6,ECON.25B  GET MIN(D-1,P) OR MIN(D-K,K-1+P) 
          SB2    B6                                                     033500
*                                                                       033510
 ECON.25B GE     B2,B3,ECON.253  SUPRESS ROUNDING IF PREVIOUSLY 
*                                ROUNDED TO THIS PRECISION OR LESS
          MX0    60-4        GENERATE ROUNDING CONSTANT .5*10**(-B2)
          SX6    -B2                                                    033530
          SB2    TEN.LIL-3                                              033540
          BX3    -X0         =15                                        033550
          IX7    X3-X6                                                  033560
          BX6    X7-X3                                                  033570
          BX7    -X0*X6      SMALL POSITIVE SCALE                       033580
          AX6    4                                                      033590
          SA1    X7+TEN.ONE 
          SB5    X6                                                     033610
          UX1    X1,B6                                                  033620
          SX2    B0                                                     033630
          SB6    B6-B1       EQUIVALENT TO MULTIPLYING BY 0.5           033640
          PX1    X1,B6                                                  033650
          DX2    X1+X2       FILL OUT TRIPLE PRECISION VALUE            033660
          DX3    X2+X2                                                  033670
*                                                                       033680
          SB6    ECON.251                                               033690
 ECON.251 SX6    B5                                                     033700
          SX4    B1                                                     033710
          ZR     B5,ECON.252  DONE SCALING                              033720
          BX7    X4*X6                                                  033730
          SB2    B2+3                                                   033740
          AX6    1                                                      033750
          SB5    X6                                                     033760
          ZR     X7,ECON.11  JP BIT ZERO                                033770
          EQ     T3=MUL3     FACTOR IN THIS POWER-OF-10                 033780
*                                                                       033790
 ECON.252 SB6    ECON.253    ADD VALUE                                  033800
          SB2    T.NUM                                                  033810
          EQ     T3=ADD3                                                033820
*                                                                       033830
* SETUP AND RECHECK FOR F-FORMAT                                        033840
*                                                                       033850
 ECON.253 SB5    ECON.254 
          EQ     ECON.SET                                               033870
 ECON.254 BX6    X0*X1       OVERFLOW BIT                               033880
          AX6    60-12                                                  033890
          SA5    T.MSG       SIGN                                       033900
          SB5    X6                                                     033910
          SA4    T.M2        FIELD WIDTH                                033920
          SB3    B3+B5       ADJUST PRECISION 
          SB4    B4-B5       ADJUST SCALE FACTOR
          IX4    X4-X5       D (ADJUSTED FOR SIGN)
* 
          GE     B4,B0,ECON.263  RECOMPUTE R = MINIMUM DIGITS NEEDED
          SB5    -B4                                                    033990
          EQ     ECON.265                                               034000
 ECON.263 SX5    X4-5        D-5                                        034010
          SX6    B3          P                                          034020
          IX6    X6-X5                                                  034030
          PL     X6,ECON.264                                            034040
          SX5    B3          MIN(P,D-5)                                 034050
 ECON.264 SB5    X5+B4       R                                          034060
 ECON.265 SB6    X4-1        D-1                                        034070
          GT     B5,B6,ECON.E1A  CANT USE F, GO TO E CONVERSION         034080
*                                                                       034090
* STEP F.3, F.4                                                         034100
*                                                                       034110
          SA5    T.MSG       SET SIGN                                   034120
          SB2    T.STRING                                               034130
          SX7    B0                                                     034140
          ZR     X5,ECON.26 +                                           034150
          SX7    1R-         -                                          034160
*                                                                       034170
 ECON.26  GE     B4,B0,ECON.F3C  JP X .LT. 1.0                          034180
          EQ     B5,B6,ECON.F3A  R = D-1                                034190
          GE     B5,B3,ECON.F3A  R .GE. P                               034200
*                                                                       034210
          LE     B3,B6,ECON.F3B  (F3B) = DDD.DD                         034220
          SB3    B6          I=(B5), J=(B3)                             034230
 ECON.F3B SB3    B3-B5                                                  034240
          EQ     ECON.F4                                                034250
*                                                                       034260
 ECON.F3A SB3    B0          (F3A) = DDDDD.  I=(B5), J=0                034270
          EQ     ECON.F4                                                034280
*                                                                       034290
 ECON.F3C SB5    -B4         NUMBER OF LEADING ZEROES AFTER DECIMAL (-) 
          SB4    B4+B3       K-1+P      (X IS .LT. 1.0) 
          SB3    B6          D-1
          LE     B3,B4,ECON.F4   (F3D) = .DDDDD                         034330
          LX7    6                                                      034340
          SB3    B4          (F3C) = 0.DDDDD                            034350
          SX7    X7+1R0                                                 034360
          SX4    X4-1        ADJUST FIELD WIDTH                         034370
*                                                                       034380
*  AT THIS POINT THE REGISTERS ARE SET AS FOLLOWS..                     034390
*                   X4 = ADJUSTED FIELD WIDTH                           034400
*                   B5 = I, DIGITS PRECEEDING THE DECIMAL               034410
*                   B3 = J, DIGITS FOLLOWING THE DECIMAL                034420
*                                                                       034430
 ECON.F4  SX6    B3+B1       J+1
          LT     B5,B0,ECON.F4A 
          SX6    X6+B5       I+J+1
 ECON.F4A IX6    X4-X6
          SA6    T.NBL       NUMBER OF LEADING BLANKS                   034470
          LE     B5,B0,ECON.271  IF NO DIGITS BEFORE DECIMAL
*                                                                       034480
          SB6    ECON.27                                                034490
 ECON.27  SB5    B5-B1                                                  034500
          GE     B5,B0,ECON.TEN                                         034510
          SB5    B0 
*                                                                       034520
 ECON.271 SB6    ECON.28     INSERT DECIMAL POINT 
          SX6    1R.                                                    034540
          EQ     ECON.PUT                                               034550
 ECON.28  SB3    B3-B1                                                  034560
          SB5    B5+B1
          SX6    1R0
          LE     B5,B0,ECON.PUT  LEADING ZERO AFTER DECIMAL 
          GE     B3,B0,ECON.TEN                                         034570
*                                                                       034580
          EQ     ECON.END    DONE WITH -F- CONVERSION                   034590
*                                                                       034600
* *                                                                     034610
*                                                                       034620
* STEP E.1                                                              034630
*                                                                       034640
 ECON.E1  SB2    X4-5        CHECK FIELD WIDTH (D-5)                    034650
          LT     B2,B1,ECON.R1  WON-T FIT                               034660
          EQ     ECON.25B 
*                                                                       034700
 ECON.E1A SB6    B4-99       ROUNDED VALUE BACK, CHECK FIELD WIDTH
          SB5    X4-5 
          LT     B6,B0,ECON.E1B 
          LE     B5,B0,ECON.R1  WON-T FIT, NEED 6 CHARS (+SIGN) MINIMUM 
*                                                                       034760
 ECON.E1B SX7    B0                                                     034770
          LT     B6,B0,ECON.E1C  EXPONENT WILL BE .GE. -99
          SB5    B5-B1                                                  034790
          SX7    B1                                                     034800
 ECON.E1C LE     B5,B3,ECON.29  JP (D-5(6) .LE. P)                      034810
          SB5    B3                                                     034820
*                                                                       034830
 ECON.29  SX7    X7+5        SET NBL (NO. LEADING BLANKS)               034840
          SX7    X7+B5                                                  034850
          IX6    X4-X7                                                  034860
          SA6    T.NBL                                                  034870
*                                                                       034880
* STEP E.2                                                              034890
*                                                                       034900
 ECON.E2  SA5    T.MSG       SET UP SIGN                                034910
          SB2    T.STRING                                               034920
          SX7    B0                                                     034930
          ZR     X5,ECON.30  +                                          034940
          SX7    1R-         -                                          034950
*                                                                       034960
 ECON.30  SB6    ECON.31     GENERATE FIRST DIGIT AND DECIMAL PT.       034970
          EQ     ECON.TEN                                               034980
 ECON.31  SB6    ECON.32                                                034990
          SX6    1R.                                                    035000
          EQ     ECON.PUT                                               035010
*                                                                       035020
 ECON.32  SB5    B5-B1       GENERATE TRAILING DIGITS                   035030
          GT     B5,B0,ECON.TEN                                         035040
*                                                                       035050
          SB6    ECON.33     GENERATE EXPONENT FIELD                    035060
          SX6    1RE                                                    035070
          EQ     ECON.PUT                                               035080
*                                                                       035090
 ECON.33  SB4    B4+B1       -E  PUT OUT EXPONENT SIGN                  035100
          SB4    -B4         E                                          035110
          SB6    B4-100D                                                035120
          GE     B6,B0,ECON.34    NO SIGN IF LARGE POSITIVE             035130
          SB6    ECON.34                                                035140
          SX6    1R+
          PL     B4,ECON.PUT                                            035160
          SX6    1R-                                                    035170
          SB4    -B4         SET EXPONENT POSITIVE                      035180
          EQ     ECON.PUT                                               035190
*                                                                       035200
 ECON.34  SX6    B4          GENERATE EXPONENT DIGITS 
          IX6    X6/X0,100D 
          ZR     X6,ECON.35                                             035230
          SX0    -100D       HUNDREDS PLACE                             035240
          IX0    X0*X6                                                  035250
          SB4    B4+X0                                                  035260
          SB6    ECON.35                                                035270
          SX6    X6+1R0                                                 035280
          EQ     ECON.PUT                                               035290
*                                                                       035300
 ECON.35  SX6    B4 
          IX6    X6/X0,10D   TENS PLACE 
          BX0    -X6                                                    035330
          IX5    X0+X0       *-2                                        035340
          LX0    3           *-8                                        035350
          IX0    X0+X5       *-10                                       035360
          SB4    B4+X0                                                  035370
          SB6    ECON.36                                                035380
          SX6    X6+1R0                                                 035390
          EQ     ECON.PUT                                               035400
*                                                                       035410
 ECON.36  SB6    ECON.END    UNITS PLACE                                035420
          SX6    B4+1R0                                                 035430
          EQ     ECON.PUT    DONE WITH -E- CONVERSION                   035440
*                                                                       035450
* STEP I.0  -VALUE IS ZERO                                              035460
*                                                                       035470
 ECON.I0  SA4    T.M2                                                   035480
          SA5    T.MSG                                                  035490
          SB2    T.STRING                                               035500
          SX7    B0                                                     035510
          ZR     X5,ECON.37  JP VALUE IS +                              035520
          SA5    T.I2 
          NZ     X5,ECON.37    BR IF FORCED INTEGER 
          SX7    1R-         -                                          035530
          SX4    X4-1                                                   035540
 ECON.37  ZR     X4,ECON.38  JP NO MORE FIELD                           035550
          LX7    6           INSERT -0-                                 035560
          SX4    X4-1                                                   035570
          SX7    X7+1R0                                                 035580
 ECON.38  BX6    X4                                                     035590
          SA6    T.NBL                                                  035600
          EQ     ECON.END                                               035610
*                                                                       035620
* STEP R.1  -NOT ENOUGH FIELD WIDTH FOR VALUE                           035630
*                                                                       035640
 ECON.R1  SA4    T.M2                                                   035650
          SA5    T.MSG                                                  035660
          SB2    T.STRING                                               035670
          SX6    1R*                                                    035680
          SX7    B0                                                     035690
          SB6    ECON.39                                                035700
          SA7    T.NBL                                                  035710
          ZR     X5,ECON.PUT  JP +                                      035720
          SX7    1R-
 ECON.39  SX4    X4-1                                                   035730
          SX6    1R*                                                    0004   5
          NZ     X4,ECON.PUT                                            035740
          EQ     ECON.END 
*                                                                       035790
* STEP X.1  - QUANTITY INFINITE, X.2   - QUANTITY INDEFINITE            035800
*                                                                       035810
 ECON.X1  SX7    1RF                                                    035820
          EQ     ECON.40                                                035830
 ECON.X2  SX7    1RD                                                    035840
*                                                                       035850
 ECON.40  SA4    T.M2                                                   035860
          SA5    T.MSG                                                  035870
          SB2    T.STRING                                               035880
          SX6    B0                                                     035890
          SB4    X4          FIELD WIDTH                                035900
          EQ     B4,B1,ECON.41   WIDTH = 1                              035910
          SB4    B4-2                                                   035920
          GT     B4,B1,ECON.44   WIDTH .GE. 4                           035930
          EQ     B4,B1,ECON.43   WIDTH = 3                              035940
          NZ     X5,ECON.42M     WIDTH = 2                              035950
          SX7    X7+100B*1RN      W=2,+                                 035960
          EQ     ECON.41                                                035970
 ECON.42M SX7    X7+100B*1R-      W=2,-                                 035980
          EQ     ECON.41                                                035990
 ECON.43  NZ     X5,ECON.43M                                            036000
          SX5    2RIN             W=3,+                                 036010
          EQ     ECON.44B                                               036020
 ECON.43M SX5    2R-N             W=3,-                                 036030
          EQ     ECON.44B                                               036040
 ECON.44  MX0    60-18                                                  036050
          SX6    X4-4        NBL WIDTH                                  036060
          NZ     X5,ECON.44M                                            036070
          SX5    3R IN            W.GE.4,+                              036080
          EQ     ECON.44A                                               036090
 ECON.44M SX5    3R-IN            W.GE.4,-                              036100
 ECON.44A BX5    -X0*X5                                                 036110
 ECON.44B LX5    6                                                      036120
          BX7    X5+X7                                                  036130
 ECON.41  SA6    T.NBL       SAVE LEADING BLANK COUNT                   036140
          EQ     ECON.END    DONE                                       036150
*                                                                       036160
* STEP Z  - FIELD WIDTH = 0                                             036170
*                                                                       036180
 ECON.Z   SB2    T.STRING                                               036190
          SX7    B0                                                     036200
          SA7    T.NBL                                                  036210
          EQ     ECON.END                                               036220
*                                                                       036230
 T3=      TITLE  TRIPLE PRECISION ARITHMETIC SUBROUTINES                042300
*                                                                       042310
**    T3=  - TRIPLE PRECISION ARITHMETIC SUBROUTINES. 
*                                                                       042330
*     THESE ROUTINES ARE USED PRIMARILY FOR SCALING AND ROUNDING        042340
*     BY GETNUM AND ECON.                                               042350
*                                                                       042360
*     THE ALGORITHMS ARE FROM -KODER-(MULTIPLICATION AND ADDITION)      042370
*                                                                       042380
*         INPUT  -  B1 = 1                                              042390
*                   B2 = ADDRESS OF A TRIPLE PRECISION VALUE (B)        042400
*                   X1 = VALUE (A) -UPPER PART                          042410
*                   X2 =           -MIDDLE PART                         042420
*                   X3 =           -LOWER PART                          042430
*                   B6 = RETURN ADDRESS                                 042440
*                                                                       042450
*         OUTPUT -  X1 = RESULT    -UPPER PART                          042460
*                   X2 =           -MIDDLE PART                         042470
*                   X3 =           -LOWER PART                          042480
*                                                                       042490
*         PRESERVED  --, --, --, --, --, --, --, --                     042500
*                    A0, A1, A2, A3, --, --, A6, A7                     042510
*                        B1, B2, B3, B4, B5, B6, B7                     042520
*                                                                       042530
*         NOTES..   THE TRIPLE PRECISION VALUES, A AND B, ARE PRESUMED  042540
*                  TO BE IN STANDARD FORM.. NORMALIZED UPPER PART AND   042550
*                  EACH FOLLOWING EXPONENT 48 LESS THAN THE UPPER PART  042560
*                  EXPONENT.                                            042570
*                                                                       042580
*                   INFINITE OR INDEFINITE RESULTS HAVE A MANTISSA OF   042590
*                  ZERO, AND ALL THREE PARTS ARE THE SAME (ALL HAVE     042600
*                  THE FUNNY EXPONENT).                                 042610
*                                                                       042620
*         THE ROUTINES WHICH ARE CONTAINED HERE ARE AS FOLLOWS..        042630
*                                                                       042640
*                T3=MUL3     MULTIPLY A(TRIPLE) BY B(TRIPLE)            042650
*                T3=MUL1     MULTIPLY A(TRIPLE) BY B(SINGLE PRECISION)  042660
*                T3=ADD3     ADD A(TRIPLE) AND B(TRIPLE)                042670
*                T3=ADD1     ADD A(TRIPLE) AND B(SINGLE PRECISION)      042680
*                                                                       042690
          SPACE  4                                                      042710
*                                                                       042720
* TRIPLE PRECISION MULTIPLICATION BY A TRIPLE PRECISION VALUE           042730
*                                                                       042740
 T3=MUL3  SA4    B2          FETCH UPPER PART  -BU                      042750
          SA5    B2+B1       FETCH MIDDLE PART -BM                      042760
          ID     X1,T3.IND   JP A INDEFINITE                            042770
          ID     X4,T3.IND   JP B INDEFINITE                            042780
          OR     X1,T3.OR1   JP A INFINITE                              042790
          OR     X4,T3.OR1   JP B INFINITE                              042800
          ZR     X1,T3.ZR    JP A ZERO                                  042810
          ZR     X4,T3.ZR    JP B ZERO                                  042820
*                                                                       042830
          RX0    X4*X3       1.   BU*AL (R)   S L                       042840
          DX6    X5*X1       2.   BM*AU       D L                       042850
          OR     X0,T3.OR2                                              042860
          RX7    X0+X6       3.   1 + 2 (R)   S L                       042870
          DX3    X4*X2       4.   BU*AM       D L                       042880
          RX0    X5*X2       5.   BM*AM (R)   S L                       042890
          RX6    X3+X0       6.   4 + 5 (R)   S L                       042900
          FX3    X4*X2       7.   BU*AM       S M                       042910
          FX0    X5*X1       8.   BM*AU       S M                       042920
          SA5    A5+B1       FETCH BL                                   042930
          RX2    X7+X6       9.   3 + 6 (R)   S L                       042940
          OR     X3,T3.OR2                                              042950
          RX6    X5*X1      10.   BL*AU (R)   S L                       042960
          DX7    X3+X0      11.   7 + 8       D L                       042970
          RX5    X2+X6      12.   9 +10 (R)   S L                       042980
          DX6    X4*X1      13.   BU*AU       D M                       042990
          FX2    X3+X0      14.   7 + 8       S M                       043000
          FX3    X4*X1      15.   BU*AU       S U                       043010
          RX0    X7+X5      16.   11+12 (R)   S L                       043020
          DX4    X6+X2      17.   13+14       D L                       043030
          FX5    X6+X2      18.   13+14       S M                       043040
          RX7    X0+X4      19.   16+17 (R)   S L                       043050
          OR     X3,T3.OR2                                              043060
          FX4    X5+X7      20.   18+19       S M                       043070
          DX6    X5+X7      21.   18+19       D L                       043080
          FX1    X3+X4      22.   15+20       S U                       043090
          DX5    X3+X4      23.   15+20       D M                       043100
          FX2    X6+X5      24.   21+23       S M                       043110
          DX3    X6+X5      25.   21+23       D L                       043120
          OR     X1,T3.OR2                                              043130
          JP     B6          EXIT                                       043140
*                                                                       043150
*                                                                       043160
 T3.OR1   ZR     X4,T3.IND   A INFINITE, JP IF B IS ZERO                043170
          ZR     X1,T3.IND   B INFINITE, JP IF A IS ZERO                043180
          BX0    X1-X4       SET SIGN IN X0                             043190
 T3.OR2   AX0    59          SET RESULT INFINITE FROM X0                043200
          SX1    3777B                                                  043210
          LX1    60-12                                                  043220
          BX3    X1-X0                                                  043230
          BX2    X1-X0                                                  043240
          BX1    X1-X0                                                  043250
          JP     B6          EXIT                                       043260
*                                                                       043270
 T3.IND   SX1    1777B       SET RESULT INDEFINITE                      043280
          LX1    60-12                                                  043290
          BX2    X1                                                     043300
          LX3    X1                                                     043310
          JP     B6          EXIT                                       043320
*                                                                       043330
 T3.ZR    MX1    0           SET RESULT TO ZERO                         043340
          BX2    X2-X2                                                  043350
          SB3    B0                                                     043360
          JP     B6          EXIT                                       043370
*                                                                       043380
          SPACE  4                                                      043390
*                                                                       043400
* TRIPLE PRECISION MULTIPICATION BY A SINGLE PRECISION VALUE            043410
*                                                                       043420
 T3=MUL1  SA4    B2          FETCH MULTIPLIER  -S                       043430
          ID     X1,T3.IND   JP A INDEFINITE                            043440
          ID     X4,T3.IND   JP S INDEFINITE                            043450
          OR     X1,T3.OR1   JP A INFINITE                              043460
          OR     X4,T3.OR1   JP S INFINITE                              043470
          ZR     X1,T3.ZR    JP A ZERO                                  043480
          ZR     X4,T3.ZR    JP S ZERO                                  043490
*                                                                       043500
          FX0    X4*X1       1.    S*AU       S U                       043510
          RX6    X4*X3       2.    S*AL (R)   S L                       043520
          DX7    X4*X2       3.    S*AM       D L                       043530
          OR     X0,T3.OR2                                              043540
          RX3    X6+X7       4.   2 + 3 (R)   S L                       043550
          DX7    X4*X1       5.    S*AU       D M                       043560
          FX2    X4*X2       6.    S*AM       S M                       043570
          DX5    X7+X2       7.   5 + 6       D L                       043580
          RX4    X3+X5       8.   4 + 7 (R)   S L                       043590
          FX3    X7+X2       9.   5 + 6       S M                       043600
          FX6    X4+X3      10.   8 + 9       S M                       043610
          DX5    X4+X3      11.   8 + 9       D L                       043620
          FX1    X0+X6      12.   1 +10       S U                       043630
          DX4    X0+X6      13.   1 +10       D M                       043640
          FX2    X4+X5      14.   13+11       S M                       043650
          DX3    X4+X5      15.   13+11       D L                       043660
          OR     X1,T3.OR2                                              043670
          JP     B6          EXIT                                       043680
*                                                                       043690
          SPACE  4                                                      043700
*                                                                       043710
* ADD TRIPLE PRECISION TO TRIPLE PRECISION (CALLS T3=ADD1)              043720
*                                                                       043730
 T3=ADD3  SX7    B6          SAVE RETURN                                043740
          SB6    T3.1                                                   043750
          EQ     T3=ADD1     ADD FIRST PART -BU                         043760
 T3.1     SA4    A4+B1                                                  043770
          SB6    T3.2                                                   043780
          OR     X1,T3.3                                                043790
          DF     X1,T3.ADD1  ADD MIDDLE PART -BM                        043800
 T3.2     SA4    A4+B1                                                  043810
          SB6    X7                                                     043820
          EQ     T3.ADD1     ADD LOWER PART -BL                         043830
 T3.3     SB6    X7          EXIT EARLY                                 043840
          JP     B6                                                     043850
*                                                                       043860
          SPACE  4                                                      043870
*                                                                       043880
* ADD SINGLE PRECISION TO TRIPLE PRECISION  (DON-T USE X7)              043890
*                                                                       043900
 T3=ADD1  SA4    B2          FETCH ADDEND  -S                           043910
          SX5    B4                                                     043920
          ID     X1,T3.IND   JP A INDEFINITE                            043930
          ID     X4,T3.IND   JP S INDEFINITE                            043940
          OR     X1,T3.OR3   JP A INFINITE                              043950
          OR     X4,T3.OR4   JP S INFINITE                              043960
          ZR     X4,T3.ZR1   JP S ZERO                                  043970
          ZR     X1,T3.ZR2   JP A ZERO                                  043980
*                                                                       043990
 T3.ADD1  SX0    B3                                                     044000
          UX6    X1,B3       EXPONENT OF A                              044010
          SX5    B4                                                     044020
          UX6    X4,B4       EXPONENT OF S                              044030
          SB3    B3-144D                                                044040
          SX6    B4-B3       S-A+144                                    044050
          SB3    X0          RESTORE B3                                 044060
          NG     X6,T3.ZR1   JP IF A MUCH GREATER THAN S                044070
          IX6    X6/X0,48    DIVIDE DIFFERENCE (OFFSET) BY 48 
          SB4    X6-6 
          GE     B4,B0,T3.ZR2  JP IF S MUCH GREATER THAN A              044100
*                                                                       044110
          JP     B4+T3.J+6   GO TO SPECIFIC ACTIONS                     044120
 T3.J     EQ     T3.A0       -144 .LE. E(S)-E(A) .LT. -96               044130
 +        EQ     T3.A1        -96 .LE. E(S)-E(A) .LT. -48               044140
 +        EQ     T3.A2        -48 .LE. E(S)-E(A) .LT.   0               044150
 +        EQ     T3.A2          0 .LE. E(S)-E(A) .LT.  48               044160
 +        EQ     T3.A4         48 .LE. E(S)-E(A) .LT.  96               044170
*       (FALL THROUGH)         96 .LE. E(S)-E(A) .LT. 144               044180
*                                                                       044190
 T3.A5    SX2    B0          USE X4,0,X1                                044200
          BX3    X1                                                     044210
          DX2    X4+X2       SET MIDDLE EXPONENT                        044220
          BX1    X4                                                     044230
          DX3    X2+X3       SET LOWER EXPONENT, SHIFTING AU            044240
          SB4    X5                                                     044250
          JP     B6          EXIT                                       044260
*                                                                       044270
 T3.A4    DX6    X4+X1       USE X4,X1,X2                               044280
          SB4    X5                                                     044290
          BX3    X2          MIDDLE TERM (X1 SHIFTED RIGHT)             044300
          DX5    X1-X6       RESIDUE WHICH WAS SHIFTED OFF              044310
          BX1    X4                                                     044320
          RX3    X3+X5       RESIDUE+X2 GIVES LOWER TERM                044330
          FX2    X6+X3       RE-NORMALIZE IN CASE RX- GAVE OVERFLOW     044340
          DX3    X6+X3                                                  044350
          JP     B6          EXIT                                       044360
*                                                                       044370
 T3.A2    DX6    X1+X4       X4 OVERLAPS X1 OR X1,X2 OR X2 ONLY         044380
          SB4    X5                                                     044390
          FX5    X1+X4                                                  044400
          FX4    X6+X2                                                  044410
          DX6    X6+X2                                                  044420
          RX6    X6+X3       PARTIAL RESULT NOW IN X5,X4,X6             044430
          FX2    X4+X6       RE-NORMALIZE IN CASE RX- GAVE OVERFLOW     044440
          DX3    X4+X6                                                  044450
          FX1    X5+X2                                                  044460
          DX2    X5+X2                                                  044470
          DX3    X2+X3                                                  044480
          JP     B6          EXIT                                       044490
*                                                                       044500
 T3.A1    DX6    X4+X2       X4 OVERLAPS X2,X3 OR OVERLIES X3 ONLY      044510
          SB4    X5                                                     044520
          FX4    X4+X2                                                  044530
          BX5    X1                                                     044540
          RX6    X6+X3       PARTIAL RESULT NOW IN X1,X4,X6             044550
          FX2    X4+X6       RE-NORMALIZE AS ABOVE                      044560
          DX3    X4+X6                                                  044570
          FX1    X5+X2                                                  044580
          DX2    X5+X2                                                  044590
          DX3    X2+X3                                                  044600
          JP     B6          EXIT                                       044610
*                                                                       044620
 T3.A0    RX4    X3+X4       X4 OVERLAPS X3 ON RIGHT                    044630
          SB4    X5          RE-NORMALIZE                               044640
          DX3    X2+X4                                                  044650
          BX5    X1                                                     044660
          FX2    X2+X4                                                  044670
          FX1    X5+X2                                                  044680
          DX2    X5+X2                                                  044690
          DX3    X2+X3                                                  044700
          JP     B6          EXIT                                       044710
*                                                                       044720
*                                                                       044730
 T3.ZR2   BX1    X4          A IS ZERO, USE S                           044740
          SX2    B0                                                     044750
          DX2    X1+X2                                                  044760
          DX3    X2+X2                                                  044770
 T3.ZR1   SB4    X5          S IS ZERO, USE A                           044780
          JP     B6                                                     044790
*                                                                       044800
 T3.OR4   BX0    X1          S IS INFINITE                              044810
          LX1    X4          SWAP                                       044820
          BX4    X0 
 T3.OR3   OR     X4,T3.IND   A IS INFINITE                              044840
          AX1    60-12       USE INFINITY                               044850
          LX1    60-12        DUMP MANTISSA                             044860
          BX2    X1                                                     044870
          LX3    X1                                                     044880
          JP     B6          EXIT                                       044890
*                                                                       044900
          END 
