         SYSTEM   SIG7FDP
         SYSTEM   BPM
         TITLE    '****** SCAN ******'
GNC      CNAME    1
CHAR     CNAME    1
         PROC
LF       EXU      GNXTCHAR,R3
         AI,R3    1
         AI,R1    1
         PEND     DALE
*************ENTRY POINTS
*
*
         DEF      BYTESNLT
         DEF      BYTESNWD
         DEF      COLUMN
         DEF      COMAFLG
         DEF      CONTROL
         DEF      DECCOM            DECIMAL-POINT CHARACTER
         DEF      DIAGCALL
         DEF      FREN,HASH
         DEF      INTAGER
         DEF      NOSCAN
         DEF        PICTYOUR
         DEF      POINTLOC
         DEF      RETURN
         DEF      RFFFLG
         DEF      SCAN
         DEF      SEMIFLG
         DEF      SKIP
         DEF       SCANRFF
         DEF      STRING
         DEF      COLAFLG
         DEF      COLACHK           AREA A VIOLATION CHECK SWITCH
         DEF      HASHNUM
         DEF      READCARD
         DEF      NDCARD
         DEF      EXNAME            HASH SUPPRESSION INDICATOR
         DEF      UNARYFLG
         DEF      CARDOUT           CARD NO. CLUSTER RTNE.
         DEF      CHARLIST
         DEF      FPERD,LIBCPY,REPLC,RNPTR
         DEF      SFRPC,SLIBN,WORDR,REARF
         DEF      HA%DNT,HA%DNTIX,HA%DNTND
         DEF      QUOTECHAR
         DEF      SVRPF                                                 SCAN
*
*************EXTERNAL REFERENCE
*
         REF      PDBXA             SOURCE LINE CNT                     SCAN
         REF      PH12EA                                                SCAN
         REF      PHASEF            ABORT                               SCAN
         REF      LEXLOOK
         REF      DIAG
         REF      CARDNO
         REF      PDBCCA
         REF      PDBCC
         REF      PDBL
         REF      PDBJ
         REF      PDBP
         REF      WREDF
         REF      WREPF
         REF      WRSPF
         REF      WRXRF             XRF OUTPUT
         REF      RDRFF             RFF INPUT
         REF      WRRFF             RFF OUTPUT
         REF      COBIOCOF
         REF      COBIOOIF
         REF      F:W5
         REF      SADNO
         REF      SADYES
         REF      ABNERR            ABNORMAL ERROR HANDLER
         REF      STRING2           PICTURE STRING AREA              BWZ
         REF      PDBDBG
         REF      PIC               PICTURE FLAG                     BWZ
         REF      SADNOSN,PDBZ
         REF      PH4FL,CBBA,CPBUF,SO%SEQ
         REF      PHASE1                                                SCAN
COPYLVL  EQU      7                 NO. OF LEVELS OF LIBRARY RETRIEVAL
RENAMLVL EQU      6                 NO. OF RENAMED FILES PERMISSIBLE
*
         PAGE
*
* SCAN ANALYZES THE SOURCE COBOL INPUT ISOLATING AND IDENTIFYING EACH
*    CHARACTER STRING AS ONE OF THE FOLLOWING
*        1. DATA NAME
*        2.  RESERVED WORD(DOD)
*        3.  NUMERIC LITERAL
*        4.  NON-NUMERIC LITERAL
*        5.  PERIOD  OR  (  OR  )
*
* THE CHARACTER STRING IS RETURNED IN THE 66 WORD BUFFER - STRING
*
*
*  CALL
*        BAL,R11  SCAN
*
*
*
R0       EQU      0
R1       EQU      1                 BYTE DISPLACEMENT OF SORIMAG
R2       EQU      2      (SAVED)    CHAR RETURNED FROM GNC
R3       EQU      3     (SAVED)     EXU INDEX FOR GNC
R4       EQU      4     (SAVED)     STORE BYTE DISPLACEMENT
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8                          UTILITY INPUT PARAM
R9       EQU      9
R10      EQU      10    (LINKAGE)
R11      EQU      11    (LINKAGE)
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
*
LNKR     EQU      11                SUBROUTINES
LNK2     EQU      10                SUBRS
RABY     EQU      R2                CHAR
         BOUND    4
*
SCAN     RES      0
         STW,LNKR RETURN2
         LI,R10   1                 HAS EOF
         CW,R10   CONTROL            OCCURRED?
         BE       *RETURN2          YES - RETURN TO USER
         MTB,0    NOSCAN            IS NOSCAN SET?
         BNEZ     PASSOUT            YES - RETURN TO CALLER
         LCI      0
         STM,R0   REGSPACE          SAVE REGISTERS
         LW,R1    BYTEP             BYTE OF SOURCE (SORIMAG)
         LW,R3    EXUP              PROC INDEX FOR GNXTCHAR
         LI,R15   0
         STW,R15  CONTROL
         STW,R15  SIGN
         STW,R15  POINTLOC
         CB,R15   PICTYOUR
         BE       PUNCTEST
*
*    PICTURE SCAN ROUTINE
*
PICPROS  LI,R4    0
         CHAR                       GET NEXT CHARACTER
         CI,R2    ' '
         BE       PICPROS+1         SPACE
         CI,R2    256
         BE       PICPROS+1         END OF CARD
STORPIC  STB,R2   STRING2,R4        STORE PICTURE CHARACTER          BWZ
         AI,R4    1
         CHAR                       GET NEXT CHARACTER
         CI,R2    ' '
         BE       PIC1              SPACE - GO TO TEST FOR PICTURE END
         CI,R2    256
         BNE      STORPIC           TO STORE THE CHARACTER
         BAL,R10  CHKCONT           IS NEXT CARD A CONTINUATION?
         B        STORPIC            YES
PIC1     RES      0                 END OF STRING
         LW,R7    R4
         AI,R7    -1
         LB,R6    STRING2,R7        GET LAST PICTURE CHARACTER       BWZ
         CI,R6    '.'               PERIOD-PUNCTUATION
         BE       PIC1D
         CI,R6    ';'               PUNCT-SEMICOLON
         BNE      PIC1E
* PUNCTUATION WAS LAST CHAR-BACKSPACE OVER IT
*
PIC1D    RES      0
         AI,R3    -2
         AI,R1    -2                BACKOVER . , OR ; ON SOURCE CARD
         AI,R4    -1                BACKOVER . , OR ; IN STRING
PIC1E    RES      0
         CI,R4    2                 IF NOT
         BNE      PIC1F              THE NOISE WORD
         LI,R2    X'FC9E2'            'IS'
         CH,R2    STRING2              GO TO COMPLETE                BWZ
         BNE      PIC1F                 THE PICTURE STRING
         CW,R15   PICTYOUR          OTHERWISE TEST THE PICTURE INDICATOR
         BEZ      PIC1F+1            IF RESET, 'IS' IS REPEATED
         STW,R15  PICTYOUR           IF NOT, RESET IT AND
         B        PICPROS             GO TO GET THE PICTURE
PIC1F    STW,R15  PICTYOUR          RESET PICTURE INDICATOR
         LI,R2    ' '               TERMINATE PICTURE STRING
         STB,R2   STRING2,R4         WITH A BLANK                    BWZ
         STW,R2   PIC               SET PICTURE FLAG                 BWZ
         B        PASSCAN           DONE
*
PUNCTEST CW,R15   COMSEMI
         BE       SCAN1A            NO PUNCTUATION BE4 PREVIOUS STRING
         CW,R15   COMAFLG
         BE       SEMITEST
         BAL,R10  DIAGCALL
         DATA     2                 ILLEGAL COMMA
         STW,R15  COMAFLG
         B        SCAN1A
*
SEMITEST RES      0
         CW,R15   SEMIFLG
         BE       SCAN1A
         BAL,R10  DIAGCALL
         DATA     2                 ILLEGAL SEMI-COLON
         STW,R15  SEMIFLG
         STW,R15  COMSEMI
*
SCAN1B1  RES      0
*
SCAN1B   RES      0
SCAN1A   CW,R15   COLAFLG
         BE       SCAN1A1
         CW,15    COLABE4           IS THE 'SKIP TO NEXT CARD' SWITCH ON
         BNE      SCAN1A1           YES - DIAGNOSE NEXT TIME THRU
*        DIAGNOSE ALL AREA A VIOLATIONS.                                SCAN
*                                                                       SCAN
         BAL,R10  DIAGCALL                                              SCAN
         DATA     3                 MARGIN A VIOLATION
         STW,R15  COLAFLG
SCAN1A1  RES      0
         STW,R15  COLABE4           RESET 'SKIP TO NEXT CARD' SWITCH
SKIPWNT  RES      0
         CW,R15   SKIP
         BE       SCAN1C
         CB,R15   SKIP              BYTE 0 = SKIP TO END OF CARD
         BNE      SKPCARD
         LI,R7    1
         CB,R15   SKIP,R7           BYTE 1 = SKIP PAST NEXT PERIOD
         BNE      SKIPPER           YES - DO IT THEN EXIT FROM SCAN
*
SCAN1C   GNC                        PROC TO GET NEXT CHAR VIA EXU
         CI,R2    ' '
         BE       SCAN1C            ELIMINATE BLANKS TILL FIND NONSO
SCAN1C1  RES      0                 ENTRY FROM NUMORWD FOR BAD QUOTE
         CB,R2    QUOTECHAR
         BNE      SCAN1D
         BAL,LNKR NONLIT            GET NON-NUMERIC LITERAL
         B        %+2
*
SCAN1D   BAL,LNKR NUMORWD           GET NON-NON-NUMERIC LITERALS
*
PASSCAN  STW,R1   BYTEP
         STW,R3   EXUP              INDEX FOR NEXT GNC EXU
         MTW,0    REARF
         BGZ      PASSCANA          IN REPLACING
         BAL,R10  MVSTRN
         LI,R10   X'1000'           IS 'SCAN' DEBUGGING OPTION
         AND,R10  PDBJ                SPECIFIED?
         BCR,3    %+2               NO - DON'T LIST
         BAL,R10  LISTSCAN
PASSCANA RES      0
         LCI      0
         LM,R0    REGSPACE          RESTORE REGISTERS
PASSOUT  LI,R10   0
         STB,R10  NOSCAN
         STB,R10  EXNAME                                                SCAN

         B        *RETURN2          RETURN TO USER (SUBRS OR SYN-DRIVER)
***
*  SKIP PAST NEXT PERIOD FOLLOWED BY SPACE,THEN POSITION TO NON-BLANK
***
*
SKIPPER  RES      0
         GNC
         CI,R2    '.'
         BNE      SKIPPER           GO TILL HIT A PERIOD CANDIDATE
         GNC
         CI,R2    ' '               IS IT A BLANK
         BE       SKIPFIN            YES - PERIOD FOUND
         CI,R2    256               IS IT END-OF-CARD?
         BNE      SKIPPER+3
         B        SKIPFIN            YES - PERIOD WAS IN COLUMN 72
***
*  SET TO BEGIN NEXT CARD
*        THIS ROUTINE ISSUES A DIAGNOSTIC IF NON-BLANK COLUMNS OCCUR
***
*
SKPCARD  RES      0
         STW,R1   COLABE4           SET 'SKIP TO NEXT CARD' SWITCH
         CW,R15   COLUMN            ZERO IF NEW CARD JUST IN
         BE       SKIPFIN
SKPCARDA RES      0
         GNC
         CI,R2    ' '
         BE       SKPCARDA          GET ANOTHER CHARACTER
         CI,R2    256
         BE       SKPCARDB          END-OF-CARD
         BAL,R10  DIAGCALL
         DATA     38                SOURCE WORDS BYPASSED
SKPCARDB RES      0
         BAL,R10  NDCARD
SKIPFIN  RES      0
         STW,R15  SKIP              CLEAR SKIPPING FLAG
         STW,R15  HYFN7             CLEAR CONTINUATION FLAG
         B        PASSCAN           EXIT FROM SCAN
****
*
*  DATA SECTION FOR SCAN
*
****
DECCOM   DATA     '.'               DECIMAL-POINT CHARACTER
SIGN     DATA     0                 SIGN OR NO SIGN ON LITERAL
POINTLOC DATA     0                 ACTUAL DECIMAL POINT FROM LEFT
INTAGER  DATA     0,0,0
         RES      6                  ALLOW FOR LONG LITERALS            SCAN
BYTESNWD DATA     0                 CHAR COUNT IN CURRENT STRING
HASHNUM  DATA     0                 HASH INDEX CURRENT WORD
CONTROL  DATA     0                 CONTROL
LITEVEN  DATA     X'000000F0'
         DATA     0                                                     SCAN

STRING   RES      64                DATA CHARACTER STRING
         DATA     0
NOSCAN   DATA     0                 INHIBIT CHAR GETTER AND EXIT IF SET
PICTYOUR DATA     0                 SET IF PICTURE IS NEXT STRING
COMSEMI  DATA     0                 COMMA,SEMICOLON OCCURRANCE FLAGS
COMAFLG  DATA     0                 COMMA OCCURRANCE FLAG
SEMIFLG  DATA     0                 SEMICOLON
SKIP     DATA     0                 SKIP OPTIONS
HYFN7    DATA     0                 CONTINUATION CURRENT CARD
EXUP     DATA     7                 EXECUTION INDEX FOR NEXT SOURCE CHAR
BYTEP    DATA     7                 CURRENT SOURCE CHAR INDEX
COLACHK  DATA     0                 SET BY SAD UPON D.D. SECTION HEADER
COLABE4  DATA     0                 SET BY 'SKIP TO NEXT CARD' ROUTINE
COLAFLG  DATA     0                 SET WHEN AREA A USED ON NEW CARD
BYTESNLT DATA     0                 BYTES OF PACK DECIMAL IN INTAGER
COPYFST  DATA     0                 1ST LINE AFTER 'COPY' INDICATOR
COPYFLG  DATA     0                 IF ON-IN COPY FROM LIB MODE
RFFFLG   DATA     0
SOREND   DATA     0                 EOF
QUOTECHAR DATA    0                 QUOTE
UNARYFLG DATA     0                 UNARY SIGN FLAG
RELSYMS  GEN,8,8,8,8     0,EQUSGN,LSSIGN,GRSIGN   RELATIONAL OPERATOR
         DATA     0                                CONTROL WORDS
REGSPACE RES      16                SAVED REGISTERS
HA%DNT   DATA     0                                                     SCAN

HA%DNTIX DATA     0                                                     SCAN

HA%DNTND DATA     0                                                     SCAN

         TITLE 'NUMORWD - GET NON-NON-NUMERIC LITERALS'
         PAGE
*******
*
*  SUBROUTINE NUMORWD - GET AND IDENTIFY ALL NON NON-NUMERIC LITERAL
*                        CHARACTER STRINGS
*  INPUT - FIRST CHAR OF STRING IN R5
*
*  OUTPUT - CHAR STRING LEFT JUSTIFIED IN STRING
*           CHAR COUNT OF STRING IN BYTESNWD
*
*  CALL
*        BAL,LNKR NUMORWD
*
*  REGISTER USAGE
*        R4 = BYTE DISPLACEMENT IN STRING
*        R14 = BINARY CHAR COUNTER
*
*
****
* THE FOLLOWING SPECIAL CHARACTERS ARE IDENTIFIED IMMEDIATELY BY SCAN
*  AND THE CONTROL SET ACCORDINGLY, THUS NO CALL TO LEXLOOK NEEDED
***
PLSIGN   EQU      O'121'
MISIGN   EQU      O'122'
PERSGN   EQU      O'1041'
RTSIGN   EQU      O'125'
LTSIGN   EQU      O'124'
EQUSGN   EQU      O'120'
EXPOSGN  EQU      O'127'
DIVSGN   EQU      O'123'
TIMSGN   EQU      O'126'
LSSIGN   EQU      O'157'
GRSIGN   EQU      O'156'
N        EQU      2
CHARCTER EQU      R2
INITWDS  EQU      N
NUMORWD  RES      0
         STW,R11  NUMRET
         STW,R1   COLUMN            BEGINNING COLUMN FOR THIS WORD
         STW,R15  S1                INITIALIZE
         STW,R15  S5
         LI,R4    0                 STORE BYTE DISP
         B        EXAMINE
STORBYTE RES      0
         STB,R2   STRING,R4         NEXT CHAR OF STRING
         AI,R4    1
NEXTCHAR GNC      CHARGETING
EXAMINE  RES      0
         EXU      CHARLIST,CHARCTER
         B        STORBYTE          STORE CURRENT CHAR
         B        NUMWORD           HAVE STRING WILL TRAVEL
         B        EXAMINE           CHECK CURRENT CHAR
         B        NUMLOUT           EXIT
         B        SCAN1C1           SPECIAL TO CHECK QUOTE
         TITLE    'CHARACTER BRANCH TABLE'
         PAGE
*
* CHARLIST IS A 258 WORD JUMP LIST TO PROCESS THE SIGMA7
*        CHARACTER SET AND 2 SPECIAL COMPILER TERMINAL CHARACTERS
*
CHARLIST RES      0
         BAL,R10  ILLEGAL           NULL     X'00'
         BAL,R10  ILLEGAL                    X'01'
         BAL,R10  ILLEGAL                    X'02'
         BAL,R10  ILLEGAL                    X'03'
         BAL,R10  ILLEGAL           PF       X'04'
         BAL,R10  ILLEGAL           HT       X'05'
         BAL,R10  ILLEGAL           LC       X'06'
         BAL,R10  ILLEGAL           DEL      X'07'
         BAL,R10  ILLEGAL           EOM      X'08'
         BAL,R10  ILLEGAL                    X'09'
         BAL,R10  ILLEGAL                    X'0A'
         BAL,R10  ILLEGAL                    X'0B'
         BAL,R10  ILLEGAL                    X'0C'
         BAL,R10  ILLEGAL                    X'0D'
         BAL,R10  ILLEGAL                    X'0E'
         BAL,R10  ILLEGAL                    X'0F'
         BAL,R10  ILLEGAL                    X'10'
         BAL,R10  ILLEGAL                    X'11'
         BAL,R10  ILLEGAL                    X'12'
         BAL,R10  ILLEGAL                    X'13'
         BAL,R10  ILLEGAL           RES      X'14'
         BAL,R10  ILLEGAL           NL       X'15'
         BAL,R10  ILLEGAL           BS       X'16'
         BAL,R10  ILLEGAL           IDL      X'17'
         BAL,R10  ILLEGAL                    X'18'
         BAL,R10  ILLEGAL                    X'19'
         BAL,R10  ILLEGAL                    X'1A'
         BAL,R10  ILLEGAL                    X'1B'
         BAL,R10  ILLEGAL                    X'1C'
         BAL,R10  ILLEGAL                    X'1D'
         BAL,R10  ILLEGAL                    X'1E'
         BAL,R10  ILLEGAL                    X'1F'
         BAL,R10  ILLEGAL           DS       X'20'
         BAL,R10  ILLEGAL           SS       X'21'
         BAL,R10  ILLEGAL           FS       X'22'
         BAL,R10  ILLEGAL           SI       X'23'
         BAL,R10  ILLEGAL           BYP      X'24'
         BAL,R10  ILLEGAL           LF       X'25'
         BAL,R10  ILLEGAL           EOB      X'26'
         BAL,R10  ILLEGAL           PRE      X'27'
         BAL,R10  ILLEGAL                    X'28'
         BAL,R10  ILLEGAL                    X'29'
         BAL,R10  ILLEGAL                    X'2A'
         BAL,R10  ILLEGAL                    X'2B'
         BAL,R10  ILLEGAL                    X'2C'
         BAL,R10  ILLEGAL                    X'2D'
         BAL,R10  ILLEGAL                    X'2E'
         BAL,R10  ILLEGAL                    X'2F'
         BAL,R10  ILLEGAL                    X'30'
         BAL,R10  ILLEGAL                    X'31'
         BAL,R10  ILLEGAL                    X'32'
         BAL,R10  ILLEGAL                    X'33'
         BAL,R10  ILLEGAL           PN       X'34'
         BAL,R10  ILLEGAL           RS       X'35'
         BAL,R10  ILLEGAL           UC       X'36'
         BAL,R10  ILLEGAL           EOT      X'37'
         BAL,R10  ILLEGAL                    X'38'
         BAL,R10  ILLEGAL                    X'39'
         BAL,R10  ILLEGAL                    X'3A'
         BAL,R10  ILLEGAL                    X'3B'
         BAL,R10  ILLEGAL                    X'3C'
         BAL,R10  ILLEGAL                    X'3D'
         BAL,R10  ILLEGAL                    X'3E'
         BAL,R10  ILLEGAL                    X'3F'
         BAL,R10  BLANK             ' '      X'40'     SPACE
         BAL,R10  ILLEGAL                    X'41'
         BAL,R10  ILLEGAL                    X'42'
         BAL,R10  ILLEGAL                    X'43'
         BAL,R10  ILLEGAL                    X'44'
         BAL,R10  ILLEGAL                    X'45'
         BAL,R10  ILLEGAL                    X'46'
         BAL,R10  ILLEGAL                    X'47'
         BAL,R10  ILLEGAL                    X'48'
         BAL,R10  ILLEGAL                    X'49'
         BAL,R10  ILLEGAL           '`'      X'4A'
         BAL,R10  PERIOD            '.'      X'4B'
         BAL,R10  LTHAN             '<'      X'4C'
         BAL,R10  LEFTPAR           '('      X'4D'
         BAL,R10  PLUS              '+'      X'4E'
         BAL,R10  ILLEGAL           '|'      X'4F'
         BAL,R10  ILLEGAL           '&'      X'50'
         BAL,R10  ILLEGAL                    X'51'
         BAL,R10  ILLEGAL                    X'52'
         BAL,R10  ILLEGAL                    X'53'
         BAL,R10  ILLEGAL                    X'54'
         BAL,R10  ILLEGAL                    X'55'
         BAL,R10  ILLEGAL                    X'56'
         BAL,R10  ILLEGAL                    X'57'
         BAL,R10  ILLEGAL                    X'58'
         BAL,R10  ILLEGAL                    X'59'
         BAL,R10  ILLEGAL           '!'      X'5A'
         BAL,R10  ILLEGAL           '%'      X'5B'
         BAL,R10  ASTERICK          '*'      X'5C'
         BAL,R10  RIGHTPAR          ')'      X'5D'
         BAL,R10  SEMICOLN          ';'     X '5E'
         BAL,R10  ILLEGAL           '~'      '5F'
         BAL,R10  MINUS             '-'      X'60'
         BAL,R10  DIVIDE            '/'      X'61'
         BAL,R10  ILLEGAL                    X'62'
         BAL,R10  ILLEGAL                    X'63'
         BAL,R10  ILLEGAL                    X'64'
         BAL,R10  ILLEGAL                    X'65'
         BAL,R10  ILLEGAL                    X'66'
         BAL,R10  ILLEGAL                    X'67'
         BAL,R10  ILLEGAL                    X'68'
         BAL,R10  ILLEGAL                    X'69'
         BAL,R10  ILLEGAL                    X'6A'
         BAL,R10  COMMA             ','      X'6B'
         BAL,R10  ILLEGAL           '%'      X'6C'
         BAL,R10  ILLEGAL                    X'6D'
         BAL,R10  GTHAN             '>'      X'6E'
         BAL,R10  ILLEGAL                    X'6F'
         BAL,R10  ILLEGAL                    X'70'
         BAL,R10  ILLEGAL                    X'71'
         BAL,R10  ILLEGAL                    X'72'
         BAL,R10  ILLEGAL                    X'73'
         BAL,R10  ILLEGAL                    X'74'
         BAL,R10  ILLEGAL                    X'75'
         BAL,R10  ILLEGAL                    X'76'
         BAL,R10  ILLEGAL                    X'77'
         BAL,R10  ILLEGAL                    X'78'
         BAL,R10  ILLEGAL                    X'79'
         BAL,R10  ILLEGAL           ':'      X'7A'
         BAL,R10  ILLEGAL           '#'      X'7B'
         BAL,R10  ILLEGAL           '@'      X'7C'
         BAL,R10  QUOTE             QUOTE/APOSROPHE
         BAL,R10  EQUAL             '='      X'7E'
         BAL,R10  ILLEGAL
         BAL,R10  ILLEGAL
         BAL,R10  ILLEGAL                    X'81'     LOWER-CASE A
         BAL,R10  ILLEGAL                    X'82'     LOWER-CASE B
         BAL,R10  ILLEGAL                    X'83'     LOWER-CASE C
         BAL,R10  ILLEGAL                    X'84'     LOWER-CASE D
         BAL,R10  ILLEGAL                    X'85'     LOWER-CASE E
         BAL,R10  ILLEGAL                    X'86'     LOWER-CASE F
         BAL,R10  ILLEGAL                    X'87'     LOWER-CASE G
         BAL,R10  ILLEGAL                    X'88'     LOWER-CASE H
         BAL,R10  ILLEGAL                    X'89'     LOWER-CASE I
         BAL,R10  ILLEGAL                    X'8A'
         BAL,R10  ILLEGAL                    X'8B'
         BAL,R10  ILLEGAL                    X'8C'
         BAL,R10  ILLEGAL                    X'8D'
         BAL,R10  ILLEGAL                    X'8E'
         BAL,R10  ILLEGAL                    X'8F'
         BAL,R10  ILLEGAL                    X'90'
         BAL,R10  ILLEGAL                    X'91'     LOWER-CASE J
         BAL,R10  ILLEGAL                    X'92'     LOWER-CASE K
         BAL,R10  ILLEGAL                    X'93'     LOWER-CASE L
         BAL,R10  ILLEGAL                    X'94'     LOWER-CASE M
         BAL,R10  ILLEGAL                    X'95'     LOWER-CASE N
         BAL,R10  ILLEGAL                    X'96'     LOWER-CASE O
         BAL,R10  ILLEGAL                    X'97'     LOWER-CASE P
         BAL,R10  ILLEGAL                    X'98'     LOWER-CASE Q
         BAL,R10  ILLEGAL                    X'99'     LOWER-CASE R
         BAL,R10  ILLEGAL                    X'9A'
         BAL,R10  ILLEGAL                    X'9B'
         BAL,R10  ILLEGAL                    X'9C'
         BAL,R10  ILLEGAL                    X'9D'
         BAL,R10  ILLEGAL                    X'9E'
         BAL,R10  ILLEGAL                    X'9F'
         BAL,R10  ILLEGAL                    X'A0'
         BAL,R10  ILLEGAL                    X'A1'
         BAL,R10  ILLEGAL                    X'A2'     LOWER-CASE S
         BAL,R10  ILLEGAL                    X'A3'     LOWER-CASE T
         BAL,R10  ILLEGAL                    X'A4'     LOWER-CASE U
         BAL,R10  ILLEGAL                    X'A5'     LOWER-CASE V
         BAL,R10  ILLEGAL                    X'A6'     LOWER-CASE W
         BAL,R10  ILLEGAL                    X'A7'     LOWER-CASE X
         BAL,R10  ILLEGAL                    X'A8'     LOWER-CASE Y
         BAL,R10  ILLEGAL                    X'A9'     LOWER-CASE Z
         BAL,R10  ILLEGAL                    X'AA'
         BAL,R10  ILLEGAL                    X'AB'
         BAL,R10  ILLEGAL                    X'AC'
         BAL,R10  ILLEGAL                    X'AD'
         BAL,R10  ILLEGAL                    X'AE'
         BAL,R10  ILLEGAL                    X'AF'
         BAL,R10  ILLEGAL                    X'B0'
         BAL,R10  ILLEGAL                    X'B1'
         BAL,R10  ILLEGAL                    X'B2'
         BAL,R10  ILLEGAL                    X'B3'
         BAL,R10  ILLEGAL                    X'B4'
         BAL,R10  ILLEGAL                    X'B5'
         BAL,R10  ILLEGAL                    X'B6'
         BAL,R10  ILLEGAL                    X'B7'
         BAL,R10  ILLEGAL                    X'B8'
         BAL,R10  ILLEGAL                    X'B9'
         BAL,R10  ILLEGAL                    X'BA'
         BAL,R10  ILLEGAL                    X'BB'
         BAL,R10  ILLEGAL                    X'BC'
         BAL,R10  ILLEGAL                    X'BD'
         BAL,R10  ILLEGAL                    X'BE'
         BAL,R10  ILLEGAL                    X'BF'
         BAL,R10  ILLEGAL                    X'C0'
         STB,R2   S1                'A'      X'C1'     SET ALPHA FLAG
         STB,R2   S1                'B'      X'C2'     SET ALPHA FLAG
         STB,R2   S1                'C'      X'C3'     SET ALPHA FLAG
         STB,R2   S1                'D'      X'C4'     SET ALPHA FLAG
         STB,R2   S1                'E'      X'C5'     SET ALPHA FLAG
         STB,R2   S1                'F'      X'C6'     SET ALPHA FLAG
         STB,R2   S1                'G'      X'C7'     SET ALPHA FLAG
         STB,R2   S1                'H'      X'C8'     SET ALPHA FLAG
         STB,R2   S1                'I'      X'C9'     SET ALPHA FLAG
         BAL,R10  ILLEGAL                    X'CA'
         BAL,R10  ILLEGAL                    X'CB'
         BAL,R10  ILLEGAL                    X'CC'
         BAL,R10  ILLEGAL                    X'CD'
         BAL,R10  ILLEGAL                    X'CE'
         BAL,R10  ILLEGAL                    X'CF'
         BAL,R10  ILLEGAL                    X'D0'
         STB,R2   S1                'J'      X'D1'     SET ALPHA FLAG
         STB,R2   S1                'K'      X'D2'     SET ALPHA FLAG
         STB,R2   S1                'L'      X'D3'     SET ALPHA FLAG
         STB,R2   S1                'M'      X'D4'     SET ALPHA FLAG
         STB,R2   S1                'N'      X'D5'     SET ALPHA FLAG
         STB,R2   S1                'O'      X'D6'     SET ALPHA FLAG
         STB,R2   S1                'P'      X'D7'     SET ALPHA FLAG
         STB,R2   S1                'Q'      X'D8'     SET ALPHA FLAG
         STB,R2   S1                'R'      X'D9'     SET ALPHA FLAG
         BAL,R10  ILLEGAL                    X'DA'
         BAL,R10  ILLEGAL                    X'DB'
         BAL,R10  ILLEGAL                    X'DC'
         BAL,R10  ILLEGAL                    X'DD'
         BAL,R10  ILLEGAL                    X'DE'
         BAL,R10  ILLEGAL                    X'DF'
         BAL,R10  ILLEGAL                    X'E0'
         BAL,R10  ILLEGAL                    X'E1'
         STB,R2   S1                'S'      X'E2'     SET ALPHA FLAG
         STB,R2   S1                'T'      X'E3'     SET ALPHA FLAG
         STB,R2   S1                'U'      X'E4'     SET ALPHA FLAG
         STB,R2   S1                'V'      X'E5'     SET ALPHA FLAG
         STB,R2   S1                'W'      X'E6'     SET ALPHA FLAG
         STB,R2   S1                'X'      X'E7'     SET ALPHA FLAG
         STB,R2   S1                'Y'      X'E8'     SET ALPHA FLAG
         STB,R2   S1                'Z'      X'E9'     SET ALPHA FLAG
         BAL,R10  ILLEGAL                    X'EA'
         BAL,R10  ILLEGAL                    X'EB'
         BAL,R10  ILLEGAL                    X'EC'
         BAL,R10  ILLEGAL                    X'ED'
         BAL,R10  ILLEGAL                    X'EE'
         BAL,R10  ILLEGAL                    X'EF'
         STB,R2   S5                '0'      X'F0'     SET NUMERIC FLAG
         STB,R2   S5                '1'      X'F1'     SET NUMERIC FLAG
         STB,R2   S5                '2'      X'F2'     SET NUMERIC FLAG
         STB,R2   S5                '3'      X'F3'     SET NUMERIC FLAG
         STB,R2   S5                '4'      X'F4'     SET NUMERIC FLAG
         STB,R2   S5                '5'      X'F5'     SET NUMERIC FLAG
         STB,R2   S5                '6'      X'F6'     SET NUMERIC FLAG
         STB,R2   S5                '7'      X'F7'     SET NUMERIC FLAG
         STB,R2   S5                '8'      X'F8'     SET NUMERIC FLAG
         STB,R2   S5                '9'      X'F9'     SET NUMERIC FLAG
         BAL,R10  ILLEGAL                    X'FA'
         BAL,R10  ILLEGAL                    X'FB'
         BAL,R10  ILLEGAL                    X'FC'
         BAL,R10  ILLEGAL                    X'FD'
         BAL,R10  ILLEGAL                    X'FE'
         BAL,R10  ILLEGAL                    X'FF'
         BAL,R10  EOC               END-OF-CARD INDICATOR
         TITLE    'MISCELLANEOUS CHARACTER-HANDLING ROUTINES'
**
*    ANY NON-COBOL CHARACTER OCCURRING OUTSIDE OF A NON-NUMERIC LITERAL
*    PASSES THRU THIS CODE TO SET A FLAG
*
ONE      EQU      R7
ILLEGAL  LI,ONE   1
         STB,ONE  S1,ONE            SET S2 NONZERO
         B        *R10
         DEF      DATCF
DATCF    LW,R6    TMPBUF+1
         LW,R7    TMPBUF+2
         SLD,R6   -8
         CW,R7    L(C'    ')
         BNE      *11               ONE DATE-COMPILED CARD
         AND,R6   =X'FF'            MASK COL 7                          SCAN
         CI,R6    '/'               PAGE EJECT                          SCAN
         BE       *11               RETURN                              SCAN
         BAL,R10  READCARD
         B        DATCF
         PAGE
***
*  SPECIAL CHARACTERS AND BLANK ANALYSIS
*
*
PERIOD   RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BNE      PER1              NOT FIRST BYTE
         GNC
         CI,R2    ' '               IS IT BLANK
         BNE      PER99
         BAL,R10  RESTCRD
         B        PER695
* NOT CONTINUED**
DEFIN    LI,R8    PERSGN
         STW,R8   CONTROL
         LI,R8    '.'
         B        PLS3
*
*
*
PER1     RES      0
         CW,R2    DECCOM            IS DECIMAL-POINT IS COMMA SPECIFIED?
         BNE      PER5              YES-THIS MUST BE A PERIOD
         LI,R7    1
         CB,R15   S5,R7             DECIMAL POINT YET
         BE       PER4              NO DECIMAL YET
*
PER5     AI,R1    -1
         AI,R3    -1                BACKSPACE ONE CHAR
RETNWD   LI,R7    1                 HAVE WORD-WILL TRAVEL
         B        *RETURN,R7        NUMWORD
*
PER4     CB,R15   S1                ALPHA CHARS AT ALL
         BNE      PER5              NO-LOOK-AHEAD
         LI,R7    1
         CB,R15   S1,R7             S2 SAY ILLEGAL CHARS IF NON-ZERO
         BNE      PER5              NO-LOOK-AHEAD
PER85    RES      0
         GNC
         CI,R2    256
         BNE      PER100            CHECK FOR BLANK
         BAL,R10  CHKCONT
         B        PER69             CONTINUED--CHK CHAR                 SCAN
         B        PER102            BACK OVER EOC INDICATOR
PERC1    LI,R7    1
         STB,R7   S1,R7             ILLEGAL CHAR
         B        *RETURN
*
PER695   LW,R7    DECCOM            WAS DECIMAL-POINT IS COMMA
         CI,R7    '.'                SPECIFIED?
         BNE      PERC1             YES - INVALID SEQUENCE OF CHARACTERS
PER69    CI,R2    '0'
         BL       PERC1             NO SPACE AFTER PERIOD
         CI,R2    '9'
         BG       PERC1
*
PER8     RES      0
         MTW,0    SVRPF
         BEZ      %+2
         STW,R4   DECPC             SAVE DECP DISPLACEMENT
         LI,R8    3
         STW,R8   CONTROL           SET NUMERIC LITERAL
         LI,R7    1
         STB,R8   S5,R7             S6=DECIMAL POINT OCCURRANCE
         STW,R4   POINTLOC
         B        *RETURN           RETURN FROM PERIOD
*
PER9     RES      0
         CI,R2    '0'
         BGE      PER8
*
PERDAG   BAL,R10  DIAGCALL
         DATA     2                 NO SPACE AFTER PERIOD
         B        DEFIN
*
PER99    RES      0
         CI,R2    256     EOC
         BNE      PER9              NOW-CHECK NUMERIC
         BAL,R10  CHKCONT
         B        PER101            FORCE NEXT CARD THEN CHECK NUMERIC
         B        DEFIN
PER101   GNC
         B        PER69
PER100   CI,R2    ' '
         BNE      PER69             MUST BE NUMERIC IF NOT BLANK
PER100A  RES      0                                                     SCAN
         STW,1    SAV1                                                  SCAN
         STW,3    SAV3                                                  SCAN
         BAL,R10  RESTCRD                                               SCAN
         B        PER69             CONTINUED AND REST OF CARD BLANK    SCAN
         LW,1     SAV1              NOT CONTINUED                       SCAN
         LW,3     SAV3              RESTORE 1 & 3                       SCAN
PER102   AI,R1    -1
         AI,R3    -1                BACK OVER BLANK
         B        PER5              BACK OVER PERIOD FOR NEXT CALL
SAV1    RES       1                                                     SCAN
SAV3    RES       1                                                     SCAN
*
         PAGE
** + INDICATOR
*        DETERMINE IF OPERATOR OR SIGN OF LITERAL.
*
PLUS     RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BE       PLS
*
TIM1     RES      0
         LI,R7    1
         STB,R7   S1,R7             SET INVALID CHARACTER-IN-STRING FLAG
         STW,R15  HYFN7             CLEAR INCASE
         B        *RETURN           EXIT -STOREBYTE
*
PLS      BAL,R10  SGNCMA
PLS0     STW,R2   SIGN              SAVE SIGN
MINTOO   CHAR
PLS1     CI,R2    ' '               BLANK
         BE       PLS11
* CHECK FOR DECIMAL POINT
*
*
         CW,R2    DECCOM
         BNE      PLS12             CHECK NUMERIC
         LI,R7    2
         STB,R7   S5,R7             SET LEADING SIGN
         STB,R7   S5
         B        PER85             TO PROCESS DECIMAL-POINT
*
PLS12    CI,R2    '0'
         BL       PLS13             NOT NUMERIC
         CI,R2    '9'
         BG       PLS13             NOT NUMERIC
PLS6     LI,R7    2
         STB,R7   S5,R7             SIGNED NUMERIC
         STB,R7   S5
         B        *RETURN           STORBYTE
*
PLS13    RES      0
         AI,R1    -1
         AI,R3    -1
         BAL,R10  RESTCRD
         B        PLS61             NEXT CARD IS A CONTINUATION
         LI,R7    X'05'             PHASE14
         CB,R7    PDBCCA            IS THIS PHASE14 ?
         BE       PSUNARY
DIAGNOSP BAL,R10  DIAGCALL
         DATA     2                 NO SPACE AFTER OPERATOR
         B        *RETURN           RETURN TO STOREBYTE                 SCAN
PSUNARY  LW,R7    SIGN              CHECK UNARY SIGN
         BGEZ     DIAGNOSP          NO TO DIAG
         CI,R2    '('
         BE       %+5               ALLOW '('
         CI,R2    'A'               IS THIS A NAME ?
         BL       DIAGNOSP
         CI,R2    'Z'               IS THIS A NAME ?
         BG       DIAGNOSP
         MTW,0    REARF
         BGZ      EXAMINE           IN REPLACING
         STW,R2   UNARYFLG          SET UNARY FLAG
         B        EXAMINE           TO GET STRING
PLS61    GNC                        GET 1ST CHARACTER OF NEW CARD
         B        PLS12              AND GO TO TEST IT
*
* CHECK EOC CONDITION
*
PLS11    RES      0
         BAL,R10  SVSGN
         BAL,R10  RESTCRD
         B        PLS6
*
PLS5     RES      0
         LW,R7    SIGN
         BLZ      MINUS2            MINUS
*
PLS4     LI,R7    PLSIGN
         STW,R7   CONTROL
         LI,R8    '+'
*
*
PLS3     AI,R1    -1                BACKSPACE
         AI,R3    -1
*
PLS33    STB,R8   STRING,R4         STORE OPERATOR IN STRING
         LI,R7    3
         STB,R7   S1,R7             SET S4=OPERATOR,(,),OR.
         B        RETNWD            NUMWORD
*
MINUS2   LI,R7    MISIGN
         STW,R7   CONTROL
         LI,R8    '-'
         B        PLS3
         PAGE
**
* ENTRY TO CHECK HYPHENS AND/OR MINUS SIGNS(OPER BOTH BINARY AND UNARY)
*
MINUS    RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BE       HY1
HY2      STB,R2   S1
         GNC
         CI,R2    ' '               BLANK
         BNE      RIDICUL           IN HYPHEN SECTION
HY3      BAL,R10  RESTCRD
         B        RIDICUL
         LI,R7    1
         STB,R7   S1,R7             SET S2=INVALID
*
*
RIDICUL  LI,R2    '-'
         AI,R1    -1
         AI,R3    -1                BACKSPACE ONE CHAR
         B        *RETURN
HY1      BAL,R10  SGNCMA
         LI,R2    -1                PREPARE TO FLAG SIGNED LITERAL
         B        PLS0
         PAGE
**
*  CHECK MULTIPLICATION (*) AND EXPONENTIATION (**)
*
ASTERICK RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BNE      TIM1              ILLEGAL CHARACTER
TIME1    GNC
         CI,R2    ' '               BLANK
         BE       TIME2             YES IS * OP
*
TIME21   CI,R2    '*'               EPON
         BE       TIME3
         CI,R2    256               ILLEGAL
         BNE      TIM1              ILLEGAL CHAR.
         BAL,R10  CHKCONT
         B        TIME21            MUST FIND  *
         B        TIME22            * IN COL 72.
*
TIME3    LI,R7    EXPOSGN           0127
         STW,R7   CONTROL
         LI,R8    '**'
         STH,R8   STRING
         B        PLS33+1
TIME2    BAL,R10  RESTCRD
         B        TIME21
TIME22   LI,R7    TIMSGN
         STW,R7   CONTROL
         LI,R8    '*'
         B        PLS3
*
         PAGE
**
*  DIVISION SIGN /
*
DIVIDE   RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BNE      TIM1              ILLEGAL CHARACTER
DIV1     GNC
         CI,R2    ' '               BLANK?
         BE       DIV2              OK
         CI,R2    256               END-OF-CARD
         BE       DIV2
         BAL,R10  RECOVEUR
*
DIV2     LI,R8    DIVSGN
         STW,R8   CONTROL
         LI,R8    '/'
         B        PLS33
         PAGE
**
*  GREATER SIGN
*
GTHAN    RES      0
         LI,R8    3
         B        EQUAL+1
**
*  LESS SIGN
*
LTHAN    RES      0
         LI,R8    2
         B        EQUAL+1
**
*  EQUAL SIGN
*
EQUAL    RES      0
         LI,R8    1
         STB,R8   RELSYMS           STORE THE OPERATOR CODE INDEX
         STW,R2   RELSYMS+1         SAVE THE CHARACTER
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BNE      TIM1              ILLEGAL CHARACTER
EQ1      GNC
         CI,R2    ' '               BLANK?
         BE       EQ2
         CI,R2    256
         BE       EQ2
         BAL,R10  RECOVEUR
*
EQ2      LB,R7    RELSYMS           GET THE LEXICON NO.
         LB,R8    RELSYMS,R7         FOR THE RELATIONAL OPERATOR
         STW,R8   CONTROL
         LW,R8    RELSYMS+1         GET THE CHARACTER ITSELF ALSO
         B        PLS3
RECOVEUR RES      0
         LI,R7    1
         STB,R7   S1,R7             ILLEGAL CHAR
         B        *R10
         PAGE
**
*  LEFT PARENTHESES
*
LEFTPAR  RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BE       LFT1
*
         BAL,R10  DIAGCALL
         DATA     2                 NO SPACE BEFORE '('
         B        PER5              NUMWORD
*
LFT1     BAL,R10  SVSGN
         MTW,1    RLPF              '(' FLAG
         LI,R8    LTSIGN
         STW,R8   CONTROL
         LI,R8    '('
         B        PLS33
*
         PAGE
**
*  RIGHT PARENTHESES
*
RIGHTPAR RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACTER
         BNE      PER5              NUMWORD
*
RT2      GNC
         CI,R2    ' '               BLANK
         BE       RT3
*    CHECK FOR ) . ; AND ,
*    THESE CHARACTERS MAY LEGALLY FOLLOW A RIGHT PARENTHESIS -
*      ANY OTHER IS DIAGNOSED
*
         CI,R2    ','
         BE       RT3
         CI,R2    ';'
         BE       RT3
         CI,R2    ')'
         BE       RT3
         CI,R2    '.'
         BE       RT3
         CI,R2    256               EOC
         BE       RT3
         BAL,R10  DIAGCALL
         DATA     2                 NO SPACE AFTER ')'
RT3      MTW,0    SVRPF
         BEZ      RT5               NOT REPLACING NAME
         MTW,-1   IDLITC
         LI,R2    ')'
         BAL,R10  SVONEC
         LI,R2    C' '
         BAL,R10  SVONEC            ADD ONE BLANK
RT5      LI,R8    0
         STW,R8   RLPF
         LI,R8    RTSIGN
         STW,R8   CONTROL
         LI,R8    ')'
         B        PLS3
         PAGE
**
*  COMMA PUNCTUATION
*
COMMA    RES      0
         STW,R10  RETURN
         CW,R2    DECCOM            IS DECIMAL-POINT IS COMMA SPECIFIED?
         BNE      COMMEX            NO
         CI,R4    0                 IS THIS THE 1ST CHARACTER?
         BE       COMA              YES
         CH,R15   S1                ANY ALPHA OR ILLEGAL CHARACTERS?
         BNE      COMMEX             YES - THIS IS A PUNCTUATION COMMA
*    A NUMERIC LITERAL IS IN PROCESS
         LI,R7    1
         CB,R15   S5,R7             HAS A DECIMAL-POINT OCCURRED YET?
         BNE      COMMEX            YES - THIS IS A PUNCTUATION COMMA
         GNC                        GET NEXT CHARACTER
         CI,R2    ' '               IS IT A BLANK?
         BNE      PER69
         BAL,R10  RESTCRD           EXAMINE THE REMAINING COLS.
         B        PER69             CONTINUED ON NEXT CARD - DECIMAL-PT
*                                   NOT CONTINUED - A PUNCTUATION COMMA
COMMEX   RES      0
         STW,R2   COMAFLG
         B        COMS1
*    COMMA IS THE FIRST CHARACTER
COMA     GNC                        GET NEXT CHARACTER
         CI,R2    ' '               IS IT BLANK?
         BNE      PER69              NO
         STW,R2   COMAFLG
         STW,R2   COMSEMI
         B        COMS3
         PAGE
**
*  SEMICOLON
*
SEMICOLN RES      0
         STW,R10  RETURN
         STW,R2   SEMIFLG
*
COMS1    STW,R2   COMSEMI
         CI,R4    0
         BNE      COMS2             RIGHT DELIMITER
         GNC
         CI,R2    ' '               BLANK
         BE       COMS3
         CI,R2    256
         BE       COMS3
         BAL,R10  DIAGCALL
         DATA     2                 NO SPACE AFTER PUNCTUATION
         B        COMSOUT
*
COMS2    STW,R15  COMSEMI           CATCH PUNCT NEXT CALL TO SCAN
         STW,R15  COMAFLG
         STW,R15  SEMIFLG
         B        PER5              NUMWORD
COMS3    CHAR                       ELIMINATE BLANKS
        CI,R2    ' '               BLANK?
         BE       COMS3             OUT WITH BLANKS
*
COMSOUT  LI,R7    4
         B        *RETURN,R7        CHECK ' AND THEN GET NEXT STRING
         PAGE
**
*  QUOTE
*
QUOTE    RES      0
         STW,R10  RETURN
         B        TIM1               ILLEGAL CHARACTER
         PAGE
**
*  EOC  - END-OF-CARD INDICATOR
*
***
EOC      RES      0
         STW,R10  RETURN
         CI,R4    0                 IS THIS FIRST CHARACE
         BE       SCAN1C            START AGAIN IN SCAN
         BAL,R10  CHKCONT           IN MIDDLE OF WORD OR NOT
         B        EXAMINE           CONTINUE WITH STRING
         LI,R7    1                 NO MORE IN STRING
         B        *RETURN,R7        NUMWORD
*
         PAGE
**
* BLANK DELIMITERS - ELIMINATE BLANKS
*        IF BLANKS TERMINATE CARD,CHECK NEXT CARD FOR HYPHEN IN COL 7
*
**
BLANK    RES      0
         STW,R10  RETURN
         BAL,R10  RESTCRD
         B        EXAMINE           CONTINUE WITH STRRING
         B        PER5              NUMWORD
         PAGE
*****
*   RESTCRD - ELIMINATE BLANKS AT END OF CARD AND CHECK FOR
*             CONTINUATION OF NEXT SOURCE CARD
*
*   CALL
*        BAL,R10  RESTCRD
*        B       (CONTINUED)   RETURN
*        B       (NOT-CONTINUED) RETURN
*
*   ENTRY-CHKCONT - WILL ONLY CHECK CONTINUATION AND GET FIRST
*                    CHARACTER ON CONTINUATION CARD
*
*        CALL
*
*        BAL,R10  CHKCONT
*        B        CONT  RETURN
*        B        NOT-CONT  RETURN
*
*****
*
RESTCRD  STW,R10  ESCAPE1
RESTBLNK CHAR
         CI,R2    ' '               BLANK
         BE       RESTBLNK
REST1B   CI,R2    256
         BE       CHKCONT1
*
REST1A   RES      0
         LI,R7    1
         B        *ESCAPE1,R7       RETURN-NOT CONTINUED
*
CHKCONT  RES      0
         STW,R10  ESCAPE1
*
*
CHKCONT1 LI,R7    6
         LB,R7    TMPBUF,R7
         CI,R7    '-'               HYPHEN
         BNE      REST1A
*                                                                       SCAN
*                                                                       SCAN
*
* NEXT CARD IS CONTINUATION
* CALL GNC TO FORCE NEXT CARD AND GE<
* FIRST NON-BLANK CHAR OIN CONTINUATION CARD
*
         GNC
         STW,R15  HYFN7             CLEAR CONT FLAG
         B        *ESCAPE1
*
%SIGN    RES      0
PERCENT  RES      0
*
*
NUMWD2   RES      0
NUMWORD  RES      0
         CI,R4    30                TEST WHETHER
         BLE      %+4                MAXIMUM LENGTH EXCEEDED
         LI,R4    30                IT IS - TRUNCATE AND DIAGNOSE
         BAL,R10  DIAGCALL
         DATA     4                 NAME OR LITERAL OF EXCESSIVE LENGTH
         STB,R4   BYTESNWD          SET # OF CHARACTERS IN STRING
         LI,R7    1                 TEST WHETHER STRING
         CB,R15   S1,R7              CONTAINED ILLEGAL CHARACTER(S)
         BE       NUM1A             NO
         BAL,R10  DIAGCALL
         DATA     5                 INVALID CHARACTER(S) IN WORD
         B        NUM1A+2
NUM1A    RES      0
         CB,R15   S1                ANY ALPHA CHARACTERS IN STRING?
         BE       NUM1B             NO - EITHER LITERAL OR OPERATOR
         BAL,R10  HASHNAME          HASH THE WORD
         LI,13    16
         CB,13    BYTESNWD
         BLE      HASNG             NO RESERVED WORDS EXCEED 15 CHARS.
         BAL,R10  LEXLOOK           LOOK-UP THE NAME IN THE LEXICON
         CW,R15   CONTROL
         BNE      NUMLOUT           RESERVED WORD
HASNG    RES      0
         CW,15    EXNAME
         BNE      NUMLOUT           THIS NAME IS NOT TO BE ENTERED
         BAL,R10  HASH              INSERT NAME INTO DNT
*
NUMLOUT  RES      0
         STW,R15  HYFN7
         B        *NUMRET           EXIT FROM NUMORWD
*
NUM1B    RES      0
         LI,R7    3
         CB,R15   S1,R7             IS IT AN OPERATOR
         BNE      NUMLOUT
         MTW,0    REARF
         BGZ      LITSET            IN REPLACING
         LI,R7    1
         CB,R15    S5,R7            ANY DECIMAL POINT
         BE       %+3
         SW,R4    POINTLOC
         STW,R4   POINTLOC
         LW,R8    SIGN
         BGEZ     PACKIT            UNSIGNED OR POSITIVE
         LB,R7    BYTESNWD
         AI,R7    -1                BACK UP TO LAST STORED BYTE
         LB,R8    STRING,R7
         AI,R8    -32               CHANGE TO NEGATIVE SIGN
         STB,R8   STRING,R7
*
*  WANT TO DEC PACK LITERAL IN LITERAL
PACKIT   LB,R7    BYTESNWD          N=DIGITS IN LIT
         AI,R7    2                 ALGORITHYM TO CALCULATE 'L'
         LI,R4    -1                OFFSET IF N+1 IS ODD
         SLS,R7   19                SET R AND X FIELDS IN PROTOTYPE INST
         EOR,R7   XFLDFIX
         AND,R7   OVFLOPFL
         OR,R7    PACKINS           OP-CODE AND WA (STRING)
         EXU      R7                PACK-DECIMAL INTO R15-R12 FROM STRIN
         AND,R7   STORDECM          EXTRACT BYTE COUNT L
         SLS,R7   -20               PACKED DECIMAL LENGTH IN BYTES
         STB,R7   BYTESNLT
         CI,R7    0
         BNE      %+3
         LI,R8    16                L=0 MEANS 16 BYTES
         STB,R8   BYTESNLT          MAXIMUM
         SLS,R7   20                ALIGN BACK FOR DECIMAL STORE
         OR,R7    STORDECI          FINISH STORE DEC PROTOTYPE INST.
         EXU      R7                DST INTO INTEGER
LITSET   LI,R15   0
         LI,R8    3
         STW,R8   CONTROL
         B        NUMLOUT           OUT
         TITLE    'INDICATOR AND WORKING CELLS'
         PAGE
*
***
*  THE FOLLOWING S-INDICATORS TELL THE NATURE OF THE CHARACTER STRING
*  GATHERED BY NUMORWD
*
*        S1 = ALPHABETIC
*        S2 = ILLEGAL CHAR
*        S3 = DECIMAL POINT OR SIGNED LITERAL
*        S4 = OPERATOR
*        S7 = LEADING SIGN OCCURRED
*        S6 = DECIMAL POINT
*        S5 = NUMERIC
*
*  INITIALLY THESE FLAGS ARE ZERO, THEY ARE SET NON-ZERO IF TRUE
*
***
S1       DATA     0                 S1,S2,S3,S4
S5       DATA     0                 S5,S6,S7FLAGS=TYPE INDICATORS
COLUMN   DATA     0                 STARTING COLUMN NR OF WD
NUMRET   DATA     0                 RETURN FROM NUMORWD
RETURN   DATA     0
ESCAPE   DATA     0                 RETURN FROM SUBROUTINES
ESCAPE1  DATA     0                 RETURN ADDRESS
RETURN1  DATA     0
RETURN2  DATA     0
SAVE4    DATA     0                 NDCARD RTNE SAVES R4 HERE
DIVISOR  DATA     127               DIVISOR FOR HASH CALCULATION
BLANKS   TEXT     '    '
XFLDFIX  DATA     X'00080000'       ADJUST ODD EVEN DIGITS FOR PACK DEC
OVFLOPFL DATA     X'0EFF0000'
STORDECM DATA     X'00F00000'       MASK OFF N=BYTES OF DECIMAL PACK.
PACKINS  GEN,8,24 X'76',STRING
STORDECI GEN,8,24 X'7F',INTAGER
EXNAME   DATA     0                 FLAG TO SUPPRESS NAME-HASHING
*
*
         TITLE    'NONLIT - NON-NUMERIC PROCESSOR'
***********
*
*  NONLIT - GET NON-NUMERIC LITERALS AND STORE THEM IN STRING
*
*  MAXIMUM SIZE OF LITERALS IS 255 CHARS
*
*  ROUTINES CALLED-
*        CHAR
*        DIAG
*
**********
*
NONLIT   RES      0
         STW,R11  NUMRET            RETURN ADDRESS
         STW,R1   COLUMN
         LI,R4    0
NONL1    GNC                        GET NEXT CHAR OF NON-NUM LIT
         CB,R2    QUOTECHAR         IS IT ENDING RIGHT QUOTE            SCAN
         BE       NONOUT            YES - LITERAL TERMINATED
NONL2    CI,R2    256               HOW ABOUT END-OF-CARD
         BNE      NONL3
         LI,R7    6
         LB,R7    TMPBUF,R7         LOOK FOR CONTINUATION ON NEXT CARD
         CI,R7    '-'               HYPHEN IN COL7.
         BE       NONL4
*
*
         BAL,R10  DIAGCALL
         DATA     6                 MISSING TERMINATING QUOTE
         B        NONOUT
*
NONL4    RES      0
         CHAR
         CB,R2    QUOTECHAR         QUOTE ON CONTINUATION CARD          SCAN
         BE       NONL1             GET NEXT CHAR
*
         BAL,R10  DIAGCALL
         DATA     6                 MISSING CONTINUATION QUOTE
*  STORIT
**
*  STORE NNLIT CHAR AND TEST4 255 MAX.
**
*
NONL3    RES      0
         STB,R2   STRING,R4         PUT CHAR IN STRING
         AI,R4    1
         CI,R4    256               MAX SIZE - JUST EXCEEDED 255
         BNE      NONL1             CONTINUE
*
         AI,R4    -1                TRUNKCATE LIT VALUE
         BAL,R10  DIAGCALL
         DATA     7                 NON-NUMERIC LITERAL> 255 CHARS
*
NONOUT   RES      0
         STB,R4   BYTESNWD          CHARS IN LITERAL
         LI,R7    2
         STW,R7   CONTROL
         B        *NUMRET
         TITLE 'UTILITY ROUTINES USED BY SCAN '
         PAGE
*    SEQUENCE CHECK THE SOURCE INPUT
*
SEQCHK   RES      0
         LI,2     1
         LH,2     SORIMAG-1,2
         BNEZ     *R10                COPYING FROM THE LIBRARY
         LI,2     BA(SORIMAG)
         LW,3     ASEQFLD
         CBS,2    0
         BG       SEQCHK2           IN SEQUENCE
         BL       SEQCHK1           OUT OF SEQUENCE
         LW,1     ASEQFLD           DUPLICATE - TEST FOR BLANKS
         CBS,0    BA(BLANKS)
         BE       *R10              DON'T DIAGNOSE REPEATED BLANKS
SEQCHK1  LI,1     1
         BAL,11   DIAG                SOURCE PROGRAM OUT OF SEQUENCE
SEQCHK2  LI,2     BA(SORIMAG)       UPDATE
         LW,3     ASEQFLD             CONTROL
         MBS,2    0                     FIELD
         B        *R10
ASEQFLD  GEN,8,24   6,BA(SEQFLD)
SEQFLD   DATA     0                 CONTROL
         DATA     0                   FIELD
         PAGE
********               ***        ***          ***               *******
*        GNXTCHAR -LOADS NEXT SOURCE CHAR FROM SOURCE INPUT IN SORIMAG *
*                                                                      *
*        EXECUTED REMOTELY
*
*        SPECIAL END-OF-CARD AND END-OF-SOURCE TESTS INCLUDED
*
*        R1 = BYTE DISPLACEMENT IN SORIMAG
*        R2 = SOURCE CHAR RETURNED
*                 E-O-C =256
*        R3 = EXU INDEX,---IS INCREMENTED AFTER EXU.
*
********
*
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1        IF BACKSPACE AT GNXTCHAR
GNXTCHAR LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         LB,R2    SORIMAG,R1
         BAL,R10  TESTND
         BAL,R10  NDOFCARD
*
TESTND   RES      0
         CI,R1    72                ATTEMPTING TO LOAD COL73-EH
         BNE      NOTEND
         LI,R2    256               END-OF-CARD
         B        *R10
NDOFCARD STW,R10  RETURN1
         BAL,R10  NDCARD            READ FIRST CARD FROM INPUT INTO
         B        *RETURN1
NOTEND   LB,R2    SORIMAG,R1        NO
         LI,R3    0
         B        *R10              RETURN
         PAGE
**********
*
*   SUBROUTINE NDCARD  -  TRANSFER  NEXT SOURCE CARDS FROM INPUT
*                         BUFFER TO SORIMAG AND TEST A AND B-MARGIN
*                         USAGE
*
*                      -  CHECK FOR HYPHEN IN COL7.
*                           IF  TRUE SET FLAG
*   SUBROUTINES CALLED.
*        READCARD - MOVE NEXT SOURCE CARD INTO SORIMAG
*        DIAG    - ISSUE DIAGNOSTIC
*        GNXTCHAR- GET NEXT CHARACTER (PROC)
*
*
*   CALL  -  BAL,R10   NDCARD
*
*   OUTPUT -  COLAFLG SET IF CARD BEGAN IN COL'S 8-11
*          -  HYFN7 FLAG SET IF CARD IS CONTINUATION FLAG
*          -
*        R2 = BLANK IF NOT CONTINUATION CARD
*          = FIRST NON-BLANK CHARACTER IF CONTINUATION CARD
*
**********
*
NDCARD   RES      0
         STW,R10  ESCAPE            RETURN ADDRESS
         STW,4    SAVE4             PRESERVE R4
         LI,15    0                 IS THIS THE FIRST LINE FOLLOWING A
         CW,15    COPYFST             LIBRARY RETRIEVAL REQUEST?
         BE       NDCARDA           NO - PROCEED NORMALLY
         STW,15   COPYFST           TES - RESET INDICATOR & READ TWICW
         BAL,R10  READCARD
         MTW,0    COPYFLG           WAS IT A VACUOUS RENAMING CLAUSE?
         BGEZ     NDCARDB            NO
         MTW,-1   COPYFLG            YES - RESET COPYFLG TO ZERO AND
         B        NDCARDF              AVOID CALLING READCARD AGAIN
NDCARDB  RES      0
         MTW,0    REARF
         BGZ      NDCARDE           IN REPLACING
         CW,15    RFFFLG
         BE       NDCARDE           THIS IS NOT A RENAMED FILE
         LW,7     RFFTI
         LW,6     RFFFLG
         CW,6     RFFTA,7
         BE       NDCARDD           ANOTHER LINE OF CURRENT RENAMED FILE
         AI,7     1                 A NEW RENAMED FILE
         CI,7     RENAMLVL+1
         BLE      NDCARDC
         STW,15   RFFFLG            RESET RFFFLG
         LI,1     118               NO. OF RENAMED FILES EXCEEDS
         BAL,11   DIAG               COMPILER CAPACITY
         B        NDCARDE
NDCARDC  STW,7    RFFTI             INITIALIZE
         STW,6    RFFTA,7            NEW
         LW,6     RFFRC               RENAMED
         STW,6    RFFTB,7              FILE
NDCARDD  MTW,1    RFFRC             INCREMENT RFF RECORD-COUNT
         LW,6     RFFRC
         STW,6    RFFTC,7
         LI,4     BA(SORIMAG)       OUTPUT
         LI,2     72                 RFF
         BAL,11   WRRFF               RECORD
NDCARDE  RES      0
         LI,R6    BA(TMPBUF)
         LW,R7    BUF1TO2
         MBS,R6   0
         LW,R2    TMPBUF
         CI,R2    1
         BE       SOREOF            EOF FOLLOWS COPY
         MTW,0    DSIMAG
         BNEZ     %+2               NEXT CARD FOR DUMMY SCAN
         BAL,11   OUTSPF            OUTPUT SOURCE IMAGE
         BAL,R10  READCARD          NEXT SOURCE CARD TO SORIMAG
*
*  CHECK COLUMNS 7,8-11
*
         MTW,0    REARF
         BNEZ     NDCARDF           REPLACING
         LI,1     X'100'            WAS SEQUENCE-CHECKING
         AND,1    PDBCC              SPECIFIED?
         BCR,3    %+2               NO - SKIP IT
         BAL,R10  SEQCHK            CHECK COLS 1-6 FOR BREAK
NDCARDF  RES      0
         LI,R3    6                 EXU
         LI,R1    6                 BYTE
         LI,R15   0
         STW,R15  COLUMN            FLAG NEW CARD
         CHAR
         CI,R2    '-'               HYPHEN
         BE       HYFNHERE
         CI,R2    '*'
         BE       DBGCK
         CI,R2    'D'
         BNE      NDCARDG           NOT DEBUG LINE
         MTW,0    PDBDBG
         BNEZ     ND1A              DEBUGGING IS ON
DBGCK    CW,15    SOREND            END OF SOURCE?
         BE       NDCARDE             NO                                SCAN
         CW,15    COPYFLG             YES, IS LIBRARY RETRIEVAL IN EFFCTSCAN
         BNE      NDCARDE               YES                             SCAN
SOREOF   LI,1     1
         STW,1    CONTROL           EOF CODE                            SCAN
         B        PASSCANA          GO TO THE EXIT FROM SCAN            SCAN
NDCARDG  RES      0                                                     SCAN
         CI,R2    '/'
         BE       ND1A              / NEW PAGE
         CI,R2    ' '               BLANK
         BE       ND1A
         CI,R2    '<'                LISTING OFF CHAR                   SCAN

         BE       ND1A                                                  SCAN

         CI,R2    '>'                LISTING ON CHAR                    SCAN

         BE       ND1A                                                  SCAN

         BAL,R10  DIAGCALL          ILLEGAL CONTINUATION CHARACTER
         DATA     218
         B        ND1A
HYFNHERE STW,R2   HYFN7             SET CONTINUATION FLAG
ND1A     GNC
ND1B     CI,R2    ' '
         BE       ND1A
         CI,R1    11                CHECK FOR COLUMN A USAGE
         BG       ND1C              SOURCE DATA BEGINS IN AREA B
         CW,R15   HYFN7             IS THIS A CONTINUATION LINE
         BNE      ND1D               YES- GO TO DIAGNOSE AREA A START
         LI,R7    1                 IS THIS WITHIN A
         CB,R15   SKIP,R7            'SKIP TO PERIOD'
         BNE      ND1D               YES- GO TO DIAGNOSE AREA A START
         STW,R7   COLAFLG            NO - SET AREA A INDICATOR
         B        ND1C
*        DIAGNOSE ALL AREA A VIOLA TIONS.                               SCAN
*                                                                       SCAN
ND1D     RES      0                                                     SCAN
         BAL,R10  DIAGCALL          AREA A VIOLATION                    SCAN
         DATA     3
ND1C     RES      0
*  ALLOW FOR DOUBLE INCREMENT
         AI,R1    -1
         AI,R3    -1
         LW,4     SAVE4             RESTORE R4
         B        *ESCAPE
*
NDCARDA  RES      0
         CW,15    SOREND            IS END-OF-SOURCE INDICATOR SET?
         BE       NDCARDB            NO
         CW,15    COPYFLG           IS LIBRARY RETRIEVAL IN EFFECT?
         BNE      NDCARDB            YES
*    THIS IS THE TRUE END OF SOURCE INPUT
         LI,1     1
         STW,1    CONTROL           EOF CODE
         B        PASSCANA          GO TO THE EXIT FROM SCAN
*    OUTPUT SOURCE IMAGE TO SPF
OUTSPF   MTW,0    REARF
         BGZ      *11               IN REPLACING
         STW,11   SVR10
         BAL,R10  CARDOUT
         LI,R10   X'400'            LINE OPTION
         AND,R10  PDBJ
         BEZ      OUTSPF1
         LI,R1    72                HEX LINE NUMBER IN 73
         LW,R3    SORIMAG-1         CARD NUMBER
NDHEXC   LI,R2    0
         SLD,R2   4                 NEXT HALF-BYTE
         AI,R2    '0'
         CI,R2    '9'
         BLE      %+2               0 - 9
         AI,R2    'A'-X'FA'         OBTAIN LETTER A - F
         STB,R2   SORIMAG,1
         AI,R1    1
         CI,R1    80
         BL       NDHEXC
         CAL1,1   PLIST2            LINE PRINT
OUTSPF1  LI,13    X'8000'
         AND,13   PDBCC
         BEZ      *SVR10            NO SPF REQUESTED
         MTW,0    RFFTZ
         BNEZ     *SVR10            RENAMING FILE
         LI,R4    BA(SORIMAG)-2
         LI,2     82                BYTE LENGTH OF SPF
         BAL,11   WRSPF
         B        *SVR10
         PAGE
*
*    SUBROUTINE TO OUTPUT A CARD NUMBER CLUSTER
*
CARDOUT  LI,15    X'10000'          NUMBER INCREMENT
         LW,14    COPYFLG           IS LIBRARY RETRIEVAL IN EFFECT?
         BEZ      CARDOUTB           NO
         BGZ      CARDOUTB-1         YES
         LH,R14   SORIMAG-1          JUST COMPLETED -
         SLS,R14  16                  RESET
         STW,R14  SORIMAG-1            SUB-NUMBER
         MTW,1    COPYFLG               & INDICATOR
         B        %+2
         LI,15    1                 SUB-NUMBER INCREMENT
CARDOUTB RES      0
         AW,15    SORIMAG-1         INCREMENT
         STW,15   SORIMAG-1          CARD-NUMBER
         STW,15   CARDNO              FIELDS
         LW,14    SLCI
         SCD,14   16
         LI,4     14*4              BYTE LOCATION OF R14
         LI,2     8                 LENGTH IN BYTES
         LB,13    PDBCC
         CI,13    X'05'
         BE       CARDOUTA
         BAL,11   WREDF             WRITE ON EDF
         CI,13    X'04'             IS PHASE 1.3 CURRENT?
         BNE      *R10               NO - DON'T OUTPUT ONTO BOTH FILES
CARDOUTA RES      0
         BAL,11   WREPF             WRITE ON EPF
         B        *R10              RETURN
         PAGE
**
* HASHIT - ADDS FIRST AND LAST CM WORDS OF NAME THEN DIVIDES SUM BY 127
*        OUTPUT - HASHNUM=HASH INDEX
* CALL -
*        BAL,R10 HASHIT
*
***
HASHNAME RES      0
HASHIT   EQU      HASHNAME
         LI,R7    ' '
         LB,R4    BYTESNWD
         STB,R7   STRING,R4
         AI,R4    1
         STB,R7   STRING,R4
         AI,R4    1
         STB,R7   STRING,R4
         AI,R4    1
         STB,R7   STRING,R4
         CI,R4    8
         BGE      HASH1A        NO
*
         LW,R7    BLANKS
         STW,R7   STRING+1          BLANK REST OF WORD 2
         AI,R4    4
*
HASH1A   SLS,R4   -2                (N+3)/4 = NR OF WORDS IN NAME
HASH1B   LW,R5    STRING            FIRST CM WORD OF NAME
         AW,R5    STRING-1,R4       LAST WORD OF NAME
         DW,R5    DIVISOR           127-HASH DIVISOR
         LI,R7    127               MASK 7 BITS
         AND,R7   R5                EXTRACT LOW ORDER 7 BITS 4 INDEX
         STW,R7   HASHNUM           FIN
         B        *R10              RETURN
         PAGE
***
*    DIAGNOSTIC MESSAGE PROCESSOR
*
* CALL -
*        BAL,R10  DIAGCALL
*        DATA     (MESSAGE-NUMBER)
*
***
DIAGCALL STW,R10  DAGRET
         LI,R7    1                 SET UP RETURN                       SCAN
         MTB,0    EXNAME            NO-DNT ON                           SCAN
         BNEZ     *DAGRET,R7        YES--GET OUT                        SCAN
         MTW,0    RFFTZ             RENAMING  GOING ON                  SCAN
         BNEZ     *DAGRET,R7        YES--GET OUT                        SCAN
         MTW,0    REARF
         BGZ      *DAGRET,R7        IN REPLACING
         XW,R1    *R10              GET DIAG, SAVE R1                   SCAN
         BAL,R11  DIAG              ISSUE  DIAG                         SCAN
         XW,R1    *R10              RESTORE DIAG, R1                    SCAN
         B        *DAGRET,R7
DAGRET   DATA     0                 RETURN FROM DIAG
DAGBLAST DATA     0                 SAVE R1
*
*
*    DIAGA SUBROUTINE FUNCTIONS IDENTICALLY TO DIAGCALL EXCEPT THAT
*        THE SUPPRESSION CAPABILITY IS BYPASSED
*
DIAGA    RES      0
         LI,R7    1                 SET UP RETURN                       SCAN
         CW,15    COLACHK           TEST AND RESET
         STW,15   COLACHK            AREA A VIOLATION CHECK SWITCH
         BNE      *R10,R7                                               SCAN
         B        DIAGCALL                                              SCAN
         PAGE
BUF1TO2  GEN,8,24  80,BA(SORIMAG)
ACOPYCD  GEN,8,24 160,BA(COPYCD)
ASORIMAG GEN,8,24 160,BA(SORIMAG)
READER   DATA     0
*
         DATA     0                 CARD NUMBER
SORIMAG  RES      20
TMPBUF   RES      35                INPUT BUFFER                        SCAN
         TITLE    'RENAMING PROCESSOR'
         PAGE
*    NOTE THIS SUBROUTINE MAY BE CALLED ONLY FROM A SINGLE POINT
SCANRFF  RES      0
         LW,2     SCANRFFX          IS THIS THE FIRST CALL TO SCANRFF?
         BNEZ     SRFFA              NO - PROCEED TO LOCATE FILE
         STW,11   SCANRFFX           YES - STORE RETURN ADDRESS
         STW,4    SAVE4             SAVE R4
*    CLOSE RFF
         LI,2     1                 SAVE
         LI,5     5                 DCB#
         BAL,11   COBIOCOF          CLOSE OUTPUT FILE
*    OPEN RFF FOR INPUT
         LI,2     0                 NON-CLUSTERED
         LI,4     1                 FWD
         LI,5     5                 DCB#
         BAL,11   COBIOOIF          OPEN INPUT
*
         LW,4     SAVE4             RESTORE R4
SRFFA    RES      0
         LI,6     0
         LW,7     RFFFLG
         STW,6    RFFFLG            RESET RFFFLG
SRFFB    AI,6     1
         CW,7     RFFTA,6
         BE       SRFFC             MATCHING FILE FOUND
         CW,6     RFFTI
         BE       *SCANRFFX         NO MATCHING RENAMED FILE EXISTS
         B        SRFFB             TRY AGAIN
SRFFC    RES      0
         STW,6    COPYFLG           SET LIBRARY RETRIEVAL INDICATOR
         STW,6    COPYFST           SET 'FIRST LINE' INDICATOR
         LW,7  RFFTC,6             IS FD ON THE RFF?
         BNEZ  SRFFD                 YES - GO TO SET UP TO RETRIEVE IT
         LI,1  -209                  NO - ISSUE DIAGNOSTIC AND THEN
         BAL,11   DIAG                      FAKE A RENAMING RETRIEVAL
         LI,6  -1                           COMPLETION
         B     SRFFE
SRFFD    RES   0
         CAL1,1   RFFPFIL           M:PFIL   F:W5,(BOF)
         LW,7     RFFTB,6           GET RECORD-COUNT
         STW,7    RFFPREC+2          & INSERT IN PLIST
         STW,7    RFFRC             INITIALIZE RECORD-COUNTER
         CAL1,1   RFFPREC           M:PRECORD   F:W58(N,?)
SRFFE    RES   0
         STW,6    RFFTZ            SET 'RENAMING' INDICATOR
         LI,6     BA(SORIMAG)       SAVE
         LW,7     ACOPYCD            CURRENT
         MBS,6    0                   LINES
         BAL,15   SRKWD             SKIP REST OF CURRENT CARD
         MTB,1    EXNAME                                                SCAN
         B        *SCANRFFX         RETURN
         TITLE    'COPY REPLACING ROUTINES'
*    SAVE LIBRARY NAME
SLIBN    LI,R3    BA(REPRG)
         LB,R2    BYTESNWD
         STW,R2   CSBSNWD           SAVE BYTESNWD
         STB,R2   R3
         LI,R2    BA(STRING)        SAVE LIBRARY NAME
         MBS,R2   0
         B        SADNO
*    SET REPLACING FLAG
SFRPC    MTW,1    SVRPF             SET REPLACING FLAG
         LI,1     0
         STW,1    PRENAM
         STW,1    LITRF
         LI,1     -1
         STW,1    DECPC
         B        SADNO
*    SKIP TO NEXT PERIOD
FPERD    LI,R2    0
         STW,R2   SVRPF             RESET REPLACE FLAG
         STB,R2   NOSCAN
         STW,R2   PRENAM
FPERD1   BAL,11   SCAN              SKIP A WORD
         LW,R2    CONTROL
         CI,R2    O'1041'
         BNE      FPERD1
         LI,R1    38                SOURCE WORD BYPASSED
         BAL,11   DIAG
         B        SADNO
*    INITIALIZE DYNAMIC BUFFER, SET REPLACING FLAG
REPLC    LW,R1    CBBA
         BNEZ     REPLC1            M:GP DONE
         LW,R1    CPBUF+1
         LW,5     CPBUF
         STW,5    DBIXA
         SLS,R1   2
         STW,R1   CSTRING
         AI,R1    260
         STW,R1   CBBA              BA OF FIRST BUFFER
REPLC1   STW,R1   REPNBA
         LI,R1    0
         STW,R1   REPNCT
         MTW,1    FREPC             SET REPLACING FLAG
         B        SADNO
*    SAVE REF NUMBER OF REPLACED NAME IN DYNAMIC BUFFER
WORDR    LW,R1    DBIXA
         AW,R1    REPNCT            DISPLACEMENT
         LW,R2    HASHNUM           REF NUMBER
         STW,R2   0,R1
         LW,R3    REPNBA            NAME ADDR
         SLS,R3   -1
         STW,R3   -1,R1
         MTW,2    IDLITC
         LI,R1    0
         STW,R1   COMAFLG
         B        SADNO
*    UPDATE REPNBA - DYNAMIC BUFFER ADDRESS
RNPTR    LI,R1    0                 RESET FLAG
         STW,R1   SVRPF
         XW,R1    IDLITC
         LW,R2    REPNBA
         SLS,R2   -1
         AI,R1    -2
         STH,R1   0,R2              SET LENGTH COUNT
         AI,R1    3
         AND,R1   L(X'FFFFFFFE')    FORCE TO HA
         AWM,R1   REPNBA            UPDATE NAME ADDRESS
         MTW,-2   REPNCT            UPDATE COUNT
         B        SADNO
*    INSERT ONE CHARACTER IN DYNAMIC BUFFER
SVSGN    MTW,0    SVRPF
         BLEZ     *R10              NO REPLACING
SVONEC   LW,R7    IDLITC
         AW,R7    REPNBA
         STB,R2   0,R7              SAVE ONE CHARACTER
SVONEC1  MTW,1    IDLITC
         B        *R10
*    SAVE SIGN CHARACTER
SGNCMA   MTW,0    SVRPF
         BLEZ     *R10              NO REPLACING
         MTW,0    RLPF              COMMA AND SIGN
         BEZ      SVONEC
         MTW,0    COMAFLG
         BEZ      SVONEC
         SLS,R2   16
         OR,R2    L(X'406B')
         STW,R10  SVR11
         MTW,-1   IDLITC
         BAL,R10  SVONEC            INSERT COMMA
         SLS,R2   -8
         BAL,R10  SVONEC            INSERT A BLANK
         SLS,R2   -8
         LW,R10   SVR11
         B        SVONEC
*    MOVE STRING IN DYNAMIC BUFFER
MVSTRN   MTW,0    SVRPF
         BLEZ     *R10              NO REPLACING
         STW,R10  SVR11
         LW,R1    CONTROL
         BEZ      MVSTRN5           NAME
         CI,R1    3
         BG       MVSTRN3           LEXICON WORD
         BE       MVSTRN7           NUMERIC
         LB,R2    QUOTECHAR         MOVE IN QUOTE
MVSTRN0  BAL,R10  SVONEC
MVSTRN1  LB,R1    BYTESNWD
         BAL,R10  MVSTRN8
MVSTRNR  LW,R10   SVR11
         AWM,R1   IDLITC            UPDATE LENGTH COUNT
         STB,R2   0,R5
         MTW,0    LITRF
         BEZ      SVONEC1           NOT NUMERIC LITERAL
         MTW,-1   LITRF
         AI,R5    -1
         LB,R4    0,R5
         OR,R4    L(X'F0')          SET ZONE ON LAST CHARACTER
         STB,R4   0,R5
         B        SVONEC1
MVSTRN2  LI,R2    C' '
         B        MVSTRN1
MVSTRN3  CI,R1    O'32'             IN
         BE       MVSTRN4
         CI,R1    O'61'             OF
         BNE      *R10
MVSTRN4  LW,R1    RLPF
         BNEZ     MVSTRN2
         STW,R1   PRENAM            RESET NAME SKIP FLAG
         B        MVSTRN2
MVSTRN5  MTW,0    RLPF
         BEZ      MVSTRN6
         MTW,0    COMAFLG
         BEZ      MVSTRN2
         MTW,-1   IDLITC
         LI,R2    ','               INSERT COMMA
         BAL,R10  SVONEC
         LI,R2    ' '
         B        MVSTRN0
MVSTRN6  MTW,0    PRENAM
         BNEZ     *R10              REPLACED NAME
         MTW,1    PRENAM
         B        MVSTRN2
MVSTRN7  MTW,1    LITRF
         LW,R1    DECPC
         BLZ      MVSTRN5           NO DECP
         BAL,R10  MVSTRN8           MOVE STRING PRECEED DECP
         AWM,R1   IDLITC
         LW,R1    DECCOM
         STB,R1   0,R5              INSERT DECP
         MTW,1    IDLITC
         LB,R1    BYTESNWD
         SW,R1    DECPC
         AI,R5    1
         STB,R1   R5
         MBS,R4   0                 MOVE IN LAST PORTION
         LI,R2    ' '
         B        MVSTRNR
MVSTRN8  LI,R4    BA(STRING)        MOVE STRING IN DYNAMIC BUFFER
         LW,R5    REPNBA
         AW,R5    IDLITC
         STB,R1   R5
         MBS,R4   0
         B        *R10
*   MAIN REPLACING ROUTINES
FARN00   LCI      0
         STM,R0   REPRG
         LW,R1    REARF
         B        FARNB,R1
         B        FASN01            ACTUAL SCANNING
FARNB    B        *R10              ERROR RETURN
         B        FARN01            READ FROM LIBRARY
         B        FARN05            DUMMY SACNNING
         B        FASN00
FARN01   BAL,11   GOREAD            READ NEXT CARD
         LW,R5    REPLBA            MOVE INTO DYNAMIC BUFFER
         AW,R5    SDISP
         LI,R6    72
         STB,R6   R5
         BAL,11   MVCPY
         AWM,R6   SDISP             UPDATE DISPLACEMENT
         AI,R4    -66
         LB,R6    0,R4              COLUMN 7
         CI,R6    '*'
         BE       FARN31            COMMENT CARD
         AI,R5    -1
         LI,R4    65                LENGTH OF SORIMAG
FARN02   LB,R3    0,R5
         CI,R3    ' '
         BNE      FARN03            NOT BLANK
         AI,R5    -1
         BDR,R4   FARN02
         B        FARN01            ALL BLANK CARD
FARN03   CI,R3    '.'
         BNE      FARN01            ANOTHER CARD FOLLOWS
         BAL,11   GOREAD            READ NEXT CARD
FARN04   LI,R4    0
         STW,R4   SDISP1
         AW,R4    REPLBA
         STW,R4   REPSBB
         MTW,1    REARF
         MTW,0    FCOPY
         BNEZ     FARNSV            NOT FIRST COPY CARD
         LW,R5    ATMPBUF
         MBS,R4   0
         B        FASN02
FARN05   MTW,0    FCOPY
         BNEZ     FARNSV
         MTW,1    FCOPY
         BAL,11   SVREG
         MTW,0    ASTRXF
         BNEZ     FARN33            COMMENT CARD
FARNSV   LI,R4    72
         LI,R2    0
         XW,R2    BUMPF
         BNEZ     FARNNX
         LI,R5    BA(SORIMAG)+6
         LB,R3    0,R5              COLUMN 7
         CI,R3    '-'
         BNE      FARNNX+1          NO CONTINUATION
         LI,R2    1
         STW,R2   CONTF
FARNNX   AWM,R4   REPSBB            BUMP TO NEXT CARD
         AWM,R4   NDISP
         LW,R3    NDISP
         CW,R3    SDISP
         BL       FARNLC            NOT LAST CARD
         MTW,1    REARF
         MTW,0    REPEOF
         BNEZ     FARNDE            END OF COPY
         BAL,11   MVCPY0
         B        FARN07
FARNDE   LW,R5    COPYFLG
         LW,R4    ESTACK,R5
         LW,R5    CTMPBF
         MBS,R4   0
         B        FARN07
FARNLC   LW,R5    CTMPBF
         AW,R4    REPSBB            NEXT CARD ADDR
         MBS,R4   0
FARN07   LI,R5    BA(SORIMAG)+71
         LI,R4    65
FARN28   LB,R3    0,R5
         CI,R3    ' '
         BNE      FARN29            NOT BLANK CHARACTER
         AI,R5    -1
         BDR,R4   FARN28
         LW,R3    REARF
         CI,R3    3
         BGE      FARN35            BLANK CARD ENDING
         MTW,1    BUMPF
         LI,R4    BA(TMPBUF)
         LW,R5    TMPSOR
         MBS,R4   0                 BUMP BY A CARD
         B        FARNSV
FARN29   AI,R4    7
         STW,R4   SCANTO
         B        FASN02
FARN08   BAL,11   SCAN              GET NEXT WORD
         LW,R3    BYTEP
         CW,R3    SCANTO
         BLE      %+2
         LW,R3    SCANTO
         STW,R3   FEXUP
         LI,R2    0
         XW,R2    FCARD
         BEZ      FARN06
         BAL,11   FTRIL
         STW,R9   STARTR
         STW,R9   STARTP
FARN06   LW,R2    PH4FL
         BNEZ     FARNNP            IN PHASE 14
         XW,R2    PIC
         BNEZ     FARN14            PICTURE
FARNNP   LW,R2    CONTROL
         BEZ      FARN10            NAME
         CI,R2    3
         BG       FARN15            LEXICON WORD
         BNE      FARN23            ALPHA LITERAL
         LW,R2    PH4FL
         BEZ      FARN14            NOT IN PHASE 14
         MTW,0    COLAFLG
         BNEZ     FARN09            PARA NO
         MTW,0    PNOF
         BEZ      FARN14
FARN09   LI,R2    1                 HASH PNO
         STW,R2   HASHNUM
         BAL,R10  HASH
FARN10   LW,R4    HASHNUM           CHECK REPLACE NAME
         LW,R5    REPNCT
FARN11   AI,R5    2
         BGZ      FARN14
         CW,R4    *DBIXA,R5
         BNE      FARN11
         AI,R5    -1
         LW,R6    *DBIXA,R5
         LH,R3    0,R6              LENGTH COUNT
         AI,R6    1
         AW,R6    R6                TO BA
         LB,R2    0,R6
         CB,R2    QUOTECHAR         QUOTATION
         BNE      FARN25            NOT ALPHA LITERAL
FARNAL   LI,R2    11
         SW,R2    STARTR
         BLEZ     FARN12            NOT A NEW CARD
         AWM,R2   STARTR
FARN12   BAL,R10  PTSTAT
         CW,R9    R3                MOVE IN ALPHA LITERAL
         BGE      FARN13
         STB,R9   R7
         SW,R3    R9
         MBS,R6   0
         MTW,1    NLITF
         BAL,R10  FRLIT
         AI,R9    11
         STW,R9   STARTR
         LI,R9    60
         B        FARN12+1
FARN13   AWM,R3   STARTR            DISP FOR NEXT WORD
         STB,R3   R7
         MBS,R6   0
         MTW,1    REPFL
         LW,R3    FEXUP
         CI,R3    72
         BNE      FARN21
FARNCP   AI,R3    15                TO COLUMN 8 OF NEXT CARD
         BAL,11   BSTART
         STW,R3   STARTP
         B        FARNPT
FARN14   LW,R6    REPSBB
         MTW,0    CONTF
         BEZ      %+3
         AI,R6    -72
         LI,R3    72
         SW,R3    STARTP
         AW,R6    STARTP
         BAL,R10  PTSTAT
FARNCT   CW,R9    R3
         BL       FARN22            NOT ENOUGH BUFFER TO MOVE
         AWM,R3   STARTR
FARN20   STB,R3   R7
         MBS,R6   0
         LW,R3    FEXUP
         CI,R3    72
         BE       FARNCP
         MTW,0    CONTF
         BLEZ     FARN21            END OF MOVE
         MTW,-1   CONTF
         LW,R2    STARTR
         CI,R2    72
         BNE      %+2
         MTW,-1   CONTF             SET INSERT - FLAG
         LI,R3    7                 POINTER TO COLUMN 8
         BAL,11   BSTART
         AW,R6    R3
         LCW,R3   R3
         AW,R3    FEXUP
         BAL,R10  PTSTAT
         MTW,0    CONTF
         BEZ      FARNCT
         AI,R7    -5
         LI,R5    '-'
         STB,R5   0,R7              SET CONTINUATION '-'
         AI,R7    5
         B        FARNCT
FARN21   STW,R3   STARTP
         CW,R3    SCANTO
         BL       FARNPT
FARN27   MTW,1    FCARD
         MTW,1    BUMPF
FARNCN   LI,R2    0
         STW,R2   CONTF
         STW,R2   REPFL
         B        FARN08
FARN22   STB,R9   R7
         MBS,R6   0
         SW,R3    R9
         BAL,R10  CALFTR
         B        FARN20
FARN23   LB,R3    BYTESNWD
         LW,R5    CSTRING
         LB,R2    QUOTECHAR         QUOTATION
         STB,R2   0,R5
         LI,R4    BA(STRING)
         AI,R5    1
         STB,R3   R5
         MBS,R4   0                 MOVE ALPHA LITERAL TO CSTRING
         STB,R2   0,R5
         AI,R3    2
         LW,R6    CSTRING
         B        FARNAL
FARNPT   LB,R5    SORIMAG,R3
         LI,R4    3
         CB,R5    PUNCC,R4
         BE       FARNPP            PUNCTUATION FOLLOWS
         BDR,R4   %-2
         CI,R5    ' '
         BNE      FARNPS
         MTW,1    STARTP
         MTW,1    STARTR
         B        FARN24
FARNPS   LW,R2    REPFL
         AWM,R2   STARTR
         B        FARNPR
FARNPP   MTW,2    STARTP
         BAL,R10  PTSTAT
         STB,R5   0,R7              STORE PUNCTUATION
         MTW,2    STARTR
FARN24   LW,R3    STARTP
         AI,R3    -1
FARNPR   CW,R3    SCANTO
         BL       FARNCN
         BG       FARN19
         BDR,R4   FARN27
         B        FARN27+1
FARN19   AI,R3    -80
         STW,R3   STARTP
         B        FARN27+1          GO TO NEXT CARD
FARN25   AI,R3    -1
         MTW,0    PH4FL
         BEZ      FARNCA
         LW,R2    NOPNOF
         BNEZ     FARNCA
         STW,R2   PNOF
FARNCA   LI,R2    7
         MTW,0    COLAFLG           CHECK MARGIN A
         BNEZ     %+2
         AI,R2    4
         SW,R2    STARTR
         BLEZ     FARN26
         AWM,R2   STARTR            ADJUST POINTER
         AW,R7    R2
FARN26   BAL,R10  PTSTAT
         CW,R9    R3
         BGE      FARN13
         STB,R9   R7
         MBS,R6   0
         SW,R3    R9
         BAL,R10  CALFTR
         B        FARN13+1
FARN15   MTW,0    PH4FL
         BEZ      FARN17            NOT IN PHASE 14
         LI,R4    10
FARNLX   CH,R2    RLXTB,R4          CHECK LEXICON WORD
         BE       FARN16
         BDR,R4   FARNLX
         STW,R4   PNOF
         B        FARN18
FARN16   CI,R4    3
         BL       FARN14            TO, IS(ARE)
         BE       FARN30            NOTE
         MTW,1    PNOF              SET PNO FLAG
         CI,R4    5
         BG       FARN14
         MTW,1    NOPNOF            DO NOT CLEAR PNO FLAG
         B        FARN14
FARN17   CI,R2    O'2122'
         BNE      FARN18            NOT PIC
         MTB,1    PICTYOUR          SET PICTURE FLAG
         B        FARN14
FARN18   CI,R2    O'1041'
         BNE      FARN14            NOT PERIOD
         STW,R3   STARTP
         B        FARNCN
FARN31   MTW,1    ASTRXF
         MTW,0    FCOPY             COMMENT CARD
         BNEZ     FARN33
         MTW,1    REARF
         B        FASN02
FARN33   BAL,11   GOREAD            READ AHEAD A CARD
FARN30   LW,R5    REPSBA            MOVE IN REPLACED BUFFER
         LW,R4    REPLBA
         LW,R6    SDISP
         LI,R7    72
         STW,R7   SDISP1
FARN32   STB,R7   R5
         MBS,R4   0
         AI,R6    -72
         BLEZ     FASN00
         AWM,R7   SDISP1
         B        FARN32
FARN35   BAL,11   FTRIL+1
FASN00   LI,R4    BA(REGS)          RECOVER REGISTERS
         LW,R5    RPTORS
         MBS,R4   0
         LI,R2    -1
         STW,R2   REARF
         LW,R5    FEXNAM            RECOVER NO DNT FLAG
         STW,R5   EXNAME
         LW,R5    SVR11
         STW,R5   RETURN2
         LW,R4    REPSBA
         LW,R5    CTMPBF
         MBS,R4   0
         BAL,11   REPTXT
         LI,R4    72
         STW,R4   NDISP
         LW,R1    NDFLAG
         MBS,R0   BA(RLXTB)         CLEAR FLAGS
         LW,R2    PH4FL
         BNEZ     FASNFS            IN PHASE 14
         XW,R2    BPIC
         BEZ      FASNFS            NO PICTURE SAVED
         LCI      9
         LM,R3    BPIC+1
         LCI      10
         STM,R2   PIC
FASNFS   LCI      0
         LM,R0    REPRG
         B        NDCARDE
FASN01   LI,R6    72
         LW,R4    NDISP
         CW,R4    SDISP1
         BE       FASN05            LAST CARD
         BG       FASN04            END OF STATEMENT
         AWM,R6   NDISP
         AW,R4    REPSBA
         LW,R5    CTMPBF
         MBS,R4   0
         BAL,11   REPTXT
FASN02   LCI      0                 GO SCANNING
         LM,R0    REPRG
         B        *R10
FASN03   LW,R1    CLFLAG            CLEAR FLAGS
         MBS,R0   BA(RLXTB)
         LI,R4    BA(REPRG)
         LW,R5    RSTORP
         MBS,R4   0
         B        LEOF              END OF COPY
FASN04   LI,R1    0
         XW,R1    DSIMAG
         BLZ      FASNAS            END OF SCANNING
         BAL,11   MVCPY0            NEXT STATEMENT CARD
         MTW,-1   DSIMAG
         B        FASN02
FASNAS   LW,R1    PH4FL
         BNEZ     FASNNS            IN PHASE 14
         XW,R1    PIC
         BEZ      FASNNS
         LCI      9
         LM,R2    PIC+1             SAVE PICTURE
         LCI      10
         STM,R1   BPIC
FASNNS   LW,R1    CSFLAG            RESET FLAGS
         MBS,R0   BA(RLXTB)
         LI,R2    1
         STW,R2   REARF
         STW,R2   FCARD
         BAL,11   SVREG
         B        FARN01+1
FASN05   MTW,0    REPEOF
         BNEZ     FASN03            END OF COPY
         AWM,R6   NDISP
         LW,R1    CTMPBF
         MBS,R0   BA(BLANKS)        SUPPLY A DUMMY BLANK CARD
         MTW,1    DSIMAG
         B        FASN02
FAREOF   MTW,1    REPEOF            END OF COPY
         LB,7     10                ABN CODE
         CI,7     6
         BNE      ABNER             ABNORMAL INPUT ERROR                SCAN
FAREOF1  MTW,0    ASTRXF
         BNEZ     FARN30            COMMENT CARD
         B        FARN04
BSTART   LB,R5    SORIMAG,R3        FIND NON BLANK START COLUMN
         CI,R5    ' '
         BNE      *11
         AI,R3    1
         B        BSTART
MVCPY0   LW,R5    CTMPBF
MVCPY    LI,R4    BA(CPYBUF)
         MBS,R4   0
         B        *11
FTRIL    LI,R9    0
         LW,R1    SDISP1            CLEAR NEXT BUFFER
         LI,R2    72
         AWM,R2   SDISP1            UPDATE DISPLACEMENT
         AW,R1    REPSBA
         STB,R2   R1
         MBS,R0   BA(BLANKS)
         B        *11
FRLIT    BAL,11   FTRIL
         AI,R7    6
         LI,R4    '-'
         STB,R4   0,R7              SET CONTINUATION '-'
         AI,R7    5
         XW,R9    NLITF
         BEZ      *R10
         LB,R4    QUOTECHAR         QUOTATION
         STB,R4   0,R7
         AI,R7    1
         B        *R10
REPTXT   LI,R4    8
         STB,R4   R5
         LI,R4    BA(REPLACED)
         MBS,R4   0
         B        *11
SVREG    LI,R4    BA(REGSPACE)      SAVE REGISTERS
         LW,R5    RSTORP
         MBS,R4   0
         LI,R5    0
         XW,R5    EXNAME
         STW,R5   FEXNAM
         LI,R5    FARN08+1
         XW,R5    RETURN2
         STW,R5   SVR11
         B        *11
GOREAD   RES      0                 READ NEXT CARD
         CAL1,1   PLIST5            M:LIB
         LI,1     WA(M:LI)
         LI,3     BA(CPYBUF)
         BAL,10   CKVR0             CHECK LONG RECORD
         B        *R11
CALFTR   STW,R10  SVR10
         AI,R6    -1
         LI,R2    ' '
         CB,R2    0,R6
         BE       CALFTR1           BLANK ENDING
         AI,R6    1
         CB,R2    0,R6
         BE       CALFTR2
         BAL,R10  FRLIT
         B        CALFTR3
CALFTR1  AI,R6    1
CALFTR2  BAL,11   FTRIL
         AI,R7    11                TO COLUMN 12 OF NEXT CARD
CALFTR3  AW,R9    R3
         AI,R9    11
         STW,R9   STARTR
         B        *SVR10
PTSTAT   LI,R9    72
         CW,R9    STARTR
         BG       PTSTAT1           NOT TO NEW CARD
         BAL,11   FTRIL+1
         LI,R7    11
         STW,R7   STARTR
PTSTAT1  LW,R7    REPSBA            NEXT START ADDR - REPLACED
         AW,R7    SDISP1
         SW,R7    R9
         AW,R7    STARTR
         SW,R9    STARTR
         B        *R10
*   WORKING BUFFERS FOR COPY REPLACING
CSBSNWD  DATA     0                  NAME LENGTH
FREPC    DATA     0                 * 01 - KEEP IN ORDER -
REARF    DATA     0                 * 02
REPEOF   DATA     0                 * 03
FCOPY    DATA     0                 * 04
ASTRXF   DATA     0                 * 05
STARTP   DATA     0                 * 06
STARTR   DATA     0                 * 07
NDISP    DATA     0                 * 08
SDISP    DATA     0                 * 09
CONTF    DATA     0                 * 10
REPFL    DATA     0                 * 11
NOPNOF   DATA     0                 * 12
BUMPF    DATA     0                 * 13
FCARD    DATA     1                 * 14
SDISP1   DATA     0
SVRPF    DATA     0                 SAVE NAME IN DYNAMIC BUFFER FLAG
PRENAM   DATA     0
LITRF    DATA     0                 NUMERIC FLAG
RLPF     DATA     0                 IN PHA FLAG
REPNCT   DATA     0                  REPLACED NAME COUNT
IDLITC   DATA     0                  IDENT-LIT LENGTH
NLITF    DATA     0
PNOF     DATA     0
FEXNAM   DATA     0
FEXUP    DATA     0
SCANTO   DATA     0
DSIMAG   DATA     0
BPIC     DATA     0                 SAVE PICTURE
         RES      9
SVR11    RES      1
DECPC    DATA     -1                DECP POSITION
DBIXA    RES      1                  REPLACING NAME INDEX ADDR
CSTRING  RES      1
REPNBA   RES      1                  REPLACING NAME BYTE ADDR
REPLBA   RES      1
REPSBA   RES      1
REPSBB   RES      1
SVR10    RES      1
REPRG    RES      16
NDFLAG   GEN,8,24 24,BA(SDISP)
CSFLAG   GEN,8,24 16,BA(ASTRXF)
CLFLAG   GEN,8,24 32,BA(FREPC)
TMPSOR   GEN,8,24 72,BA(SORIMAG)
CTMPBF   GEN,8,24 72,BA(TMPBUF)
RSTORP   GEN,8,24 64,BA(REGS)
RPTORS   GEN,8,24 64,BA(REGSPACE)
REPLACED TEXT     'REPLACED'
PUNCC    DATA     ' .,;'            PUNCTUATION CHARACTERS
CPYBUF   RES      35                COPY LIB BUFFER                     SCAN
PLIST5   GEN,8,24 X'10',M:LI        M:READ
         DATA     X'70000010'
         DATA     FAREOF            ABN
         DATA     CPYBUF            BUFF
         DATA     140               SIZE                                SCAN
RLXTB    DATA,2   0,O'107',O'37',O'1443',O'1611',O'13'
         DATA,2   O'1602',O'1615',O'1040',O'63',O'105'
         TITLE    'I/O ROUTINES'
         PAGE
*  READCARD - INPUT ROUTINE TO OBTAIN NEXT SOURCE LINE
         REF      M:SI
         REF      M:SO
         REF      M:LO
         REF      M:LI
*
READCARD STW,R10  READRTN           SAVE RETURN ADDRESS
         MTW,0    REARF
         BNEZ     FARN00            IN REPLACING
         LCI      0                 SAVE REGISTERS
         STM,0    REGS
         LW,R10   COPYFLG           IS LIBRARY RETRIEVAL IN EFFECT?
         BGZ      READLIBE            YES
         CAL1,1   PLIST1            M:READ   M:SI
         LI,1     WA(M:SI)
         LW,2     4,1               ARS                                 SCAN
         SLS,2    -17                                                   SCAN
         CI,2     80                                                    SCAN
         BLE      NO%SO1                                                SCAN
         LI,1     283               TRUNCATION DIAG                     SCAN
         BAL,11   DIAG                                                  SCAN
         LI,1     WA(M:SI)                                              SCAN
         LI,2     80                TRUNCATE TO 80 CHAR                 SCAN
NO%SO1   RES      0                                                     SCAN
         MTW,0    SO%SEQ            SOURCE OUT REQUESTED                SCAN

         BEZ      NO%SO             NO .. GO ON                         SCAN

*  SOURCE OUTPUT REQUESTED                                              SCAN

         CAL1,1   SO%OUT                                                SCAN

         LI,2     1000                                                  SCAN

         AWM,2    SO%SEQ                                                SCAN

NO%SO    RES      0                                                     SCAN

         BAL,R10  CKVR              CHECK VARIABLE LENGTH RECORD
         B        RDCARDA
READLIBE RES      0
         LW,1     RFFTZ             IS RFF RETRIEVAL IN PROCESS?
         BNEZ     READRFF            YES
         CAL1,1   PLIST4            M)READ   M:LIB
         LI,1     WA(M:LI)
         BAL,R10  CKVR
         LW,1     COPYFLG           INCREMENT
         MTW,1    DSTACK,1             RECORD COUNTER
RDCARDA  RES      0
         LCI      0                 RESTORE
         LM,0     REGS               REGISTERS
         B        *READRTN          RETURN FROM READ CARD SUBROUTINE
READRFF  RES      0
         BGZ      READRFFA          END OF THE FILE HAS NOT YET OCCURRED
         LI,2     0
         STW,2    RFFTZ             RESET
         STW,2    COPYFLG            INDICATORS
         LI,6     BA(COPYCD)        RESTORE
         LW,7     ASORIMAG           SAVED
         MBS,6    0                   LINES
         MTB,1    EXNAME                                                SCAN
         B        LEOFA
READRFFA RES      0
         LW,2     RFFRC             HAS THE END OF THIS FILE
         CW,2     RFFTC,1            BEEN REACHED?
         BNE      READRFFB          NO - GO TO READ ANOTHER LINE
         LW,1     ATMPBUF           SUPPLY A
         MBS,0    BA(BLANKS)         BLANK LINE
         LI,2     -1                SET A FLAG TO
         STB,2    RFFTZ              DENOTE END OF FILE
         B        RDCARDA
READRFFB RES      0
         LI,2     BA(TMPBUF)        READ A RECORD
         BAL,11   RDRFF              FROM THE RFF
         MTW,1    RFFRC             INCREMENT RECORD-COUNT
         B        RDCARDA
*    PROCESS ABNORMAL RETURN FROM M:SI
NOREAD   RES      0
         LB,R7    R10               PICK UP MONITOR ABNORMAL CODE
         CI,R7    5
         BE       EOF               END-OF-DATA
         CI,R7    6
         BE       EOF                                                   SCAN
ABNER    CI,R7    7                                                     SCAN
         BNE      ABNERR            UNWANTED ABN RETURN                 SCAN
         LI,1     284               SOURCE IMAGE TOO BIG                SCAN
         B        EOF0                                                  SCAN
EOF      LH,R7    PDBXA             CHECK SOURCE LINE = 0               SCAN
         BG       EOF1              NO                                  SCAN
         LI,1     21                                                    SCAN
EOF0     BAL,11   DIAG              DIAGNOSTIC                          SCAN
         LI,R7    -1                                                    SCAN
         STW,R7   PHASEF            SET ABORT FLAG                      SCAN
         B        PHASE1                                                SCAN
EOF1     MTW,1    SOREND            FLAG END OF SOURCE INPUT            SCAN
         CAL1,1   SI%CLOSE                                              SCAN

         MTW,0    SO%SEQ                                                SCAN

         BE       %+2                                                   SCAN
         CAL1,1   SO%CLOSE                                              SCAN

         CAL1,1   SI%OPEN                                               SCAN

         B        NO%SO                                                 SCAN

*    BLANK OUT TRAILING BUFFER FOR VARIABLE LENGTH RECORD
CKVR     LI,3     BA(TMPBUF)
CKVR0    LW,2     4,1
         AND,2    L(X'FFFE0000')    GET ARS
         CW,2     L(X'FFFE0000')
         BNE      CKVR1
         LW,2     13,1              GET RWS
         B        CKVR2
CKVR1    SCS,2    15
CKVR2    AI,2     -1
         CI,2     80                IS RECORD LARGE ENOUGH
         BGE      *R10              ..GET ON OUT                        SCAN

         AW,3     2
         LB,1     0,3
         CI,1     X'40'             TRUNCATE NON ACCEPTABLE
         BL       CKVR4                 CH AARACTERS                    SCAN

         AI,R2    1                                                     SCAN

         AI,3     1
CKVR4    LW,1     3
         LI,3     80
         SW,3     2                 LEGTH TO BLANK OUT
         STB,3    1
         MBS,0    BA(BLANKS)        BLANK OUT FROM N TO COL 72
         B        *R10
ATMPBUF  GEN,8,24 80,BA(TMPBUF)
SO%OUT   GEN,8,24 X'11',M:SO                                            SCAN

         GEN,8,24 X'38',X'30'                                           SCAN

         DATA     TMPBUF                                                SCAN

         GEN,4,28 8,2                                                   SCAN

         DATA     SO%SEQ                                                SCAN

SO%CLOSE GEN,8,24 X'15',M:SO                                            SCAN

         DATA     X'80000000',2                                         SCAN

SI%CLOSE GEN,8,24 X'15',M:SI                                            SCAN

         DATA     X'80000000',2                                         SCAN

SI%OPEN  GEN,8,24 X'14',M:SI                                            SCAN
         DATA     X'40000'                                              SCAN
         DATA     X'10000'                                              SCAN
         TITLE    'COPY LIBRARY ROUTINE'
LIBCPY   LW,1     RFFTZ             IS RENAMING IN PROCESS
         BGZ      SADYES            YES - DO NOT COPY
         LW,1     COPYFLG
         BGEZ     %+2
         LI,1     0
         LI,2     BA(TMPBUF)        SAVE
         LW,3     ESTACK,1             SOURCE
         MBS,2    0                          CARD
         AI,1     1                 PUSH ANOTHER LEVEL
         CI,1     COPYLVL
         BG       COPYLIB2          NESTED TOO DEEP
         LI,2     0
         STW,2    DSTACK,1
         LW,7     CSTACK,1
         LW,R2    R7
         LW,3     CSBSNWD           BYTE LENGTH
         SLS,7    2
         STB,3    5,7               DISP TO FILE-NAME POSITION
         AI,7     21
         STB,3    7
         LI,6     BA(REPRG)         FILE-NAME SAVED AREA BA
         MBS,6    0
         CI,1     1
         BE       LIBCPY1           1ST COPY LEVEL-NO FILE TO CLOSE
         CAL1,1   PLIST6            M:CLOSE  M:LIB
LIBCPY1  LW,R3    PDBZ              POINT TO ACCT TBL START
         AI,R3    1
         LI,R6    X'40'
         CB,R6    *R3               CHECK TAPE ACCT
         BE       LIABN             NO
         LI,R6    2                 READ TAPE
         LI,R7    3                 SET LABEL INDICATOR
         STS,R6   1,R2               IN FPT
LIBCPY2  LW,R6    0,R3              MOVE ACCT NUMBER
         STW,R6   14,R2
         LW,R6    1,R3               TO OPEN FPT
         STW,R6   15,R2
         EXU      CSTACK,1          M:OPEN  M:LIB,(FILE,   )
         STW,1    COPYFLG
         STW,1    COPYFST
         MTW,0    FREPC
         BEZ      SADYES
         LI,R6    1
         STW,R6   REARF
         STW,R6   FCARD
         LW,R6    REPNBA
         STW,R6   REPSBA            REPLACED CARD ADDR
         AI,R6    432
         STW,R6   REPLBA            START ADDR FROM LIBRARY
         B        SADYES
*
COPYLIB2 RES      0
         LI,1     109               EXCESSIVE NESTING OF COPY STMTS.
         BAL,11   DIAG
         B        SADNO
*
*    ABNORMAL RETURN FROM M:OPEN OF M:LI COMES HERE
LIABN    RES      0
         AI,R3    2                 UPDATE TO NEST ACCT
         LI,R6    X'40'
         CB,R6    *R3               IF NON BLANK
         BNE      LIBCPY2           LIBRARY FILE IS FOUND
         LI,1     117               INVALID LIBRARY RETRIEVAL STMT
         B        COPYLIB2+1
*
*    ABNORMAL RETURN FROM M:READ OF M:LI COMES HERE
LIBEOF   RES      0
         LB,7     10                ABN CODE
         CI,7     6
         BNE      ABNERR            UNWANTED ABN RETURN
LEOF     RES      0
         CAL1,1   PLIST6            M:CLOSE
         MTW,-1   COPYFLG           POP ONE LEVEL
         LW,7     COPYFLG
         LW,2     ESTACK,7          RESTORE
         LW,3     ATMPBUF            SAVED
         MBS,2    0                   CARD
         LW,7     COPYFLG
         BNEZ     LEOFB             STILL COPYING
         MTW,0    SOREND            END OF SOURCE PRIOR TO START OF COPY
         BEZ      LEOFA              NO
         LI,R2    1                 SET EOF FOLLOW COPY FLAG
         STW,R2   TMPBUF
         B        RDCARDA
LEOFA    MTW,-1   COPYFLG
         B        RDCARDA           RETURN TO SOURCE PROGRAM LEVEL
LEOFB    EXU      CSTACK,7          EXECUTE M:OPEN
         LW,15    DSTACK,7          GET
         STW,15   PLIST7+2           RECORD-COUNT
         CAL1,1   PLIST7            M:PRECORD  M:LIB
         B        RDCARDA           RETURN TO LOWER LEVEL OF COPYING
*
SRKWD    RES      0
         LI,2     1                 SET TO
         STB,2    SKIP,2             SKIP PAST NEXT PERIOD
         LI,2     0                 RESET
         STB,2    NOSCAN             NOSCAN
         BAL,11   SCAN
         MTB,1    SKIP              SET TO SKIP TO NEXT CARD
         BAL,11   SCAN
         B        *15               RETURN
READRTN  RES      1
REGS     RES      16                REGISTER SAVE AREA
SLCI     GEN,32   X'00040400'
*   TEMPORARY PRINTOUT OF SOURCE CODE
*
LISTSCAN RES      0
         LB,R7    BYTESNWD          PUT
         BNEZ     %+2                BYTE-COUNT
         LI,R7    1                   INTO
         STW,R7   PLIST3+3             PLIST
         CAL1,1   PLIST3            LIST CONTENTS OF STRING
         B        *R10              RETURN
PLIST1   GEN,8,24     X'10',M:SI
         DATA     X'70000010'
         DATA     NOREAD
         DATA     TMPBUF
         DATA     140               SIZE                                SCAN
PLIST2   GEN,8,24  X'11',M:LO
         DATA     X'30000010'
         DATA     SORIMAG           BCD BUFFER
         DATA     80                PRINT OUT FULL CARD IMAGE
PLIST3   GEN,8,24   X'11',M:LO
         DATA    X'30000010'
         DATA     STRING
         DATA     1                 VARIABLE STRING BUFFER COUNT
PLIST4   GEN,8,24 X'10',M:LI        M:READ
         DATA     X'70000010'
         DATA     LIBEOF            ABN
         DATA     TMPBUF            BUFF
         DATA     140               SIZE                                SCAN
*
PLIST6   GEN,8,24 X'15',M:LI        M:CLOSE
         DATA     X'80000000'
         DATA     2                 SAVE
*    CSTACK CONTAINS A CAL1,1 INSTRUCTION FOR EACH PERMISSIBLE LEVEL
*      OF LIBRARY RETRIEVAL
*
CSTACK   EQU      %-1
NESTL    DO       COPYLVL
         CAL1,1   PLIST8+((PLIST8E-PLIST8)/COPYLVL)*(NESTL-1)  M:OPEN
         FIN
*    PLIST8 CONTAINS AN OPEN PROCEDURE PLIST FOR EACH PERMISSIBLE LEVEL
*      OF LIBRARY RETRIEVAL
PLIST8   RES      0
         DO       COPYLVL
         GEN,8,24 X'14',M:LI        M:OPEN   M:LI,(FILE,    )
         DATA     X'41000009'
         DATA     LIABN             ABN
         DATA     1
         GEN,8,8,8,8  1,0,8,8
         RES      8
         DATA     X'02010202'
         DATA     0,0               ACCT NUMBER
         FIN
PLIST8E  EQU      %
*    DSTACK CONTAINS ONE WORD FOR EACH PERMISSIBLE LEVEL OF LIBRARY
*      RETRIEVAL IN WHICH THE RECORD POSITION IS PRESERVED
DSTACK   EQU      %-1
         RES      COPYLVL
*    ESTACK CONTAINS A POINTER TO THE SAVED CARD BUFFER FOR EACH
*      LIBRARY RETRIEVAL LEVEL
ESTACK   RES      0
NESTP    DO       COPYLVL
         GEN,8,24 80,BA(COPYCD+20*(NESTP-1))
         FIN
*    COPYCD CONTAINS A SAVED CARD BUFFER FOR EACH LIBRARY RETRIEVAL
*      LEVEL
COPYCD   RES      0
         DO       COPYLVL
         RES      20
         FIN
PLIST7   GEN,8,24 X'1D',M:LI        M:PRECORD
         DATA     X'80000000'
         DATA     0                 MODIFIED - SET BEFORE EACH USE
*    PLIST FOR INITIALIZING THE RFF
RFFPFIL  GEN,8,24 X'1C',F:W5        M:PFIL     F:W5,(BOF)
         DATA     X'10'             BOF
*    PLIST FOR REPOSITIONING THE RFF
RFFPREC  GEN,8,24 X'1D',F:W5        M:PRECORD  F:W5,(N,?)
         DATA     X'80000000'
         DATA     0                 RECORD-COUNT - MODIFIED BEFORE USE
*    TABLE OF RENAMED FILE ID'S
RFFTA    EQU      %-1
         DO       RENAMLVL
         DATA     0
         FIN
*    TABLE OF RENAMED FILE LEADING RECORD POSITIONS
RFFTB    EQU      %-1
         DO       RENAMLVL
         DATA     0
         FIN
*    TABLE OF RENAMED FILE FINAL RECORD POSITIONS
RFFTC    EQU      %-1
         DO       RENAMLVL
         DATA     0
         FIN
RFFTI    DATA     0
RFFRC    DATA     0                 RFF RECORD COUNT
RFFTZ    DATA     0
SCANRFFX DATA     0                 RETURN ADDRESS OF SCANRFF SUBROUTINE
         TITLE    'HASH-DATA NAME TABLE BUILDING AND LOOKUP ROUTINE'
         PAGE
*******
*
*  HASH- BUILDS DNT
*      - LOOKS UP REFERENCE NUMBERS FOR NAMES
*
*      - INDEXES ON HASHNUM CALCULATED BY HASHIT
*
*              WHERE INDEX =((WD(1)+WD(N))/127)25-31
*      - INPUT - STRING,BYTESNWD(BYTE0) AND HASHNUM
*      - OUTPUTS REFERENCE NUMBER IN HASHNUM OR
*          IF  DNT OVERFLOW, THE HASH INDEX IS OUTPUT IN HASHNUM
*          WITH BYTE0=8 ,IE. HASHNUM <0
*
*      - SAVES NO REGISTERS
*      - USES R2,R5,R6,R7,R8,R9,R10,R15
*
*******
FREN     RES      0
HASH     EQU      FREN
         STW,R10  RETURN
         LB,R5    BYTESNWD          BYTES IN STRING
         LW,R6    HASHNUM           LOCATE INITIAL LINKAGE
         AW,R6    HA%DNTIX        IN THE HASH TABLE                     SCAN

         B        NOLINK
*
LNKAGE   RES      0
         LH,R6    0,R6            LINK                                  SCAN

         AW,R6    HA%DNT              PLUS BASE                         SCAN

         CH,R5    1,R6
         BE       COMPAREB
*
NOLINK   RES      0
         LH,R2    0,R6
         BNEZ     LNKAGE
         LW,R7    DNTPNTR
         AW,R7    HA%DNT          TABLE                                 SCAN

         CW,R7    HA%DNTND         FULL...                              SCAN

         BLE      HASHOK
         LI,7     X'C00'
         LB,2     PDBCC             IS PHASE 1.4
         CI,2     X'05'              CURRENT?
         BNE      %+2                NO - FLAG BOTH EDF & EPF
         LI,7     X'400'             YES - FLAG EPF ONLY
         STS,7    PDBP              RECORD DNT OVERFLOW IN PDB
         LI,R7    X'80'
         STB,R7   HASHNUM           SIGNAL HASH RATHER THAN REF NO9
         B        *RETURN
*
*
* R7=ABSOLUTE HALF WORD ADDRESS OF NEW ENTRY
*
HASHOK   RES      0
         LW,R8    DNTPNTR
         STH,R8   0,R6              SET THE LINK
         LW,R8    R5
         AI,R8    1
         SLS,R8   -1
         AI,R8     3                SUM OF LINK,REF NR,BYTE LENGTH,NME
         AWM,R8   DNTPNTR           UPDATE DNT POINTER
         MTH,3    PDBL              GET NEXT REFERENCE-NUMBER
         LH,8     PDBL
         STW,R8   HASHNUM
         LW,R6    R7
         AI,R6    1
         STH,R8   0,R6              NEW ENTRY REFERENCE NUMBER
         LI,R15   0
         STH,R15  0,R7              NEW ZERO LINK
         STH,R5   1,R7              LENGTH NEW BYTE ADDRESS
         AW,R7    R7                BYTE ADDRESS
         AI,R7    6                 POINTS TO HW(4) OF ENTRY
         STB,R5   R7                COUNT IN BYTES TO MOVE
         LI,R6    BA(STRING)
         MBS,R6   0
         LI,14    X'2006'
         AND,14   PDBCC              SPECIFIED?
         REF      ON:LINE                                               SCAN
         OR,14    ON:LINE                                               SCAN
         BEZ      *RETURN                                               SCAN
*    BUILD AND OUTPUTXRF NAME CLUSTER
         STW,8    XRFCL             REFERENCE-NUMBER
         LI,6     BA(STRING)        PREPARE
         LI,7     BA(XRFCL)+5        NAME-STRING
         STB,5    XRFCL+1             AND
         STB,5    7                    LENGTH-COUNT
         MBS,6    0                 MOVE NAME INTO CLUSTER AREA
         AI,5     7                 COMPUTE
         SLS,5    -1                 HALF-WORD LENGTH
         STB,5    XRFCL               OF CLUSTER
         STW,4    SAVE4             SAVE R4
         LI,4     BA(XRFCL)            AND OUTPUT IT
         BAL,11   WRXRF
         LW,4     SAVE4             RESTORE R4
         B        *RETURN           EXIT
*
COMPAREB RES      0
         LW,R9    R6                FORM THE
         SLS,R9   1                 BYTE ADDRESS                        SCAN

         AI,R9    6                     OF NAME-STRING
         STB,R5   R9                SET THE LENGTH COUNT
         LI,R8    BA(STRING)
         CBS,R8   0                 COMPARE THE STRINGS
         BNE      NOLINK            UNEQUAL - GO TO FOLLOW THE CHAIN
         AI,R6    1
         LH,R7    0,R6
         STW,R7   HASHNUM
         B        *RETURN
*    CROSS-REFERENCE LISTING (XRF) CLUSTER AREA
XRFCL    DATA     0
         RES      8
DNTPNTR  DATA     68                NEXT DNT POINTER
         END
