         TITLE    'APLFMT-B00,10/10/73,DWG702985'
         SYSTEM   SIG7F
APLFMT@  CSECT    1
*
* DEF'S
         DEF      APLFMT@
         DEF      DELTAFMT
*
* REF'S
*
         REF      ALOCBLK           ROUTINE TO ALLOCATE DATA BLOCK
         REF      ALOCHNW           ALLOCATE DATA BLOCK-N WORDS+HEADER
         REF      BITMASK           TABLE OF 1 BIT MASKS
         REF      BREAKFLG          BREAK FLAG
         REF      CURRCS            CURRENT CODESTRING POINTER
         REF      DXRETURN          DYADIC EXECUTION RETURN
         REF      ERDOMAIN          DOMAIN ERROR
         REF      ERFORMAT          FORMAT SYNTAX ERROR
         REF      ERRANK            RANK ERROR
         REF      F0F9              CONSTANTS  'F0' AND 'F9'
         REF      FLHALF            FL. PT. LONG 0.5                    U21-0004
         REF      FMTMPS            BASE OF TEMPS FOR DELTAFMT-DW BOUND-
         REF      LETTERS           DW 'A','Z'
         REF      LFARG             LEFT ARGUMENT POINTER
         REF      OFFSET            CODESTRING OFFSET
         REF      OPBREAK           TRANSFER POINT FOR BREAK
         REF      PLUSREAL          ENTRY TO REAL # CONV ROUTINE
         REF      RESULT            RESULT POINTER
         REF      RTARG             RIGHT ARGUMENT POINTER
         REF      SINGOUT           ROUTINE TO WRITE A DATA BLOCK
         REF      STATEPTR          STATE POINTER
         REF      TENSTBL           TABLE OF INTEGER POWERS OF 10
         REF      X4E1              CONST. USED TO FIX FL. PT. NO.      U21-0006
         REF      ZEROZERO          DW ZERO
*
* TEMPS FOR APLFMT-LOCATED IN APLUTSI (CSECT 0)
*      DOUBLE-WORD-GROUPS
NROWS    EQU      FMTMPS            DWB      MAX # OF ROWS       @@@@@@@
NCOLS    EQU      FMTMPS+1                   TOTAL # OF COLUMNS        @
ARGWORDS EQU      FMTMPS+2          DWB-DW   ARG ADDRESS AND COUNT     @
ARGADR   EQU      FMTMPS+4          DWB      ARG POINTER ADDRESS       @
ARGCOUNT EQU      FMTMPS+5                   ARG COUNT                 @
ARGROWS  EQU      FMTMPS+6          DWB      # OF ARG ROWS             @
ARGCOLS  EQU      FMTMPS+7                   # OF ARG COLUMNS          @
SAVEREAL EQU      FMTMPS+8          DW SAVE LOC FOR REAL VALUE
*                                                                @@@@@@@
* DECORATOR ADDRESS AND LENGTH TEMPS
*
DECORTEX EQU      MTEXT-1STDECOR    TABLE OFFSET                 @@@@@@@
MTEXT    EQU      FMTMPS+20         ADDRESSES OF DECORATORS            @
NTEXT    EQU      MTEXT+1                                              @
PTEXT    EQU      MTEXT+2                                              @
QTEXT    EQU      MTEXT+3                                              @
RTEXT    EQU      MTEXT+4                                        @@@@@@@
*
DECORLEN EQU      MLENGTH-1STDECOR  TABLE OFFSET                 @@@@@@@
MLENGTH  EQU      FMTMPS+25         LENGTHS OF DECORATORS
NLENGTH  EQU      MLENGTH+1                                            @
PLENGTH  EQU      MLENGTH+2                                            @
QLENGTH  EQU      MLENGTH+3                                            @
RLENGTH  EQU      MLENGTH+4                                      @@@@@@@
*
*  SINGLE TEMPS-SPACE LEFT FOR INSERTION OF OTHERS-ALPHABETIC ORDER
*
COMMACNT EQU      FMTMPS+40         COMMA COUNT
COMMALOC EQU      FMTMPS+42         COMMA INSERTION LOCATION
DATALOC  EQU      FMTMPS+44         DATUM ADDRESS
DATASPEC EQU      FMTMPS+46         FLAG TO INDICATE DATA USE
DORS     EQU      FMTMPS+48         'D' OR 'S' SPECIFICATION
EXPSTART EQU      FMTMPS+52         EXPONENT STARTING CHAR POS
FORMLIM  EQU      FMTMPS+54         FORMAT POINTER LIMIT
GAPSIZE  EQU      FMTMPS+56         SIZE OF FIELD GAP
INTLEFT  EQU      FMTMPS+58         LOCATION LEFT END OF INTEGER PART
INTRIGHT EQU      FMTMPS+60         LOCATION RIGHT END OF INTG.  PART
INTSIZE  EQU      FMTMPS+62         SIZE OF INTEGER PART
LDFLAG   EQU     FMTMPS+63         LONG DIVIDE FLAG
LOGLBITS EQU      FMTMPS+64         LOGICAL DATA BITS
LOGLCNT  EQU      FMTMPS+65         LOGICAL DATA BIT COUNT
LOWEND   EQU     FMTMPS+66         LOW END OF # IN LONG DIVIDE
NSIZE    EQU      FMTMPS+67         # OF DIGITS IN R8-R9 TO BE CNVRTD
RESLTPTR EQU      FMTMPS+68         INITIAL ADDRESS OF RESULT DATA
RESWIDTH EQU      FMTMPS+70         # OF CHARACTERS/ROW OF RESULT
RETAIN   EQU      FMTMPS+72         FLAG INDICATING RETAIN OR DISPLAY
ROWINDEX EQU      FMTMPS+74         INDEX OF ROW BEING PROCESSED
RPTCOUNT EQU      FMTMPS+76         REPEAT COUNT FOR A FORMAT
TEXTADR  EQU      FMTMPS+78         TEXT STRING ADDRESS
VALFLAG  EQU      FMTMPS+80         VALUE FLAG;NEG,ZERO,OR POS
*
*  REGISTER DESIGNATIONS
*
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
*
* CHARACTER CODES
*
END      EQU      -1                END-OF-FORMAT
MINUSIGN EQU      X'72'             NEGATIVE CONSTANT SIGN
QUADQUOT EQU      X'52'             QUOTE-QUAD
UNDRSCOR EQU      X'6D'             UNDERSCORE
BOSCODE  EQU      37                BEGINNING OF STATEMENT
*
*  FORMAT SPECIFIER VALUES:BITS
*
IFORMAT  EQU      1                 FORMAT CODES I
FFORMAT  EQU      2                              F
EFORMAT  EQU      3                              E
AFORMAT  EQU      4                              A
XFORMAT  EQU      5                              X
TFORMAT  EQU      6                              T
*
BBIT     EQU      1                 QUALIFIER BIT FLAGS B
CBIT     EQU      2                                     C
LBIT     EQU      4                                     L
ZBIT     EQU      8                                     Z
MBIT     EQU      X'10'             DECORATION BITS     M
NBIT     EQU      X'20'                                 N
PBIT     EQU      X'40'                                 P
QBIT     EQU      X'80'                                 Q
RBIT     EQU      X'100'                                R
*
*  DATUM TYPE CODES
*
LOGL     EQU      1                 LOGICAL (BIT)
CHAR     EQU      2                 TEXT    (BYTE)
INTG     EQU      3                 INTEGER (WORD)
FLOT     EQU      4                 REAL    (DW)
INDSEQ   EQU      5                 INDEX SEQ-HANDLED AS INTEGER
LIST     EQU      6                 LIST
         BOUND    8
FESPEC   DATA     FFORMAT,EFORMAT   2,3
*
ONE      EQU      BITMASK+1
TWO      EQU      FESPEC            2
THREE    EQU      FESPEC+1          3
X1F      DATA     X'1F'             MASK
XFF      DATA     X'FF'             MASK
*
*  TABLES FOR FORMAT SCAN ROUTINES
*
SPECTBL  TEXTC    'IFEAXBCLZMNPQR'  FORMAT, QUAL, AND DECOR  SPEC'S.
*
1STQUAL  EQU      6                 INDEX OF  1ST QUALIFIER SPEC.
1STDECOR EQU      10                INDEX OF  1ST DECORATION SPEC.
*
QDBITS   EQU      %-1STQUAL
         DATA     BBIT
         DATA     CBIT
         DATA     LBIT
         DATA     ZBIT
         DATA     MBIT
         DATA     NBIT
         DATA     PBIT
         DATA     QBIT
         DATA     RBIT
*
DEFAULTS EQU      %-1               DEFAULT DECORATION DATA
         DATA     BA(DSTR)          M TEXT
         DATA     BA(DSTR)+1        N TEXT
         DATA     BA(DSTR)+1        P TEXT
         DATA     BA(DSTR)+1        Q TEXT
         DATA     BA(DSTR)+2        R TEXT
         DATA     1,0,0,0,1
*
DSTR     DATA,1   MINUSIGN,QUADQUOT,' ',QUADQUOT
*
* DELTAFMT-DYADIC SCALAR TO PROVIDE FORMATTED OUTPUT FOR PRINTING
*        OR INTERNAL ASSIGNMENT
*
*  THE FIRST SECTION OF CODE- DELTAFMT TO FMT9 -CONCERNS ANALYSIS OF
*        ARGUMENTS AND GENERATION OF RESULT STRUCTURE
*
*        THE LEFT ARGUMENT MUST BE A TEXT VECTOR, THE CONTENTS OF WHICH
*         MUST BE VALID SPECIFICATION FORMS FOR OUTPUT CONVERSION AND
*         FORMATTING
*
*        THE RIGHT ARGUMENT MAY BE ANY VALID 'DATA' TYPE WITH RANK 2 OR
*        LESS  OR A 'LIST' OF RANK 1,WHOSE ELEMENTS ARE VALID DATA BLKS
*
*        THE RESULT WILL BE A TEXT VECTOR OR MATRIX:
*           A MATRIX IS POSSIBLE ONLY IF THE RIGHT ARGUMENT INDICATES
*           MORE THAN ONE 'ROW' OF RESULT AND THE RESULT IS TO BE
*           RETAINED-THAT IS-THE NEXT ITEM IN APL CS EXECUTION IS
*           NOT 'BEGINNING OF STATEMENT'
*
CATQ     EQU      7                 EXECUTE OR EVALUATED INPUT
*                                   CATEGORY FOR STATE ENTRY.
         LOCAL    FMT1,FMT2,FMT3,FMT4,FMT5,FMT6,FMT7,FMT8,FMT9
DELTAFMT LI,R1    CATQ              TEST FOR EXEC. OR EVAL INPUT
         CB,R1   *STATEPTR
         BE       SRETAIN           IF SO,SET TO RETAIN DATA
         LW,R1    OFFSET            CHECK IF
         AI,R1    -1                 RESULT IS FOR
         LB,R1   *CURRCS,R1           OUTPUT ONLY-THAT IS-
         AI,R1    -BOSCODE             FOR BEGINNING OF STATEMENT
SRETAIN  STW,R1   RETAIN            0=DON'T RETAIN-DISPLAY ONLY
         LB,R1   *LFARG             CHECK LEFT ARGUMENT
         CI,R1    CHAR               FOR DOMAIN
         BNE      ERDOMAIN            AND RANK
         LH,R1   *LFARG
         AI,R1    -CHAR*X'100'-1
         BNEZ     ERRANK
         STD,R1   NROWS     AND NCOLS -INITIALIZE MAX ROWS AND COLUMNS
         BAL,R14  INITARG           SET UP FOR ARGUMENT SCAN
FMT1     BAL,R14  GETARG            GET NEXT ARGUMENT-INCLUDES RANK CHK
         B        FMT3               NO MORE
         CW,R8    NROWS
         BLE      FMT2
         STW,R8   NROWS             UPDATE MAXROWS IF INDICATED
FMT2     AWM,R9   NCOLS             UPDATE MAXCOLS
         CI,R5    LIST              CHECK DATA TYPE
         BL       FMT1               OK
         B        ERDOMAIN           ERROR-LIST OR HIGHER
FMT3     LW,R8    NROWS
         BEZ      NULRESLT          NO DATA-NULL RESULT
         LI,R1    0
         STW,R1   RESWIDTH          PRESET RESULT WIDTH TO 0
         LW,R1    NCOLS             SET # OF COLUMNS
         BEZ      NULRESLT          IF DATA COLUMN COUNT=0 GIVE NULL RES
         BAL,R14  INITFORM          INITIALIZE FORMAT SCAN
FMT4     BAL,R12  FPHRASE           SCAN A FORMAT PHRASE
         AWM,R3   RESWIDTH          ADJUST RESULT WIDTH
         CI,R4    AFORMAT           CHECK IF FORMAT USES DATUM
         BG       FMT4               NO,KEEP SEARCHING
        AI,R1    -1                 YES-DECREMENT
         BGZ      FMT4                LOOP IF ALL DATA COLUMNS NOT USED
FMT5     BAL,R12  FPHRASE           DATA IS USED UP-CHECK FOR
RESWCHK  CI,R4    AFORMAT            TRAILING NON-DATA FORMAT PHRASES
         BLE      FMT6                NO-DATA USER ENCOUNTERED
         AWM,R3   RESWIDTH              YES-KICK FIELD SIZE
         B        FMT5                   AND LOOP
NOWRAP   RES      0                 RETURN FROM FPHRASE IF 'END' REACHED
FMT6     LW,R11   NROWS             NO. OF ROWS                         U21-0008
         LW,R9    RETAIN            MATRIX-CHECK IF TO BE RETAINED
         BNEZ     FMT7               YES                                U21-0010
         LI,R11   1
FMT7     LW,R8    R11               SAVE EFFECTIVE NROWS IN R8          U21-0012
FMT8     MW,R11   RESWIDTH          # OF BYTES
         AI,R11   11                'BOUND 4' ROUND UP +8 BYTES         U21-0014
*                                     FOR LENGTH WORDS                  U21-0015
         SAS,R11  -2                 # OF WORDS
         BAL,R7   ALOCHNW           GET DATA BLOCK
         STW,R4   RESULT             ASSIGN TO RESULT
         LW,R7    RESULT
         AI,R7    4                 POINT TO DATA                       U21-0018
         LI,R2    CHAR*X'100'+2     CHARACTER MATRIX                    U21-0019
         STH,R2  *RESULT             SET TYPE AND RANK
         STW,R8   -2,R7              SET # OF ROWS
         LW,R9    RESWIDTH           SET NO. OF COLUMNS                 U21-0022
         STW,R9   -1,R7              SET # OF COLUMNS
         SLS,R7   2
         STW,R7   RESLTPTR          SET R7 TO POINT TO BA-RESULT
         B        MAINSCAN
         LOCAL
NULRESLT LI,R11   4                 EMPTY RESULT-QUIT
         BAL,R7   ALOCBLK
         LI,R11   X'0201'           TEXT VECTOR
         STH,R11 *R4
         LI,R11   0
         STW,R11  2,R4
         STW,R4   RESULT
         B        DXRETURN
*
* MAINSCAN-THIS IS THE DRIVER TO ACTUALLY GENERATE A RESULT OR RESULTS
*          USES THE INDICATED SUBROUTINES TO SCAN THE FORMAT STATEMENT
*          -REPEATEDLY IF NECESSARY-UNTIL DATA IN RIGHT ARGUMENT IS
*          EXHAUSTED
*
MAINSCAN BAL,R14  INITARG           INITIALIZE FOR 'GETARG'
         BAL,R14  INITDATA          INITIALIZE FOR 'GETDATUM'
NEXTROW  BAL,R14  INITFORM          INITIALIZE FOR 'FPHRASE'
         MTW,1    ROWINDEX          INCREMENT ROW INDEX
         LI,R8    1
         STW,R8   ARGCOLS           INITIALIZE ARGUMENT COLUMN #
         LD,R8    ARGWORDS          INITIALIZE ARG ADDRESS AND COUNT
         STD,R8   ARGADR   AND ARGCOUNT
NXPHRASE BAL,R12  FPHRASE           SCAN NEXT FORMAT PHRASE
FTYPETBL B        FTYPETBL,R4                                    @@@@@@@
         B        IFORMGEN          IW                                 @
         B        FFORMGEN          FW.D                               @
         B        EFORMGEN          EW.D                               @
         B        AFORMGEN          AW                                 @
         B        XFORMGEN          XW                                 @
         B        TFORMGEN          'TEXT'                       @@@@@@@
ENDROW   LW,R13   BREAKFLG          CHECK FOR BREAK
         BNEZ     OPBREAK            YES-GET OUT
         LW,R8    ROWINDEX
         CW,R8    NROWS
         BGE      DXRETURN
         BAL,R13  SENDROW            NO-OUTPUT ROW IF INDICATED
         B        NEXTROW            PROCEED
*
* SENDROW-IF RETAIN=0 :OUTPUT THE CURRENT ROW
*                      SINGOUT USED-SAVES & RESTORES REGISTERS
*                      R7 SET TO START OF RESULT DATA BLOCK,WHICH
*                      IS REUSED
*         IF RETAIN NOT=0, RETURNS WITH NO ACTION
*
SENDROW  LW,R1    RETAIN            CHECK IF DATA TO BE RETAINED
         BNEZ    *R13                YES-NO DISPLAY
         LW,R4    RESULT
         BAL,R14  SINGOUT           OUTPUT RESULT
         B        OPBREAK           (ERROR RETURN-VERY UNLIKELY)
         LW,R7    RESLTPTR           RESET POINTER TO RE-USE
         B       *R13
         PAGE
*
* TFORMGEN-TEXT GENERATION
*
TFORMGEN LW,R1    TEXTADR           ADDRESS
         LW,R2    R3                COUNT
         BAL,R14  PUTSTRNG           PUT'EM
         B        NXPHRASE            RETURN
*
* XFORMGEN-OUTPUT BLANKS
*
XFORMGEN LW,R1    R3                COUNT
         BAL,R14  PUTBLNKS           PUT'EM
         B        NXPHRASE            RETURN
*
* AFORMGEN-OUTPUT TEXT AND,AS INDICATED, BLANKS
*
AFORMGEN BAL,R13  GETDATUM          GET DATUM
         CI,R5    CHAR              CHECK FOR CHAR DATA
         BNE      ERDOMAIN
AFORM1   LW,R1    R3                GET W
         AI,R1    -1                CHECK IF 1
         BLEZ     AFORM2             YES-NO BLANKS
         BAL,R14  PUTBLNKS           NO-STUFF W-1 BLANKS
AFORM2   STB,R8   0,R7              STUFF THE CHARACTER
         AI,R7    1
         B        NXPHRASE          CONTINUE
*
*
* EFORMGEN-  E FORMAT PROCESSOR
*
*        GENERATES ONE FIELD ENTRY
*          DORS=NO OF DIGITS PRINTED
*             W=FIELD WIDTH
*
*        MAY EXIT TO OVERFLOW   NORMAL EXIT TO NXPHRASE
*
        LOCAL    EFORM1,EFORM2,EFORM3,EFORM4,EFORM5
EFORMGEN BAL,R13  GETDATUM          GET A VALUE
         CI,R5    CHAR               CHECK FOR TEXT
         BE       ERDOMAIN            YES-ERROR
         LCW,R1   DORS              -S
         BIR,R1   EFORM0            1-S
         AI,R1    1                 IF S=1, 2-5
EFORM0   AW,R1    R3                W+1-S OR,IF S=1, W+2-S
         LW,R0    VALFLAG
         BGEZ     EFORM1
         AI,R1    -1                SPACE FOR SIGNBIT
EFORM1   AI,R1    -6     R1=W-S-4(FOR 'E+XX')
*                              -1(FOR DECIMAL PT-UNLESS S=1)
*                              -1(FOR SIGN BIT IF VALUE NEGATIVE)
         BEZ      EFORM2             JUST RIGHT
         BLZ      ERFORMAT          W AND S NOT COMPATIBLE
         BAL,R14  PUTBLNKS           NEEDS LEADING BLANKS
EFORM2   LW,R0    VALFLAG
         BGEZ     EFORM3            CHECK FOR '-'
         LI,R0    MINUSIGN
         STB,R0   0,R7
         AI,R7    1
EFORM3   LW,R2    NSIZE             # OF DIGITS IN R8-R9 VALUE
         LW,R11   DORS              # OF DIGITS TO BE PRINTED
         LI,R12   1                 # OF DIGITS LEFT OF DECIMAL
         BAL,R13  GENDIGSF          GENERATE DIGIT FIELD
         LI,R0    'E'                AND 'E'
         BAL,R14  SETCHAR
         STW,R7   EXPSTART          SAVE POSITION
         LW,R9    INTSIZE
         AI,R9    -1                GET EXPONENT SIZE
         BGEZ     EFORM4             +
         LI,R0    MINUSIGN           -
         BAL,R14  SETCHAR
         LAW,R9   R9
EFORM4   LI,R8    0
         DW,R8    TENSTBL+1         DEVELOP 10'S VALUE
         BEZ      EFORM5             NONE
         AI,R9    X'F0'              GENERATE 10'S VALUE
         STB,R9   0,R7
         AI,R7    1
EFORM5   AI,R8    X'F0'              GENERATE UNIT'S VALUE
         STB,R8   0,R7
         AI,R7    1
         LW,R1    EXPSTART          GET POSITION OF EXPONENT
         SW,R1    R7
         AI,R1    3                 CHECK IF BLANK FFLL NEEDED
         BLEZ     NXPHRASE           NO-EXIT
         LI,R14   NXPHRASE           YES-SET EXIT
         B        PUTBLNKS            GENERATE BLANKS
*
* IFORMGEN-
* FFORMGEN-PROCESSORS FOR F AND I FORMATS
*
*        THIS ONE IS REALLY A GRINDER!
*
*    IN ADDITION  TO FORMING THE EBCDIC DIGITS IN THE FIELD
*        'DECORATORS' AND 'QUALIFIERS' ARE HANDLED
*          THIS INCLUDES-ACCORDING TO THE OPTIONS:
*            LEFT OR RIGHT JUSTIFICATION
*            INSERTION OF DECORATORS ON LEFT OR RIGHT
*            INSERTION OF COMMAS ALA-  2,345,678.9012345
*            BLANKING ZERO VALUES
*            INSERTING LEADING ZEROS
*
*
         LOCAL    FIF1,FIF2,FIF3,FIF4,FIF5,FIF6,FIF7,FIF8,FIF9,FIF10
         LOCAL    FIF11,FIF12,FIF13,FIF14,FIF15
         LOCAL    FIF16,FIF17,FIF18,FIF19,FIF20
IFORMGEN BAL,R13  GETDATUM          GET A VALUE
         CI,R5    CHAR               SCRUB ON TEXT
         BE       ERDOMAIN
         LW,R1    R3                GET FIELD WIDTH
         B        FIFORMGN
FFORMGEN BAL,R13  GETDATUM          GET A VALUE
         CI,R5    CHAR               SCRUB ON TEXT
         BE       ERDOMAIN
         LW,R1    R3                GET FIELD WIDTH
         AI,R1    -1                SPACE FOR '.'
         SW,R1    DORS              # OF FRACTIONAL DIGITS
FIFORMGN CI,R10   BBIT              CHECK IF 'B' OPTION SET
         BAZ      FIF1               NO                                 21-00001
         LW,R11   VALFLAG            YES
         BE       GAPFIELD          (BLANKS OR  'R' DECORATION)
FIF1     LW,R11   INTSIZE
         CI,R11   1                 GET # OF INTEGER DIGITS OR 1 IN R11
         BGE      FIF2
         LI,R11   1
FIF2     SW,R1    R11               ADJUST SIZE
         STW,R11  SAVEREAL          SAVE # OF INTEGERS
         LW,R2    VALFLAG
         BGEZ     FIF3
         SW,R1    MLENGTH           SPACE FOR M/N TEXT LENGTHS IF -
         SW,R1    NLENGTH           (DEFAULT IS MLENGTH=1,NLENGTH=0)
         B        FIF4
FIF3     SW,R1    PLENGTH           SPACE FOR P/Q TEXT LENGTHS IF +
         SW,R1    QLENGTH           (DEFAULT IS PLENGTH=0,QLENGTH=0)
FIF4     BLZ      OVERFLOW           TOO DAMN BIG
         STW,R1   GAPSIZE            OK:REMEMBER GAP SIZE
         LI,R2    0
         STW,R2   COMMACNT          SET COMMA COUNT TO ZERO
         CI,R10   CBIT               CHECK FOR COMMAS
         BAZ      FIF7                NO-THANK GOD!
         LI,R11   LBIT+ZBIT           YECCH!-CHECK FOR C.AND.Z.AND.NOT.L
         CS,R10   BITMASK+4    (ZBIT)AND NOT L
         BNE      FIF5                NO-HOORAY
         AW,R1    SAVEREAL            YES-THE GAP WILL BE LEADING ZEROS
         SAS,R1   -2                   INFESTED WITH COMMAS
         B        FIF6
FIF5     LW,R1    SAVEREAL          IN THIS CASE ONLY 1 COMMA FOR EVERY
         AI,R1    -1                 3 INTEGER PART DIGITS
         DW,R1    THREE               (STARTING WITH THE 4TH DIGIT)
FIF6     STW,R1   COMMACNT
         LCW,R1   COMMACNT
         AWM,R1   GAPSIZE           REDUCE THE GAP SIZE
         BLZ      OVERFLOW           THE COMMAS BLEW IT !
FIF7     CI,R10   LBIT+ZBIT
         BANZ     FIF8              IF Z OR L SET,NO GAP AT LEFT
         BAL,R14  PUTGAP
FIF8     LW,R1    VALFLAG           CHECK VALUE
         BLZ      FIF9              NEGATIVE
         LW,R2    PLENGTH            POSITIVE
         BLEZ     FIF11               SET PTEXT IF PRESENT (DEFAULT-NO)
         LW,R1    PTEXT
         B        FIF10
FIF9     LW,R2    MLENGTH             SET MTEXT IF PRESENT (DEFAULT-'-')
         BLEZ     FIF11
         LW,R1    MTEXT
FIF10    BAL,R14  PUTSTRNG
FIF11    STW,R7   INTLEFT           SAVE POSITION OF 1ST INTEGER
         AW,R7    COMMACNT           ADD SPACE FOR COMMAS IF PRESENT
         LI,R11   LBIT+ZBIT         TEST FOR   Z AND NOT.L
         CS,R10   BITMASK+4         (Z,NOT L)
         BNE      FIF12              NO
         LW,R1    GAPSIZE            YES
         BEZ      FIF12               NO GAP
         BAL,R14  PUTZEROS             GAP IS LEADING ZERO'S
FIF12    LI,R1    0
         STW,R1   INTRIGHT          PRESET-NO INTEGER RIGHT POSITION
         LW,R2    NSIZE             # OF CHARS IN R8-R9 TO CONVERT
         LW,R12   INTSIZE           # OF CHARS LEFT OF  '.'
         LW,R11   SAVEREAL
         AW,R11   DORS              R11=# OF DIGITS TO BE GENERATED
         BAL,R13  GENDIGSF           DO IT
         LW,R1    INTRIGHT          CHECK IF  INTRIGHT SET
         BNEZ     FIF13              YES
         STW,R7   INTRIGHT           NO-SET IT
         CI,R4    FFORMAT           CHECK IF F FORMAT
         BNE      FIF13              NO-PROCEED
         LW,R1    DORS               YES-CHECK IF D IS ZERO
         BGZ      FIF13               NO-PROCEED
         LI,R0    '.'                 YES-REQUIRES DECIMAL POINT
         BAL,R14  SETCHAR                 INSERTION
FIF13    LW,R1    VALFLAG           CHECK VALUE
         BLZ      FIF14              NEGATIVE
         LW,R2    QLENGTH             POSITIVE
         BLEZ     FIF16                SET QTEXT IF PRESENT(DEFAULT-NO)
         LW,R1    QTEXT
         B        FIF15
FIF14    LW,R2    NLENGTH              SET NTEXT IF PRESENT(DEFAULT-NO)
         BLEZ     FIF16
         LW,R1    NTEXT
FIF15    BAL,R14  PUTSTRNG
FIF16    CI,R10   LBIT              CHECK 'L'
         BAZ      FIF17              NO
         BAL,R14  PUTGAP              YES-PUT GAP HERE
FIF17    CI,R10   CBIT              CHECK INSANITY
         BAZ      NXPHRASE           NO-ESCAPE
         LCW,R9   COMMACNT           YES-DRAT!
         BEZ      NXPHRASE           NO COMMAS SET-SCRAM
         AW,R9    INTRIGHT
         SW,R9    INTLEFT           (INTRIGHT-INTLEFT-COMMACNT)
         LI,R8    0
         DW,R8    THREE             MODULO 3
         AI,R8    0                  CHECK FOR 0
         BGZ      FIF17A               NO                               21-00011
         LI,R11   LBIT+ZBIT          CHECK FOR (Z,NOT L)                21-00012
         CS,R10   BITMASK+4                                             21-00013
         BE       FIF17A               YES,COMMA MAY LEAD               21-00014
         LI,R8    3                    NO,ADD 3,COMMA MAY NOT LEAD      21-00015
FIF17A   AW,R8    INTLEFT                                               21-00016
         STW,R8   COMMALOC          FIRST COMMA LOCATION
         LW,R1    INTLEFT
         AW,R1    COMMACNT          FIRST INTEGER CHARACTER
         XW,R7    INTLEFT           SWITCH TARGET BYTE ADDRESS AND SAVE
FIF18    CW,R7    COMMALOC           IS IT COMMA TIME
         BNE      FIF19               NO-MOVE BYTES
         LI,R0    ','                 YES
         STB,R0   0,R7                 STASH
         AI,R7    1                     A COMMA
         MTW,4    COMMALOC               BUMP LOC FOR NEXT COMMA
         MTW,-1   COMMACNT                KNOCK COUNT
         BLEZ     FIF20                    QUIT IF DONE
FIF19    LB,R0    0,R1              GET A DIGIT
         AI,R1    1
         STB,R0   0,R7               SET A DIGIT
         AI,R7    1
         B        FIF18               LOOP
FIF20    LW,R7    INTLEFT           RESTORE R7 TO END OF FIELD
         B        NXPHRASE           ESCAPE
         LOCAL
         PAGE
*
* INITFORM-INITIALIZE FORMAT (LEFT ARG) SCAN
*   R14=LINK
*   R6 IS SET AS POINTER TO FORMAT SCAN
*     ---R6 IS RESERVED REGISTER FOR THIS PURPOSE---
*   R9 IS USED-0 RETURNED ON EXIT
*        RPTCOUNT  SET=0
*        DATASPEC  SET=0
*
INITFORM LW,R6    LFARG             GET DB POINTER
         LW,R9    2,R6               AND LENGTH OF FORMAT STATEMENT
         SLS,R6   2                 FORM BYTE ADDRESS OF FIRST FORMAT
         AI,R6    X'8000C'           CHARACTER,SET HI-ENV NEG. FOR BIR
         AW,R9    R6
         STW,R9   FORMLIM           SET LIMIT OF SCAN (ALSO NEG. VALUE)
         LI,R9    0
         STW,R9   RPTCOUNT          INITIALIZE REPEAT COUNT
         STW,R9   DATASPEC                 AND DATA SPECIFIER FLAG
         B       *R14
*
* FPHRASE-SCAN FORMAT PHRASE
*
*    THIS ROUTINE SCANS A FORMAT PHRASE AND RETURNS INFORMATION
*         FOR PROCESSING SAME:
*
*    IF A PHRASE INCLUDES A REPEAT COUNT,SUBSEQUENT CALLS RETURN
*         THE SAME INFORMATION UNTIL THE REPEAT COUNT IS EXHAUSTED
*
*    R12=LINK         REGISTERS NOT TOUCHED:R1,R2,R5,R7,R8,R11,R15
*        ROUTINES  CALLED:
*           FCHAR-R0,R6,R14
*           FSTRING-R0,R3,R6,R13-FCHAR
*           FNUM -R0,R6,R9,R13-FCHAR
*    ON EXIT:
*        R4=FORMAT TYPE  1,I 2,F 3,E 4,A 5,X   6,TEXT
*        R3=FIELD WIDTH
*        R10=QUALIFIER AND DECORATOR FLAG BITS (FORMAT I OR F ONLY)
*        BITS 23-31  ARE: 23 24 25 26 27 28 29 30 31
*                          R  Q  P  N  M  Z  L  C  B
*        FOR DECORATION BIT, STRING POINTERS AND LENGTHS ARE ALSO SET:
*            M    ADDRESS IN MTEXT    LENGTH IN  MLENGTH
*            N                NTEXT              NLENGTH
*            P                PTEXT              PLENGTH
*            Q                QTEXT              QLENGTH
*            R                RTEXT              RLENGTH
*   DEFAULT STRINGS ARE ESTABLISHED FOR NON-SPECIFIED DECORATIONS
*   'DORS' IS SET TO D OR S VALUE FOR F OR E FORMAT TYPE
*           IS SET TO ZERO FOR I FORMAT TYPE
         LOCAL    FPH1,FPH2,FPH3,FPH4,FPH5,FPH5A,FPH6,FPH7,FPH8,FPH9
         LOCAL    FPH10,FPH11,FPH12,FPH13
FPHRASE  MTW,-1   RPTCOUNT          CHECK FOR A REPEATER
         BGZ     *R12                GOOD-SAVED SOME TIME HERE!
FPH1     BAL,R14  FCHAR             START NEW SCAN
FPH2     CLM,R0   LETTERS            CHECK 1ST CHARACTER
         BCS,8    FPH4                DIGIT (OR ERROR)
         BCR,1    FPH5                LETTER
         CI,R0    QUADQUOT          CHECK QUOTE-QUAD
         BE       FPH3              -START OF SUBSTRING
         CI,R0    END               CHECK END
         BNE      ERFORMAT           NO VALID FORM
         LW,R9    DATASPEC          END-CHECK IF ANY DATA USE SPECIFIED
         BEZ      ERFORMAT           NONE-THATS A NO-NO
         CI,R12   RESWCHK            CHECK IF FPHRASE CALLED FOR
         BE       NOWRAP              RESULT WIDTH CALC. QUIT IF YES
         CI,R12   FTYPETBL          CHECK IF MAINSCAN CALL              21-00003
         BNE      WRAPPER            WRAPAROUND IF NOT                  21-00004
         LW,R9    ARGCOLS             CHECK IF COLUMNS OF ARG USED UP   21-00005
         BDR,R9   WRAPPER               NO-WRAP AROUND                  21-00006
         MTW,0    ARGCOUNT           CHECK IF ARGUMENTS USED UP         21-00007
         BLEZ     ENDROW                YES                             21-00008
WRAPPER  LW,R6    LFARG                 NO,ITS WRAP AROUND TIME         21-00009
         SLS,R6   2
         AI,R6    X'8000C'          SET POINTER TO START FROM BEGINNING
         B        FPH1               AND GO-
FPH3     BAL,R13  FSTRING1          PROCESS SUBSTRING
         LI,R4    TFORMAT            SET FORMAT TYPE -TEXT
         BAL,R14  FCHAR             GET FIELD TERMINATOR CHARACTER
         B        FPH13             EXIT
FPH4     BAL,R13  FNUM1             THIS HAS TO BE THE REPEAT COUNT
         STW,R9   RPTCOUNT
         AI,R9    0                 CHECK SIZE
         BGZ      FPH2               OK (NEXT CHAR IS IN R0)
         B        ERFORMAT           NO DICE!
FPH5     LI,R10   0                 PRESET BIT FLAGS TO 0
         STW,R10  DORS              SET 'D OR S' TO ZERO
         LI,R4    RLENGTH-MTEXT+1
FPH5A    LW,R9    DEFAULTS,R4       PRESET DEFAULTS FOR
         STW,R9   MTEXT-1,R4         MTEXT THROUGH RLENGTH
         BDR,R4   FPH5A
FPH6     LB,R4    SPECTBL           (BYTE COUNT)
FPH7     CB,R0    SPECTBL,R4        CHECK CONVERSION TYPE
         BE       FPH8               FOUND IT
         BDR,R4   FPH7
         B        ERFORMAT          NONE-ERROR
FPH8     CI,R4    1STQUAL           CHECK IF TYPE IS QUAL OR DECOR
         BL       FPH10              NO-CLEAN CONVERSION
         OR,R10   QDBITS,R4          YES-SET A FLAG BIT
         CI,R4    1STDECOR          IS IT A DECOR
         BL       FPH9               NO-
         BAL,R13  FSTRING            YES-GET THE SUBSTRING
         LW,R9    TEXTADR
         STW,R9   DECORTEX,R4
         STW,R3   DECORLEN,R4
FPH9     BAL,R14  FCHAR             SCAN FOR NEXT FORMAT ID, QUAL
         B        FPH6               OR DECOR.
FPH10    CI,R4    FFORMAT           CHECK FORMAT ID
         BLE      FPH11                  I OR F
         AI,R10   0                  NOT I OR F-NO QUAL OR DECOR ALLOWED
         BNEZ     ERFORMAT
FPH11    BAL,R13  FNUM              GET FIELD WIDTH
         LW,R3    R9
         BLEZ     ERFORMAT          FIELD WIDTH MUST BE GR THAN ZERO
         CLM,R4   FESPEC             IS THIS AN F OR E  TYPE
         BCS,9    FPH12               NO
         CI,R0    '.'                 YES-NEED A DOT HERE
         BNE      ERFORMAT              BAD FORM
         BAL,R13  FNUM              GET D OR S VALUE
         STW,R9   DORS               SAVE IT
         CI,R4    EFORMAT           CHECK IF E FORMAT
         BNE      FPH12              NO
         CI,R9    0                  YES-CHECK S VALUE
         BLE      ERFORMAT            MUST BE GR THAN ZERO
FPH12    CI,R4    XFORMAT           CHECK FOR BLANK INSERTION
         BE       FPH13              YES-NO DATA SPEC.
         MTW,1    DATASPEC          SET DATA SPEC. FLAG
FPH13    CI,R0    ','               FORMAT PHRASE TERMINATOR
         BE      *R12                 OK
         CI,R0    END
         BE      *R12                 OK
         B        ERFORMAT            ERROR
*
* FCHAR-GET NEXT NON-BLANK FORMAT CHARACTER
*       IF THERE ARE NO MORE,RETURNS 'END'
*       R14=LINK
*       CHAR RETURNED IN R0
*       R6,FORMAT POINTER,IS UPDATED
*
FCHAR    CW,R6    FORMLIM           CHECK FOR END
         BL       FCHAR1             NO
         LI,R0    END                YES
         B       *R14
FCHAR1   LB,R0    0,R6              GET CHAR
         AI,R6    1                 KICK POINTER
         CI,R0    ' '               CHECK FOR BLANK
         BNE     *R14               NO
         B        FCHAR             YES-SKIP
*
* FNUM-SCAN FORMAT NUMBER
*        SCANS AND EVALUATES A DEC. NO. IN THE FORMAT STRING
*  R13=LINK
*        ON EXIT, R9=VALUE OF NUMBER
*                 R0=TERMINATING CHARACTER
*                 R6(FORMAT POINTER) UPDATED
*
*        CALLS FCHAR,WHICH USES R0,R6,R14
* FNUM1-ENTRY USED WHEN FIRST CHARACTER ALREADY SCANNED AND IN R0
*
         LOCAL    FNUMLOOP
FNUM     BAL,R14  FCHAR             GET 1ST CHAR
FNUM1    CLM,R0   F0F9               RANGE CHECK
         BCS,9    ERFORMAT            NO NUMBER WHEN REQUIRED
         LW,R9    R0
         AI,R9    -'0'              SET R9=VALUE
FNUMLOOP BAL,R14  FCHAR             GET NEXT CHAR
         CLM,R0   F0F9               RANGE TEST
         BCS,9   *R13                 DONE
         AI,R0    -'0'              GET VALUE
         MI,R9    10                FORM RESULT
         BOV      ERFORMAT           TOO BIG
         AW,R9    R0
         BNOV     FNUMLOOP          LOOP FOR NEXT DIGIT
         B        ERFORMAT          TOO BIG
*
* FSTRING-SCAN FORMAT SUBSTRING-BETWEEN QUOTE-QUADS-
*    R13=LINK
*    RETURNS BA OF 1ST CHAR. IN 'TEXTADR'
*            LENGTH OF STRING IN
*            R6 IS UPDATED TO END OF SUBSTRING+1
* FSTRING1-ENTRY FOR USE WHEN LEFT QUOTE-QUAD ALREADY SCANNED
*
*   CALLS FCHAR, WHICH USES R0,R6, AND R14
*
         LOCAL    FSTRING2,FSTRING3
FSTRING  BAL,R14  FCHAR             GET FIRST CHAR
         CI,R0    QUADQUOT
         BNE      ERFORMAT           MUST BE QUOTE-QUAD
FSTRING1 STW,R6   TEXTADR           SAVE BA OF TEXT STRING
         LI,R0    QUADQUOT          SET TO TEST FOR END
FSTRING2 CW,R6    FORMLIM           CHECK OVERRUN
         BGE      ERFORMAT           YES-ERROR
         CB,R0    0,R6               CHECK END
         BE       FSTRING3            YES
         BIR,R6   FSTRING2            NO-LOOP
FSTRING3 LW,R3    R6
         SW,R3    TEXTADR           GET LENGTH
         BIR,R6  *R13
         PAGE
*
* INITIALIZE RIGHT ARGUMENT SCAN-SET-UP FOR GETARG
*   R14=LINK
*   R1,R2,R5,R8,R9 USED
*
*   ON EXIT: R5=DATA TYPE
*
         LOCAL    INITARG1
INITARG  LI,R1    1
         STW,R1   ARGCOUNT          SET ARG COUNT=1
         LI,R1    RTARG
         STW,R1   ARGADR            SET ARG POINTER
         LB,R5   *RTARG
         CI,R5    LIST              CHECK FOR LIST
         BNE      INITARG1           NO-DONE!
         LH,R2   *RTARG              YES-DAMN!
         AI,R2    -LIST*X'100'-1
         BNEZ     ERRANK            RANK MUST BE 1
         LW,R1    RTARG             SET FOR ARGADR
        LW,R2    2,R1
         STW,R2   ARGCOUNT          ARGCOUNT=LENGTH OF LIST
         AI,R1    3
         STW,R1   ARGADR            ARG POINTER FOR 1ST ARG IN LIST
INITARG1 LD,R8    ARGADR    AND ARGCOUNT
         STD,R8   ARGWORDS          SET-UP FOR 'RESETARG'
         B       *R14               RETURN
*
* GETARG-GETS NEXT(OR ONLY) RIGHT ARGUMENT
*        RETURNS INFORMATION PERTAINING TO ARGUMENT
*         IF NO ARG,RETURNS TO CALL+1
*         IF ARG,   RETURNS TO CALL+2
*          ON EXIT: R1=ARG ADDRESS
*                   R2=RANK
*                   R5=DATA TYPE  1 LOGL
*                                 2 CHAR
*                                 3 INTG
*                                 4 FLOT
*                                 5 INDS (INTEGER INDEX SEQUENCE)
*                   R8=NO. OF ROWS
*                   R9=NO. OF COLUMNS
*
*         R14=LINK,R1,R2,R5,R8,R9 USED
*
*
GETARG   MTW,-1   ARGCOUNT          CHECK AND DECREMENT ARGUMENT COUNT
         BLZ     *R14                NONE-ZAP!
         LW,R1   *ARGADR            GET ARG POINTER
         MTW,1    ARGADR             KICK POINTER-POINTER
         LH,R2   *R1
         AND,R2   XFF
         CI,R2    2
         BG       ERRANK
         EXU      ROWSETBL,R2
         EXU      COLSETBL,R2
         LB,R5   *R1
         AI,R14   1
         B       *R14
*
ROWSETBL LI,R8    1                 SCALAR
         LW,R8    2,R1              VECTOR
         LW,R8    2,R1              ARRAY
COLSETBL LI,R9    1                 SCALAR
         LI,R9    1                 VECTOR
         LW,R9    3,R1              ARRAY
*
* INITDATA-INITIALIZES PARAMETERS USED BY 'GETDATUM'
*
*  R14=LINK  R8,R9 USED
*
INITDATA LI,R8    0
         STW,R8   ROWINDEX          ROW INDEX=0
         STW,R8   ARGCOLS           SIMULATE 'LAST COLUMN' CONDITION
         LD,R8    ARGWORDS           INITIALIZE  ARG ADR AND COUNT
         STD,R8   ARGADR   AND  ARGCOUNT
         B       *R14
*
* GETDATUM-GET A SINGLE ELEMENT (OR NULL) FROM AN ARGUMENT
*          DATA ARE ACCESSED COLUMN BY COLUMN (FOR MATRICES)
*          THEN ADVANCE TO COLUMN 1 OF NEXT ARGUMENT
*
*  R13=LINK  CALLS:GETARG-WHICH USES R1,R2,R5,R8,R9 AND R14
*                  PLUSREAL-WHICH USES R2,R5,R8,R9,AND R12
*                           (R5 IS SAVED AND RESTORED)
*
*    ON EXIT,R5=TYPE  1=LOGL  2=CHAR  3=INTG   4=FLOT
*
*        IF CHAR, VALUE IS IN R8
*        IF LOGL,INTG,OR FLOT,RESULT IS:
*                 VALUE AS LONG INTEGER IN R8-R9
*                 TOTAL # OF IDGITS (MAX=16) IN NSIZE
*                 # OF INTEGER DIGITS IN INTSIZE
*
* IF THE CURRENT ARGUMENT HAS FEWER ROWS THAN CURRENT ROW INDEX
*        EXIT TO XFORMGEN-GENERATE BLANK FIELD
*
         LOCAL    GETD1,GETD2,GETD3,GETD4,GETD5,GETD6,GETD7
         LOCAL    GETD8,GETD9,GETD10
GETDATUM MTW,-1   ARGCOLS           ANY MORE COLUMNS IN THIS ARG
         BGZ      GETD4              YES-EASY
         BAL,R14  GETARG             NO-NEXT ARGUMENT
         B        ENDROW            NO MORE ARG'S THIS ROW
         STD,R8   ARGROWS  AND ARGCOLS
         CW,R8    ROWINDEX          IF ROWINDEX > ARGROWS
         BL       GETD5              THIS IS NULL
         CI,R5    INDSEQ            CHECK FOR INDEX SEQ
         BE       GETD2              YES-SPECIAL CASE
         MW,R9    ROWINDEX            COMPUTE  OFFSET (IN ELEMENTS)
         SW,R9    ARGCOLS              TO DESIRED ELEMENT
         AW,R1    R2                ADD # OF LENGTH WORDS TO DB POINTER
         AI,R1    2                  OFFSET 2 HDR WORDS-POINT TO DATA
         EXU      SETDATBL,R5       CONVERT TO 1ST ELEMENT ADDRESS
GETD1    AW,R1    R9                 OFFSET TO DESIRED ELEMENT
         STW,R1   DATALOC             THAT'S IT!
         B        GETD7
GETD2    LW,R9    4,R1              'B'
         MW,R9    ROWINDEX          'B'*'I'
         AW,R9    3,R1              +'A'
         LW,R8    R9                VALUE FOR IND SEQ ELEMENT
         LI,R5    INTG              FAKE INTEGER DATA TYPE
SETDATBL B        CONVINT            CONVERT INTEGER DATA TYPE   @@@@@@@
         B        GETD3             LOGIC-YIKES!                       @
         SLS,R1   2                 TEXT- SHIFT                        @
         NOP                        INTG-LEAVE ALONE                   @
         B        %+1               FLOT-                              @
         AI,R1    1                 INSURE DW-BOUND                    @
         SLS,R1   -1                 SHIFT TO DW ADDRESS               @
         B        GETD1               CONTINUE                   @@@@@@@
GETD3    LI,R2    X'1F'             LOGICAL DATA:SEPARATE OFFSET INTO
         AND,R2   R9                 WORD OFFSET-R9
         SLS,R9   -5                 BIT #      -R2
         LW,R8   *R9,R1             GET WORD
         SLS,R8   0,R2               POSITION TO BIT 0
         STW,R8   LOGLBITS            SAVE VALUE (32 OF 'EM)
         EOR,R2   X1F
         AI,R2    1
         STW,R2   LOGLCNT           LOGLCNT=32-BIT #
         B        GETD1
GETD4    LW,R8    ROWINDEX          CHECK IF ARG HAS THIS MANY ROWS
         CW,R8    ARGROWS
         BLE      GETD6              YES
GETD5    B        XFORMGEN          EXIT-GENERATE BLANKS
GETD6    LW,R1    DATALOC           GET ELEMENT ADDRESS
GETD7    EXU      GETDATBL,R5        GET ELEMENT
         MTW,1    DATALOC             BUMP ELEMENT ADDRESS
GETDATBL B        CONVRTR            CONVERT DATUM               @@@@@@@
         B        GETD8             LOGIC-YECH!                        @
         B        GETD11            TEXT                               @
         LW,R8    0,R1              INTG                               @
         LD,R8    0,R1              FLOT                         @@@@@@@
GETD8    MTW,-1   LOGLCNT           LOGIC VALUE:ANY MORE BITS
         BGEZ     GETD9              YES
         LI,R9    31                 NOT IN THIS WORD
         STW,R9   LOGLCNT             RESET COUNTER
         LW,R8    1,R1                 GET NEXT WORD
         MTW,1    DATALOC               KICK ELEMENT ADDRESS
         B        GETD10                 SKIP
GETD9    LW,R8    LOGLBITS          GET CURRENT WORD
GETD10   SCS,R8   1                  CYCLE
         STW,R8   LOGLBITS            USE A BIT
         AND,R8   ONE                  MASK IT
CONVLGL  STW,R8   VALFLAG           SAVE SIGN-ZERO FLAG
         LW,R9    R8                SET VALUE IN R9
         LI,R8    1
CONVIORL STW,R8   INTSIZE           SET INTEGER SIZE
         STW,R8   NSIZE             SET NUMBER SIZE
         LI,R8    0
         B       *R13
CONVINT  STW,R8   VALFLAG           SAVE SIGN-ZERO FLAG
         LAW,R9   R8                 GET ABS VALUE IN R9
         LI,R2    -9
CONVINT1 CW,R9    TENSTBL+10,R2     RANGE TEST
         BL       CONVINT2           SIZE FOUND
         BIR,R2   CONVINT1
CONVINT2 AI,R2    10                INTSIZE
         LW,R8    R2
         CI,R13   EFORMGEN+1        CHECK IF E FORMAT
         BNE      CONVIORL           NO-OK
         SW,R2    DORS               YES-CHECK IF INT. MUST BE ROUNDED
         BLEZ     CONVIORL            NO
         LW,R2    TENSTBL,R2           YES-GET POWER OF 10
         SLS,R2   -1                    DIVIDE BY 2
         AW,R9    R2                     ROUND
         LW,R2    R8                RESTORE INTSIZE
         CW,R9    TENSTBL,R2        CHECK FOR OVERFLOW BY ROUND
         BL       CONVIORL           NO
         AI,R8    1                  YES-KICK INTSIZE
         B        CONVIORL
CONVRTR  CI,R5    FLOT              CHECK DATA TYPE (REAL OR INTEGER)
         BNE      CONVINT            INTEGER
         STW,R8   VALFLAG             REAL
         LAD,R8   R8                   SET + VALUE
         BEZ      CONVLGL               QUICK EXIT IF ZERO
         CI,R13   EFORMGEN+1        CHECK E FORMAT
         BE       CONVRL1            YES-ROUNDOFF IS FIXED BY DORS
         STD,R8   SAVEREAL           NO-SAVE VALUE
         BAL,R11  PLUSREAL           CONVERT TO GET DECIMAL EXPONENT
         LW,R5    R12               CALCULATE NSIZE
         AW,R5    DORS
         BLZ      CONVRL5            ANOTHER ZERO CASE
         BEZ      CONVRLH           0 TO 1,SPECIAL CASE.                U21-0024
         CI,R5    FLOT              CHECK FOR COINCIDENT CORRECT CONV.
         BE       CONVRL4            YES
         LD,R8    SAVEREAL            NO-RESTORE UNCONVERTED VALUE
         B        CONVRL2              CONTINUE CONVERSION
CONVRLH  LD,R8    SAVEREAL          RESTORE UNCONVERTED VALUE           U21-0026
         FAL,R8   FLHALF             ROUND IT                           U21-0027
         FAL,R8   X4E1                FIX                               U21-0028
         SW,R8    X4E1                  IT                              U21-0029
         LI,R5    1                 SET NSIZE TO 1                      U21-0030
         LI,R12   1                 SET INTSIZE TO 1                    U21-0031
         AI,R9    0                  CHECK IF ZERO                      U21-0032
         BNEZ     CONVRL4             NO-OK                             U21-0033
         STW,R9   VALFLAG             YES-SET VALUE FLAG                U21-0034
         B        CONVRL4                                               U21-0035
CONVRL1  LW,R5    DORS              E-FORMAT, NSIZE=DORS
CONVRL2  CI,R5    16                 CHECK MAXIMUM NSIZE
         BLE      CONVRL3             NO
         LI,R5    16                  YES-USE 16 MAX
CONVRL3  BAL,R11  PLUSREAL          CONVERT
CONVRL4  STW,R5   NSIZE              SAVE NSIZE
         STW,R12  INTSIZE             AND INTSIZE
         LI,R5    FLOT              RESTORE R5
         B       *R13                EXIT
CONVRL5  LD,R8    ZEROZERO          LOW VALUE-SET ZERO
         LI,R5    FLOT              RESET R5
         B        CONVLGL
GETD11   LB,R8    0,R1              TEXT
         MTW,1    DATALOC           UPDATE DATA LOCATION
         B       *R13                EXIT
*
* PUTSTRNG-STUFF A TEXT STRING
*      R2=COUNT     R0 USED INTERNALLY
*      R1=BA(TEXT)
*      R14=LINK
*      R7=BA CURRENT RESULT
*
PUTSTRNG LB,R0    0,R1
         STB,R0   0,R7
         AI,R7    1
         AI,R1    1
         BDR,R2   PUTSTRNG
         B       *R14
*
* PUTBLNKS-STUFF N BLANKS  R1=N
*    R14=LINK     R0 USED INTERNALLY
*    R7=BA CURRENT RESULT
PUTBLNKS LI,R0    ' '
PUTIT    STB,R0   0,R7
         AI,R7    1
         BDR,R1   PUTIT
         B       *R14
*
* PUTZEROS-STUFF N ZEROS  R1=N
*
PUTZEROS LI,R0    '0'
         B        PUTIT
*
* PUTGAP-FILLS GAP WITH BLANKS,OR,IF RBIT SET, WITH 'RTEXT'
*        IF USED, 'RTEXT' IS REPEATED AS REQUIRED TO FILL THE GAP
*
*   R14=LINK  R0,R1,R2,R7,R11 USED
*
         LOCAL    PUTGAP1,PUTGAP2,PUTGAP3
GAPFIELD CI,R10   RBIT              CHECK IF 'R' SET
         BAZ      XFORMGEN           NO-EASY OUT
         STW,R3   GAPSIZE            YES-GAPSIZE=FIELD WIDTH
         LI,R14   NXPHRASE           EXIT TO NXPHRASE
PUTGAP   LW,R1    GAPSIZE           GET GAPSIZE
         BLEZ    *R14               EMPTY GAP
         CI,R10   RBIT              CHECK IF RBIT IS SET
         BAZ      PUTBLNKS           NO
         B        PUTGAP2            ENTER LOOP
PUTGAP1  BDR,R11  PUTGAP3           DECREMENT R-COUNT,SKIP IF NOT DONE
PUTGAP2  LW,R11   RLENGTH            R-COUNT
         LW,R2    RTEXT              R-ADDRESS
PUTGAP3  LB,R0    0,R2               GET 'R' BYTE
         STB,R0   0,R7                STASH IT
         AI,R7    1                    UPDATE
         AI,R2    1                     POINTERS
         BDR,R1   PUTGAP1           DECREMENT GAP COUNT-LOOP IF NOT DONE
         B       *R14
*
* OVERFLOW-REACHED FROM  E-F-OR I FORMAT GEN IF CONVERSION WON'T FIT
*   R3=FIELD WIDTH
*   EXIT TO NXPHRASE
OVERFLOW LI,R0    '*'               OVERFLOW CHARACTER
         LW,R1    R3                 WIDTH
         LI,R14   NXPHRASE          EXIT LOC
         B        PUTIT              ENTER LOOP
*
* GENDIGSF-ROUTINE TO GENERATE DIGITS FOR DELTAFMT
*
*   R13=LINK
*
*   ON ENTRY  R2=# OF DIGITS IN R8-R9 VALUE TO BE CONVERTED
*             R11=# OF DIGITS+UNDERSCORES OR BLANKS TO BE GENERATED
*             R12=# OF DIGITS LEFT OF DECIMAL
*             R8-R9=VALUE TO BE CONVERTED
*             R7= BA TO STORE DIGITS
*
*    REGISTERS NOT USED:R3(W) R4(FORMAT TYPE)R5(DATUM TYPE)
*                       R6(FORMAT POINTER)R10(FLAG BITS)
*
*    REGISTERS USED AND VOLATILE:R0,R1,R2,R8,R9,R11,R12,R14
*
*   ON EXIT   R7= BA FOR NEXT FIELD ITEM
*
         LOCAL    GENDIG0,GENDIG1,GENDIG2,GENDIG3,GENDIG4,GENDIG5
         LOCAL    GENDIG6,GENDIG7,GENDIG8,GENDIG9,GENDIG10,GENDIG11
         LOCAL    GENDIG12,GENDIG13,GENDIG14,GENDIG15
GENDIGSF AI,R12   0                 TEST 'INTSIZE'
         BGZ      GENDIG4            INTEGER CHARS EXIST
         BAL,R14  SETZER              NO INTEGER CHARS-INSERT 0
         STW,R7   INTRIGHT          SAVE END OF INTEGER POSITION
         LI,R14   GENDIG1
GENDIG0  LI,R0    '.'
         BDR,R11  SETCHAR           F OR E FORMAT BRANCHES
         B       *R13               I FORMAT EXIT FOR 0
GENDIG1  AI,R12   0                 CHECK FOR FRACT. WITH LEADING ZEROS
         BEZ      GENDIG4            NO
         LI,R14   GENDIG3            YES
         AI,R12   -1                 ADJUST COUNT FOR BIR LOOP
GENDIG2  BIR,R12  SETZER              SET ZEROS
         B        GENDIG4
GENDIG3  BDR,R11  GENDIG2             DECREMENT 'TSIZE' FOR EACH ZERO
         B       *R13                  EXIT IF TSIZE REACHED
GENDIG4  LI,R1    0
         STW,R1   LDFLAG            RESET LONG-DIVIDE FLAG
         LI,R1    16                SET SIGNIFICANCE COUNT
         CI,R2    10                CHECK MSIZE
         BLE      GENDIG6            SHORT DIVIDE
         MTW,1    LDFLAG              LONG DIVIDE-SET FLAG
         DW,R8    TENSTBL+9            DIVIDE
         STW,R8   LOWEND                SAVE LOW END
         AI,R2    -9                     ADJUST DIVIDE INDEX
GENDIG5  LI,R8    0                 SET FOR DIVIDE
GENDIG6  DW,R8    TENSTBL-1,R2       DIVIDE OUT A DIGIT
         XW,R8    R9
         AI,R8    X'F0'               FORM EBCDIC CHAR
         STB,R8   0,R7                 STASH IT
         AI,R7    1
         AI,R1    -1                DECREMENT SIGNIFICANCE COUNT
         BDR,R11  GENDIG7           DECREMENT CHAR COUNT
         B       *R13                EXIT IF DONE
GENDIG7  AI,R12   -1                DECREMENT DECIMAL POSITION
         BNEZ     GENDIG8            NOT TIME FOR '.'
         STW,R7   INTRIGHT            TIME FOR '.'-SAVE POSITION
         LI,R0    '.'
         BAL,R14  SETCHAR              SET '.'
GENDIG8  BDR,R2   GENDIG5           LOOP
         MTW,-1   LDFLAG             CHECK LONG-DIVIDE FLAG AND RESET
         BLZ      GENDIG9             SHORT DIVIDE(OR 2ND LOOP DONE)
         LI,R2    9                 SETUP FOR 2ND LOOP
         LW,R9    LOWEND             GET LOW END OF VALUE
         B        GENDIG5             DO 2ND LOOP
GENDIG9  LI,R14   GENDIG10          STUPID LONG FIELD CASE!
GENDIG10 AI,R12   -1                ADJUST AND TEST DECIMAL POSITION
         BGZ      GENDIG13           INTEGERS LEFT
         BLZ      GENDIG15           FRACTION LEFT
         LI,R14   GENDIG12           AT '.' POINT
GENDIG11 AI,R1    -1                DECREMENT SIGNIFICANCE AND TEST
         BGEZ     SETZER             OK-GEN ZERO
         LI,R0    UNDRSCOR           16+  GEN UNDERSCORE
         B        SETCHAR
GENDIG12 LI,R14   GENDIG10          GENERATE  '.'
         B        GENDIG0            OR QUIT IF  I FORMAT
GENDIG13 LI,R14   GENDIG14
         B        GENDIG11
GENDIG14 BDR,R11  GENDIG10
         B       *R13
GENDIG15 XW,R11   R1                SWITCH TSIZE AND SIGNIF. COUNT
         LW,R14   R13                SET EXIT
         AI,R11   0                   CHECK IF SIG.  CHARS. REMAIN
         BLEZ     PUTBLNKS             NO-PUT ALL BLANKS
         CW,R1    R11               CHECK IF SIG CHARS EXCEED TSIZE
         BLE      PUTZEROS             YES-PUT ALL ZEROS
         XW,R1    R11                  NO-MIXED BAG
         SW,R11   R1                       SAVE BLANK COUNT IN R11
         BAL,R14  PUTZEROS                PUT SOME ZEROS
         B        GENDIG15          R1=0 HERE-NEXT PASS PUTS THE BLANKS
SETZER   LI,R0    X'F0'
SETCHAR  STB,R0   0,R7              SET A CHARACTER
         AI,R7    1
         B       *R14
         LOCAL
         END

