CSECT    CSECT
         SYSTEM   BPM
         SYSTEM   SIG7FDP
HEADER   EQU      '* ** *** METAFUMBLE VERSION 6 *** ** *'
         TITLE    HEADER
MF#DATE  EQU      X'081978'         DATE OF LAST UPDATE
*
***
*  METAFUMBLE IS A PROGRAM DESIGNED TO HELP THE SYSTEMS PROGRAMMING
*   STAFF IN A MAINTENCE FUNCTION BY REDUCING THE CONTROL CARDS
*   REQUIRED TO UPDATE A SYSTEM OR PROCESSOR OR ANY PROGRAM MADE UP
*   OF A LARGE NUMBER OF METASYMBOL ASSEMBLIES.
*
*
*  METAFUMBLE WAS ORIGINALLY WRITTEN BY H. GARDNER ROWLEY II (XEROX)
*
*  SIGNIFICANT IMPROVEMENTS AND CORRECTIONS HAVE BEEN MADE BY:
*
*      GORDON P. PATNUDE  (SMTS)
*      COMPUTER SCIENCES CORPORATION
*      FIELD SERVICES DIVISION
*      1101 SAN ANTONIO ROAD
*      MOUNTAIN VIEW, CALIF.  94040
*
*   IN CO-OPERATION WITH:
*
*      MARTIN M. FOGEL, JR.
*      XEROX CORPORATION
*      MARINA PLAYA EXECUTIVE OFFICE CENTER
*      1333 LAWRENCE EXPRESSWAY
*      SANTA CLARA, CALIF.   95051
*
*  ONLINE FEATURES, IA(,N) AND
*  .ASI,.ACI,.ALL,.MCI OPTIONS ADDED BY:
*
*      PETER A. RUMSEY (XEROX)
*
***
*
          PAGE
***
*
* PROGRAM DEFINITIONS
*
***
          DEF       CHKMOD
          DEF       INSERT
          DEF       JOBENT
          DEF       METAFUMBLE,MF#DATE,MF#EXIT
          DEF       #PATCH,#SIZE
*  PROGRAM FLAGS THAT ARE USEFUL:
*    XXFLG - DCB/OPTION FLAGS
*      BIT0=1 IF FILE/LABEL ASSIGN AND OPTION ON METAFUM CARD
*      BIT1=1 IF OPTION ON METAFUM
*      BIT2=1 (LOFLG ONLY) IF CL OPTION ON METAFUM
*      BIT16=1 IF ASSIGN
*    FLGS (WORD 5 OF LISTFILE ENTRY)
*      BIT0=1 => NORMAL ASSEMBLY
*      BIT1=1 => ASSEMBLE CI,BO
*      BIT2=1 => DEVICE SI (BETWEEN :NAME CARDS)
*      BIT3=1 => :NAME CARD RECEIVED FOR THE THING
*      BITS4-15=3 => DEVICE CI (BETWEEN :NAME CARDS)
*      BITS16-31='F' => FORTRAN MODULE
          PAGE
***
*
*  PROCEDURES FOR ASSEMBLY TIME GENERATION
*
***
*
*  BSMODE CONTROLS THE ASSEMBLY OF TWO BYTE-STRING MANIPULATION
*   ROUTINES.  IF BSMODE IS 'OFF' THEN THE ROUTINES ARE ASSEMBLED
*   SUCH THAT METAFUMBLE WILL RIN ON A SIGMA-5 WITHOUT THE BYTE-STRING
*   SIMULATION ROUTINES IN THE MONITOR.
*
OFF      EQU      0
ON       EQU      1
BSMODE   EQU      ON
TEXTX    CNAME
         PROC
         BOUND    8
P        SET      %
LF(1)    TEXT     AF(1)
         PEND
FILL     CNAME
         PROC
Q        SET      %
R        SET      20-(Q-P)
         DO       R>=0
LF(1)    EQU      %
         LIST     0
         DO1      R
         TEXT     '    '
         LIST     1
         ELSE
         ERROR,3,1 'TEXT STRING TOO LONG TO EXTEND'
LF(1)    EQU      %
         FIN
         PEND
         REF      M:C
         REF      M:PO
          PAGE
M:SI     DSECT    1
M:SI     M:DCB    IN,LABEL,INSN,OUTSN,PASS,SAVE,(BUF,SIASS)
          PAGE
M:EI     DSECT    1
M:EI     M:DCB    IN,LABEL,INSN,OUTSN,PASS,SAVE
          PAGE
M:E0     DSECT    1
M:E0     M:DCB    (FILE,'999'),OUTIN,KEYED,REL,DIRECT,(KEYM,15),;
                  (BUF,BUF1),(RECL,120)
         PAGE
M:P0     DSECT    1
M:P0     M:DCB    (FILE,'999FUMSAVE'),SAVE,(BUF,CHKSUM),(RECL,8),;
                                      OUTIN
          PAGE
M:EO     DSECT    1
M:EO     M:DCB    (OUT),(LABEL),(INSN),(OUTSN),(PASS),(SAVE)
          PAGE
M:BO     DSECT    1
M:BO     M:DCB    OUT,LABEL,INSN,OUTSN,PASS,SAVE,(BUF,BOASS)
          PAGE
M:LO     DSECT    1
M:LO     M:DCB    OUT,LABEL,INSN,OUTSN,PASS,SAVE,(BUF,LOASS)
          PAGE
M:CI     DSECT    1
F:JOB     EQU       M:CI
M:CI     M:DCB    IN,LABEL,INSN,OUTSN,PASS,SAVE,(BUF,CIASS)
          PAGE
M:CO     DSECT    1
M:CO     M:DCB    OUT,LABEL,INSN,OUTSN,PASS,SAVE,(BUF,COASS)
          PAGE
M:SO     DSECT    1
M:SO     M:DCB    OUT,LABEL,OUTSN,PASS,SAVE,INSN,(BUF,SOASS)
          PAGE
M:LIST   DSECT    1
M:LIST   M:DCB    IN,(FILE,'LISTFILE',8),INSN,PASS,SAVE
         ORG      M:LIST+19
         GEN,8,24 20,M:C
         DATA     X'40000001',ASS00
         USECT    CSECT
         PAGE
*        CONSTANTS AND TABLES
#PATCH    RES       10             BUILT IN PATCH AREA
DOT       EQU       '.'
IAFLAG   DATA     0                 INDIVIDUAL ASSEMBLIES FLAG
2PRINT   DATA     0                 TWO PRINTER FLAG
E0KEY    DATA     X'7000000',0
TSTACK   RES      1
NXTCN    DATA     0
MAXCN    DATA     -CNSIZ-6
CNS      EQU      2
FLGS     EQU      5
TITLE    EQU      6
CNSIZ    EQU      10
Y1       DATA     X'10000000'
Y2       DATA     X'20000000'
Y4       DATA     X'40000000'
Y8       DATA     X'80000000'
CNFLG    DATA     0
BUF1     TEXTX    '!JOB '
         FILL
BUF3     RES      20
BUF2     DATA     0
         RES      19
SOASS    TEXTX    '!ASSIGN M:SO,('
         FILL
SOSN     DATA     0,0
SOFLG    DATA     0,0
CHKSUM   DATA     0
1STCN    DATA     0
BUF2FULL DATA     0
BOTOBO   TEXTX    '!ASSIGN M:BO,(DEVICE,BO)'
         FILL
LOTOLO   TEXTX    '!ASSIGN   M:LO,(DEVICE,LO)'
         FILL
METABO   TEXTX    '!METASYM CI,BO'
METABO1  EQU      %
         FILL
META     TEXTX    '!METASYM '
META1    FILL
FORCD    TEXTX    '!FORTRAN SI,BO'
         FILL
FORSOCD  TEXTX    '!ASSIGN   M:SO,(SAVE),(FILE,'
FORSO1   TEXT     '999SODUM'
FORSO2   TEXT     '        '
FORSO3   TEXT     ')'
         FILL
FORSICD  TEXTX    '!ASSIGN    M:SI,(REL),(FILE,'
FORSI1   TEXT     '999SODUM'
FORSI2   TEXT     '        '
FORSI3   TEXT     ')'
         FILL
FORMETA  TEXTX    '!METASYM SI,CI,SO'
FORMETA1 EQU      %
         FILL
SUPCLSCD TEXTX    '!LDEV L1'
         FILL
SBADD    DATA     0
SCADD    DATA     0
TITFLG   DATA     0
TITCD     TEXTX     '!TITLE  **********'
TITCD1   FILL
         BOUND    8
LASTBO   RES      2
MATCHCN  DATA     0
MULTCI   DATA     0
DATAIG   DATA     0
ALLFLG   DATA     0
LIMFLG    DATA      0
SUPFLG   DATA     0
LOASSNPTR DATA    LOASSN
2PRLOCD  TEXTX    '!ASSIGN M:LO,(DEVICE,'
2PRLOCD1 TEXT     '         )'
LINES    EQU      %
         FILL
         BOUND    8
LOASSN   EQU      %
         DO1      10                10 PRINTERS MAX
         TEXT     '        '
*
OPNSO    GEN,8,24 X'14',M:SO
         DATA     X'01400000'
         DATA     2                 OUT
         DATA     2                 SAVE
         DATA     X'01010505'
SONAME   RES      5
*
SIASS    TEXTX    '!ASSIGN M:SI,('
         FILL
SISN     DATA     0,0
SIFLG    DATA     0,0
*
SITOSI   TEXTX    '!ASSIGN M:SI,(DEVICE,SI)'
         FILL
DEVSIFLG DATA     0
*
BOASS    TEXTX    '!ASSIGN M:BO,('
         FILL
BOBN     DATA     0,0
BOFLG    DATA     0,0
DUMCNT   DATA     0
LODUM    TEXTX    '!ASSIGN   M:LO,(SAVE),(FILE,'
LODUM1   TEXT     '999LODUM'
LODUM2   TEXT     '        '
LODUM3   TEXT     ')'
         FILL
EIDUM    TEXTX    '!ASSIGN    M:EI,(REL),(FILE,'
EIDUM1   TEXT     '999LODUM'
EIDUM2   TEXT     '        '
EIDUM3   TEXT     ')'
         FILL
UTIL     TEXTX    '!UTILIST'
         DATA     0
         FILL
LOASS    TEXTX    '!ASSIGN M:LO,('
         FILL
LOLN     DATA     0,0
LOFLG    DATA     0,0
EODCD    TEXTX    '!EOD'
         FILL
DOTENDCD TEXTX    '.END'
         FILL
DIOFLG   DATA     0
DIOCD    RES      20
DSSFLG   DATA     0
DSSCD    RES      20
DOSFLG   DATA     0
DOSCD    RES      20
DDSFLG   DATA     0
DDSCD    RES      20
PENDCD   TEXTX    '+END'
         FILL
         BOUND    8
STTCD    TEXT     'START'
STPCD    TEXT     'STOP '
MONTEXT  TEXT     'M:MON'
BJOB     TEXT     '!JOB'
STTFLG   DATA     0
NXTOPT   DATA     BA(META1)
EXTRAS   DATA     0
2COPFLG  DATA     0
CIASS    TEXTX    '!ASSIGN M:CI,('
         FILL
CICN     DATA     0,0
CIFLG    DATA     0,0
CINOCD   TEXTX    '!ASSIGN M:CI,(DEVICE,CI)'
         FILL
COASS    TEXTX    '!ASSIGN M:CO,('
         FILL
COCN     DATA     0,0
COFLG    DATA     0,0
COTOCO   TEXTX    '!ASSIGN M:CO,(DEVICE,CO)'
         FILL
COTONO   TEXTX    '!ASSIGN M:CO,(DEVICE,NO)'
         FILL
NOCOFLG  DATA     0
NOENT    DATA     0
*
*
BPMUTSFLAG DATA   0
SLEEP    GEN,8,24 15,25
VERSION  TEXTC    HEADER
         PAGE
*
* ANALYZE THE DCB'S FOR CHANGES FROM
*  ASSIGN CARDS.  ANY CHANGES CAUSE
*  CONSTRUCTION OF A PARAMETER FOR
*  THE CORRESPONDING ASSIGN CARD.
*  THE PRESENCE OF AN ASSIGN CARD FOR THE
*  M:SO DCB WILL CAUSE METAFUM TO PUT
*  UPDATE OUTPUT TO FILE OR TAPE FOR
*  LATER USE.
*
METAFUMBLE  RES     0              DA BEGINNING OF DA END
          STW,0     TSTACK         OUR VERY OWN TSTACK
         M:TRAP   (IGNORE,FX)
         LW,1     X'2B'             GET SYSTEM ID FLAG WORD
         AND,1    Y2                IS UTS RUNNING?
         BEZ      XSTART0           NO, DON'T SET FLAG
         M:PC     '>'
         STW,1    BPMUTSFLAG        YES, SAVE IS WORD
         LC       *X'4F'
         BCR,8    XSTART0
         STCF     BPMUTSFLAG
         LW,1     M:LL+1
         CI,1     X'FF00'
         BANZ     XSTART0
         MTB,-2   PRNTBUF1
         MTB,-2   PAGE
         MTB,-2   B2PRNT
         B        XSTART0+2
XSTART0  RES
PAGE     M:DEVICE M:LL,PAGE
         M:PRINT  (MESS,VERSION)
         LI,15    M:EI
         BAL,10   CHKCHG            CHECK FOR CHANGE
         BNE      INSERT            CHANGED, JUST INSERT JOB
         LI,1     80
         CAL1,1   E0WRT             WRITE A JOB CARD
         LI,7     2
         LI,1     3
         CS,1     M:C
         BNE      ASS0
         LI,1     2
         CW,1     M:LIST
         BANZ     L0
         CAL1,1   M:LIST+19         OPEN M:C TO THE LISTFILE
ASS0     BAL,10   READC
         LB,4     BUF1
         CI,4     '!'
         BE       ASS01
         CAL1,1   CLSC
ASS00    CAL1,1   OPNC
         CAL1,1   CLSC
         B        L0
ASS01    LI,1     -1
         LW,9     =X'8000040'
         BAL,10   NXS
         SD,2     BOTOBO
         BNE      L0
         STW,2    ASSFPT+1
         STB,2    ASSSN,7
         STB,2    ASSAC,7
         LW,9     =X'400006B'
         BAL,10   NXS
         LI,3     #DCB
         CW,2     DCBT,3
         BE       %+3
         BDR,3    %-2
         B        ASSERR
         LW,15    DCBT-1,3
         BAL,10   CHKCHG
         BNE      ASS0
         LI,7     2
ASS1     BAL,10   NXC
         CI,8     '('
         BNE      ASSERR
         LW,9     =X'600006B'
         BAL,10   NXS
         LI,4     #ASSO
         CD,2     ASSO,4
         BE       %+3
         BDR,4    %-2
         B        ASSERR
         CI,4     3
         BG       ASS3
         AI,4     X'7000'
         XW,4     ASSFPT+1
         BNEZ     ASSERR
         LW,9     =X'C006B5D'
         BAL,10   NXS
         SLD,4    -8
         STB,3    4
         SLD,2    -8
         STB,6    2
         LCI      4
         STM,2    ASSFN
         CI,8     ','
         BNE      ASS2
         STB,7    ASSAC,7
         LW,9     =X'800005D'
         BAL,10   NXS
         LCI      2
         STM,2    ASSAC+1
ASS2     BAL,10   NXC
         BE       ASS4
         CI,8     ','
         BE       ASS1
ASSERR   EXU      PRNTBUF1
         M:PRINT  (MESS,ASSERRM)
         M:ERR
ASSERRM  TEXTC    'BAD ASSIGN CARD'
ASS3     LI,5     1
         MTB,0    ASSSN,7
         BNEZ     ASSERR
ASS31    RES
         LW,9     =X'4006B5D'
         BAL,10   NXS
         STW,2    ASSSN,5
         STB,5    ASSSN,7
         CI,8     ')'
         BE       ASS2
         AI,5     1
         CI,5     3
         BLE      ASS31
         B        ASSERR
ASS4     LW,0     ASSFPT+1
         BE       ASSERR
         EXU      PRNTBUF1
         CAL1,1   ASSFPT
         B        ASS0
ASSFPT   DATA     X'9400000F',0,0,X'1000404'
ASSFN    RES      4
ASSAC    DATA     X'2000002',0,0
ASSSN    DATA     X'7010003',0,0,0
DCBT     DATA     M:SI,'M:SI'
         DATA     M:SO,'M:SO'
         DATA     M:CI,'M:CI'
         DATA     M:CO,'M:CO'
         DATA     M:LO,'M:LO'
         DATA     M:BO,'M:BO'
#DCB     EQU      %-DCBT-1
         BOUND    8
ASSO     EQU      %-2
         TEXT     'FILE '
         TEXT     'LABEL'
         TEXT     'DEVICE'
         TEXT     'SN   '
         TEXT     'INSN '
         TEXT     'OUTSN'
#ASSO    EQU      DA(%)-DA(ASSO)-1
*
*
NXC      AI,1     1
         CI,1     80
         BGE      *10
         LB,8     BUF1,1
         AI,10    0
         BLZ      *10
         CI,8     ' '
         BE       NXC
         B        *10
*
NXS      LCI      3
         LM,2     BLKS
         LI,6     0
         PSW,10   *TSTACK
         BAL,10   NXC
         BE       ASSERR
         OR,10    Y8
         CB,8     9,7
         BE       NXSX
         CB,9     BUF1,1
         BE       NXSX
         CI,8     ' '
         BE       NXS2
         STB,8    2,6
         AI,6     1
         CB,6     9
         BG       ASSERR
         B        NXC
NXS2     BAL,10   NXC
         BE       ASSERR
         CB,8     9,7
         BE       NXSX
         CB,9     BUF1,1
         BNE      ASSERR
NXSX     AI,6     0
         BE       ASSERR
         B        PULLRET
L0       LI,15    M:EO
         BAL,10   CHKCHG
         STCF     NOENT             JUST ENTER JOB TO EO
         LI,15    M:BO
         BAL,10   CHKCHG
         LI,15    M:LO
         BAL,10   CHKCHG
         LI,15    M:CI              CHECK CI
         BAL,10   CHKCHG
         LI,15    M:CO
         BAL,10   CHKCHG
         LI,15    M:SI
         BAL,10   CHKCHG
L9       LI,15    M:SO
         BAL,10   CHKCHG
         LI,10    L10A
         LI,1     1
         LC       M:C,1
         BCS,2    L10A
READC0   LC       BPMUTSFLAG
         BCR,8    %+2
         M:TYPE   (MESS,WITH)
         PAGE
*
*  NEXT, READ THE METAFUM CARD
*   AND BEGIN TO ANALYZE THE
*   OPTIONS REQUESTED
*
READC    PSW,10   *TSTACK
         M:READ   M:C,(BUF,BUF1),(SIZE,120),(ABN,READCA)
         LI,1     5
         LI,8     0
         XW,8     BUF1
         LC       8
         BCR,14   %+4
         STW,8    BUF1
         LW,1     M:C+4
READCB   SLS,1    -17
         LI,8     X'5040'
         CI,1     80
         BLE      %+2
         LI,8     X'7800'
         AI,1     -121
         CB,8     BUF1+30,1
         BL       %+2
         STB,8    BUF1+30,1
         BIR,1    %-1
         SLS,8    -8
         LI,1     X'FF000'
         CVA,1    BUF1
         AWM,1    CHKSUM
         LW,1     8
         PLW,10   *TSTACK
         MTW,0    BUF1
         B        *10
READCA   LI,1     0
         STW,1    BUF1
         B        *8
WITH     TEXTC    'WITH'
L10A     BE       ASS00-1
         EXU      PRNTBUF1
L11      LI,5     0
         LW,4     NXTOPT
         BAL,10   GETOPT1
         BE       L6
FUMERR0  EQU      %
         BAL,14   ABORT
         TEXTC    'METAFUM CI OPTION REQUIRED'
L6       LC       BUF1,5
         BCR,11   L7
         BDR,5    L6
         AI,5     -1
L7       STW,4    NXTOPT
         BAL,10   GETOPT
         BLZ      OPTDUN            DONE WITH CARD
         LI,1     NUMSPC
         STH,8    8                 EXTEND SIGN
         LH,8     8
         CH,8     SPECOPT,1         LOOK FOR SPECIAL OPTIONS
         BE       SPECJMP,1
         BDR,1    %-2
L8       BAL,10   STOOPT            STORE OPTION IN METASYM CARD
         B        L7
STOOPT   LI,2     ','
         CI,4     BA(META1)         NO COMMA BEFORE 1ST OPTION
         BE       %+2
         STB,2    0,4
         AI,4     1
         SCS,8    -8
         STB,8    0,4
         AI,4     1
         SCS,8    8
         STB,8    0,4
         AI,4     1
         B        *10
SPECOPT  EQU      %
         TEXT     '  CLCNSBSCBOCOACSILOSO.OCIDCRTFL'
SPECJMP  EQU      %-1
         B        SPCL
         B        SPCN
         B        SPSB
         B        SPSC
         B        SPBO
         B        SPCO
         B        SPAC
         B        SPSI
         B        SPLO
         B        SPSO
         B        L7                IGNORE .OPT
         B        SPCI
         B        SPDC              DEFAULT CONCORDANCE
         B        SPRT              REAL-TIME LIBRARY MODULES
         B        SPFL              FLAG LIBRARY MODULES
NUMSPC   EQU      %-SPECJMP-1
*
SPCL     EQU      %                 WANT COMPRESSED LISTING
         LW,15    Y2
         LC       LOFLG
         STS,15   LOFLG
         BCS,6    L7
         LI,10    LOFLG
         LI,8     'LO'              NO LO OPTION IF ALREADY THERE
         B        SPOPT+1
SPCI     LI,10    CIFLG
SPOPT    LW,15    Y4
         STS,15   *10
         LW,15    *10
         SLS,15   16
         STS,15   *10
         B        L8
*
SPDC      RES       0
          LCI       2              SET BIT FOR DC
          STCF      CNFLG          FOR LATER
*
SPCN     MTW,-1   CNFLG             SET CONCORDANCE FLAG
         B        L8
*
SPSO     LW,15    SOFLG
         STH,15   SOFLG
         B        L8
*
SPBO      EQU       %
         LI,10    BOFLG
         B        SPOPT
SPSB     EQU      %                 SEQUENCE BINARY
         LI,15    SBADD
         LW,2     ='(BS,'
SPSB1    EQU      %
         MTW,0    *15               OPTION ONLY ONCE
         BNEZ     L7
         LI,1     4
         STB,2    0,4
         AI,4     1
         SLS,2    -8
         BDR,1    %-3
         STW,4    *15
         AI,4     4
         LI,2     ')'
         STB,2    0,4
         AI,4     1
         B        L7
*
*
SPCO      EQU       %
         LW,8     ='O,CO'
         STW,8    FORMETA1-1
         LI,10    COFLG
         B        SPOPT
*
SPSC     LW,2     ='(CS,'
         LI,15    SCADD
         B        SPSB1
*
*
*                 RTORFLAG ACCEPTABLE VALUES ARE :
*
*                                   1 - (INIT AT PROG EXEC) FOR
*                                       NORMAL FORTRAN LIBRARY
*                                   2 - R/T FORTRAN LIBRARY
*                                   3 - FLAG LIBRARY
*
*
*                 THESE VALUES CORRESPOND TO BYTE 34 IN THE
*                 LIBRARY LISTFILE.
*
*
*
SPRT     EQU      %
         MTW,1    RTORFLAG          SET FLAG &
         LW,1     RTFLB              SET UP ERROR
         STW,1    SPFL                BRANCH
         B        L7
*
SPFL     EQU      %
         MTW,2    RTORFLAG          SAME AS ABOVE
         LW,1     RTFLB               ETC.
         STW,1    SPRT
         B        L7
*
RTFLERR  EQU      %
         BAL,14   ABORT
         TEXTC    'RT AND FL BOTH SPECIFIED'
RTFLB    B        RTFLERR           ERROR BRANCH FOR SETUP
RTORFLAG DATA     1
*
SPAC     EQU      %                 PUT IN ACCOUNT OPTION
         LI,2     ','               PUT AC OPTION ON ALTERNATE METASYM CARD
         STB,2    METABO1
         LI,2     1
         STH,8    METABO1,2
         BAL,10   STOOPT
         LI,2     BA(METABO1+1)
         LW,5     EXTRAS
         LI,10    ')'               LOOK FOR RIGHT PAREN FIRST
SPAC2    AI,5     1
         LB,8     BUF1,5
         CW,8     10
         BNE      SPAC3
         CI,10    ','               FOUND RIGHT CHAR, IF COMMA THEN DUN
         BE       L7                ELSE LOOK FOR COMMA NOW
         LI,10    ','
SPAC3    EQU      %
         CI,8     ' '
         BE       L7
         STB,8    0,4
         STB,8    0,2
         AI,2     1
         AI,4     1
         B        SPAC2
*
SPSI     EQU      %
         LI,10    SIFLG
         B        SPOPT
*
SPLO     EQU      %
         LW,15    Y4
         B        SPCL+1
          PAGE
GETOPT   EQU      %                 GET AN OPTION
         AI,5     1
         CI,5     72
         BGE      GETDUN
         LB,8     BUF1,5
         CI,8     ' '               DON'T USE BLKS FOR OPTION
         BE       GETOPT
         SLS,8    8
         AI,5     1
         LB,1     BUF1,5
         OR,8     1
         STW,5    EXTRAS            REMEMBER WHERE EXTRA STUFF IS
GETOPT1  LI,1     ','
         AI,5     1
         CI,5     71
         BG       *10
         CB,1     BUF1,5
         BE       *10
         B        GETOPT1
GETDUN   LI,1     -1                SET CC
         B        *10
         PAGE
*
*
CHKCHG   EQU      %                 CHECK IF DCB AT *15 HAS CHANGED
         PSW,10   *TSTACK
         LI,7     2
         BAL,10   FNDTYP            GET ADDRESS OF ACCOUNT TO R11
         NOP
         LW,11    9
         LI,2     3                 CHECK IF NOT LABEL THEN CHANGED
         AND,2    *15
         CI,2     2
         BNE      CHKASS
         LI,7     1
         BAL,10   FNDTYP            FIND FILE/LABEL NAME
         B        PULLRET           NO NAME => NOT CHANGED
         LI,7     -2
         LB,7     *9,7
         BNEZ     CHKASS            ZERO => NOT CHANGED
PULLRET  PLW,10   *TSTACK
         LCI      0
         B        *10
PULLRET1 PLW,10   *TSTACK
         LCI      3
         B        *10
         PAGE
GTNAME   PSW,10   *TSTACK
         LI,7     1
         BAL,10   FNDTYP
         B        PULLRET
         LCI      4
         LM,2     *9
         LB,6     2
         MTB,-2   2
         BNEZ     GTNAM1
         LB,3     2,6
         CI,3     'N'
         BNE      PULLRET
         SLS,2    -8
         STW,2    *11
         B        PULLRET
GTNAM1   SCD,4    8
         STB,5    2
         SCD,2    8
         AI,6     -16
         LI,0     0
         STB,0    6,6
         BIR,6    %-1
GTNAM2   CW,3     ='NAME'
         BE       GTNAM3
         SLD,4    -8
         STB,3    4
         SLD,2    -8
         MTB,0    3
         BNEZ     GTNAM2
         B        PULLRET
GTNAM3   OR,2     BLKS
         STW,2    *11
         AI,11    1
         STW,4    *11
         B        PULLRET
         PAGE
*
FNDTYP   EQU      %                 R7 HAS TYPE TO FIND
         LCI      3                 R15 HAS DCB ADDRESS
         PSM,1    *TSTACK           R9 RETURNS ADDRESS
         LI,2     3
         LI,1     6
         LW,1     *15,1             GET FLP
FNDTYP1  CB,7     *1
         BE       RET
         LB,3     *1,2
         AW,1     3
         AI,1     1
         B        FNDTYP1
RET      LI,2     2                 GET # OF SIGNIFICANT BYTES
         LB,3     *1,2              FROM VLP
         BEZ      %+2               ANYTHING GOOD HERE?
         AI,10    1                 YUP, TELL EM.
         LI,9     1
         AW,9     1
RET1     LCI      3
         PLM,1    *TSTACK
         B        *10
*
         BOUND    8
TIME     RES      4
KEY      RES      4
BLKS     EQU      %
         DO1      8
         TEXT     '    '
         PAGE
CHKASS   LI,6     2
         LI,3     X'1FFFF'
         AND,3    *15,6
         BEZ      PULLRET1
         STW,2    23,3
         CI,2     3
         BE       PULLRET1
         LI,4     X'8000'
         STW,4    22,3
         LD,4     ASSO,2
         SLS,3    2
         AI,3     14
         AI,5     ','-' '
         BAL,10   BASS
         AI,3     17
         LI,7     2
         BAL,10   FNDTYP
         B        CHKASS1
         LI,4     ','
         BAL,10   BASS
         LCI      2
         LM,4     *9
         BAL,10   BASS
CHKASS1  LI,4     ')'
         BAL,10   BASS
         LI,7     X'D0006'
         AI,7     X'10001'
         BGZ      CHKASS4
         BAL,10   FNDTYP
         B        %-3
         LW,4     =',(SN'
         BAL,10   BASS
         LI,7     1
         AI,9     -1
CHKASS2  LI,4     ','
         LW,5     *9,7
         BAL,10   BASS
         AI,7     1
         CB,7     *9,6
         BLE      CHKASS2
         LI,4     ')'
         BAL,10   BASS
CHKASS4  LW,11    *15,6
         AI,11    20
         BAL,10   GTNAME
         B        PULLRET1
*
*
BASS0    SLD,4    8
         CW,4     5
         BCR,7    *10
BASS     LB,8     4
         BEZ      BASS0
         CI,8     ' '
         BE       BASS0
         STB,8    0,3
         AI,3     1
         B        BASS0
         PAGE
*
OPTDUN   EQU      %                 DONE WITH OPTIONS, GET DOT CARDS
         LC       CIFLG
         BCR,8    FUMERR0
         LC       LOFLG
         BCR,2    DOT1
         BCS,8    DOT1
         BAL,14   ABORT
         TEXTC    'CL REQUIRES M:LO ASSIGN'
DOT1A    CAL1,1   CLSC
         CAL1,1   OPNC
*
DOT1     BAL,10   READC
         LB,10    BUF1
         BEZ      DOT1A
         CI,10    ':'
         BE       DEND
PRNTBUF1 M:WRITE  M:LL,(BUF,BUF1),(SIZE,80),(WAIT)
         LI,3     NUMDOTS
         LW,2     BUF1
         CW,2     DOTS,3
         BE       DOTJMP,3
         BDR,3    %-2
DOTERR   EQU      %
         M:PRINT  (MESS,BADDOT)
         LC       BPMUTSFLAG
         BCS,8    DOT1
         M:ERR
BADDOT   TEXTC    'ILLEGAL DOT CARD'
DOTS     EQU      %-1
         TEXT     '.JOB'
         TEXT     '.LIM'
         TEXT     '.POO'
         TEXT     '.TIT'
         TEXT     '.INS'            INSERT SPECIAL CARDS
         TEXT     '.IO'
         TEXT     '.SS'
         TEXT     '.OS'
         TEXT     '.DS'
         TEXT     '.IA'             INDIVIDUAL ASSEMBLIES
         TEXT     '.IA,'
         TEXT     '.2PR'            2 PRINTERS
         TEXT     '.2CO'
         TEXT     '.OPT'
         TEXT     '.MCI'
         TEXT     '.ALL'
         TEXT     '.ASI'
         TEXT     '.ACI'
         TEXT     '.NBO'
DAPP1     TEXT      '.APP'
         TEXT     '.SEL'            SELECT LMN
         TEXT     '.FOR'
         TEXT     '.ANS'            ALLOW ANSFORT
         TEXT     '.LDE'            SUPER-CLOSE LO WITH LDEV
         TEXT     '.AP'
DOTEND1  EQU      %
         TEXT     '.END'
DOTJMP   EQU      %-1
         B        DJOB
         B        DLIMIT
         B        DPOOL
         B        DTITLE
         B        DINSERT
         B        DIO
         B        DSS
         B        DOS
         B        DDS
         B        DIA
         B        DIA
         B        D2PR
         B        D2COP
         B        L11
         B        DMCIP
         B        DALLP
         B        DASIP
         B        DACIP
         B        DNBO
          B         DAPPEND
         B        DSELECT
         B        DFOR
         B        DFOR              ALLOW ANSFORT
         B        DSUP
         B        DAP
         B        DEND
NUMDOTS  EQU      %-DOTJMP-1
*
*
DJOB     EQU      %
         LI,3     0
         STW,3    E0KEY+1
         LI,3     '!'
         STB,3    BUF1
         CAL1,1   E0WRT
         B        DOT1
DLIMIT   LI,3     1
         B        DJOB+1
DPOOL    LI,3     2
         B        DJOB+1
DAP      LD,8     APFUM
         STD,8    METABO
         STD,8    META
         STD,8    FORMETA
         B        DOT1
APFUM    TEXTX    '!AP   '
*
DSELECT  EQU      %
         LI,5     0
         MTW,-1   DSELFLAG
         BAL,10   GETOPT1           SEARCH FOR COMMA SEPARATOR
         BG       DOT1              YES, ASSUME M:MON SELECTED
         MTW,2    DSELFLAG
         BAL,10   DGET
         STD,2    SELECTLMN         BLANK FILL LMN NAME
         B        DOT1
DGET     LD,2     BLKS
         LI,1     0
DSELW    EQU      %
         AI,5     1
         CI,5     71                END OF CARD?
         BG       *10               YES
         LB,6     BUF1,5            GET CHAR
         CI,6     ','
         BE       *10
         CI,6     ' '               SKIP LEADING BLANKS
         BNE      %+4
         CI,1     0
         BE       DSELW
         B        *10
         STB,6    2,1
         AI,1     1
         CI,1     7
         BG       *10
         B        DSELW
*
DTITLE   EQU      %
         MTW,1    TITFLG
         B        DOT1
*
DINSERT  EQU      %                 INSERT SPECIAL CARDS INTO FRONT
*                                   OF JOB STREAM
         LI,3     3
         STW,3    E0KEY+1
INSRTLUP EXU      DOT1              READ A CARD
         BE       DEND
         CI,1     80                IS IT BINARY
         BG       INSTBIN           YES, JUST INSERT IT
          EXU       PRNTBUF1       PRINT ALL CARDS INSERTED/APPENDED
         LW,2     BUF1
          CW,2      DAPP1          IS IT .APPEND
          BE        DAPPEND0
          CW,2      DOTEND1        IS IT .END
         BE       DEND
DOTINS0   EQU       %
         LB,2     BUF1              NO WRITE CARD
         CI,2     X'E0'             0-2-8 PUNCH
         BNE      DINS1             NO
          LI,2      DOT               YES, CHANGE TO DOT
         B        DINS2
DINS1    EQU      %
         CI,2     '.'               1ST CHAR A DOT
         BNE      INSTBIN
         LI,2     '!'               YES, CHANGE TO BANG
DINS2    EQU      %
         STB,2    BUF1
INSTBIN  EQU      %
,E0WRT   M:WRITE  M:E0,(BUF,BUF1),(SIZE,*1),(KEY,E0KEY),;
                  (ONEWKEY),(WAIT)
         MTW,1    E0KEY+1           UPDATE KEY
         B        INSRTLUP
*
*
DAPPEND0  EQU       %
DAPPEND   EQU       %
         MTB,0    E0KEY+1
         BNEZ     DOTINS0
         LW,3     E0KEY
         B        DINSERT+1
DIO      EQU      %
         LI,3     DIOFLG
DIO1     MTW,1    *3
         LI,1     20
         LW,2     BUF1-1,1
         STW,2    *3,1
         BDR,1    %-2
         B        DOT1
*
DSS      LI,3     DSSFLG
         B        DIO1
*
DOS      LI,3     DOSFLG
         B        DIO1
*
DDS      LI,3     DDSFLG
         B        DIO1
*
DIA      MTW,-1   IAFLAG            SET FLAG
         LI,15    DOT1
GETIA    RES
         LI,5     0
         BAL,10   GETOPT1
         BG       *15
         BAL,10   DGET
         LI,5     0
DIA1     LB,4     2
         AI,4     -'0'
         BLZ      *15
         MI,5     10
         AW,5     4
         STW,5    IAFLAG
         SLD,2    8
         B        DIA1
*
D2PR     LI,5     0
         LI,4     -10
         BAL,10   GETOPT1
D2PR1    BAL,10   DGET
         BL       DOT1
         STD,2    LOASSN+20,4
         STW,4    2PRINT
         BIR,4    D2PR1
         B        DOT1
*
D2COP    MTW,1    2COPFLG
         B        DOT1
*
DMCIP    MTW,1    MULTCI
         B        DOT1
*
DALLP    LW,3     Y4                FLAG FOR ALL
         LI,8     1
DALLP1   LC       ALLFLG
         BCS,7    DOTERR            ONLY ONE LEGAL
DALLP2   CI,8     1
         BNE      DOTERR            MUST BE ASSIGNED TO A FILE
         STS,3    ALLFLG
         B        DOT1
DASIP    LC       SIFLG             M:SI MUST BE FILE
         BCR,4    DOTERR
         LW,8     SIFLG+1
         LW,3     Y2
         B        DALLP1
DACIP    LW,8     CIFLG+1
         LW,3     Y1
         B        DALLP1
DNBO     LW,3     Y8
         LW,8     BOFLG+1
         B        DALLP2
*
DFOR     LI,3     20
         LW,8     BUF1-1,3
         STW,8    FORCD-1,3
         BDR,3    %-2
         LI,8     '!'
         STB,8    FORCD
         B        DOT1
*
DSUP     MTW,1    SUPFLG
         B        DOT1
*
         PAGE
*
* END OF ALL DOT CARDS ENCOUNTERED
*
*READ LISTFILE & CONSTRUCT ALL THE TABLES
*
*
LIST@    EQU      %
DEND     EQU      %
*  CONTAINING CINAMES, BINAMES, TITLE-DATA, ETC.
*
*
         BAL,10   CHKNXT1           GET A PAGE FOR TABLES
         STW,9    NXTCN             SET NXT
         AWM,9    MAXCN
         STW,9    1STCN
         LW,7     9
*
          M:OPEN    M:LIST,IN,(BUF,BUF3),(ABN,LISTABN),(RECL,80)
LIST1    M:READ   M:LIST,(ABN,LISTABN)
         LI,1     0
         BAL,10   LISTGET
         CD,2     STTCD             IS IT 'START'
         BNE      LIST1A            NO
         MTW,1    STTFLG            YES, SET FLAG
         EXU      LIST1             READ NEXT CARD
         B        LIST7
         BOUND    8
SELECTLMN TEXT    'M:MON'
DSELFLAG DATA     0
*
LIST1A   EQU      %
         CD,2     MONTEXT           SKIP TO 'M:MON'
         BNE      LIST1
*
*        GOT TO 1ST GOOD ONE, SET POINTERS ETC
*
LIST7    EQU      %
         MTW,0    DSELFLAG
         BEZ      LIST70
         BGZ      %+3
         LC       ALLFLG            IF ASI OR ACI, SELECT ALL
         BCS,3    LIST70
         CD,2     SELECTLMN
         BNE      LIST5C
LIST70   EQU      %
         LI,1     33
         BAL,10   LISTGET
         SLD,2    -24
         CI,2     '#'
         BNE      LIST71
         LB,2     3
         AI,2     -X'F0'
         BLZ      LISTABN2
         CW,2     RTORFLAG
         BE       LIST7A
         B        LIST5C
LIST71   EQU      %
         CI,2     '*'
         BNE      LIST7A
         LB,2     3
         CI,2     '1'
         BE       LIST5C
         CI,2     '3'
          BE        LIST5C         SKIP ALL *1,*3,*4 TYPES
          CI,2      '4'            FOUND IN LISTFILE
          BE        LIST5C
         CI,2     'F'               FORTRAN MODULE?
         BE       %+2
*
*  ONLY *2,*5, OR *F TYPES GET ASSEMBLED
*  OR THOSE NOT HAVING * IN  COL. 33
*
LIST7A   EQU      %
         LI,2     0                 SET FLGAG
         LI,10    LIST7C
CHKNXT   LI,8     CNSIZ
         AWM,8    NXTCN
         CW,7     MAXCN
         BLE      *10
CHKNXT1  M:GP     1
         BCS,8    NOCORE
         LI,8     512
         AWM,8    MAXCN
         B        *10
LIST7C   RES
         STW,2    FLGS,7
         LI,1     20
         BAL,10   LISTGET
         LCI      3
         STM,2    CNS,7
         LI,1     9
         BAL,10   LISTGET
         CD,2     LASTBO
         STD,2    LASTBO
         BNE      %+2
         SD,2     2
         STD,2    *7
         LI,1     35
         BAL,10   LISTGET
         LCI      4
         STM,2    TITLE,7
         AI,7     CNSIZ
LIST5C   EQU      %
         M:READ   M:LIST,(ABN,LISTABN)
         LI,1     0
         BAL,10   LISTGET
         MTW,0    STTFLG            START/STOP MODE
         BEZ      LIST5A            NO, NORMAL CHECK
         CD,2     STPCD             YES, IS IT 'STOP' CARD
         BE       LIST5B            YES, STOP
         B        LIST7             NO, CONTINUE
*
LISTGET  LH,8     M:LIST+4
         SLS,8    -1
         LCI      4
         LM,2     BLKS
         LI,6     -16
LISTG1   CW,1     8
         BGE      *10
         LB,0     BUF3,1
         CI,0     ' '
         BE       *10
         STB,0    6,6
         AI,1     1
         BIR,6    LISTG1
         B        *10
LIST5A   EQU      %
         CW,1     BLKS
         BNE      LIST7
LIST5B   EQU      %
         CW,7     1STCN             ANY SELECTIONS MADE?
         BNE      READ0             YES
         M:PRINT  (MESS,NLISTSEL)
         B        READ0
NLISTSEL TEXTC    'NO SELECTIONS FROM LISTFILE...'
LISTABN  LB,10    10
         CI,10    7
         BE       *8                LOST DATA OK
         BL       LIST5B
LISTABN2 BAL,14   ABORT
         TEXTC    'LISTFILE IS BAD'
NOCORE   BAL,14   ABORT
NOCOM    TEXTC    'NO CORE TO BUILD DATA'
*
READ0    LC       ALLFLG            IF ALL DONT READ ANYMORE CARDS
         BCS,7    RDSPC
         LB,10    BUF1
         CI,10    ':'
         BE       READ1A
READ1    EQU      %                 NOW WE START READING THE UPDATE
*                                   PACKETS & SETTING UP THE JOB STREAM
         BAL,10   READC
READ1A   EQU      %
         LI,1     0
         XW,1     BUF2FULL          BUFFER FULL
         BEZ      READ1B            NO, NO CARD
B2PRNT   M:WRITE  M:LL,(BUF,BUF2),(SIZE,80),(WAIT)
         MTW,0    SOFLG             WRITE SOURCE TAPE
         BEZ      READ1B            NO, NO CARDS
PUNCH    EQU      %
         M:WRITE  M:PO,(BUF,BUF2),(SIZE,80),WAIT
READ1B   EQU      %
         LC       ALLFLG            IF ALLSI OR ALLCI, GO GET NEXT NAME
         BCS,7    RDALL1
         LB,1     BUF1
         BEZ      INSERT1
         CI,1     ':'
         BE       READ2
         MTW,0    DATAIG
         BNEZ     READ1
         M:PRINT  (MESS,DATAIGMES)
         MTW,1    DATAIG
         B        READ1
DATAIGMES TEXTC   'CARDS OUT OF ORDER, SOME CARDS SKIPPED.'
READ2    LI,1     0
         STW,1    DATAIG
         STW,1    MATCHCN
         LW,1     BUF1
         CW,1     =':ALL'
         BNE      READ2C
         LB,1     BUF1+1
         CI,1     ' '
         BNE      READ2C
         LW,1     Y4
         STS,1    ALLFLG            ALL IS SPECIFIED
         B        ENT00
READ2C   EQU      %
         LI,1     -20
         LW,4     BUF1+20,1         MOVE :CARD TO OTHER BUFFER
         STW,4    BUF2+20,1
         BIR,1    %-2
         MTW,1    BUF2FULL          SET BUFFER FULL FLAG
         LI,1     1
          LI,5    0                USE R5 FOR INDEX TO R2,3,4
          LW,4      BLKS
         LD,2     BLKS
*
*  THIS ROUTINE GETS THE NAME FROM THE
*    :CINAME CARD INTO R2,3,4  (PREVIOUSLY BLANKED)
*
READ2E   EQU      %
         LB,0     BUF1,1
         CI,0     '.'
         BE       READ2D
         CI,0     ' '
         BE       READ2D
         CI,0     ','
         BE       READ2D
          STB,0     2,5            PUT CHAR INTO R2,3,4
         AI,1     1
          AI,5      1              BUMP INDICES
          CI,5      12             CI NAMES UP TO 12 CHAR ALLOWED
         BL       READ2E
READ2D   EQU      %
         LC       ALLFLG            IF AC/SI, WEVE GOT THE INDEX NOW
         BCS,7    READ3
         LW,7     1STCN
         B        %+2
READ2A   AI,7     CNSIZ
         CW,7     NXTCN
         BGE      READ2B            NOT THERE
         LW,8     7
          AI,8      CNS            AND ADD BASE OF CNS TABLE
          SLS,8     2              THEN MAKE BYTE ADDRESS FOR CBS
         LW,9     =X'0C000008'
         MTW,-1   CMPRFLAG
         BAL,10   CMPRBS
         BE       READ3
         B        READ2A
*
*        DIDN'T FIND IN CN TABLE, MAKE AN ENTRY
*
READ2B   LW,1     MATCHCN
         BNEZ     READ1A
         MTW,0    DSELFLAG          IF SELECTING
         BEZ      %+3
         LC       ALLFLG            AND ALLING SI OR CI
         BCS,3    RDSPC1            DONT ADD ANY
         BAL,10   CHKNXT            GET ROOM
         STW,1    FLGS,7            ZAP FLAGS
         LCI      3
         STM,2    CNS,7             SET CN
         LI,1     -1
         STW,1    0,7               SET NO BO FLAG
READ7    AI,1     1
         LB,3     BUF1,1            SCAN FOR DELIMITER
         CI,3     ' '
         BE       READ8             GO INCREMENT POINTERS
         CI,3     ','
         BNE      READ7
READ4D   EQU      %                 GET NEW BONAME
         AI,1     1
         LI,2     0
         LI,0     READ9
READ9    LB,3     BUF1,1
         CI,3     ' '
         BNE      %+2
         LI,0     %+1
         STB,3    *7,2
         AI,1     1
         AI,2     1
         CI,2     8
         BL       *0
READ8    LCI      4                 MOVE TITLE
         LM,1     BLKS
         STM,1    TITLE,7
READ3    EQU      %
         INT,1    FLGS,7
         BCS,12   READ1A
         LW,1     Y8
         STS,1    FLGS,7            SET MODULE FOR REGULAR ASSEMBLY
         LW,1     MATCHCN
         STW,7    MATCHCN
         BNEZ     READSFL
         BAL,8    CNSKEY           CONSTRUCT KEY FOR M:E0
         LCI      4                SAVE KEY
         STM,2    KEY
         LW,1     Y1
         STS,1    FLGS,7            SET : CARD READ FLAG.
         LC       ALLFLG            ALLSI/ALLCI, NO READING
         BCS,7    READGCN
         BAL,10   READC             READ A CARD
         INT,3    FLGS,7
         LC       SIFLG
         BDR,3    %+2               FORT ALWAYS HAS SI OPTION
         BCR,4    RDC4
         LW,3     Y2
         LB,0     BUF1
         CI,0     '+'
         BE       %+2               GOT UPDATES
         BCS,8    RDC4                NONE, BUT DONT NEED EM
         STS,3    FLGS,7            SET DEVICE SI FLAG
         BNE      RDC4              NO SI, MAKE ;END
RDC2     LW,2     BUF1
         CW,2     PENDCD
         BE       RDC3
WRTE0    M:WRITE  M:E0,(BUF,BUF1),(ONEWKEY),(KEY,KEY),(SIZE,*1)
         MTW,1    KEY+3            BUMP BINARY PART OF KEY
         BAL,10   READC
         BEZ      READGCN
         CI,1     80
         BLE      RDC2
RDC4     CI,1     80                A CI DECK TOO
         BLE      READGCN           NO
         EXU      WRTE0             YES, CONTINUE TILL SIZE GOES TO 80
         LI,1     0
         STW,1    BUF2FULL          RESET BUFFER FULL FLAG SO NO : CARD
*                                   GETS PUNCHED FOR THOSE MODULES THAT
*                                   HAVE COMPRESSED DECKS.
         EXU      B2PRNT
         MTW,1    KEY+3            BUMP BINARY PART OF KEY
         LI,1     X'30000'
         STS,1    FLGS,7            SET CI TO DEVICE CI FOR THIS
RDC3     BAL,10   READC
         B        RDC4
*
READSFL  LW,8     FLGS,1
         STW,8    FLGS,7
READGCN  BAL,8    LOADCNS0          GET SI NAME
         LC       ALLFLG
         BCS,5    READ1A
         B        READ2A            CHECK FOR MULTIPLE ONES
*
*
RDSPC    BCR,4    %+3               ASSEMBLE ALL IF .ALL
         LW,7     1STCN
         B        RDSPC3
         BCS,2    %+3
         LI,1     M:CI-M:SI         SET UP OPNNXT
         AWM,1    OPNNXT            SET FPT FOR M:CI
         CAL1,1   OPNNXT            GET FIRST FILE
         MTW,-1   OPNNXT+1          ZAP FILE NAME
         B        %+2
RDSPC1   CAL1,1   OPNNXT
         LW,15    OPNNXT
         AI,15    23
         LCI      5
         LM,2     BLKS
         LB,1     *15
         STB,6    2,1
         LB,6     *15,1
         BDR,1    %-2
         STB,6    2
         LCI      4
         STM,2    BUF1
         LW,7     1STCN             FIND NAME IN TABLE
         B        %+2
RDSPCC1  AI,7     CNSIZ
         CW,7     NXTCN
         BL       RDSPCC2
         LW,0     DSELFLAG
         BNEZ     RDSPC1
         LW,1     OPNNXT
         AI,1     23                POINT TO TEXTC FILENAME
         LW,8     -21,1             GET INFO ADRESS
         AI,8     20
         LI,6     1
         LD,8     *8
         BEZ      DECONSX
         CI,8     X'F0000'
         BANZ     DECONS1
         LH,2     8,6
         CH,2     BUF1
         BNE      RDSPC1
         LC       BUF1+2
         BCS,11   DECONS1
         LW,6     ='0000'
         AND,6    BUF1
         STH,6    6
         AND,6    BUF1+1
         EOR,6    ='0000'
         BNE      DECONS1
         LI,8     'CN'
         STH,8    BUF1
         B        DECONSX
DECONS1  LI,6     4
         LI,3     -1
         CI,9     X'FF'
         BANZ     %+2
         SLS,9    -8
         LI,0     X'BF'
         CB,0     8
         BANZ     %+4
         SLS,8    8
         SLS,3    8
         LW,2     6
         BDR,6    DECONS1+2
         LB,4     *1
         CI,9     X'FF'
         BAZ      %+5
         CB,9     *1,4
         BNE      RDSPC1
         SLS,9    -8
         BDR,4    %-5
         LW,9     3
         CS,8     BUF1
         BNE      RDSPC1
         LI,3     -16
         SW,4     2
         LB,0     *1,2
         STB,0    BUF1+4,3
         AI,2     1
         BIR,3    %-3
         LI,0     ' '
         AI,4     -11
         STB,0    BUF1+3,4
         BIR,4    %-1
DECONSX  BAL,10   CHKNXT
         LCI      4
         LM,2     BUF1
         STW,6    5
         STM,2    CNS,7             SET CN AND FLAGS
         STD,2    *7
         LM,2     BLKS              AND,TITLE
         STM,2    TITLE,7
         B        RDSPC3
RDSPCC2  LI,9     SISN
         LC       ALLFLG
         BCS,2    %+2
         LI,9     CICN
         BAL,10   CNSNAME
         CD,2     BUF1
         BNE      RDSPCC1
         CD,4     BUF1+2
         BNE      RDSPCC1
RDSPC3   BAL,8    LOADCNS0          GET CODE NAME
         LI,5     -16               MOVE TO BUF1
         LI,1     ':'               WITH COLON
         STB,1    BUF1+4,5
         STB,1    BUF2+4,5          PUT IN BUF2 IN CASE NO SI
         LB,1     6,5
         BIR,5    %-3
         LI,1     -80+13            BLANK REST OF BUF1
         LI,0     ' '
         STB,0    BUF1+20,1
         STB,0    BUF2+20,1
         BIR,1    %-2
         LC       ALLFLG            IF ASI, JUTS GO
         BCS,2    READ2
         LI,9     SISN              GEN SI NAME
         BAL,10   CNSNAME
         LI,6     -20               MAKE TEXTC
         STB,1    TSTSIFN+5,6
         LB,1     2+5,6
         BIR,6    %-2
         LD,0     SIFLG             IF SI TO A FILE
         BGEZ     READ2             ONLY,  IS IT THERE
         BDR,1    READ2
         LI,9     TSTSI1            SET NOT THERE EXIT
         CAL1,1   TSTSI
         B        READ2
TSTSIABN LB,1     10                IF NOT 03, ITS THERE
         CI,1     3
         BNE      *8
         B        *9
TSTSI1   LW,1     Y8                IF NOT THERE, CAUSE DEVICE SI
         OR,1     Y2                AND +END CARD
         STS,1    FLGS,7            AND +END CARD
         EXU      B2PRNT
RDALL1   LC       ALLFLG
         BCS,3    RDSPC1
         AI,7     CNSIZ             DO NEXT ONE
         CW,7     NXTCN
         BL       RDSPC3
         B        ENT00
*
OPNNXTABN LB,1    10                IF NOT 02, TRY NEXT ONE
         CI,1     2
         BE       INSERT1           ALL DONE
         LI,1     1
         LI,0     0
         STS,0    OPNNXT+1          TURM OFF FILE NAME
         B        RDSPC1            TRY THE NEXT
*
OPNNXT   DATA     X'14080000'+M:SI
         DATA     X'C0000401',OPNNXTABN,OPNNXTABN
         DATA     X'1010001'
TSTSI    DATA     X'14080000'+M:SI
         DATA     X'C0000001',TSTSIABN,TSTSIABN
         DATA     X'01010505'
TSTSIFN  RES      5
*
INSERT1  EQU      %                 NOT ALL, MUST SET UP TO ASSEMBLE
         LC       ALLFLG
         BCS,7    INSERT1A          DONT GO READING IF ALL
         MTW,0    BUF2              DID WE GET ANY INPUT
         BNEZ     INSERT1A
,CLSC    M:CLOSE  M:C
,OPNC    M:OPEN   M:C,(DEVICE,'C')
         B        READ1
*                                   EXTRA ROMS IF BO TO A FILE
INSERT1A LC       BOFLG
         BCR,8    INSERT2           PUNCH, DONE
*        NEITHER, MUST ASSEMBLE ALL IF ANY ARE SET
*
         LW,6     1STCN
         LW,7     1STCN
         LW,1     Y4                FOR SET FLAG
         LI,8     0
SETUP4   LD,2     *7
         BEZ      SETUP1
SETUP5   AI,8     0
         BEZ      SETUP2            NONE ASSEMBLED, CONTINUE
SETUP3   INT,2    FLGS,6
         BCS,8    %+2
         STS,1    FLGS,6
         AI,6     CNSIZ
         CW,6     7
         BL       SETUP3
SETUP2   LW,6     7
         LI,8     0
SETUP1   INT,2    FLGS,7
         BCR,8    %+2
         AI,8     1
         AI,7     CNSIZ
         CW,7     NXTCN
         BL       SETUP4
         BE       SETUP5            SET FOR LAST
*
INSERT2  EQU      %                 START INSERTING JOB
         MTW,0    SOFLG             SO THIS TRIP
         BEZ      ENT00             NO, INSERT JOB
*
*        YES, WRITE SO TO FILE/LABEL
*
         LH,7     M:PO
         CI,7     X'20'             M:PO OPEN
         BAZ      %+2               NO, DON'T CLOSE
         M:CLOSE  M:PO,SAVE         YEP, SAVE IT
         M:SETDCB M:E0,(ABN,SOERR),(ERR,SOERR)
         LW,7     1STCN
SO3      BAL,8    CNSKEY           CONSTRUCK KEY FOR M:E0
         LCI      4                SAVE KEY
         STM,2    KEY               AND TRY A READ
SORD1    M:READ   M:E0,(ERR,SOERR),(ABN,SOERR),(KEY,KEY)
*
*        NOW OPEN THE FILE/LABEL
*
         LI,9     SOSN
         BAL,10   CNSNAME
         LI,6     -20
         STB,1    SONAME+5,6
         LB,1     7,6
         BIR,6    %-2
         LW,9     SOFLG+1
         STS,9    OPNSO+1
SO4      CAL1,1   OPNSO             OPEN SO, OUT
SO2      LW,1     M:E0+4
         SLS,1    -17
         CI,1     80
         BG       SO1               DONE, THIS IS A CI CARD
         M:WRITE  M:SO,(BUF,BUF1),(SIZE,*1),(WAIT)
          MTW,1     KEY+3          BUMP BINARY PART OF KEY
         EXU      SORD1
         B        SO2
*
SO1      EQU      %                 DONE WITH SO
         LH,1     M:SO
         CI,1     X'20'             IS DCB OPEN
         BAZ      %+2
         M:CLOSE  M:SO,SAVE         YES, CLOSE IT
         AI,7     CNSIZ             INCREMENT CN COUNTER
         CW,7     NXTCN
         BL       SO3
         B        ENT00
*
SOERR    LB,1     10
         CI,1     X'43'
         BE       SO1
         B        E0ABORT
         PAGE
* ROUTINE TO LOAD R2-3-4 WITH CI-NAME
*
LOADCNS   EQU       %
         MTW,0    MULTCI            IF MULTIPLE CI, ALLBUTSI
         BEZ      LOADCNS0          ARE SAME AS BO
         LD,2     *7
         LW,4     BLKS
         CI,2     -1                IF NONE, GET SI NAME
         BAZ      %+2
         BNE      *8
LOADCNS0 RES
         LCI      3
         LM,2     CNS,7            AND DO LOAD-MULTIPLE
         B        *8               RETURN WITH CI-NAME IN R2-3-4
*
* ROUTINE TO CONVERT CI-NAME TO A KEY
*  FOR M:E0 TEMPFILE
*
CNSKEY   EQU      %
         LCI      3
         LM,2     CNS,7
         LI,5     256              PUT  X'00000100' INTO R5
         SLD,4    -8               BECOMES XX000001 AFTER SHIFT
         STB,3    4                MOVE BYTE FROM R3
         SLD,2    -8               BEFORE MOVING R3
         LI,6     15               STUFF IN KEYLN
         STB,6    2
         B        *8               RETURN
         PAGE
*        ROUTINE TO CONSTRUCT A NAME (TEXT IN 2,3,4)
*        PRE IN 8, POST IN 9(INVERTED)
CNSNAME  RES
         LD,4     BLKS              OUTPUT IS FOUR WOTDS
         CI,9     BOBN
         BE       CNSNAM0           IF BO, NAME IS IN 2-3
         BAL,8    LOADCNS           GET NAME FOR ALL BUT SI
         CI,9     SISN
         BNE      CNSNAM0
         BAL,8    LOADCNS0
CNSNAM0  LD,8     *9
         CI,8     0
         BE       CNSNAM1
         CI,8     X'F0000'          IS IT LN OR SN
         BANZ     CNSNAM4           NO, ADD PRE
         LH,9     2                 YES, IS THIS A CN NAME
         AI,9     X'10000'-'CN'
         BNEZ     CNSNAM4           NO, ADD TO FRONT
         STH,8    2                 YES, REPLACE CN
CNSNAM1  LI,1     -16               FIND END
         LC       6,1
         BCS,11   CNSNAM2
         LB,8     9
         BEZ      CNSNAM3
         STB,8    6,1
         SLS,9    8
CNSNAM2  BIR,1    CNSNAM1+1
CNSNAM3  AI,1     16                MAKE TEXTC COUNT
         B        *10
CNSNAM4  CI,8     X'BF'
         BAZ      CNSNAM1
         SLD,4    -8
         STB,3    4
         SLD,2    -8
         STB,8    2
         SLS,8    -8
         B        CNSNAM4
         PAGE
*
*  ROUTINE TO COMPARE BYTE-STRING OR MOVE BYTE-STRING
*
*    ENTRY:  BAL,10   CMPRBS
*              BAL,10   MOVEBS
*          R8-R9 CONTAIN THE MBS/CBS CONTROL
*                 PARAMETERS  (SEE SIGMA-7/8/9 REF. MAN.)
*          CMPRFLAG = -1 TO COMPARE
*                      0 TO MOVE
*
CMPRBS   EQU      %
MOVEBS   EQU      %
         DO       BSMODE=ON        IF ON, USE BYTE-STRING INSTRUCTIONS
         MTW,0    CMPRFLAG         MOVE OR COMPARE
         BNEZ     CMPR00
         MBS,8    0                ....MOVE
         B        *10              EXIT
CMPR00   EQU      %
         PSW,10   *TSTACK          RESET
         LI,10    0                THE FLAG
         STW,10   CMPRFLAG
         PLW,10   *TSTACK
         CBS,8    0                ....COMPARE
         B        *10              EXIT
         ELSE
          STCF      CMPRCC
         LCI      8                SAVE R0--R7
         PSM,0    *TSTACK          IN STACK
         LD,6     8                GET STUFF INTO
         LB,5     7                R5,R6,R7 TO WORK WITH
         MTW,0    CMPRFLAG
         BNEZ     CMPR00
MV01     EQU      %
         LB,4     0,6              GET SOURCE-BYTE
         STB,4    0,7              MOVE TO DESTINATION
         AI,6     1                BUMP INDICES
         AI,7     1                FOR BOTH
         BDR,5    MV01             DECREMENT COUNT % LOOP
         B        CMPRX1
CMPR00   EQU      %
         LB,4     0,6              COMPARE SOURCE-BYTE
         CB,4     0,7              WITH DESTINATION
         BNE      CMPRX0           IF NOT EQUAL--GET OUT
         AI,6     1                BUMP INDICES
         AI,7     1                FOR BOTH
         BDR,5    CMPR00           DECREMENT COUNT % LOOP
         LCI      0                SET CC FOR EQUAL
CMPRX0   EQU      %
         STCF     CMPRCC
CMPRX1   EQU      %
         STB,5    7
         LD,8     6
         LI,6     0                RESET MOVE/COMPARE
         STW,6    CMPRFLAG         FLAG
         LCI      8                RESTORE
         PLM,0    *TSTACK          ALL USER REG'S
         LCF      CMPRCC           RESTORE CC TO INDICATE FINAL RESULT
         B        *10              RETURN
         FIN
*
CMPRFLAG DATA     0
CMPRCC   DATA     0
*
         PAGE
*
INSMISC  EQU      %                 A SUBROUTINE
         LI,14    0
         STW,14   NOCOFLG           ZAP NOCO
         STW,14   DEVSIFLG          AND SET DEVICE SI
INSMISC1 STW,14   E0KEY+1           SET START POINT
         PSW,10   *TSTACK
         M:SETDCB M:E0,(ABN,MISC),(ERR,MISC)
ENT3A    M:READ   M:E0,(KEY,E0KEY),(ABN,MISC),(ERR,MISC)
         LI,14    BUF1
         LW,13    M:E0+4
         SLS,13   -17
         CI,13    80                IS IT BIN
         BLE      %+2               NO
         AI,13    X'20000'          YES, SET BINARY BIT
         BAL,10   *15               INSERT CARD
ENT3     MTW,1    E0KEY+1           UPDATE KEY
         B        ENT3A
*
MISC     EQU      %
         LW,10    E0KEY+1
         CI,10    3
         BL       ENT3              ALWAYS TRY FIRST THREE
         M:SETDCB M:E0,(ERR,ENTABN),(ABN,ENTABN)
          B         PULLRET
         PAGE
*
*  MISC CARDS DONE.  NO MORE DATA FROM
*  INPUT STREAM.  TIME NOW TO SET THE
*  REMAINING FLAGS FOR ASSIGN CARDS.
*
*  THE JOB STREAM CONTROL CARDS ARE
*  GENERATED IN THE FOLLOWING ORDER:
*
*    TITLE
*    BO
*    LO
*    CI
*    CO
*    SI
*    SO
*    METASYM
*    .END
*    SI
*    FORTRAN
*    EO
*    LO
*    EI
*    UTILIST
*
RESTMSG  TEXTC    '******* RESTART AT XXXXXXXXXXXX'
P0ABN    M:OPEN   M:P0,OUT
         M:CLOSE  M:P0,SAVE
         M:OPEN   M:P0,INOUT
         B        ENT37
ENT00    EQU      %
         LI,4     M:BO-M:SI         CHANGE TSTSI TO TSTBO FOR NBO
         AWM,4    TSTSI
         EXU      PAGE
         LI,15    JOBENT
         LC       NOENT
         BEZ      %+2
         LI,15    EOWRT
*        BUILD A UTILIST CARD IF ONE IS REQUIRED
         LW,4     ='  CL'
         LC       LOFLG
         BCR,6    ENT5
         BCS,2    ENT4
         BCS,8    ENT5
         LW,4     2COPFLG
         BEZ      ENT5
         LW,4     ='  PR'
ENT4     STW,4    UTIL+2
         LW,4     ='M:EO'
         STW,4    LOASS+2
         LW,4     =' ,PR'
         BCR,4    ENT5              CC4&8 STILL SET FROM LOFLG
         BCR,8    %+2
         STW,4    UTIL+3
         LW,0     2COPFLG
         BEZ      ENT5
         AI,4     'JE'-'PR'
         STW,4    UTIL+4
ENT5     LI,3     -1                CHECKSUM THE DATA
         LI,1     #PATCH
         CVA,2    0,1
         AWM,2    CHKSUM
         AI,1     32
         CI,1     BPMUTSFLAG
         BL       %-4
         LD,6     CHKSUM
         M:OPEN   M:P0,INOUT,(ABN,P0ABN)
         M:READ   M:P0,(ABN,ENT37)
         CW,6     CHKSUM
         STW,6    CHKSUM
         BNE      ENT37
         LW,7     1STCN
         BAL,8    LOADCNS
         LCI      3
         STM,2    RESTMSG+5
         M:PRINT  (MESS,RESTMSG)
ENT37    MTW,0    BPMUTSFLAG        IS IT CP-V?
         BEZ      ENT37C            NO,JUST SKIP ON BY!
         LW,1     *X'4F'            GET SYS ID. . .
         SLS,1    16                ONLY USE LOW ORDER NIBBLES
         BAL,10   HEXOUT            CONVERT TO EBCDIC
         STW,2    LODUM2            MAKE LO NAME UNIQUE
         STW,2    EIDUM2            MAKE EI MATCH LO
         STW,2    FORSO2            MAKE SO NAME UNIQUE
         STW,2    FORSI2            MAKE SI MATCH SO
         LW,1     DUMCNT
         MTW,1    DUMCNT            INSURE UNIQUE NAMES
         SLS,1    16                WE ONLY NEED 4 NIBBLES
         BAL,10   HEXOUT            CONVERT TO EBCDIC
         STW,2    FORSO2+1          UNIQUE SO NAME
         STW,2    FORSI2+1          MAKE SI MATCH
         STW,2    LODUM2+1
         STW,2    EIDUM2+1
ENT37C   LD,2     *7
         BEZ      %+2
         STD,2    LASTBO
         LC       ALLFLG            IF ALL NO CHECK
         BCS,4    %+3
         INT,1    FLGS,7
         BCR,12   ENT25A            NO ASSEMBLY, SKIP
         LC       ALLFLG            IF NBO, ONLY ASSEMBLE
         BCR,8    ENT37B            THOSE THAT ARENT THERE
         CI,2     -1
         BE       ENT37B
         LD,2     LASTBO
         LI,9     BOBN
         BAL,10   CNSNAME
         LI,6     -20
         STB,1    TSTSIFN+5,6
         LB,1     7,6
         BIR,6    %-2
         LI,9     ENT37B
         CAL1,1   TSTSI
         B        ENT25A            DONT ASSEMBLE IF THERE
ENT37B   MTW,0    BUFFER            IF NOT STARTED, DO SO
         BEZ      ENT37D
         LW,10    IAFLAG
         BEZ      ENT37A
         AI,2     0                 YES, IS THIS A NEW ROM SET
         BEZ      ENT37A            NO, ALL BOS IN SAME JOB THEN
         STW,7    1STCN
ENT37D   BAL,10   INSMISC           YES, INSERT JOB CARD AGAIN
ENT37A   EQU      %
         LI,13    80
          MTW,0     TITFLG         CHECK FOR TITLE REQUESTED
          BEZ       NOTIT          .....NONE
          LCI       0              SAVE ALL 16
          PSM,0     *TSTACK        (SOLVES FUNNY PROBLEM)
         BAL,8    LOADCNS0
         LCI      3
          STM,2     TITCD1         PUT IT AWAY
          LD,2      LASTBO         GET BO NAME
         CI,2     -1
         BE       %+2
         BANZ     %+2
         LD,2     BLKS
          LCI       2
          STM,2     TITCD1+3
          LCI       4
          LM,2      TITLE,7
          STM,2     TITCD1+6
          LI,14     TITCD
          BAL,10    *15            ENTER TITLE CARD INTO JOB
          LCI       0              RESTORE
          PLM,0     *TSTACK         REGS......
NOTIT     RES       0
         LI,14    BOASS
         LC       BOFLG
         BCR,8    ENT26
         LD,2     *7
         BEZ      ENT26
         CI,2     -1
         BNE      %+2               SPECIAL FOR EXTRA MODULES NOT ON
         LI,14    BOTOBO            LISTFILE WITH NO BOFILE SPECIFIED
         LI,9     BOBN
         BAL,10   CNSNAME
         LCI      4
         STM,2    BOASS+5
         BAL,10   *15               INSERT BO CARD
ENT26    EQU      %
         LD,2     *LOASSNPTR
         BLZ      %+4
         LI,2     LOASSN
         STW,2    LOASSNPTR
         LD,2     LOASSN
         MTW,2    LOASSNPTR
         STD,2    2PRLOCD1
         INT,1    FLGS,7
         BCS,4    ENT27             NO LO, NO ASSIGN
         LI,9     LOLN
         BAL,10   CNSNAME
         LCI      4
         STM,2    LOASS+5          SAVE IN THE LO ASSIGN CARD
         LI,14    LODUM
         MTW,0    UTIL+2
         BNEZ     ENT27B
         LI,14    LOASS
         LC       LOFLG
         BCS,8    ENT27B
         LI,14    2PRLOCD
         MTW,0    2PRINT
         BEZ      ENT27
         MTW,-3   2PRLOCD+2
         BAL,10   *15
         MTW,3    2PRLOCD+2
ENT27B   BAL,10   *15               ENTER LO CARD
ENT27    EQU      %
          BAL,10    CHKMOD         AND GO CHECK IF DIFFERENT ON TAPE
CHKEXIT  LI,9     CICN
         LW,5     BLKS
         BAL,10   CNSNAM0
          LCI       4
         STM,2    CIASS+5
         LI,14    CINOCD
         INT,2    FLGS,7
         BDR,2    %+2
         LI,14    CIASS
         BAL,10   *15               INSERT CI CARD
*
ENT30    EQU      %                 CO ASSIGN IS NEXT
         INT,1    FLGS,7
         BCS,4    ENT32B            NO CO OR SI
         MTW,0    NOCOFLG           CO TO NO
         BNEZ     ENT32             YES, DON'T REASSIGN
         LC       COFLG
         BCR,8    ENT32             NO ASSIGN OR OPTION
         LI,9     COCN
         BAL,10   CNSNAME
         LCI      3
         STM,2    COASS+5
         LI,14    COASS
         BAL,10   *15               INSERT CO CARD
*
ENT32    LC       SIFLG             SI CARD IS NEXT
         BCR,4    ENT32B            NO SI OPTION
         BCR,8    ENT32S            NO ASSIGN, SET DEVICE
         LI,9     SISN
         BAL,10   CNSNAME
         LCI      4
         STM,2    SIASS+5
         LI,14    SIASS
         INT,1    FLGS,7
         BCS,2    ENT32S            SI PACKET,YES, SI FROM DEVICE
         BCS,1    ENT32D
ENT32S   LI,14    SITOSI
         MTW,0    DEVSIFLG          IF ALREADY DEVICE, NO ASSIGN
         BEZ      ENT32B
ENT32D   EQU      %                 INSERT SI ASSIGN CARD
         BAL,10   *15
         AI,14    -SITOSI           SET DEVSI FLG PROPERLY
         STW,14   DEVSIFLG
*        METASYM CARD IS NEXT
ENT32B   EQU      %
         INT,1    FLGS,7            GET FORT FLAG
         BDR,1    %+2               SET
         B        ENT32F            NO
         LI,14    FORSOCD           YES, ENTER ALL GOODIES
         LI,13    80
         BAL,10   *15               M:SO
         LI,14    FORMETA
         BAL,10   *15               METASYM CARD
         B        ENT35             GET UPDATES
ENT32F   EQU      %
         BCR,4    ENT32A
         LI,14    METABO
         BAL,10   *15
         B        ENTABN1A          BRANCH AROUND +END TEST
ENT32A   LC       SOFLG             DO WE NEED SO ASSIGN
         BCR,8    ENT32E            NO
         LI,9     SOSN
         BAL,10   CNSNAME
         LCI      4
         STM,2    SOASS+5
         LI,14    SOASS
         BAL,10   *15
ENT32E   RES
         LW,1     SBADD
         BEZ      ENT33             NO BO
         BAL,8    LOADCNS          ---> USE ONLY 8-CHAR'S OF NAME FOR SB
         LI,4     4
         SLD,2    8
         STB,2    0,1
         AI,1     1
         BDR,4    %-3
ENT33    LW,1     SCADD
         BEZ      ENT34
         BAL,8    LOADCNS          ---> USE ONLY 8-CHAR'S OF NAME FOR SB
         LI,4     4
         SLD,2    8
         STB,2    0,1
         AI,1     1
         BDR,4    %-3
ENT34    LI,14    META
         BAL,10   *15               INSERT METASYM CARD
         MTW,0    CNFLG
         BGEZ     ENT35
*        INSERT CONCORDANCE CONTROL CARDS
         MTW,0    DIOFLG
         BEZ      %+3
         LI,14    DIOCD
         BAL,10   *15
         MTW,0    DSSFLG
         BEZ      %+3
         LI,14    DSSCD
         BAL,10   *15
         MTW,0    DOSFLG
         BEZ      %+3
         LI,14    DOSCD
         BAL,10   *15
         MTW,0    DDSFLG
         BEZ      %+3
         LI,14    DDSCD
         BAL,10   *15
         LI,14    DOTENDCD
         BAL,10   *15               INSERT .END CARD
*
*        NOW WE MUST READ M:E0 TO GET UPDATE CARDS & PUT THOSE IN
*
ENT35    EQU      %
         BAL,8    CNSKEY           CONSTRUCT KEY TO READ M:E0
         INT,1    FLGS,7
         BCR,2    ENTABN1B
         LCI      4
         STM,2    KEY
ENT36    M:READ   M:E0,(ABN,ENTABN),(ERR,ENTABN),(KEY,KEY)
         LW,13    M:E0+4
         SLS,13   -17
         CI,13    80
         BLE      %+2
         OR,13    =X'20000'         SET BINARY BIT
         LI,14    BUF1
         BAL,10   *15               INSERT CARD
         MTW,1    KEY+3
         B        ENT36
ENTABN   EQU      %
         LB,13    10
         CI,13    X'43'
         BE       ENTABN1
E0ABORT  EQU      %
         BAL,14   ABORT
         TEXTC    'BAD E0 TEMP FILE'
ENTABN1  EQU      %
         LI,13    80
         LI,14    PENDCD            INSERT +END CARD FOR ALL OPTION
         BAL,10   *15
ENTABN1B EQU      %
         INT,1    FLGS,7
         BDR,1    %+2
         B        ENTABN1I          IF FORT, WE STILL HAVE MORE TO DO
         LI,14    FORSICD           M:SI CARD FOR FORTRAN
         BAL,10   *15
         LI,14    FORCD
         BAL,10   *15               INSERT FORRAN CARD
         LC       SIFLG
         BCS,8    ENTABN1I
         LI,14    SITOSI            IF NO SI CARD,
         BAL,10   *15               REASSIGN SI TO DEVICE SI.
ENTABN1I EQU      %
         MTW,0    UTIL+2            IS THIS UTILIST JOB
         BEZ      ENTABN1A          NO
         LI,14    LOTOLO
         MTW,0    2PRINT
         BEZ      %+2
         LI,14    2PRLOCD
         BAL,10   *15
         LI,14    EIDUM             UTILIST INPUT FILE
         BAL,10   *15
         LI,14    LOASS             UTILIST OUTPUT (M:EO)
         LC       LOFLG
         BCR,8    %+2
         BAL,10   *15
         LI,14    UTIL              UTILIST CARD
         BAL,10   *15
ENTABN1A EQU      %
         LW,14    E0KEY             TRY FOR APPEND CARDS
         BAL,10   INSMISC1
         MTW,0    SUPFLG
         BEZ      ENT25A
         LI,14    SUPCLSCD
         BAL,10   *15
ENT25A   EQU      %
         AI,7     CNSIZ
         CW,7     NXTCN
         BL       ENT37
         MTW,0    BUFFER
         BNEZ     ENT25C
         LI,14    NONEMES+X'80000'
         B        ABORT
NONEMES  TEXTC    'NOTHING TO DO....'
ENT25C    EQU       %
         LI,13    -1
         BAL,10   *15               INSERT JOB & QUIT
         LI,14    -100
MF#EXIT   EQU       %
         M:CLOSE  M:P0,REL
         M:CLOSE  M:EO,SAVE,REM
         M:CLOSE  M:LL,SAVE
         BIR,14   %+2
         M:XXX
         M:EXIT
         PAGE
*
*        SUBROUTINE TO CONVERT HEX TO EBCDIC
*
*        LINK - 10
*
*        HEX  -  1
*
*        EBCDIC  2
*
*        WORK    3,4
*
HEXOUT   EQU      %
         PSW,0    *TSTACK           SAVE REG 0
         LI,4     0
         LI,3     4                 CONVERT 4 NIBBLES
HEXOUT1  LI,0     X'F'
         SLD,0    4
         CI,0     '9'               IS NIBBLE A LETTER?
         BLE      %+2               DO GOOD THINGS
         AI,0     'A'-'9'-1
         STB,0    2,4               SAVE BYTE
         AI,4     1
         BDR,3    HEXOUT1           ONCE MORE WITH FEELING
         PLW,0    *TSTACK           RESTORE REG 0
         B        *10               GO BACK
         PAGE
*        CHKMOD   CHECK FOR SPECIAL CN'S THAT EITHER DON'T HAVE CI ON
*                 THE TAPE OR DON'T HAVE THE SAME CI # AS THEIR OWN.
*
***
*
* THIS ROUTINE CHECKS FOR THOSE SPECIAL MODULES THAT
*   ARE GENERATED WHICH HAVE NO REAL CI OF THEIR OWN
*   IF ONE IS FOUND THEN THE REAL CI NAME IS SUBSTITUTED
*   AND A FURTHER CHECK IS DONE TO DETERMINE THE SOURCE
*   OF ANY UPDATES.  IF NO UPDATES HAVE BEEN PRESENTED
*   BY THE USER, A SET OF DEFAULT UPDATES IS INSERTED TO
*   CAUSE ASSEMBLY OF THE DESIRED BINARY OUTPUT.
*
***
*
CHKMOD    BAL,8     CNSKEY         KEY TO READ M:E0
          LCI       4              SAVE KEY
          STM,2     KEY            TO READ
         BAL,8    LOADCNS
         LI,9     DIFFS+3*NUMDIFFS
          LI,6      NUMDIFFS       GET #-OF-POSSIBILITIES (LOOP COUNT)
*
CKM02     EQU       %
         LCI      3
         LM,10    *9
         CD,2     10
         BNE      %+3
         CW,4     12
          BE        DIFFCI         IF EQUAL IT'S SPECIAL--GO MAKE SUBSTITUTION.
         AI,9     -3
          BDR,6     CKM02          & GO TRY UNTIL IT'S DRY.
         LI,0     0
         XW,0     NOCOFLG
         BEZ      CHKEXIT
         LC       COFLG
         BCS,8    CHKEXIT
         BCR,4    CHKEXIT
         LI,14    COTOCO
         BAL,10   *15
         B        CHKEXIT
*
DIFFCI   EQU      %
          LC        COFLG          IF NOT SET, THEN DON'T BOTHER
          BCR,4     DIFFCI2        .....JUST GO AROUND
         LI,1     1
         XW,1     NOCOFLG
         BNEZ     DIFFCI2
         LI,14    COTONO
         BAL,10   *15
DIFFCI2   EQU       %
         INT,1    FLGS,7
         BCR,2    CHKMOD1           IF NOT DEVICE SI, NO CARDS
         LW,6     PCARDS,6
         BEZ      CHKMOD1           NOTHING TO ADD
         M:SETDCB M:E0,(ERR,CHKABN),(ABN,CHKABN)
         M:READ   M:E0,(KEY,KEY),(ABN,CHKABN),(ERR,CHKABN)
*
*  IF WE FALL THROUGH, THEN NO UPDATE CARDS WILL BE INSERTED
*
CHKMOD1   EQU       %
          AI,9      DIFFS2-DIFFS   REAL CN NAME
          LCI       3              TO DO LOAD MULT.
          LM,2      *9             INTO R2-3-4
SDCBE0   M:SETDCB M:E0,(ERR,ENTABN),(ABN,ENTABN)
         B        CHKEXIT
CHKABN   EQU      %
         LB,1     10
         CI,1     X'43'
         BNE      ENTABN
CHKABN2  M:WRITE  M:E0,(KEY,KEY),(BUF,*6),(SIZE,80),(ONEWKEY)
         MTW,1    KEY+3
         AI,6     20
         EXU      CHKABN2
         M:READ   M:E0,(KEY,KEY),(BUF,BUF1),(SIZE,120)
         B        CHKMOD1
          PAGE
         BOUND    8
DIFFS     EQU       %-3      *** THESE CN'S ARE DUMMY'S ***
          TEXT      'CN705429 '    BTM-LOAD:
          TEXT      'CN705399 '    BTM-SYMBOL:
          TEXT      'CN706427 '    BSBTM-M:KEYIN
          TEXT      'CN706432 '    BSBTM-M:DISPLAY
          TEXT      'CN706256 '    FANALYZE
          TEXT      'CN706428 '    PCD0
          TEXT      'CN706430 '    PCD0
          TEXT      'CN706431 '    PCD0
          TEXT      'CN706429 '    PCD0
          TEXT      'CN704751 '    IO=IOSYM
          TEXT      'CN706297 '    IOPOOL=IOSYM
          PAGE
DIFFS2    EQU       %-3        *** THESE ARE THE REAL CN'S ***
          TEXT      'CN705260 '    LOPE
          TEXT      'CN704159 '    SYMBOL
          TEXT      'CN706120 '    M:KEYIN
          TEXT      'CN704020 '    M:DISPLAY
          TEXT      'CN706124 '    RCVR2
          TEXT      'CN704746 '    REAL
          TEXT      'CN704929 '    REAL
          TEXT      'CN704762 '    REAL
          TEXT      'CN704963 '    REAL
          TEXT      'CN704879 '    REAL CN FOR IO=IOSYM
          TEXT      'CN704879 '    REAL CN FOR IOPOOL=IOSYM
          PAGE
PCARDS    EQU       %-1
          DATA      PCD1           LOAD:/LOPE
          DATA      PCD2           SYMBOL:/SYMBOL
          DATA      PCD3           M:KEYIN & M:DISPLAY
          DATA      PCD3           BOTH USE PCD3
          DATA      PCD4           FANALYZE/RCVR2
          DATA      0
          DATA      0
          DATA      0
          DATA      0
          DATA      PCD5
          DATA      PCD6
NUMDIFFS  EQU       %-PCARDS-1
          PAGE
PCD1      TEXTX     '+29,29'
         FILL
         TEXTX    'USER     EQU       2          TIME SHARING LOADER'
         FILL
PCD2     TEXTX    '+2,2'
         FILL
         TEXTX    ;
 'MODE     EQU      3                DEFINES CN705399 BTM SYMBOL'
         FILL
PCD3      TEXTX     '+4,4'
          FILL
          TEXTX     'BSBTM     EQU     1'
          FILL
PCD4      TEXTX     '+8,8'
          FILL
          TEXTX     'FANLZ     SET       1'
          FILL
PCD5      TEXTX     '+7,8'
          FILL
          TEXTX     'SYMBFLAG,DUALFLAG  SET  0,0'
          FILL
PCD6      TEXTX     '+7,8'
          FILL
          TEXTX     'SYMBFLAG,DUALFLAG  SET  1,1'
          FILL
         PAGE
*        A SUBROUTINE TO INSERT CARDS INTO A SYMBIONT STREAM
*                 R10  LINK
*                 R13  HAS BYTE COUNT
*                     + RECORD CONTROL CHAR IN BYTE 1
*                     -1 MEANS INSERT THE JOB
*                 R14 HAS WA(CARD TO GO)
*                     JOB PRIORITY WHEN R13 = -1
*
TYMES    TEXTX    ' FUMJOB'
         FILL
JOBID    DATA     0
IDPLACE  DATA     0
JOBMES   TEXTX    '    '
         FILL
MAXPRI   TEXTC    'PRIORITY TOO HIGH - DEFAULT USED'
CVT      TEXT     '0123456789ABCDEF'
YESNO    DATA     0
SPACEL   DATA     0
SPACEU   DATA     1
BUFFER   DATA     0
FPT      GEN,8,24 X'2F',F:JOB
         DATA     X'E0000000'
         DATA     JOBABN
BUFADD   PZE      *BUFFER
         DATA     1
*
FPT1     GEN,8,24 X'2F',F:JOB
         DATA     X'F0000000'
         DATA     JOBABN1
         PZE      *BUFFER
         DATA     1
PRIJOB   DATA     1
*
FPT2     GEN,8,24 X'2F',F:JOB
         DATA     0
JOBENT   EQU      %
         LCI      0
         PSM,0    *TSTACK
         MTW,0    BUFFER
         BNEZ     JOBENT1
         MTW,1    YESNO             SET FLAG FOR NO TEST
         M:GP     1
         STW,9    BUFFER
         LI,1     253
         STW,1    SPACEL
         LI,1     19
         LW,2     BLKS              IF NO NAME ACCNT ETC
         CW,2     BUF1,1
         BNE      DJOB0             PUT ONE
         BDR,1    %-2
         LW,1     X'4F'
         LCI      2
         LM,4     1,1
         LI,3     BA(BUF1+1)+1
         BAL,10   BASS
         LI,4     ','
         BAL,10   BASS
         LCI      2
         LM,4     3,1
         BAL,10   BASS
         LW,4     5,1
         MTW,0    BPMUTSFLAG
         BNEZ     %+2
         AI,1     39-17
         LW,5     17,1
         SLS,5    -20
         AND,5    =15
         LB,5     CVT,5
         AI,5     X'6B00'
         BAL,10   BASS
DJOB0    RES
*        GET PRIORITY FROM JOB CARD
         LI,3     2
         LI,1     4
         LI,2     ','
DJOB2    CB,2     *14,1
         BE       DJOB1
DJOB3    AI,1     1
         CI,1     72
         BL       DJOB2
         B        DJOB6
DJOB1    AI,3     -1
         BGZ      DJOB3
         AI,1     1
DJOB4    LB,2     *14,1
         CI,2     ' '
         BNE      DJOB5
         AI,1     1
         CI,1     72
         BLE      DJOB4
DJOB6    LI,2     '1'
DJOB5    EQU      %
         CI,2     '.'
         BE       DJOB6
         CI,2     X'30'
         BANZ     DJOB7             A NUMBER
         AI,2     9                 A LETTER
DJOB7    LI,3     X'F'
         SLD,2    20
         LW,4     X'4F'
         MTW,0    BPMUTSFLAG
         BNEZ     %+2
         AI,4     39-17
         CS,2     17,4
         BLE      %+3
         M:PRINT  (MESS,MAXPRI)
         LW,2     17,4
         SLD,2    -20
         STS,2    PRIJOB
*
*        NOW MOVE JOB CARD TO MESSAGE
*        R1 HAS # BYTES TO MOVE
         STW,1    IDPLACE
         LB,2     *14,1
         STB,2    JOBMES,1
         BDR,1    %-2
         INT,1    IAFLAG
         CH,1     IAFLAG
         BCR,7    JOBENT1           NOTHING
         M:PFIL   M:P0,BOF
         M:WRITE  M:P0,WAIT
         BG       IAJOB2            STILL GOING STRONG
         STW,1    IAFLAG
         CAL1,8   SLEEP
         BAL,15   JOBWAIT
IAJOB2   MTH,1    IAFLAG
JOBENT1  EQU      %
         AI,13    0
         BGEZ     JOBENT2
*        THIS IS THE LAST BLOCK, INSERT JOB
JOBENT5  CAL1,1   FPT1
         STW,8    JOBID             SAVE ID
         LI,1     18
         LW,2     JOBMES,1
         STW,2    TYMES+1,1
         BDR,1    %-2
         LW,3     IDPLACE
         AI,3     5
         LI,2     '-'
         STB,2    TYMES,3
*
*
*        NEXT CONVERT JOB ID
*
*
         LW,5     8
         SLS,5    16
         LI,1     4
         LI,4     0
JE30     SLD,4    4
         AI,4     0
         BNEZ     %+2
         BDR,1    JE30
JE35     LB,4     CVT,4
         AI,3     1
         STB,4    TYMES,3
         LI,4     0
         SLD,4    4
         BDR,1    JE35
         MTW,0    IAFLAG
         BEZ      JE50
         LI,2     '-'
         AI,3     1
         STB,2    TYMES,3
         LI,1     1
JE40     LB,2     KEY,1
         CI,2     ' '
         BE       JE45
         AI,3     1
         STB,2    TYMES,3
         AI,1     1
         B        JE40
JE45     BIR,1    JE50
         M:TIME   TIME
         LI,1     -17
         LI,2     '-'
         B        JE40+1
JE50     STB,3    TYMES
         M:PRINT  (MESS,TYMES)
*
*
*        DONE AT LAST
*
         LI,1     0
         STW,1    BUFFER
         LI,1     1
         STW,1    SPACEU
         M:FP     1
         B        JOBEXIT
*
JOBENT2  EQU      %
         LI,6     0
         XW,6     YESNO
         BNEZ     JOBENT2A          SKIP TEST IF 1ST TIME THRU
         LW,6     *14
         CW,6     BJOB              IS IT A JOB CARD?
         BNE      JOBENT2A          NO, CONTINUE
         LI,13    -1                YES, SET SIGNAL,
         BAL,10   JOBENT            AND INSERT JOB
         LCI      0                 RESET REGS
         PLM,0    *TSTACK
         B        JOBENT            AND RESTART NEW JOB
JOBENT2A EQU      %
         LW,7     SPACEU            GET INDEX
         INT,1    13
         LW,3     1                 GET NEW BYTE COUNT
         AI,1     3
         SLS,1    -2
         MTW,0    BPMUTSFLAG        IS IT CP-V?
         BNEZ     JOBENT2B          YES
         SLS,13   -16
         STB,13   3
         B        JOBENT6
JOBENT2B LI,2     2                 SET FOR CP-V
         LI,3     1
         STH,13   3
         SLS,13   -16
         STB,13   3,2
JOBENT6  EQU      %
         MTW,1    SPACEU
         MTW,-1   SPACEL
         CW,1     SPACEL
         BLE      JOBENT3
JOBENT4  CAL1,1   FPT               INSERT BLOCK
         LI,2     253
         STW,2    SPACEL
         LI,7     1
         STW,7    SPACEU
         B        JOBENT6
JOBENT3  EQU      %
         AWM,1    SPACEU
         LCW,2    1
         AWM,2    SPACEL
         STW,3    *BUFFER,7
         LI,2     0
         AI,7     1
         LW,8     *14,2
         STW,8    *BUFFER,7
         AI,2     1
         BDR,1    %-4
         AI,7     1
         MTW,0    BPMUTSFLAG        IS IT CP-V?
         BNEZ     JOBENT3A          YES
         LW,8     =X'40000000'      NO
         B        JOBENT3B
JOBENT3A LI,8     X'4001'           SET EOSB AND SKIP - CP-V
JOBENT3B STW,8    *BUFFER,7
JOBEXIT  EQU      %
         LCI      0
         PLM,0    *TSTACK
         B        *10
*
JOBABN   LI,15    JOBENT4
JOBABN2  LH,6     10
         SLS,6    -1
         AND,6    =X'7F'
         CI,6     X'3B'
         BNE      JOBABORT
JOBWAIT  MTW,0    BPMUTSFLAG        IS IT CP-V?
         BEZ      JEAB10            NO, SKIP THIS SLEEPING JAZZ
         CAL1,8   SLEEP             WAIT 2 MINS.
JOBW1    LW,8     JOBID
         BEZ      *15
         CAL1,1   FPT2
         CI,8     2
         BE       JOBWAIT
         B        *15               TRY AGAIN
JEAB10   EQU      %
         LW,1     =7500000          WAIT ABOUT 30 SECS
         MTW,-1   1
         BGZ      %-1
         B        JOBW1             TRY AGAIN
JOBABORT EQU      %                 ABORT THE JOB
         BAL,14   ABORT
         TEXTC    'CAN''T ENTER JOB'
JOBABN1  LI,15    JOBENT5
         B        JOBABN2
         PAGE
*
*        SUBROUTINE TO ENTER A JOB STREAM TO TAPE
*           SAME REGS AS JOBENT
*
         LOCAL INSERT1,INSERT2
EOWRT    EQU      %
         LCI      0
         PSM,0    *TSTACK
         MTW,-1   BUFFER
         BC       %+2
         M:OPEN   M:EO,(OUT)
         AI,13    0
         BLZ      EOEXIT
EOWRT1   EQU      %
         INT,1    13
         CI,1     80
         BG       %+5
         AI,1     -1
         LC       *14,1
         BCR,11   %-2
         AI,1     1
         M:WRITE  M:EO,(BUF,*14),(SIZE,*1),(WAIT)
EOEXIT   LCI      0
         PLM,0    *TSTACK
         B        *10
         PAGE
*
*        JUST INSERT THA JOB
*
INSERT   M:OPEN   M:EI,(BUF,BUF1),(RECL,120),(IN)
         BAL,10   READC
         BAL,15   GETIA
INSERT2  M:READ   M:EI,(ABN,INSERT1)
         LI,10    INSERT0
         PSW,10   *TSTACK
         LW,1     M:EI+4
         B        READCB
INSERT0  LW,13    1
         LW,10    BUF1
         CW,10    EODCD
         BNE      %+2
         AI,13    X'10000'
         CI,13    80
         BLE      %+2
         AI,13    X'20000'          SET BIIN
         LI,14    BUF1
         BAL,10   JOBENT
         B        INSERT2
INSERT1  EQU      %
         LB,1     10
         CI,1     6
         BE       INSERT4
         CI,1     5
         BNE      INSERT3
*        INSERT PHONEY EOD CARD IN JOB STREAM
*        ACTUALLY THIS CAN NEVER HAPPEN, BUT IF IT DOES, WE WILL TAKE
*        CARE OF IT PROPERLY
         LI,14    EODCD
         LI,13    X'10000'+80
         BAL,10   JOBENT
         B        INSERT2           READ ANOTHER RECORD
INSERT4  EQU      %
         LI,13    -1
         BAL,10   JOBENT
         M:EXIT
INSERT3  EQU      %
         BAL,14   ABORT
         TEXTC    'CAN''T READ M:EI'
ABORT    M:PRINT  (MESS,*14)
         B        MF#EXIT
#SIZE     EQU       %-#PATCH
          END       METAFUMBLE     DA END
