*DECK CRMEPC
          IDENT  CFG
          B1=1
          TITLE  CFG - CONVERT FLOATING POINT NUMBER TO G (DISPLAY) FORM
,AT.
          COMMENT CONVERT FLOATING POINT NUMBER TO G (DISPLAY) FORMAT.
 CFG      SPACE  4,8
***       CFG  -  CONVERT FLOATING POINT NUMBER TO G (DISPLAY) FORMAT.
* 
*         R. H. GOODELL.     77/01/24.
* 
*         CFG CONVERTS A BINARY FLOATING POINT NUMBER TO A DISPLAY
*         FORMAT SIMILAR TO A *G20.12* SPECIFICATION IN FORTRAN.
* 
*         PROC  CFG  (I, E, L, A).
* 
*         ITEM  I  R.        ITEM VALUE TO BE CONVERTED.
*         ITEM  E  I.        EXPONENT LETTER INDICATOR - 1 = E, 2 = D.
*         ITEM  L  I.        LENGTH (IN CHARACTERS) OF RESULT.
*         ITEM  A  C (20).   CONVERSION RESULT, LEFT JUSTIFIED. 
 DATA     SPACE  4,8
*         LOCAL DATA. 
  
  
 AB       BSS    2           ASSEMBLY BUFFER FOR CONVERSION 
 EV       BSS    1           EXPONENT VALUE 
 PA       BSS    1           PARAMETER LIST ADDRESS 
 SN       BSS    1           SIGN CHARACTER 
  
 D        EQU    13          NUMBER OF DIGITS IN COEFFICIENT
 CFG      SPACE  4,8
*         CFG  -  CONTROL ROUTINE.
  
  
 CFG      SUBR   =           ENTRY/EXIT 
          SB1    1           (B1) = CONSTANT 1
          SA2    X1          VALUE OF I 
          SX6    A1          SAVE PARAMETER LIST ADDRESS
          NX7    X2          MAKE SURE (I) IS NORMALISED
          SA6    PA 
          NZ,X7  CFG1        IF (I) NOT ZERO
          SA7    EV 
          SB2    B1 
          MX1    0           HANDLE (I) = 0   -   PRINT 0.0 
          SB3    3
          SA7    SN 
          EQ     CFG3 
 CFG1     AX2    59 
          BX1    X7-X2       ABS (I)
          SX3    1R--1R0
          BX7    X2*X3       SN = 0 IF +, OR 1R--1R0 IF - 
          SA7    SN 
          RJ     SCALE       REDUCE (I) TO COEFFICIENT AND EXPONENT 
          SB7    X7-D+1 
          SB3    D+1         (B3) = TOTAL DIGITS INCLUDING DEC POINT
          MI,X7  CFG2        IF EXPONENT < 0 OR > FIELD WIDTH 
          PL,B7  CFG2        THEN GO PROCESS AS -E- FORMAT
          SX6    B0 
          SA6    EV          PROCESS AS -F- FORMAT, NO EXPONENT 
          SB2    X7+B1       (B2) = NUMBER OF DIGITS BEFORE DEC POINT 
          RJ     ROUND       ROUND COEFFICIENT TO D DIGITS
          SB2    B2+X7       ADJUST DIGIT COUNT IF CARRY OVERFLOW 
          SB3    B3+X7
          EQ     CFG3 
 CFG2     SB2    X7          SAVE EXPONENT FOR -E- FORMAT 
          RJ     ROUND       ROUND COEFFICIENT TO D DIGITS
          SX7    B2+X7       ADJUST EXPONENT IF CARRY OVERFLOW
          SB2    B1          ONE DIGIT BEFORE DECIMAL POINT 
          SA7    EV          SAVE EXPONENT VALUE
 CFG3     SA2    SN          ALL PATHS REJOIN HERE
          SA5    CFGZ        (X5) = DISPLAY ZEROS 
          SB6    B0          (B6) = ASSEMBLY WORD INDEX 
          SB7    60-6        (B7) = CHARACTER POSITION
          LX2    -6 
          IX6    X5+X2       (X6) = ASSEMBLY
          ZR,X2  CFG4        IF NO SIGN 
          SB7    B7-6        POSITION AFTER SIGN CHARACTER
 CFG4     RJ     FCD         FORMAT COEFFICIENT DIGITS
          RJ     FEX         FORMAT EXPONENT IF ANY 
          SA6    AB+B6       STORE ASSEMBLY WORD
          SX2    B7-60+6
          SX3    6           CHARACTERS IN LAST WORD = (54-B7)/6
          IX4    X2/X3
          SA1    PA          PARAMETER LIST ADDRESS 
          SX2    B6 
          SX6    10          CHARACTERS IN FIRST WORD(S) = 10*B6
          IX7    X2*X6
          SA2    X1+2        LOC OF L 
          SA1    A2+B1       LOC OF A 
          IX6    X7-X4       TOTAL CHARACTER COUNT
          SA3    AB 
          BX4    X5 
          ZR,B6  CFG5        IF ONLY ONE WORD 
          SA4    A3+B1
 CFG5     SA6    X2          STORE CONVERSION LENGTH INTO L 
          BX7    X3 
          LX6    X4          MOVE ASSEMBLY BUFFER TO A
          SA7    X1 
          SA6    X1+B1
          JP     EXIT.       RETURN 
  
 CFGZ     CON    10H0000000000
 CFG      SPACE  4,8
*         CONSTANT TABLES.
  
  
 CFGA     CON    289
          CON    1.0E+289 
          CON    212
          CON    1.0E+212 
          CON    135
          CON    1.0E+135 
          CON    58 
          CON    1.0E+58
          CON    -18
          CON    1.0E-18
          CON    -96
          CON    1.0E-96
          CON    -173 
          CON    1.0E-173 
          CON    -250 
          CON    1.0E-250 
          CON    0
          CON    3.41757925747345E-227
  
 CFGM     CON    1.0E0       MINUS POWERS OF TEN, ROUNDED  DOWN 
          CON    1.0E-1-1 
          CON    1.0E-2-1 
          CON    1.0E-3-1 
          CON    1.0E-4 
          CON    1.0E-5 
          CON    1.0E-6 
          CON    1.0E-7 
          CON    1.0E-8-1 
          CON    1.0E-9-1 
          CON    1.0E-10-1
          CON    1.0E-11-1
          CON    1.0E-12-1
          CON    1.0E-13
          CON    1.0E-14-1
          CON    1.0E-15-1
          CON    1.0E-16-1
          CON    1.0E-17-1
          CON    1.0E-18
          CON    1.0E-19
          CON    1.0E-20
  
 CFGP     CON    1.0E0       PLUS POWERS OF TEN 
          CON    1.0E1
          CON    1.0E2
          CON    1.0E3
          CON    1.0E4
          CON    1.0E5
          CON    1.0E6
          CON    1.0E7
          CON    1.0E8
          CON    1.0E9
          CON    1.0E10 
          CON    1.0E11 
          CON    1.0E12 
          CON    1.0E13 
          CON    1.0E14 
          CON    1.0E15 
          CON    1.0E16 
          CON    1.0E17 
          CON    1.0E18 
          CON    1.0E19 
          CON    1.0E20 
          CON    1.0E21 
 FCD      SPACE  4,8
**        FCD  -  FORMAT COEFFICIENT DIGITS.
* 
*         ENTRY  (X1) = COEFFICIENT, FIXED POINT WITH 54-BIT FRACTION.
*                (B2) = NUMBER OF DIGITS TO PRECEDE DECIMAL POINT.
*                (B3) = TOTAL NUMBER OF DIGITS INCLUDING DECIMAL POINT. 
*                (X5) = DISPLAY ZEROS.
*                (X6) = CURRENT WORD OF ASSEMBLY. 
*                (B6) = ASSEMBLY WORD INDEX.
*                (B7) = NEXT CHARACTER POSITION, I.E. 54,48,...,6,0.
* 
*         EXIT   (X6, B6, B7)  UPDATED. 
*                (X5) = SPACES. 
  
  
 FCD      SUBR               ENTRY/EXIT 
          MX7    6
          SB3    B3-B2
 FCD1     BX2    -X7*X1      FRACTION 
          IX3    X2+X2       2* 
          LX2    3           8* 
          BX4    X7*X1       DIGIT
          ZR,B2  FCD2        IF ALL DIGITS DONE 
          LX4    B7          POSITION DIGIT 
          IX1    X2+X3       10*
          SB7    B7-6 
          SB2    B2-B1       COUNT DIGITS 
          LX4    6
          IX6    X6+X4       ADD TO ASSEMBLY
          PL,B7  FCD1        IF WORD NOT FULL, LOOP 
          SA6    AB+B6       STORE ASSEMBLY WORD
          SB7    60-6 
          SB6    B6+B1       START NEW WORD 
          LX6    X5 
          NZ,B2  FCD1        LOOP 
 FCD2     ZR,B3  FCD3        IF FRACTION DONE 
          SX2    1R.-1R0+1R 
          RJ     ICH         INSERT DECIMAL POINT 
          SB2    B3-B1       NUMBER OF FRACTION DIGITS
          SB3    B0 
          GE,B2,B1  FCD1     IF ANY 
 FCD3     IX3    X6-X5       PROCEED TO REMOVE TRAILING ZEROS 
          SA1    FCDA 
          SA2    A6 
          NZ,X3  FCD4        IF CURRENT WORD NOT ALL ZEROS
          BX6    X2          BACK UP TO PRECEDING WORD
          SB6    B6-B1
 FCD4     SX2    B1 
          BX3    X6-X5       CHANGE ALL ZEROS TO 00 
          IX4    X3-X2       FIND LOWEST BIT SET
          BX2    -X4+X3 
          SB2    60-5 
          BX1    X1*X2       BUILD MASK FOR TRAILING NON-00 CHARACTERS
          LX2    X1,B2
          IX3    X1-X2
          BX1    X1+X3
          MX3    -6 
          BX1    -X1         MASK FOR TRAILING ZEROS
          CX2    X1 
          SB7    X2 
          AX4    X6,B7       GET RIGHTMOST NON-ZERO CHARACTER 
          BX2    -X3*X4 
          SB2    X2-1R. 
          NZ,B2  FCD5        IF NOT DECIMAL POINT 
          SB7    B7-6        KEEP ONE ZERO AFTER DECIMAL POINT
          AX1    6
          PL,B7  FCD5        IF NOT AT WORD BOUNDARY
          BX6    X5 
          MX1    6
          SB7    60-6        SET NEXT WORD
          SB6    B6+B1
          BX1    -X1
 FCD5     SA5    FCDB        (X5) = SPACES
          BX2    -X1*X6 
          SB7    B7-6 
          BX1    X1*X5       REPLACE TRAILING ZEROS WITH SPACES 
          IX6    X2+X1
          SA6    AB+B6
          PL,B7  EXIT.       IF WORD NOT FULL 
          SB7    60-6 
          SB6    B6+B1       START NEW WORD 
          BX6    X5 
          JP     EXIT.       RETURN 
  
 FCDA     CON    40404040404040404040B
 FCDB     CON    10H
 FEX      SPACE  4,8
**        FEX  -  FORMAT EXPONENT, IF ANY.
  
  
 FEX      SUBR               ENTRY/EXIT 
          SA2    PA          PARAMETER LIST ADDRESS 
          SA1    EV          EXPONENT VALUE 
          SA3    X2+B1       LOC OF SECOND ARGUMENT (E) 
          SX2    1RD
          SA4    X3          VALUE OF E 
          SX3    1R+         SET EXPONENT SIGN
          SB2    X4-2 
          PL,X1  FEX1        IF EXPONENT IS POSITIVE
          SX3    1R-
 FEX1     ZR,B2  FEX2        IF *D* WANTED
          SX2    1RE
          ZR,X1  EXIT.       IF *E* AND VALUE IS ZERO 
 FEX2     RJ     ICH         INSERT CHARACTER D OR E
          SX2    X3 
          RJ     ICH         INSERT CHARACTER + OR -
          BX2    X1 
          SX7    100
          AX2    59 
          BX1    X1-X2       ABS (EV) 
          SB2    X1-10
          LX2    X1 
          MI,B2  FEX4        IF ONLY ONE DIGIT
          IX3    X2/X7,B2    GET HUNDREDS DIGIT 
          ZR,X3  FEX3        IF NO HUNDREDS 
          SX7    100
          IX4    X3*X7       REDUCE VALUE 
          IX1    X1-X4
          SX2    X3+1R0 
          RJ     ICH         INSERT CHARACTER 
 FEX3     BX2    X1 
          SX7    10 
          IX3    X2/X7,B2    GET TENS DIGIT 
          SX7    10 
          IX4    X3*X7       REDUCE VALUE 
          IX1    X1-X4
          SX2    X3+1R0 
          RJ     ICH         INSERT CHARACTER 
 FEX4     SX2    X1+1R0      UNITS DIGIT
          RJ     ICH         INSERT CHARACRER 
          JP     EXIT.
 ICH      SPACE  4,8
**        ICH  -  INSERT CHARACTER. 
* 
*         ENTRY  (X2) = THE CHARACTER, IN 1R FORMAT.
*                (X5) = SPACES. 
*                (X6) = CURRENT WORD OF ASSEMBLY. 
*                (B6) = ASSEMBLY WORD INDEX.
*                (B7) = NEXT CHARACTER POSITION.
* 
*         EXIT   (X6, B6, B7)  UPDATED. 
  
  
 ICH      SUBR               ENTRY/EXIT 
          PL,B7  ICH1        IF WORD NOT FULL 
          SA6    AB+B6       STORE ASSEMBLY WORD
          SB6    B6+B1
          SB7    60-6        START NEW WORD 
          LX6    X5 
 ICH1     SX2    X2-1R       INSERT NEW CHARACTER 
          LX2    B7 
          IX6    X6+X2
          SB7    B7-6        ADJUST CHARACTER POSITION
          JP     EXIT.
 ROUND    SPACE  4,8
**        ROUND  -  ROUND COEFFICIENT FOR DECIMAL DIGITS. 
* 
*         ENTRY  (X1) = COEFFICIENT, 1.0 .LE. VALUE .LT. 10.0.
* 
*         EXIT   (X1) = COEFFICIENT AS UNSIGNED BINARY FIXED (6,54).
*                (X7) = 1 IF ROUNDING CAUSED CARRY, ELSE 0. 
  
  
 ROUND    SUBR               ENTRY/EXIT 
          SX2    D           NUMBER OF DIGITS WANTED
          MX3    -4 
          BX4    -X3*X2      D MOD 16 
          AX2    4           D / 16 
          SA3    CFGM+X4     SMALL PART 
          SA4    RNDA+X2     BIG PART 
          FX2    X3*X4
          RX1    X1+X2       ADD ROUNDING VALUE 
          SX3    2S10        FORCE ROUND UP 
          UX1,B7
          SB6    B7+54       MAKE COEFFICIENT FIXED POINT 
          LX2    X1,B6       WITH 54-BIT FRACTION 
          IX1    X2+X3
          UX4,B7 X1          CHECK FOR OVERFLOW 
          SB6    B7+1777B-10S6
          SX7    B0 
          MI,B6  EXIT.       IF < 10.0
          SX1    B1 
          BX7    X1 
          LX1    54          OVERFLOW, RETURN 1.0 
          JP     EXIT.
  
  
 RNDA     CON    5.0+5       ROUNDING FACTORS 
          CON    5.0E-16+5
          CON    5.0E-32+5
 SCALE    SPACE  4,8
**        SCALE  -  REDUCE GIVEN NUMBER TO COEFFICIENT AND EXPONENT.
* 
*         ENTRY  (X1) = THE NUMBER. 
* 
*         EXIT   (X1) = COEFFICIENT.
*                (X7) = EXPONENT. 
* 
*         THE RESULTS ARE SUCH THAT 
* 
*                      1.0  .LE.  (X1)  .LT.  10.0,  AND
*                      (X1) * 10.0 ** (X7)  = ORIGINAL NUMBER.
  
  
 SCALE    SUBR               ENTRY/EXIT 
          UX6,B2 X1 
          SX2    B2+2360B 
          AX2    8           (EXP+2360B)/256 = SUBSCRIPT FOR CFGA 
          SB2    X2-4 
          SA3    CFGP+1      =10.0
          NZ,B2  SCA1        IF NOT  1E-55 TO 1E+18 
          IX4    X1-X3
          SB3    -20         BEGIN EXPONENT 
          MI,X4  SCA3        IF  1E-55 TO 1E+1
 SCA1     LX2    1
          SA3    CFGA+X2     OFFSET FOR EXPONENT
          SA4    A3+B1       10.0**N / 2**N 
          SB3    X3-20       BEGIN EXPONENT 
          NZ,X3  SCA2        IF NOT 1E-324
          SX3    -324 
          SB3    B3+X3       SPECIAL CASE - MACHINE CAN HOLD
          LX3    48          5E-324 BUT NOT 1E-324
          IX1    X1+X3
 SCA2     FX1    X1*X4       REDUCE NUMBER TO 1E-79 TO 1E+1 
          ZR,X1  SCA6 
 SCA3     SA3    CFGM+19     MULTIPLY BY 1E+20 UNTIL NUMBER 
          SA4    CFGP+20     IS AT LEAST 1E-19
          IX2    X1-X3
          SB3    B3+20       TALLY EXPONENT 
          MI,X2  SCA2        IF STILL LESS THAN 1E-19, LOOP 
          SA3    CFGP+0      =1.0 
          IX4    X1-X3
          PL,X4  SCA5        IF NOT LESS THAN 1E0 
          UX2,B2 X1 
          SX3    B2+54B      NUMBER IS NOW 1E-19 TO 1E+1
          BX4    -X3
          LX3    2           COMPUTE APPROXIMATE LOG10
          IX4    X4-X3         =  - ((EXP+54B)*5)/16 - 2
          AX4    4
          SA2    CFGM+X4-1   =1E-N
          IX3    X1-X2
          MI,X3  SCA4        IF CORRECT LOG10 
          SX4    X4-1 
 SCA4     SA2    CFGP+X4     MULTIPLY NUMBER BY 1E+N
          SB3    B3+X4       TALLY EXPONENT 
          FX1    X1*X2
          BX3    X1          CHECK FOR NUMBER EQUAL TO
          AX3    45          0.9999999999999999ENNN 
          SX2    X3-1.0/1S45
          SX4    B1          IF SO, MULTIPLY BY TEN 
          MI,X2  SCA4 
 SCA5     SX7    -B3         (X7) = EXPONENT
          JP     EXIT.
 SCA6     SX7    B0          NUMBER = MACHINE ZERO
          JP     EXIT.
  
  
          END 
          IDENT     GETTXT
          SST 
          ENTRY     GETTXT
 DMC      SET       0              0= NO CAPSULE FOR DM TEXT
          TITLE     GETTXT
 A0TMP    DATA      0 
* CALL /PASSMAC/
*CALL /PASSMAC/ 
 PASS     PLOC
          PLY       DM$ETAB        DATA MANAGER ERROR TEXT ENTRY POINT
          PLY       DM$NTAB        DATA MANAGER NOTE TEXT ENTRY POINT 
          PLY       RM$ETAB        RECORD MANAGER ERROR TEXT ENTRY POINT
          PLY       RM$NTAB        RECORD MANAGER NOTE TEXT ENTRY POINT 
 XFIT     PLY       RM$XFIT        RECORD MANAGER FIT DUMP TABLE
 ENDPL    BSS 
 PLOCS    BSS       0 
          VFD       42/0,18/PASS
          DATA      0 
 LIBRARY  BSS       0 
          VFD       42/0LBAMLIB,18/0
          DATA      0 
 GROUP    BSS       0 
          DATA      0LCDCS
          DATA      0LBAM 
 CAPNAME  BSS       0 
          DATA      0LDM$MSGS      DATA MANAGER MESSAGE TEXT
          DATA      0LRM$MSGS      RECORD MANAGER MESSAGE TEXT
 CAPXFIT  DATA      0LRM$XFIT      INTERPRETIVE FIT DUMP TABLE
 FDLERR   DIS       ,* UNABLE TO LOAD ERROR TEXT* 
 FDLENO   DATA      0              CONTAINS CODE ON FDL ERROR.
*#
*1CD  GETTXT
*0D   PURPOSE 
*0        GIVEN A MESSAGE NUMBER RETURN THE ASSOCIATED TEXT FROM A TABLE
*0D   CALL
*0        GETTXT( MESID,CRMMSG,TEXTWSA,TEXTCHS ); 
*0D   PARAMETERS
*0        MESID-   MESSAGE IDENTIFIER AS A BINARY NUMBER. 
*         CRMMSG-  1=RECORD MANAGER ORIGIN, 0=DATA MANAGER ORIGIN 
*         TEXTWSA- AREA TO RECEIVE TEXT OF MESSAGE. 
*         TEXTCHS- TEXT STRING SIZE IN CHARACTERS.
*0D   ACTION
*0         IF CRMMSG INDICATES DATA MANAGER ORIGIN THEN RETURN UP ARROW 
*0         FOR TEXT STRING AND STRING LENGTH OF ONE AND RETURN.  USE
*         NOTE FLAG (BIT 9 OF MESID) AND CRMMSG TO FORM INDEX INTO ENTRY
*         TABLE.  THE ARE ENTRY POINTS FOR RECORD MANAGER NOTES, RECORD 
*         MANAGER ERRORS, DATA MANAGER NOTES, DATA MANAGER ERRORS.
*         (DATA MANAGER ENTRY POINTS ARE RESERVED FOR FUTURE USE OF A 
*         TEXT CAPSULE BY DATA MANAGER).  NOTE TEXT AND ERROR TEXT ARE
*         REFERENCED THROUGH TWO ENTRY POINTS WITHIN THE SAME CAPSULE.
*         IF THE DESIRED ENTRY POINT IS NOT SATISFIED THEN ATTEMPT TO 
*         LOAD THE CAPSULE.  FDL ERRORS ARE DISPLAYED IN THE DAYFILE AND
*         MESSAGE LENGTH OF ZERO IS RETURNED. 
*         A LINEAR SEARCH OF THE TEXT TABLE IS NOW EMPLOYED TO LOCATE 
*         THE ENTRY CORRESPONDING TO THE MESSAGE NUMBER (MESID).  EACH
*         ENTRY OF THE TABLE CONSISTS OF A WORD CONTAINING THE MESSAGE
*         ID, THE FIRST WORD ADDRESS OF THE STRING, AND THE LENGTH OF 
*         THE STRING IN CHARACTERS.  STRING LENGTH OF ZERO INDICATES NO 
*         CORRESPONDING TEXT EXISTS FOR THIS ID.  THE LOCATED TEXT IS 
*         TRANSFERED TO THE TEXT WSA AND ITS LENGTH IN CHARACTERS IS
*         RETURNED IN TEXTCHS.
*0D   REGISTERS 
*0         NOT APPLICABLE 
*0D   OTHER CODE
*0        PROGRAMS- FDL.LDC,SYS=
*         MACROS-   MESSAGE,PASS
*#
          SPACE     1 
 NOTFOUND BSS       0 
          SA1       A0+3           RETURN TEXT CHS = 0
          MX6       0 
          SA6       X1
 EXIT     BSS       0 
          SA1       A0TMP          RESTORE OLD APLIST 
          SA0       X1+0
 GETTXT   EQ        *+1S17         ENTRY/EXIT 
          SX6       A0+0
          SA6       A0TMP          SAVE OLD APLIST
          SA0       A1+0           USE NEW APLIST 
          SB1       1              B1=1 
 TRYNOW   BSS       0 
          SA3       A0             (MESSAGE ID) 
          SA2       A0+B1          (PROD IND) 
          SA3       X3             MESSAGE ID 
          SA2       X2             PROD IND (RM=1/DM=0) 
.DM       IFEQ      DMC,0 
          NZ        X2,RM          IF NOT DATA MGR MSG
          SA2       A0+2           (TEXT WSA) 
          SA3       A0+3           (TEXT CHS) 
          SX6       1R'            MESSAGE INSERT INDICATOR 
          SX7       B1             LENGTH OF STRING = 1 
          LX6       54             LEFT JUSTIFY STRING
          SA7       X3             TEXT CHS 
          SA6       X2             TEXT WSA 
          EQ        EXIT           RETURN 
          SPACE     1 
 RM       BSS       0 
 .DM      ENDIF 
          SX0       1000B          NOTE FLAG MASK 
 REG      SET       #PLAO#+1
          LX1       X2,B.REG       CONVERT PROD INDEX TO PASSLOC INDEX
          BX4       X0*X3          EXTRACT NOTE FLAG
          AX4       9              CONVERT NOTE FLAG TO PASSLOC OFFSET
          IX1       X1+X4          PASSLOC INDEX + OFFSET 
          SA4       X1+PASS+1      LOAD ENTRY ADDRESS FROM PASSLOC TABLE
          SB5       X4+0           ISOLATE ENTRY ADDRESS
          GT        B5,B0,LDD      IF TEXT LOADED 
          SA1       X2+GROUP       GROUP NAME 
          SA2       X2+CAPNAME     CAPSULE NAME 
          SX3       LIBRARY        LIBRARY LIST 
          SX4       PLOCS          PASSLOC LIST 
          RJ        =XFDL.LDC      LOAD TEXT CAPSULE
          ZR        X6,TRYNOW      IF NO FDL FAILURE
          SA6       FDLENO
          MESSAGE   FDLERR,,RECALL DIAGNOSE FDL FAILURE 
          EQ        NOTFOUND       RETURN TEXT CHS = 0
          SPACE     1 
 LDD      BSS       0 
          SA2       B5             (NO. OF ENTRIES) 
          SB4       B0             INDEX POINTER
          SB3       X2             NO. OF ENTRIES 
          SB2       X3             MESSAGE ID.
 SCANDEX  BSS       0 
          SB4       B4+B1          INCREMENT INDEX POINTER
          GT        B4,B3,NOTFOUND IF ENTRIES EXHAUSTED 
          SA1       B5+B4          LOAD INDEX ENTRY 
          SB6       X1             ISOLATE ENTRY ID.
          NE        B6,B2,SCANDEX  IF NOT MESSAGE ID, KEEP SEARCHING
          AX1       18             POSITION STRING LENGTH FIELD 
          MX2       48
          BX6       -X2*X1         ISOLATE TEXT STRING LENGTH (CHARS) 
          AX1       12             POSITION FWA TEXT STRING 
          SB3       X1             FWA TEXT STRING
          SX4       10             CHARS PER CM WORD
          SA3       A0+3           (TEXT CHS) CHARS IN STRING 
          SB6       0              INITIALIZE STRING WORD INDEX 
          SA6       X3             RETURN TEXT CHS PARAMETER
          SA5       A3-B1          (TEXT WSA) DESTINATION 
 XFERSTR  BSS       0 
          SA2       B3+B6          LOAD WORD OF TEXT
          IX6       X6-X4          DECREMENT CHAR. COUNT
          BX7       X2             A WORD OF TEXT 
          SB5       X6             CHAR COUNT 
          SA7       X5+B6          STORE IN TEXT WSA
          SB6       B6+B1          INCREMENT STRING INDEX 
          GT        B5,B0,XFERSTR  IF STRING NOT EXHAUSTED
          EQ        EXIT           RETURN 
          TITLE     FIELDER 
*#
*1CD  FIELDER 
*0D   PURPOSE 
*0        GIVEN A TABLE ORDINAL EXTRACT AND RETURN INFORMATION NEEDED TO
*         DISPLAY AN FIT FIELD NAME AND ITS CONTENT.
*0D   CALL
*0        FIELDER( ORD,SYMBOL,SLEN,VWORD,VPOS,VLEN ); 
*0D   PARAMETERS
*0        ORD-    ORDINAL OF REQUESTED FIT FIELD DATA 
*         SYMBOL- THE SYMBOL RETURNED LEFT JUSTIFIED GARBAGE FILLED 
*         SLEN-   THE LENGTH OF THE SYMBOL IN CHARACTERS
*         VWORD-  WORD OF FIT CONTAINING FIELD COUNTS FROM 1
*         VPOS-   BIT POSITION OF FIELD COUNTS FROM LEFT
*         VLEN-   LENGTH OF FIELD IN BITS 
*0D   ACTION
*0        IF THE TABLE ENTRY UNSATISFIED THEN WE ARE BEING CALLED ONLY
*         TO LOAD THE TABLE CAPSULE.  IN THIS CASE PERFORM THE LOAD,
*         NOTE ANY FDL ERROR, AND TRANSFER THE TABLE SIZE (NUMBER OF
*         SYMBOLS) FROM FWA OF TABLE - 1 TO THE CALLING PROGRAM VIA THE 
*         ENTRY POINT SYMBOLS AND EXIT. THIS INITIAL CALL IS NECESSARY
*         BECAUSE THE ORDINAL INPUT PARAMETER FOR SUBSEQUENT CALLS IS A 
*         FUNCTION OF THE NUMBER OF SYMBOLS (UNKNOWN BEFORE TNE CAPSULE 
*         IS LOADED).  IF THE CAPSULE IS LOADED THEN WE CAN RETURN
*         VALUES.  LOAD THE TABLE ENTRY AT ENTRY ADDRESS PLUS ORDINAL 
*         AND RETURN IT TO SYMBOL PARAMETER.  A LOOP IS NOW ENTERED TO
*         EXTRACT THE NEXT SIX BITS FROM THE TABLE WORD AND RETURN IT IN
*         THE NEXT PARAMETER PER ITERATION.  RETURN.
*0D   REGISTERS 
*0         NOT APPLICABLE 
*0D   OTHER CODE
*0         PROGRAMS- FDL.LDC,SYS= 
*         MACROS-   MESSAGE 
*#
          ENTRY     FIELDER 
 EXIT2    BSS       0 
          SA1       A0TMP          RESTORE OLD PARAMETER LIST 
          SA0       X1+0
 FIELDER  EQ        *+1S17         ENTRY/EXIT 
          SX6       A0             SAVE OLD PARAMETER LIST
          SA0       A1
          SA6       A0TMP 
          SA2       XFIT+#PLAO#    ENTRY WORD FOR FIT DUMP TABLE
          SB2       X2
          SA1       A0             FIRST PARAMETER
          GT        B2,B0,LDD2     IF THE FIT DUMP TABLE IS LOADED
          SA1       GROUP+1        FDL GROUP NAME 
          SA2       CAPXFIT        FDL CAPSULE NAME 
          SX3       LIBRARY        CRM LIBRARY NAME 
          SX4       PLOCS          PASSLOC TABLE LIST 
          RJ        =XFDL.LDC      GO LOAD THE FITDUMP TABLE
          NZ        X6,SKIPIT      IF UNABLE TO LOAD
          SA2       XFIT+#PLAO#    LOAD ENTRY WORD WITH ENTRY POINT 
          SA3       X2-1           LOAD WORD CONTAINING TABLE LENGTH
          SX7       X3+0
          SA7       =XSYMBOLS      STORE NO. OF SYMBOLS INTO CRMEP
          EQ        EXIT2          FIRST CALL ONLY TO INITIALIZE
          SPACE     1 
 LDD2     BSS       0 
          SB1       1              1
          MX0       36             MASK FOR SYMBOL STRING 
          SA2       X1             ARRAY INDEX F.P. 
          SA3       X2+B2          LOAD ARRAY ITEM
          SA2       A1+B1          (SYMBOL) F.P.
          BX6       X0*X3          EXTRACT SYMBOL STRING
          LX3       36             POSITION FOR LOOP
          SA6       X2+0           STORE SYMBOL F.P.
          SB4       4              PARAMETER COUNT
 PARLOOP  BSS       0 
          SA2       A2+B1          (NEXT F.P.)
          LX3       6              POSITION NEXT FIELD
          MX0       60-6           MASK FOR FIELD 
          SB4       B4-B1          DECREMENT PARAMETER COUNT
          BX6       -X0*X3         EXTRACT FIELD
          SA6       X2             STORE PARAMETER VALUE
          NZ        B4,PARLOOP     IF MORE PARAMETERS 
          EQ        EXIT2          RETURN 
          SPACE     1 
 SKIPIT   BSS       0 
          SA6       FDLENO
          MESSAGE   FDLERR,,RECALL
          SA2       A0+7
          SA2       X2             RETURNS
          SB5       X2
          JP        B5             OMIT FIT DUMP
          TITLE     SYSTEM FUNCTIONS
          ENTRY     CLOCK,DATE,MESSAGE
          SPACE     1 
 CLOCK    EQ        *+1S17         ENTRY/EXIT 
          CLOCK     ST
          SA1       ST
          BX6       X1
          EQ        CLOCK 
          SPACE     1 
 DATE     EQ        *+1S17         ENTRY/EXIT 
          DATE      ST
          SA1       ST
          BX6       X1
          EQ        DATE
          SPACE     1 
 ST       DATA      10H 
          SPACE     1 
 MESSAGE  EQ        *+1S17         ENTRY/EXIT 
          MESSAGE   X1,,RECALL
          EQ        MESSAGE 
  
          ENTRY     GETPAGE 
  
 GETPAGE  EQ        *+1S17         ENTRY/EXIT 
          SB7       X1             KEEP PARAMETER ADDRESS 
          GETPAGE   PB             GET PAGE SIZE PARAMETERS 
          SA1       PB             GET JOB PAGE SIZE
          BX6       X1
          SA6       B7             RETURN JOB PAGE SIZE PARAMETERS
          EQ        GETPAGE        RETURN 
  
 PB       BSSZ      2              PAGE SIZE PARAMETER BLOCK
  
          END 
          IDENT  OCTAL
          B1=1
          LIST   F,X
          TITLE  OCTAL - CONVERT WORD TO OCTAL DISPLAY CODE.
          COMMENT CONVERT WORD TO OCTAL DISPLAY CODE. 
 OCTAL    SPACE  4,8
**        OCTAL - CONVERT WORD TO OCTAL DISPLAY CODE. 
* 
*         R. H. GOODELL.     76/06/23.
* 
*         SYMPL-CALLABLE ROUTINES THAT RETURN, AS DISPLAY CODE
*         CHARACTERS, THE OCTAL REPRESENTATION OF ALL OR HALF 
*         OF A GIVEN BINARY WORD. 
 OCTAL    SPACE  4,8
**        OCTAL - RETURN TEN OCTAL DIGITS FOR LOWER HALF OF BINARY WORD.
* 
*         FUNC OCTAL (W) C (10).
* 
*         ITEM W I.          BINARY WORD. 
  
  
 OCTAL    SUBR   =           ENTRY/EXIT 
          SB1    1           (B1) = 1 
          SA1    X1+         FETCH W
          RJ     =XWOD       CONVERT
          BX6    X7          (X6) = RESULT
          JP     EXIT.       RETURN 
 OCT20    SPACE  4,8
**        OCT20 - RETURN TWENTY OCTAL DIGITS FOR THE ENTIRE BINARY WORD.
* 
*         PROC OCT20 (W, A, B). 
* 
*         ITEM W I.          BINARY WORD. 
*         ARRAY A.           CHARACTER WORD BUFFER. 
*         ITEM B I.          STARTING WORD INDEX IN A.
* 
*         STORES 20 CHARACTERS INTO WORDS B AND B+1 OF ARRAY A. 
  
  
 OCT20    SUBR   =           ENTRY/EXIT 
          SB1    1           (B1) = 1 
          SB7    A1          SAVE (A1)
          SA1    X1          FETCH W
          RJ     =XWOD       CONVERT
          SA2    B7+B1       FETCH LOC (A)
          SA3    A2+B1       FETCH LOC (B)
          SA3    X3          FETCH B
          IX2    X2+X3
          SA6    X2          STORE UPPER 10 CHARACTERS
          SA7    X2+B1       STORE LOWER 10 CHARACTERS
          JP     EXIT.       RETURN 
 COMCWOD  SPACE  4,8
**        COMCWOD - COMPASS-CALLABLE ROUTINE. 
  
  
          CTEXT  COMCWOD - CONVERT WORD TO OCTAL DISPLAY CODE.
 WOD      SPACE  4
          IF     -DEF,QUAL$,1 
          QUAL   COMCWOD
          BASE   D
 WOD      SPACE  4
***       WOD - CONVERT WORD TO OCTAL DISPLAY CODE. 
*         C. R. WILLIS. 
*         UNIVERSITY OF MINNESOTA.
 WOD      SPACE  4
***              WOD CONVERTS A WORD TO OCTAL DISPLAY CODE BY AN
*         IN-LINE SEQUENCE OF SHIFTS AND MASKS. 
* 
*         ENTRY  (X1) = WORD TO CONVERT.
*                (B1) = 1.
* 
*         EXIT   (X6,X7) = CONVERSION.
* 
*         USES   X - 0, 1, 2, 3, 4, 5, 6, 7.
*                B - NONE.
*                A - 2, 3, 4, 5.
* 
*         CALLS  NONE.
  
  
 WOD      PS                 ENTRY/EXIT 
  
*         (X1)   =           ABCDE FGHIJ KLMNO PQRST
  
          SA2    WODA        7.... 7.... 7.... 7....
          BX7    X2*X1       A.... F.... K.... P....
          LX1    3           BCDEF GHIJK LMNOP QRSTA
          BX6    X2*X1       B.... G.... L.... Q....
          LX1    3           CDEFG HIJKL MNOPQ RSTAB
          LX7    27          .K... .P... .A... .F...
          BX0    X2*X1       C.... H.... M.... R....
          LX6    21          ...L. ...Q. ...B. ...G.
          LX1    3           DEFGH IJKLM NOPQR STABC
          IX7    X6+X7       .K.L. .P.Q. .A.B. .F.G.
          BX5    X2*X1       D.... I.... N.... S....
          LX1    3           EFGHI JKLMN OPQRS TABCD
          LX0    15          H.... M.... R.... C....
          BX6    X2*X1       E.... J.... O.... T....
          IX7    X7+X0       HK.L. MP.Q. RA.B. CF.G.
          LX5    9           ..I.. ..N.. ..S.. ..D..
          LX6    3           ....J ....O ....T ....E
          IX7    X7+X6       HK.LJ MP.QO RA.BT CF.GE
          SA4    A2+B1       .7.7. 7.7.7 ..... .....
          SA3    A4+B1       ..... .7.7. 7.7.7 .....
          BX7    X7+X5       HKILJ MPNQO RASBT CFDGE
          BX2    X7*X4       .K.L. M.N.O ..... .....
          SA5    A3+B1       00000 00000 00000 00000
          BX1    X7*X3       ..... .P.Q. R.S.T .....
          LX7    30          RASBT CFDGE HKILJ MPNQO
          IX2    X5+X2       .K.L. M.N.O 00000 00000
          BX0    X7*X4       .A.B. C.D.E ..... .....
          IX0    X0+X5       .A.B. C.D.E 00000 00000
          LX1    45          ..... ..... .P.Q. R.S.T
          BX3    X7*X3       ..... .F.G. H.I.J .....
          IX7    X1+X2       .K.L. M.N.O .P.Q. R.S.T
          LX3    45          ..... ..... .F.G. H.I.J
          IX6    X0+X3       .A.B. C.D.E .F.G. H.I.J
          EQ     WOD         RETURN 
  
 WODA     CON    70000700007000070000B
          CON    07070707070000000000B
          CON    00000070707070700000B
          CON    10H0000000000
          SPACE  4
          BASE   *
 QUAL$    IF     -DEF,QUAL$ 
          QUAL   *
 WOD      EQU    /COMCWOD/WOD 
 QUAL$    ENDIF 
          ENDX
  
  
          ENTRY  WOD
  
  
          END 
          IDENT  XCDD                                                    XCDD 
          B1=1                                                           XCDD 
          LIST   F,X                                                     XCDD 
          TITLE  XCDD - CONVERT INTEGER TO DECIMAL DISPLAY CODE.         XCDD 
          COMMENT  CONVERT INTEGER TO DECIMAL DISPLAY CODE.              XCDD 
 XCDD     SPACE  4,8                                                     XCDD 
**        XCDD  -  CONVERT INTEGER TO DECIMAL DISPLAY CODE.              XCDD 
*                                                                        XCDD 
*         R. H. GOODELL.     76/06/22.                                   XCDD 
*                                                                        XCDD 
*         SYMPL-CALLABLE ENTRY POINTS FOR INTERFACING TO THE             XCDD 
*         STANDARD COMPASS-CALLABLE ROUTINE.                             XCDD 
 XCDD     SPACE  4,8                                                     XCDD 
**        XCDD - CONVERSION RIGHT JUSTIFIED.                             XCDD 
*                                                                        XCDD 
*         FUNC XCDD (N) C (10).                                          XCDD 
*                                                                        XCDD 
*         ITEM N I.          INTEGER TO BE CONVERTED.                    XCDD 
                                                                         XCDD 
                                                                         XCDD 
 XCDD     SUBR   =           ENTRY/EXIT                                  XCDD 
          SB1    1           (B1) = 1                                    XCDD 
          SA1    X1+         FETCH N                                     XCDD 
          RJ     =XCDD       CONVERT                                     XCDD 
          JP     EXIT.       RETURN, RESULT IN X6                        XCDD 
 XCDDL    SPACE  4,8                                                     XCDD 
**        XCDDL - CONVERSION LEFT JUSTIFIED.                             XCDD 
*                                                                        XCDD 
*         PROC XCDDL (N, M, L).                                          XCDD 
*                                                                        XCDD 
*         ITEM N I.          INTEGER TO BE CONVERTED.                    XCDD 
*         ITEM M C (10).     CONVERTED RESULT.                           XCDD 
*         ITEM L I.          6 * NUMBER OF DIGITS IN (M).                XCDD 
                                                                         XCDD 
                                                                         XCDD 
 XCDDL    SUBR   =           ENTRY/EXIT                                  XCDD 
          SB1    1           (B1) = 1                                    XCDD 
          SB7    A1          SAVE (A1)                                   XCDD 
          SA1    X1          FETCH N                                     XCDD 
          RJ     =XCDD       CONVERT                                     XCDD 
          SA1    B7+B1       FETCH M AND L ADDRESSES                     XCDD 
          SA2    A1+B1                                                   XCDD 
          BX6    X4          (M) = LEFT JUSTIFIED RESULT                 XCDD 
          SX7    B2          (L) = BIT COUNT OF SIGNIFICANT DIGITS       XCDD 
          SA6    X1                                                      XCDD 
          SA7    X2                                                      XCDD 
          JP     EXIT.       RETURN                                      XCDD 
 CDD      SPACE  4,8                                                     XCDD 
**        CDD  -  COMPASS-CALLABLE ROUTINE.                              XCDD 
                                                                         XCDD 
                                                                         XCDD 
          CTEXT  COMCCDD - CONSTANT TO DECIMAL DISPLAY CODE CONVERSION.  COMCCDD
 CDD      SPACE  4                                                       COMCCDD
          IF     -DEF,QUAL$,1                                            COMCCDD
          QUAL   COMCCDD                                                 COMCCDD
          BASE   D                                                       COMCCDD
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1994. 
 CDD      SPACE  4                                                       COMCCDD
***       CDD - CONSTANT TO DECIMAL DISPLAY CODE CONVERSION.             COMCCDD
*         G. R. MANSFIELD.  70/12/18.                                    COMCCDD
*         ADAPTED FROM SUBROUTINE *CONDEC* IN *COMPASS VER 2.0*.         COMCCDD
 CDD      SPACE  4                                                       COMCCDD
***              CDD CONVERTS UP TO 10 DIGITS TO DISPLAY CODE WITH       COMCCDD
*         LEADING ZERO SUPPRESSION.  CONVERSION CONTAINS SPACE FILL      COMCCDD
*         AND IS RIGHT AND LEFT JUSTIFIED.                               COMCCDD
*                                                                        COMCCDD
*         ENTRY  (X1) = NUMBER TO BE CONVERTED.                          COMCCDD
*                (B1) = 1.                                               COMCCDD
*                                                                        COMCCDD
*         EXIT   (X6) = DPC CONVERSION RIGHT JUSTIFIED.                  COMCCDD
*                (X4) = DPC CONVERSION LEFT JUSTIFIED.                   COMCCDD
*                (B2) = 6*COUNT OF DIGITS CONVERTED.                     COMCCDD
*                                                                        COMCCDD
*         USES   X - 1, 2, 3, 4, 6, 7.                                   COMCCDD
*                B - 2, 3, 4.                                            DOK07
*                A - 2, 3, 4.                                            COMCCDD
*                                                                        COMCCDD
*         CALLS  NONE.                                                   COMCCDD
                                                                         COMCCDD
                                                                         COMCCDD
 CDD1     DX6    X1*X2       COMPUTE QUOTIENT                            COMCCDD
          FX1    X1*X2                                                   COMCCDD
          UX7    X1          CHECK QUOTIENT                              KRON107
          LX4    -6          SHIFT ASSEMBLY                              COMCCDD
          SB2    B2+B4                                                   COMCCDD
          FX6    X6*X3       EXTRACT REMAINDER DIGIT                     COMCCDD
          SX6    X6+B3       CONVERT DIGIT                               KRON107
          IX4    X6+X4                                                   KRON107
          NZ     X7,CDD1     LOOP TO ZERO QUOTIENT                       KRON107
          LX4    -6          LEFT JUSTIFY ASSEMBLY                       COMCCDD
          LX6    X4,B2       RIGHT JUSTIFY ASSEMBLY                      COMCCDD
                                                                         COMCCDD
 CDD      PS                 ENTRY/EXIT                                  COMCCDD
          SA2    CDDA        =.1P48+1                                    COMCCDD
          SA3    A2+B1       =10.P                                       COMCCDD
          PX1    X1                                                      COMCCDD
          SB2    B0          CLEAR JUSTIFY COUNT                         COMCCDD
          SA4    A3+B1       =1H                                         COMCCDD
          SB3    1R0-1R      (B3) = CONVERSION CONSTANT                  COMCCDD
          SB4    6           (B4) = SHIFT INCREMENT                      COMCCDD
          EQ     CDD1                                                    COMCCDD
                                                                         COMCCDD
 CDDA     CON    0.1P48+1                                                COMCCDD
          CON    10.P                                                    COMCCDD
          CON    1H                                                      COMCCDD
          SPACE  4                                                       COMCCDD
          BASE   *                                                       COMCCDD
 QUAL$    IF     -DEF,QUAL$                                              COMCCDD
          QUAL   *                                                       COMCCDD
 CDD      EQU    /COMCCDD/CDD                                            COMCCDD
 QUAL$    ENDIF                                                          COMCCDD
          ENDX                                                           COMCCDD
                                                                         XCDD 
                                                                         XCDD 
          ENTRY  CDD                                                     XCDD 
                                                                         XCDD 
                                                                         XCDD 
          END                                                            XCDD 
          IDENT  XCOD 
          B1=1
          LIST   F,X
          TITLE  XCOD - CONVERT INTEGER TO OCTAL DISPLAY CODE.
          COMMENT  CONVERT INTEGER TO OCTAL DISPLAY CODE. 
 XCOD     SPACE  4,8
**        XCOD  -  CONVERT INTEGER TO OCTAL DISPLAY CODE. 
* 
*         R. H. GOODELL.     76/06/23.
* 
*         SYMPL-CALLABLE ENTRY POINTS FOR INTERFACING TO THE
*         STANDARD COMPASS-CALLABLE ROUTINE.
 XCOD     SPACE  4,8
**        XCOD - CONVERSION RIGHT JUSTIFIED.
* 
*         FUNC XCOD (N) C (10). 
* 
*         ITEM N I.          INTEGER TO BE CONVERTED. 
  
  
 XCOD     SUBR   =           ENTRY/EXIT 
          SB1    1           (B1) = 1 
          SA1    X1+         FETCH N
          RJ     =XCOD       CONVERT
          JP     EXIT.       RETURN, RESULT IN X6 
 XCODL    SPACE  4,8
**        XCODL - CONVERSION LEFT JUSTIFIED.
* 
*         PROC XCODL (N, M, L). 
* 
*         ITEM N I.          INTEGER TO BE CONVERTED. 
*         ITEM M C (10).     CONVERTED RESULT.
*         ITEM L I.          6 * NUMBER OF DIGITS IN (M). 
  
  
 XCODL    SUBR   =           ENTRY/EXIT 
          SB1    1           (B1) = 1 
          SB7    A1          SAVE (A1)
          SA1    X1          FETCH N
          RJ     =XCOD       CONVERT
          SA1    B7+B1       FETCH M AND L ADDRESSES
          SA2    A1+B1
          BX6    X4          (M) = LEFT JUSTIFIED RESULT
          SX7    B2          (L) = BIT COUNT OF SIGNIFICANT DIGITS. 
          SA6    X1 
          SA7    X2 
          JP     EXIT.       RETURN 
 COD      SPACE  4,8
**        COD  -  COMPASS-CALLABLE ROUTINE. 
  
  
          CTEXT  COMCCOD - CONSTANT TO OCTAL DISPLAY CODE CONVERSION. 
 COD      SPACE  4
          IF     -DEF,QUAL$,1 
          QUAL   COMCCOD
          BASE   D
*         COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1994. 
 COD      SPACE  4
***       COD - CONSTANT TO OCTAL DISPLAY CODE CONVERSION.
*         G. R. MANSFIELD.  70/12/18. 
*         ADAPTED FROM SUBROUTINE *COD* IN *LIBEDIT*. 
 COD      SPACE  4
***              COD CONVERTS UP TO 10 DIGITS TO DISPLAY CODE WITH
*         LEADING ZERO SUPPRESSION.  CONVERSION CONTAINS SPACE FILL 
*         AND IS RIGHT AND LEFT JUSTIFIED.
* 
*         ENTRY  (X1) = NUMBER TO BE CONVERTED. 
*                (B1) = 1.
* 
*         EXIT   (X6) = DPC CONVERSION RIGHT JUSTIFIED. 
*                (X4) = DPC CONVERSION LEFT JUSTIFIED.
*                (B2) = 6*COUNT OF DIGITS CONVERTED.
* 
*         USES   X - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 4. 
*                A - 2, 4.
* 
*         CALLS  NONE.
  
  
 COD      PS                 ENTRY/EXIT 
          SA4    CODA        =1H
          SB3    6           (B3) = SHIFT INCREMENT 
          MX2    -3          (X2) = DIGIT MASK
          SB2    B0          CLEAR JUSTIFY COUNT
          SB4    1R0-1R      (B4) = CONVERSION COUNT
 COD1     BX7    -X2*X1      EXTRACT DIGIT
          LX4    -6          SHIFT ASSEMBLY 
          SB2    B2+B3
          SX3    X7+B4       CONVERT DIGIT
          AX1    3           SHIFT OFF DIGIT
          IX4    X4+X3       ADD DIGIT TO ASSEMBLY
          NZ     X1,COD1     LOOP TO ZERO DIGIT 
          LX4    -6          LEFT JUSTIFY ASSEMBLY
          LX6    X4,B2       RIGHT JUSTIFY ASSEMBLY 
          EQ     COD         RETURN 
  
 CODA     CON    1H 
          SPACE  4
          BASE   *
 QUAL$    IF     -DEF,QUAL$ 
          QUAL   *
 COD      EQU    /COMCCOD/COD 
 QUAL$    ENDIF 
          ENDX
  
  
          ENTRY  COD
  
  
          END 
