*
*               FILES USED: F:SCHE-DESCRIBES THE DATA BASE TO THIS PROGRAM
*
*                 F:DBNN - USED TO SCAN A DATA BASE AREA
*                                  OR PRINTED.
*
*                        M:LO-     USED TO LIST SOURCE INPUT AND RELATED
*                                   ERROR MESSAGES AS WELL AS REPORT
*
*                        M:SI-     DIRECTIVE SOURCE FILE.
         TITLE    'UXXX - DMSSPACE '
         SYSTEM   BPM
*        SYSTEM REFERENCES
         REF      M:LO
*        JIT REFERENCES
         REF      J:DCBLINK
         REF      J:ACCN
*        BU004 REFERENCES
         REF      CHKPAG
*        NO DIRECT BU005 - REQUIRED BY OTHER REFERENCED MODULES
*        BU006 REFERENCES
         REF      COMMON
         REF      F:SCHE
         REF      QCAUTH,QCTYP
         REF      QCPGSZ,QCPHSZ,QCPCKS,SPCHRF
         REF      QCLNSZ,QCLNRS,QCLNMK
*        BU007 REFERENCES
         REF      HIRAN2,LINEBITS,LORAN2,PARAM2
         REF      PAGERR
         REF      CVTIOE
         REF      NXTRAN
         REF      CVTCON
         REF   ALFSCN,NXTCHR,PARAM,DELIM
         REF      SCNEQS
         REF      QPARM
         REF      READC
         REF      NOPRT
         REF      SKIPBL
         REF      LORAN,HIRAN
         REF      CHKS1
         REF      Q:PCSR,Q:OBJS
         REF   FLSERR,RECERR,WRTERR
         REF      ERRLEV
         REF      PSWDOK
         PAGE
*        DMS REFERENCES
         REF      SCHMA,OPENRET
         REF      FINDD,FINDN,FINDG,FINDC,GET
         REF      CLOSEDB
         REF      FINDM
*        PROGRAM DEFINITIONS
         DEF      CCB
         DEF      DBXX
         DEF      DBNN
         DEF      DMSSPACE
         DEF      QGETD
         DEF      QUIT
         DEF      PATCH
         PAGE
         SYSTEM   SPACECI2
         PAGE
         CSECT    0
         PSYS     1                 LIST SUBSCHEMA
         SYSTEM   SPACECI3
         PAGE
RESERVE  CNAME
         PROC
         DISP     %
         LIST     0
LF(1)    DO1      AF(1)
         DATA     0
         LIST     1
         PEND
         TITLE    'UXXX - DMSSPACE - DATA'
SPACDATA CSECT    0
PATCH    RESERVE  20
ALLAREA  DATA     0                 ALL AREAS DEFAULT FLAG
CIPHKEY  DATA     0                 INPUT CIPHERKEY
FCIPHER DATA      0                 NONZERO IF AREA IS ENCIPHERED
ENSTMNT  DATA     0
DBNN     DATA     0                 DB01--DB64
INVTSW   DATA    0                   NONZERO IF INVENTORIES
NPGPIP   EQU      2032
CNPPIP   DATA     NPGPIP            NUMBER OF DATA PAGES PER INVENTORY PG
CHKSUM   DATA     0                 0-NO CHECKSUM, NONZERO - CHECKSUM
MAXRAN   DATA    0                   LAST PAGE OF F:DBASE.
SEQNO    DATA     0
FODBAS   DATA    0                   NONZERO INDICATES F:DBASG IS OPEN
OLDSEQ   DATA     0
PAGESZ   EQU     512                 SIZE OF DMS PAGE.
PAGHSZ   EQU     2                   SIZE OF PAGE HEADER.
DBXX     DATA     0
NLINE    DATA     0                 LINE NUMBER ON CURRENT REPORT
SPACUSD  DATA     0                 # OF WORDS IN DATA PAGE
GRPPTR   DATA     0                 GROUP LOCATION PTR
GRPHGH   DATA     0                 HIGHEST GROUP #
NGRP     DATA     0                 NUMBER OF NON-EMPTY GROUPS
SUMV2V3  DATA     0                 SUM OF V2+V3
DCBPTR   DATA     0                 DCB POINTER F:SCHE OR F:NEWSCHE
FNEW     DATA     0                 FLAG = 0 NO F:NEWSCHE ASSIGNED
TEN      DATA    10                  USED TO CONVERT FROM BINARY TO EBCDIC
CVTTBL TEXT    '0123456789'
FSTORE   DATA     0                 STORAGE FLAG
NUMOPTR  DATA     0                 # OWNER POINTERS
NUMMPTR  DATA     0                 # MEMBER POINTERS
*
NUMOWN   DATA     0                 # OWNER GROUPS
NUMMEM   DATA     0                 # MEMBER GROUPS
         PAGE
GTAB     DATA     BA(AREA)
         DATA     BA(UNIT)
         DATA     BA(ASOWNER)
         DATA     BA(ASMEMBER)
         DATA     BA(ELEMENT)
         DATA     BA(ASCNTROL)
         DATA     BA(SCHEMAHD)
         DATA     BA(PASSWORD)
         DATA     BA(SSCHEM)
         DATA     BA(INDX)
AREA     EQU      AREAGP
         PAGE
*        BINARY VALUES TO BE PRINTED
V1       DATA     0
V2       DATA     0
V3       DATA     0
V4       DATA     0
V5       DATA     0
V6       DATA     0
V7       DATA     0
V8       DATA     0
V9       DATA     0
V10      DATA     0
V11      DATA     0
V12      DATA     0
V13      DATA     0
V14      DATA     0
*        BCD VALUES TO BE PRINTED
T1       RESERVE  1
T2       RESERVE  2
T3       RESERVE  2
T4       RESERVE  1                 3 DIGITS
T5       RESERVE  3                 10 DIGITS
T6       RESERVE  1
T7       DATA     0                 2 DIGITS
T8       DATA     0                 2 DIGITS
T9       DATA     0                 2 DIGITS
T10      DATA     0                 2 DIGITS
T11      DATA     0                 2 DIGITS
T12      DATA     0                 2 DIGITS
T13      DATA     0                 2 DIGITS
T14      DATA     0                 2 DIGITS
TX1      TEXT     '    '
         TEXT     'DRCT'            LOCATMOD
         TEXT     'INDX'
         TEXT     'CALC'
         TEXT     'CALC'
         TEXT     ' VIA'
         PAGE
         BOUND   8
FIBUFL   DATA    FIBUF1,FIBUF2       LOC OF DBASE INPUT BUFFERS
FIBUF1   RESERVE  512               DBASE INPUT BUFFERS
FIBUF2   RESERVE  512
OCCUR1   RESERVE  1000              # OF NON D-SWITCH OCCURRENCES
OCCUR2   RESERVE  1000              # OF D-SWITCH OCCURRENCES
PBUF     RESERVE  20                80 CHARACTER PRINT BUFFER
         PAGE
FFER16   DATA     FFER17
FFER17   TEXTC    '*** INCORRECT DATA PAGE READ FROM          ',;
                  '                       '
SCHBAD   DATA     SCHBAD1
SCHBAD1  TEXTC    '  *** SCHEMA FILE IS BAD, DBM ERROR CODE - XX'
         PAGE
ASNMIS   DATA     ASNMIS1
ASNMIS1  TEXTC    '** ASSIGN CARD MISSING FOR                  ',;
                   '                      '
CHKSC3   DATA    CHKSC4
CHKSC4   TEXTC    '***THE ABOVE WAS READ FROM            ',;
                  '                       '
RCNTMSG  DATA     RCNTMSG1
RCNTMSG1 TEXTC    'NNNNNNN PAGES DUMPED FROM AREA X                 ',;
                  '            '
RCNTAREA EQU      BA(RCNTMSG1)+32
WRTMNY   DATA    WRTMMS
WRTMMS TEXTC   '**** THERE WERE     DIAGNOSTIC MESSAGES RECORDED'
         PAGE
SCEM03   DATA    SCEM04
SCEM04   TEXTC    ' *** I/O ERROR, F:SCHE--XX YY'
SCEM05   DATA     SCEM06
SCEM06   TEXTC    ' *** I/O ERROR, F:NEWSCHE--XX YY'
FWEM01   DATA    FWEM02
FWEM02   TEXTC    ' **** I/O ERROR, F:DBNN--XX YY'
         PAGE
BADNM    TEXTC    '*** AREA NAME INCORRECT'
FFEM01   TEXTC    '*** SYNTAX ERROR'
FFERA1   DATA     FFERM1
FFERM1   TEXTC    '*** UNEXPECTED END OF FILE ON SI'
WRTONE   DATA    WRTOMS
WRTOMS TEXTC   '**** THERE WAS 1 DIAGNOSTIC MESSAGE RECORDED'
AREAMSG  TEXT     '     AREA = '
         TEXT     '                              '
         PAGE
SPACTEXT CSECT    1
         BOUND    8
BLANKS  TEXT    '        '
AREATX   TEXT     'AREA'
CIPHKEYX TEXT     'CIPHKEY'
DBEMPTY  TEXT     ' AREA EMPTY'
TIT1     TEXT     '1 CURRENT DATA BASE & CURRENT SCHEMA    '
TIT2     TEXT     '1 CURRENT DATA BASE & NEW SCHEMA        '
         PAGE
HDRLINE1 TEXT     '  GROUP <--OCCURRENCES--> <----SPACE----'
         TEXT     '>GROUP  STORAGE SETS  NON-STG SETS      '
HDRLINE2 TEXT     ' NUMBER NON D-SW     D-SW GROUP     TOTA'
         TEXT     'L TYPE  OWNER MEMBER  OWNER MEMBER      '
HDRLINE3 TEXT     '                          SIZE       USE'
         TEXT     'D       # PTR  # PTR  # PTR  # PTR      '
DUMMYLINE  TEXT   '  9999  99999999 99999999  999 999999999'
         TEXT     '9 9999  99 99  99 99  99 99  99 99      '
VERCON   TEXT     ' DMSSPACE -EXTENDED DMS'
         TITLE    'UXXX - DMSSPACE - SUBROUTINES'
SPACPROG CSECT    1
*
*        THIS ROUTINE ANALYSES THE GRP OF THE CURRENT GRP TO BE
*                 PRINTED TO SEE IF ITS ACCESS CODE COINCIDES WITH
*                 THE USER-SPECIFIED PASSWORD'S ACCESS CODES
*                  - IF NOT, IT SKIPS THE GROUP, OR BLANKS THE ITEM.
QGETD    SAVE     X1,X2,X3,A,Q
QGET24   EQU      %
         LI,X2    BA(GROUPC)        FIND MASTER OF GROUPSET
         BAL,X7   FINDSM
         BNE      FFEM2             'BAD SCHEMA'
QGET25   EQU      %
         LI,X2    BA(GROUPC)        GET NXT GROUP
         BAL,X7   GETNXT
         BNE      QGET99            END OF GROUP SET
         BCDBIN   GROUPNO,4         GET BINARY GROUP IN X9
         CW,X9    QCTYP             RIGHT PROUPNO REQ ?
         BNE      QGET25            NO, TO TEST NXT GROUP
         LI,X2    BA(GRPRLOCK)      CONVER GRPRETLOCK IN BINARY
         BCDBIN   (0,X2),3            IN X9
         MTW,0    X9                IS THERE A LOCK
         BEZ      QGET32            NO
         CALL     CAUTHKY           CHECK GRP RETRIEVE KEY
         LW,A     QCAUTH            AUTHORITY GOOD OR BAD ?
         BEZ      QGET32            GOOD
         MTW,3    NOPRT             SET NOTPRT FLAG
         B        QGET99            RETURN
QGET32   EQU      %
         LI,X2    BA(ITEMSET)       FIND MASTER OF ITEMSET
         BAL,X7   FINDSM
         BNE      FFEM2             'BAD SCHEMA'
QGET33   EQU      %
         LI,X2    BA(ITEMSET)       GET NXT ITEM
         BAL,X7   GETNXT
         BNE      QGET99            END OF ITEMSET
         LI,X2    BA(ITMRLOCK)
         BCDBIN   (0,X2),3          GET BINARY ITMRLOCK IN X9
         MTW,0    X9                IS THERE A LOCK
         BEZ      QGET99            NO
         CALL     CAUTHKY           CHECK ITEM RETRIEVE KEY
         LW,A     QCAUTH            AUTHORITY GOOD OR BAD ?
         BEZ      QGET33            GOOD , TO NXT ITEM
         LW,X1    ITEMPSTN          RELATIVE POSITION OF ITEM IN GP
         LW,X7    ITEMSIZE          GET ITEM SIZE IN BYTES
         LI,Q     0
QGET35   STB,Q    *X3,X1            BLANKS UNAUTHORIZED ITEM
         AI,X1    1                 BUMP TO NXT BYT OF ITEM
         BDR,X7   QGET35
         B        QGET33            GET NXT ITEM
QGET99   RETURN   QGETD
         PAGE
*
*   CAUTHKY       CHECK GROUP OR ITEM RETRIEVE KEY WITH USER-SPECIFIED
*                 PASSWORD'S ACCESS CODES
*              UPON ENTRY: X9 = GROUP OR ITEM RETRIEVE KEY
*              UPON EXIT : QCAUTH = 0, ACCESS ALLOW
*                          QCAUTH NOT= 0, ACCESS NOT ALLOW
CAUTHKY  SAVE     X1,X2,X3
         LW,X2    X9                MOVE RETKEY IN X2
         SLD,X2   -5                GET WORD DISPLACEMENT IN X2
         SLS,X3   -27               RIGHT JUSTIFY
         LCW,X3   X3                FLIP SIGN
         LI,X1    1
         SLS,X1   31,X3             SHIFT TO PROPER POSITION
         LI,X9    RETKEYS           GET WA(RETKEYS) IN X9
         CW,X1    *X9,X2            IT BIT SET
         BAZ      %+2               NOT
         LI,X1    0                 YES
         STW,X1   QCAUTH            SET QCAUTH
         RETURN   CAUTHKY
         PAGE
*
*   MVSCHN        MOVE SCHEMA NAME INTO AREA DEFN
*
MVSCHN   SAVE
         M:OPEN   *DCBPTR,(SAVE),(IN),(RANDOM),;
                         (ERR,SCOERR),(ABN,SCOABN)
         LW,X1    DCBPTR
         AI,X1    6
         LW,X2    *X1               GET FLP OF SCHEMA FILE
         AND,X2   =X'1FFFF'         GET ADDR PORTION
         AI,X2    1                 BYPASS CONTROL WORD
         SLS,X2   2                 CHANGE TO BA
         LI,X1    0                 CLEAR X1
         LB,X1    0,X2              GET BYTE COUNT OF SCHEMA FILENAME
         AI,X1    1                 1ST BYTE INCLUDED
         LI,X3    SCHMA+2           GET FIRST OF AREA LINK ADDR
         LW,X3    *X3
         AI,X3    6                 FORM AREA NAME ADDR
         SLS,X3   2                 CHANGE TO BA
         MOVE     (0,X2),(0,X3),*X1 MOVE SCHEMA FILE NAMETO INCORE SCH
         M:CLOSE  *DCBPTR,(SAVE)
         RETURN   MVSCHN            RETURN
         PAGE
OPENSCHE SAVE
         LI,A    PAGESZ              INITALIZE PAGE SIZE
         STW,A    QCPGSZ
         LI,A    PAGHSZ              INITIALIZE PAGE HEADER SIZE
         STW,A    QCPHSZ
         CALL     MVSCHN            MOVE SCHEMA NAME INTO SUBSCHMA
         LI,A     SCHMA             GET SCHEMA ADDR
         STW,A    Q:OBJS            SET OBJECT SCHEMA ADDR
         MTW,1    Q:PCSR            SET Q:PCSR FLAG
*
         LI,14    2                 TWO ARGS
         BAL,15   OPENRET           OPEN SCHEMA DATABASE
         DATA     REF%CODE@CCB
         DATA     BA(SCHEBASE)      AREA NAME FOR SCHEMA
*
         LI,X2    X'101'            REF-CODE = PAGE  1 LINE 1
         STW,X2   REF%CODE@CCB
         STB,X2   REF%CODE@CCB      SET AREA#
*
         LI,14    0
         BAL,15   FINDD             GET SCHDR
*
         MTW,0    ERR%CODE@CCB
         BNEZ     FF00051
         LI,14    1
         BAL,15   GET               GET SCHEMAHD
         DATA     BA(SCHEMAHD)
*
         LW,X1    SCHESIZE          GET SCHEMA SIZE IN X1
         CALL     FIXSCHMA          FORM COMPLETE INCORE SCHEMA
         RETURN   OPENSCHE
         PAGE
*    FIXSCHMA     INSERTS NECESSARY INFORMATION INTO
*                 IN-CORE SUBSCHEMA
*               UPON ENTRY: X1 = SCHEMA SIZE
*                           FIRST CALCULATE NEXT LARGEST
*                           PRIME NUMBER
*                                   LINK IS ON X7
*
FIXSCHMA STW,X1   X5                SAVE SIZE (PRIME BASE)
         OR,X1    =1                MAKE IT ODD
         CI,X1    3
         BLE      FIX:4
FIX:1    LI,X4    3                 START DIVISOR AT LOWEST ODD NUMBER
FIX:2    LI,X2    0
         STW,X1   X3                CANDIDATE FOR PRIME
         DW,X2    X4                DIVIDE IT
         CI,X2    0                 WAS THERE A REMAINDER
         BNE      FIX:3             NO -- STILL MAY BE PRIME
         AI,X1    2                 NOT PRIME -- BUMP BASE TO NEXT ODD
         B        FIX:1             START OVER
FIX:3    AI,X4    2                 BUMP DIVISOR TO NEXT ODD
         STW,X4   X3                SQUARE DIVISOR
         MW,X3    X4
         CW,X3    X1                IS DIVISOR SQUARED < PRIME CANDIDATE
         BL       FIX:2             YES - TRY DIVIDING BY IT
*        PRIME VALUE IN X1, SCHEMA SIZE IN X5
*        SUBCHEMA FOR SCHEMA DATABASE STARTS AT 'SCHMA'
*
FIX:4    LW,X2    =X'200000'        MASK FOR CALC BIT
         LW,X3    SCHMA+2           X3 = ADDR OF AREA DEFN
         STW,X5   1,X3              SET NUMBER OF DATA PAGES IN AREA DEF
FIX:5    LW,X3    4,X3              ADDR OF NXT DEFN IN GROUP LINK
         AND,X3   =X'1FFFF'
         CW,X3    SCHMA+2           IS IT AREA DEFN
         BE       0,X7              EXIT IF SO -- DONE
         CW,X2    0,X3              IS GROUP CALC
         BAZ      FIX:5             BR IF NOT
         STW,X5   7,X3              STORE PAGE RANGE MAX
         STW,X1   8,X3              STORE PRIME VALUE
         B        FIX:5
         PAGE
SPACECOD CSECT    0
*
*   FINDSM        FIND SET MASTER
*                 UPON ENTRY: X2 = BA(SETNAME)
FINDSM   EQU      %
         LI,14    1
         STW,X2   %+2               SET ARG
         BAL,15   FINDM             FIND SET MASTER
         DATA     0
*
         MTW,0    ERR%CODE@CCB
         BEZ      *X7               GOOD RETURN
         LCI      3
         B        *X7               BAD RETURN
         PAGE
*
*   GETNXT        RETRIEVE NEXT GROUP OF A SET
*
GETNXT   LI,14    1
         STW,X2   %+2               STORE ARG
         BAL,15   FINDN
         DATA     0
*
         SLS,X2   -2                WORD ADDR OF SET TABLE
         LW,X1    0,2               REFCODE OF OWNER
         BEZ      GETNXT1           CANT BE CURRENT
         CW,X1    2,2               CURRENT OF SET
         BNE      GETNXT1           BR IF NOT
         LCI      3
         B        *7                XIT FALSE
GETNXT1  LW,X2    GRP%NO@CCB        GET ADDR OF SET TABLE
         LW,X2    GTAB-1,2
         B        GETGRP1
         PAGE
*
*   GETGRP        RETRIEVE GROUP AND MOVE TO WORKING STORAGE
*
GETGRP   LI,14    1
         STW,X2   %+2
         BAL,15   FINDG
         DATA     0
*
         MTW,0    ERR%CODE@CCB
         BEZ      GETGRP1
         LCI      3                 XIT FALSE
         B        *X7
GETGRP1  STW,X2   %+2               STW ARG
         BAL,15   GET
         DATA     0
         LCI      0
         B        *X7
         PAGE
         USECT    SPACPROG
*
*                 GET DCB ADDR AND CHECK FILE NAME
*                 RETURN IN DBXX DCB ADDR IF AREA NAMED IS
*                 PROPERLY ASSIGNED, ELSE SET CONDITION CODE
*                 = 3
GTDBFN   EQU      %
FG0010   EQU      %
         LW,X4    J:DCBLINK         ADDR OF DCB NAMES
         LW,X9    0,X4              ADDR OF NEXT BLOCK
         AI,X4    1
FG0011   LW,A     1,X4              GET DBNN IN 2,3TH BYTE OF A
         LW,X10   0,X4
         BNEZ     FG0012
         LCI      3                 FILE NOT ASSIGNED
         B        *7
FG0012   CW,X4    X9                AT NXT LINK
         BNE      FG0013
         LW,X4    X10
         B        FG0010            GO TRY NXT LINK
FG0013   SLD,X10  -24               TEXTC COUNT IN X10
         SLS,X11  -16               FIRST TWO CHAR OF DCB NAME IN X11
         AI,X10   4
         SLS,X10  -2
         AW,X4    X10               NOW POINT TO DB ADDR
         CI,X11   X'C67A'
         BE       FG0015            = F:
FG0014   AI,X4    1                 BYPASS DB ADDR
         B        FG0011
FG0015   LW,X11   0,X4              DCB ADDR
         STW,X11  DBXX              SAVE DCB ADDR
         SLS,A    -8                SHIFT 'DNN' TO LEFT
         LI,X3    X'C4'             'D'
         STB,X3   A                 FORM DBNN
         STW,A    DBNN              SAVE IT
         AI,X11   6                 TO VARIABLE PARAMETER LIST POINTER
         LW,X10   *X11
         AND,X10  =X'1FFFF'         GET ADDR PORTION
         AI,X10   1                 BYPASS NAME PARAMETER CONTROL WORD
         SLS,X10  2
         LB,X11   AREA              TEXTC COUNT OF AREANAME
         AI,X11   1                 ADD 1 BYTE COUNT, COMPARE COUNT TOO
         SLS,X11  24
         AI,X11   BA(AREA)
         CBS,X10  0
         BNE      FG0014            TRY NXT ON DCBLINK
         LCI      0
         B        *X7
         PAGE
*
*   CIPHDP        THIS ROUTINE WILL DECIPHER A DATA PAGE.
*                 THE PORTION OF THE PAGE THAT IS ENCIPHERED CONSISTS
*                 OF ALL DATA GROUPS IN THE PAGE.
*                 THE PAGE HEADER (WORDS 0 AND +1) AND THE OPTIONAL
*                 CHECKSUM ARE NOT ENCIPHERED.
*                 THE TECHNIQUE OF ENCIPHERING IS TO USE THE ENCIPHER
*                 KEY SPECIFIED FOR THE AREA AND GENERATE A RANDOM
*                 NUMBER FROM THE KEY. THE RANDOM NUMBER IS EXCLUSIVE
*                 OR'ED WITH WORD +2 OF THE PAGE. A SECOND RANDOM
*                 NUMBER IS GENERATED FOR WORD +3. THE PROCESS IS
*                 REPEATED FOR THE REST OF THE PAGE.
*                 UPON ENTRY : X4 = BEGINING WA ADDR OF DATA PAGE
*                              X8 = USER'S CIPHER KEY
*
CIPHDP   EQU      %
         SAVE     X1,X4
         LI,X2    X'C00'            GET PAGE TYPE
         AND,X2   0,X4              AND'D WITH WORD 0
         CI,X2    X'400'            IS THIS A DATA PAGE
         BNE      CRET              NO, SKIP ENCIPHER & DECIPHER
         LI,X1    PAGESZ            GET PAGESIXE
         LI,X2    X'1FF'
         AND,X2   0,X4              GET AVAIL SPACE
         SW,X1    X2
         AI,X1    -3                LESS PAGE HEADER & CHECKSUM
         BLEZ     CRET              RETURN
         LI,Q     2
         OR,Q     X8                OR WITH USER CIPHER KEY
CIPHDP2  SLS,Q    -1
         MI,Q     65539             CALC RANDOM NUMBER
         SCS,Q    1
         LW,A     2,X4
         EOR,A    Q
         STW,A    2,X4              RESTORE DATA
         AI,X4    1                 POINT TO NXT WORD
         BDR,X1   CIPHDP2
CRET     RETURN   CIPHDP            RETURN
*                                   SET WITH THE NEXT PARAMETER.
         PAGE
*              CLOSE-THIS ROUTINE CLOSES BOTH F:DBASE AND F:DUMP
*              IF THEY ARE OPEN.
*
CLOSE    SAVE     X1,X3,X8
         MTW,0   FODBAS              DATA BASE OPEN?
         BEZ     CLOS10              NO
         LI,A    0                   MARK AS CLOSED
         STW,A   FODBAS
         M:CLOSE  *DBXX,(SAVE)
         LW,A     SEQNO             CALC # PAGES DUMPED & SAVE OLDSEQ
         SW,A     OLDSEQ
         BEZ      CLOS10            BR IF NO COUNT
         AWM,A    OLDSEQ
         BINBCD   A,BA(RCNTMSG1)+1,7 COUNT TO MSG
         LW,X3    DBXX              DCB ADDR
         LI,Q     1                 PARAM TYE CODE
         CALL     QPARM             LOCATE NAME
         LB,A     0,X1              MOVE NAME TO MSG
         AI,X1    1
         MOVE     (0,X1),RCNTAREA,*A
         CALL     WRTERR,RCNTMSG
         MTW,-1   ERRLEV
         BLANK    RCNTAREA,30
CLOS10   RETURN   CLOSE
         PAGE
*              THIS ROUTINE READS IN THE PAGE SPECIFIED BY LORAN
*              INTO THE BUFFER SPECIFIED IN FIBUFL+1. 512 WORDS ARE
*              ALWAYS READ.
*
*              UPON ENTRY:LORAN CONTAINS PAGE # TO READ.
*
FREAD    SAVE    X1,X3,A,Q
         MTW,-1  LORAN
         M:READ   *DBXX,(SIZE,512*4),(BUF,*FIBUFL+1),(BLOCK,*LORAN)
         MTW,1   LORAN
         RETURN  FREAD
         PAGE
*              THIS ROUTINE CHECKS FOR THE COMPLETION OF I/O FROM
*              THE DATABASE FILE. IF AN ERROR OCCURS, A MESSAGE
*              IS OUTPUTED AND THE JOB IS ABORTED
*
FWAIT    SAVE
         M:CHECK  *DBXX,(ABN,FWABN),(ERR,FWERR)
         LD,A     FIBUFL            FLIP BUFFER POINTERS.
         STW,A   FIBUFL+1
         STW,Q   FIBUFL
         RETURN  FWAIT
         PAGE
REPORT   SAVE
         LI,R1    0
         STW,R1   NGRP              RESET # OF NON-EMPTY GROUPS
         LI,X1    1
         STW,X1   V1
REPORT1  LW,X1    V1
         LW,R2    OCCUR1,X1
         STW,R2   V2
         LW,R3    OCCUR2,X1
         STW,R3   V3
         AW,R2    R3
         STW,R2   SUMV2V3           SAVE SUM OF V2+V3
         BGZ      REPORT3           OCCURRENCE FOUND FOR THIS GROUP
*        TRY NEXT GROUP
REPORT2  LW,X1    V1
         AI,X1    1                 BUMP GROUP #
         STW,X1   V1
         CI,X1    999
         BLE      REPORT1
         MTW,0    NGRP
         BNEZ     REPORT5
         M:WRITE  M:LO,(BUF,DBEMPTY),(SIZE,12)
REPORT5  RETURN REPORT
*
REPORT3  MTW,0    NGRP
         BNEZ     REPORT4
         CALL     HEADER            FIRST GROUP - PRINT HEADER
REPORT4  MTW,1    NGRP              BUMP NON-EMPTY COUNT
         CALL     SGROUP            GATHER SCHEMA STATS FOR GROUP
         CALL     ALINE
         B        REPORT2
         PAGE
*        PRINT REPORT HEADER
HEADER   SAVE
LSIZE    EQU      74
         M:WRITE  M:LO,(BUF,HDRLINE1),(SIZE,LSIZE)
         M:WRITE  M:LO,(BUF,HDRLINE2),(SIZE,LSIZE)
         M:WRITE  M:LO,(BUF,HDRLINE3),(SIZE,LSIZE)
         LI,X1    4
         STW,X1   NLINE             STORE NEXT LINE NUMBER
         RETURN   HEADER
         PAGE
*        SCAN SCHEMA AS DATA BASE FOR REST OF DATA
SGROUP   SAVE
         LI,R1    0
         STW,R1   V4
         STW,R1   V6
         STW,R1   V7
         STW,R1   V8
         STW,R1   V9
         STW,R1   V10
         STW,R1   V11
         STW,R1   V12
         STW,R1   V13
         STW,R1   V14
*        FIND GROUP BY CALC ON GROUPNO
         BINBCD   V1,GROUPNO,4
*
         LI,R14   1
         BAL,R15  FINDG             CALC ON GROUPNO
         DATA     BA(UNIT)
         LW,R1    ERR%CODE@CCB
         BNEZ     SGROUPX           EXIT IF GROUP DOES NOT EXIST
*
         LI,R14   1
         BAL,R15  GET
         DATA     BA(UNIT)
*
         LW,X1    =BA(LOCATMOD)
         LI,R2    0
         LB,R2    0,X1
         AND,R2   =X'F'             BCD TO BIN
         STW,R2   V6
*
         LW,R1    GRPSIZE
         AI,R1    3                 ROUND UP TO WORD BOUNDRY
         SLS,R1   -2                BYTES --> WORDS
         STW,R1   V4
         PAGE
OWN1     LI,R1    0
         STW,R1   NUMOPTR           RESET # OF OWNER POINTERS
*        RETRIEVE OCCURRENCES OF ASOWNER SET FOR THIS GROUP
         LI,R14   1
         BAL,R15  FINDN
         DATA     BA(OWNERSET)
*
         LW,R1    GRP%NO@CCB
         CI,R1    3
         BNE      MEM1              NO MORE OWNER OCCURRENCES - TRY MEMBER
*
         LI,R14   1
         BAL,R15  GET
         DATA     BA(ASOWNER)
*
         LI,R1    1
         MTW,0    OPSTNPRI
         BEZ      %+2
         AI,R1    1
         AWM,X1   NUMOPTR
         MTW,1    NUMOWN
         PAGE
*        RETRIEVE MEMBER OCCURRENCE TO TST FOR STORAGE ST
         LI,R1    0
         STW,R1   FSTORE
OWN2     LI,R14   1
         BAL,R15  FINDN
         DATA     BA(SETLINK)
*
         LW,R1    GRP%NO@CCB
         CI,X1    4
         BNE      OWN3              NO MORE MEMBER OCCURRENCES
*        MEMBER OCCURRENCE FOUND
         LI,R14   1
         BAL,R15  GET
         DATA     BA(ASMEMBER)
*
         LW,X1    =BA(STORAG)
         LI,R2    0
         LB,R2    0,X1
         CI,R2    X'F0'
         BEZ      OWN2
         MTW,1    FSTORE
         B        OWN2              LOOP THROUGH ALL MEMBERS
OWN3     MTW,0    FSTORE
         BEZ      NOSTOR
*        STORAGE SET ENCOUNTERED - ACCUMULATE OWNER STATISTICS
STOR     MTW,1    V7
         LW,X1    NUMOPTR
         AWM,X1   V8
         B        OWN1              TRY FOR ANOTHER MEMBER
*        NON-STORAGE SET ENCOUNTERED - ACCUMULATE OWNER STATISTICS
NOSTOR   MTW,1    V11
         LW,X1    NUMOPTR
         AWM,X1   V12
         B        OWN1              TRY FOR ANOTHER MEMBER
         PAGE
*        RETRIEVE OCCURRENCES OF ASMEMBER SET FOR THIS GROUP
MEM1     LI,R1    0
         STW,R1   NUMMPTR
*
         LI,R14   1
         BAL,R15  FINDN
         DATA     BA(MEMBRSET)
*
         LW,R1    GRP%NO@CCB
         CI,R1    4
         BNE      SGROUPX           NO MORE MEMBER OCCURRENCES - EXIT
*        MEMBER OCCURRENCE FOUND
         LI,R14   1
         BAL,R15  GET
         DATA     BA(ASMEMBER)
*
         LI,R1    1
         MTW,0    MPSTNPRI
         BEZ      %+2
         AI,R1    1
         MTW,0    PSTNHEAD
         BEZ      %+2
         AI,R1    1
         AWM,R1   NUMMPTR
         MTW,1    NUMMEM
         LW,R1    =BA(STORAG)
         LI,R2    0
         LB,R2    0,X1
         CI,R2    X'F0'
         BE       NOSTOR1
         PAGE
*        STORAGE SET ENCOUNTERED - ACCUMULATE MEMBER STATISTICS
STOR1    MTW,1    V9
         LW,R1    NUMMPTR
         AWM,R1   V10
         B        MEM1
*        NON-STORAGE SET ENCOUNTERED - ACCUMULATE MEMBER STATISTICS
NOSTOR1  MTW,1    V13
         LW,R1    NUMMPTR
         AWM,R1   V14
         B        MEM1
SGROUPX  RETURN   SGROUP
         PAGE
*        SET UP ONE LINE OF PRINT IN PBUF AND PRINT IT
ALINE    SAVE
*        CONVERT BINARY VALUES TO BCD
         BINBCD   V1,T1,4
         BINBCD   V2,T2,8
         BINBCD   V3,T3,8
         BINBCD   V4,T4,3
         LW,R5    V4
         MW,R4    SUMV2V3
         STW,R5   V5
         BINBCD   V5,T5,10
         LW,R2    BLANKS
         LW,X1    V6
         CI,X1    6
         BG       %+2
         LW,R2    TX1,X1
         STW,R2   T6
         BINBCD   V7,T7,2
         BINBCD   V8,T8,2
         BINBCD   V9,T9,2
         BINBCD   V10,T10,2
         BINBCD   V11,T11,2
         BINBCD   V12,T12,2
         BINBCD   V13,T13,2
         BINBCD   V14,T14,2
         PAGE
         LI,X1    20
         LW,R2    BLANKS
         STW,R2   PBUF-1,X1         BLANK PRINT BUFFER
         BDR,X1   %-1
         LI,X3    2
         MOVE     T1,(PBUF,X3),4
         AI,X3    6
         MOVE     T2,(PBUF,X3),8
         AI,X3    9
         MOVE     T3,(PBUF,X3),8
         AI,X3    10
         MOVE     T4,(PBUF,X3),3
         AI,X3    4
         MOVE     T5,(PBUF,X3),10
         AI,X3    11
         MOVE     T6,(PBUF,X3),4
         AI,X3    6
         MOVE     T7,(PBUF,X3),2
         AI,X3    3
         MOVE     T8,(PBUF,X3),2
         AI,X3    4
         MOVE     T9,(PBUF,X3),2
         AI,X3    3
         MOVE     T10,(PBUF,X3),2
         AI,X3    4
         MOVE     T11,(PBUF,X3),2
         AI,X3    3
         MOVE     T12,(PBUF,X3),2
         AI,X3    4
         MOVE     T13,(PBUF,X3),2
         AI,X3    3
         MOVE     T14,(PBUF,X3),2
         PAGE
*        STRIP OFF LEADING ZEROES
         LI,X1    0
NEXT1    LI,R2    0
         LB,R2    PBUF,X1
         CI,R2    X'40'             IS IT A BLANK
         BE       NEXT2             BLANK - GET NEXT CHARACTER
         CI,R2    X'F0'
         BL       SKPBLK            SKIP TO NEXT BLANK - ALPHA
         CI,R2    X'F9'
         BG       SKPBLK            SKIP TO NEXT BLANK - ALPHA
*        NUMERIC
         CI,R2    X'F0'
         BNE      SKPBLK
*        LEADING ZERO - IS IT THE LAST ZERO
NEXT3    BAL,7    INCTEST
         LI,R2    0
         LB,R2    PBUF,X1
         CI,R2    X'40'
         BE       NEXT2             LAST ZERO GO ON
         AI,X1    -1                BACK UP
         LI,R2    X'40'
         STB,R2   PBUF,X1           BLANK THE LEADING ZERO
         B        NEXT2
INCTEST  AI,X1    1
         CI,X1    LSIZE
         BG       NEXT4             END OF BUFFER - EXIT TO PRINT
         B        *7                NOT END OF BUFFER YET
NEXT2    BAL,7    INCTEST
         B        NEXT1             CONTINUE TESTING
SKPBLK   BAL,7    INCTEST
         LB,R2    PBUF,X1
         CI,R2    X'40'
         BNE      SKPBLK            CONTINUE SKIPPING NON-NUMERICS
         B        NEXT1             CONTINUE WITH SCAN
NEXT4    M:WRITE  M:LO,(BUF,PBUF),(SIZE,LSIZE)
         MTW,1    NLINE             BUMP LINE COUNTER
         RETURN   ALINE
         PAGE
*        ADD COUNTS FOR CURRENT GROUP TO OCCUR1,OCCUR2 TABLES
ADDGRP   SAVE
         LI,X1    1
         LW,X2    *GRPPTR           GET FIRST WORD
         SLS,X2   -14
         AND,X2   =X'3FF'           GET GROUP #
         LW,X3    *GRPPTR           GET FIRST WORD OF GROUP, D-SWITCH
         AND,X3   =X'00002000'      SELECT DELETE FLAG
         LW,X4    *GRPPTR           GET GROUP WORD COUNT
         AND,X4   =X'000001FF'
         AW,X4    GRPPTR
         STW,X4   GRPPTR            BUMP GRPPTR TO NEXT GROUP
         CI,X2    999               TEST FOR GROUP # WITHIN LIMITS
         BG       ADDGRP3           GROUP # > 999 - SKIP COUNTS.
         CI,X3    0
         BNE      ADDGRP2
ADDGRP1  MTW,1    OCCUR1,X2         BUMP NON D-SWITCH
         RETURN   ADDGRP
ADDGRP2  MTW,1    OCCUR2,X2         BUMP D-SWITCH
ADDGRP3  RETURN   ADDGRP
         TITLE    'UXXX - DMSSPACE - ERROR EXITS, QUIT'
*                                   *** THE ABOVE WAS READ FROM
FF0102D  EQU      %
         LI,X3    0
         LB,X3    AREA
         MOVE     AREANAME,CHKSC4+7,*X3
         CALL    WRTERR,CHKSC3
         LI,A    0                   RESET ERROR SWITCH.
         STW,A   PAGERR
         B        QUIT
*                                   ***SCHEMAFILE IS BAD, DBM ERROR CODE
FF00051  EQU      %
         CALL     WRTERR,SCHBAD     'SCHEMA IS BAD'
         B        QUIT
DBOERR   EQU     %
DBOABN   EQU     %
FWABN    EQU     %
FWERR    EQU     %
         CALL     CVTIOE,FWEM02,26  OUTPUT ERROR CODE
         MOVE     DBNN,FWEM02+5,4
         CALL    WRTERR,FWEM01
         B       QUIT
         PAGE
*                                   ***SCHEMAFILE IS BAD, DBM ERROR CODE
BDSCH    EQU      %
         BINBCD   ERR%CODE@CCB,SCHBAD1+11,2
         CALL     WRTERR,SCHBAD     'SCHEMA FILE IS BAD'
         B        QUIT              QUIT THIS JOB
*                                   ** ASSIGN CARD MISSING FOR  ---
NOASSN   EQU      %
         LI,X3    0
         LB,X3    AREA
         MOVE     AREANAME,ASNMIS1+7,*X3
         CALL     WRTERR,ASNMIS     'ASSIGN CARD MISSING'
         B        QUIT
*                                   *** SYNTAX ERROR
FF0041   CALL     RECERR,FFEM01     ILLEGAL SYNTAX
         B        QUIT
         PAGE
*                                   *** AREANAME INCORRECT
FF0045   EQU      %
         CALL     RECERR,BADNM
         B        QUIT
*                                   ***SCHEMAFILE IS BAD, DBM ERROR CODE
FFEM2    EQU      %
         BINBCD   ERR%CODE@CCB,SCHBAD1+11,2
         CALL     WRTERR,SCHBAD     SCHEMA FILE IS BAD
         B        QUIT
*                                   *** I/O ERROR, F:SCHE
SCOABN   EQU     %
SCOERR   EQU     %
         LW,R1    DCBPTR
         CI,R1    F:SCHE
         BNE      SCOERR1
         CALL     CVTIOE,SCEM04,25  OUTPUT ERROR CODE
         CALL    WRTERR,SCEM03
         B       QUIT
         PAGE
*        F:NEWSCHE ERROR
SCOERR1  CALL     CVTIOE,SCEM06,28
         CALL     WRTERR,SCEM05
         B        QUIT
*                                   ***UNEXPECTED END OF FILE ON SI
FFER10   CALL    WRTERR,FFERA1
         B       QUIT
*                                   *** INCORRECT DATA PAGE READ FROM
FFER15   EQU      %
         LI,X3    0
         LB,X3    AREA
         MOVE     AREANAME,FFER17+9,*X3
         CALL     WRTERR,FFER16     ERROR
         B        QUIT
         PAGE
QUIT     CALL    FLSERR              FLUSH ANY ERROR MESSAGES
         CALL    CLOSE                CLOSE ALL OPEN FILES
         LW,X3   ERRLEV              ANY ERRORS DETECTED
         BNEZ    QUIT10              YES
         M:EXIT
QUIT10   EQU     %
         CI,X3   1                   ONLY ONE ERROR
         BNE     QUIT30              NO, MORE
         CALL    WRTERR,WRTONE
QUIT20   M:XXX                       ABORT
QUIT30   LI,X1   BA(WRTMMS+4)+3      LOCATION OF ERROR COUNT
QUIT40   LI,X2   0                   SET UPPER HALF TO ZERO
         DW,X2   TEN
         LB,X2   CVTTBL,X2           CONVERT TO EBCDIC
       STB,X2  ,X1                 STORE IN ERROR MESSAGE
       AI,X1   -1                  DECREMENT BYTE POSITION IN MESSAGE.
         CI,X3   0                   ANYTHING LEFT TO CONVERT
         BNEZ    QUIT40              YES, KEEP GOING
         CALL    WRTERR,WRTMNY
         B       QUIT20
         TITLE    'UXXX - DMSSPACE '
DMSSPACE EQU      %
         M:TRAP   (IGNORE,FX)       SET OVERFLOW MASK FOR ALL CHECKSUMS
         M:DEVICE M:LO,(VFC)
         MTW,+1   PSWDOK            ALLLOW PASSWORD SPECIFICATION
         LI,X6   COMMON              LOC. OF COMMON REGION.
         LI,X1    1000              RESET OCCURRENCE TABLES
         LI,R2    0
         STW,R2   OCCUR1-1,X1
         STW,R2   OCCUR2-1,X1
         BDR,X1   %-2
*   SKIP M:C , OPEN DBASE AND FIND SCHDR
FF0005   EQU      %
         LI,X1   VERCON
         CALL     READC
         CALL     SKIPBL            READ M:SI
         LI,R1    F:SCHE
         STW,R1   DCBPTR
         CALL     OPENSCHE          OPEN F:SCHE
         M:OPEN   F:NEWSCHE,(SAVE),(IN),(RANDOM),;
                  (ERR,NSERR),(ABN,NSERR)
         M:CLOSE  F:NEWSCHE,(SAVE)
         LI,R1    1                 SET FLAG=F:NEWSCHE FILE EXISTS
         B        NSERR1
NSERR    LI,R1    0                 RESET FLAG
NSERR1   STW,R1   FNEW              =1 ONLY IF SUCCESSFUL OPEN
         PAGE
*
*   START TO PROCESS DIRECTIVES
*
FF0015   EQU      %
         CALL     ALFSCN            GET COMMAND
         MTW,0    NXTCHR            EOF ?
         BEZ      FF0031            EOF - ALL AREAS
*                                   WITHOUT ENCIPHERING
*        NEXT STATEMENT LOOP RETURN
FF0016   EQU      %
         LI,A     0
         STW,A    ALLAREA           CLEAR FLAG
         STW,A    ENSTMNT           CLEAR ENSTMNT
*   PROCESSING AREA-NAME
*
FF0030   EQU      %
         CALL     SCNEQS            CHECK '.'
         CI,A     C'.'
         BE       FF0031            END OF STATEMENT
         CI,A     0                 EOF PROTECTION
         BE       FF0031            EOF ASSUMED
         MTW,0    NXTCHR            EOF REACHED
         BNEZ     FF0040            TO PROCESS INDIVIDUAL AREA
         B        FF0041            ILLEGAL SYNTAX
         PAGE
*        EOF OR END OF STATEMENT '.' ENCOUNTERED
*        EVALUATE SPACE REQUIREMENTS FOR ALL AREAS WITHOUT ENCIPHERING
*
FF0031   EQU      %
         MTW,1    ENSTMNT           SET ENSTMNT FG
         LI,X2    BA(AREASET)
         BAL,X7   FINDSM            GET MASTER OF AREASET
FF0032   LI,X2    BA(AREASET)
         BAL,X7   GETNXT            GET NXT ON AREASET
         BNE      BDSCH             BAD SCHEMA
         MTW,1    ALLAREA           SET ALLAREA FLAG
FF0033   EQU      %
         BAL,X7   GTDBFN            VERIFY ASSIGNMENT
         BNE      NOASSN            NO ASSIGN CARD
         LI,X2    BA(AREASET)
         BAL,X7   GETNXT            GET NXT AREA
         BNE      FF0035            TO PROCESS EACH AREA
         B        FF0033            TO CHECK ASSIGNMENT
FF0035   EQU      %
         LI,X2    BA(AREASET)
         BAL,X7   FINDSM            FIND AREASET MASTER
*        NEXT AREA STATEMENT LOOP RETURN
FF0036   LI,X2    BA(AREASET)
         BAL,X7   GETNXT            GET NXT ON AREASET
         BNE      PREP              END OF DUMP ALL - PRINT REPORT
         B        FF0050            TO PROCESS DATABASE
         PAGE
*
*   DUMP SPECIFIED AREAS
FF0040   EQU      %
         LW,X2    AREATX            'AREA' ?
         CW,X2    PARAM
         BNE      FF0041            ILLEGAL SYNTAX
FF0042   EQU      %
         CALL     SCNEQS            '=' ?
         CI,A     C'='
         BNE      FF0041            ILLEGAL SYNTAX
         MTW,1    SPCHRF            SET SPEC CHR FLAG
         CALL     ALFSCN            GET AREA:NAME
         MTW,-1   SPCHRF            RESET SP CHR FG
*        GET MASTER OF AREASET
FF0043   LI,14    1
         BAL,15   FINDC             GET SET MASTER OF AREASET
         DATA     BA(SCHEMAHD)
*
         MTW,0    ERR%CODE@CCB
         BNEZ     FFEM2
FF0044   EQU      %
         LI,X3    0
         LB,X3    AREA              GET BYTE COUNT
         LI,X2    BA(AREASET)
         BAL,X7   GETNXT
         BNE      FF0045            ILLEGAL AREANAME
         LI,X3    0
         LB,X3    AREA              GET BYTE COUNT
         COMPARE  AREANAME,PARAM,*X3
         BNE      FF0044            GO CHECK NXT AREANAME
         PAGE
*
*   ACCESSING SCHEMA FILE AFTER MATCHING FILE NAME
*                 AND AREA NAME
FF0050   EQU      %
         LI,A     0
         STW,A    PARAM2
         STW,A    LORAN2
         STW,A    HIRAN2
         STW,A    CHKSUM            CLEAR CHKSUM FLAG
         STW,A    QCPCKS            CLEAR CHKSUM FLAG
         STW,A    CIPHKEY           CLEAR CIPHKEY
         STW,A    FCIPHER           ZERO AREA CIPHER KEY
         STW,A    SEQNO             CLEAR SEQUENCE NUMBER
         BCDBIN   INVPERCT,2,INVTSW STORE INV PERCENT IN INVTSW
         LI,A     1
         AND,A    FILPERCT          ENCIPHER FLAG FROM AREAGRP
         STW,A    FCIPHER
         LW,Q     INVPERCT          GET NBR OF LINES
         AND,Q    L(X'00000F00')
         SLS,Q    -8
         STW,Q    LINEBITS          SAVE LINEBITS FOR PRINT
         LW,Q     INVPERCT          GET NBR OF LINES
         CI,Q     1
         BAZ      %+4               NO CHECKSUM
         LI,A     2
         STW,A    CHKSUM            SET CHKSUM=2
         STW,A    QCPCKS            SET CHKSUM FLAG
         SLS,Q    -8
         AND,Q    =X'0000000F'
         AI,Q     3                 FORM BITS # FOR LINES
         STW,Q    QCLNSZ            #BIT IN LINE#
         LCW,A    Q
         STW,A    QCLNRS            # RIGHT SHIFT TO DROP LINE#
         LI,A     0
         LW,X1    Q
         LW,Q     =X'FF000000'
         SLD,A    0,X1
         STW,A    QCLNMK            LINE# MASK
         BAL,X7   GTDBFN            PUT DCB NAME IN DBXX FROM ASSIGN CARD
         BNE      NOASSN            NO ASSIGN CARD
         PAGE
*        OPEN DATA BASE FOR SCAN
         M:OPEN   *DBXX,IN,(ERR,DBOERR),(ABN,DBOABN)
         MTW,1    FODBAS            SET FILE OPEN SWITCH ON
FF0051   LW,Q     DATAPGES          GET TOTAL DATAPGS
         STW,Q    MAXRAN
FF0053   STW,Q    HIRAN             STORE IN CASE NO RANGE IS GIVEN
         LI,A     1
         STW,A    LORAN
         PAGE
FF0075   EQU      %
         MTW,0    ALLAREA           ALL AREAS ?
         BNEZ     FF0095            YES
         CALL     SCNEQS            GO SCAN FOR NXT PARAMETER
         CI,A     C'.'              END OF COMMAND ?
         BNE      FF0077
         MTW,1    ENSTMNT           SET ENSTMNT FLAG
         B        FF0095
FF0077   EQU      %
         LW,A     FILPERCT
         CI,A     1                 ENCIPHERED DP ?
         BAZ      FF0095            NO
         COMPARE  CIPHKEYX,PARAM,7
         BNE      FF0041            SYNTAX ERROR
         PAGE
*        GET CIPHER KEY FROM DIRECTIVE
FF0080   EQU      %
         CALL     SCNEQS            GET '='
         CI,A     C'='
         BNE      FF0041            ILLEGAL SYNTAX
         MTW,-1   SPCHRF            SET FLAG TO GET CIPHKEY
         CALL     ALFSCN
         MTW,1    SPCHRF
         MTW,0    NXTCHR
         BEZ      FFER10            EOF
         LW,A     PARAM
         STW,A    CIPHKEY           STORE KEY
         CALL     SCNEQS            GET NXT WORD
         CI,A     C'.'              END OF COMMAND ?
         BNE      FF0041            SYNTAX ERROR
         MTW,1    ENSTMNT           SET ENSTMNT FLAG
         B        FF0095
         PAGE
*        READ A PAGE OF THE DATA BASE
FF0095   CALL     FREAD             READ DATA BASE BLOCK C(LORAN)-1
*        READ A DATA BASE PAGE LOOP RETURN
FF0100   CALL    FWAIT               WAIT FOR I/O TO COMPLETE.
         LW,A     *FIBUFL           CHECK DATA PAGE #
         SLS,A    -12
         CW,A     LORAN             RIGHT PAGE BEING READ
         BNE      FFER15            INCORRECT PAGE
         LW,A     *FIBUFL
         AND,A    =X'C00'
         CI,A     X'400'
         BNE      FF0106A           NOT DATA PAGE - SKIP TO END OF AREA
         MTW,1   LORAN               BUMP TO NEXT PAGE
         LW,A    LORAN
         CW,A    HIRAN               ALL PROCESSED
         BG       FF0102            YES - SKIP NEXT BLOCK READ
         CALL FREAD                  START NEXT READ
FF0102   EQU     %
         MTW,0    FCIPHER           ENCIPHERED AREA
         BEZ      FF0102B           NO
         LW,X8    CIPHKEY           CIPHER KEY INPUT
         BNEZ     FF0102A           GO DECIPHER PAGE
         B        FF0102B           NO CIPHER  CHECKSUM WILL ABORT
FF0102A  LW,X4    FIBUFL            STARTING ADDR OF PAGE
         CALL     CIPHDP            DECIPHER THE PAGE
FF0102B  LW,X3    FIBUFL            STARTING ADDR OF PAGE
         MTW,0    CHKSUM            AREA HAVE CHECKSUM
         BEZ      FF0102C
*        COMPUTE CHECKSUM
         LI,A    X'1FF'              MASK TO ISOLATE # WORDS
         AND,A    *FIBUFL           SPACE AVAIL TO AR
         LI,X1   PAGESZ-1            CALC # WORDS IN RECORD
         SW,X1    A
         CALL    CHKS1               YES, GO CHECK IT.
         MTW,0   PAGERR              CHECKSUM ERROR
         BNEZ     FF0102D
FF0102C  CALL     CHKPAG            GO CHECK LEGALITY OF PAGE
         MTW,0   PAGERR              ILLEGAL PAGE.
         BNEZ     FF0102D            ERROR
         B        FF0200            PROCESS A PAGE
         PAGE
*        TABULATE GROUP COUNTS FOR THIS PAGE OF THE DATA BASE
FF0200   EQU     %
*        ACCUMULATE GROUP OCCURRENCES FOR ONE DATA PAGE
ACCUM    EQU      %
*        INITIALIZE GROUP POINTER
         LI,A    X'1FF'              MASK TO ISOLATE # WORDS
         AND,A    *FIBUFL           SPACE AVAIL TO AR
         LI,X1    PAGESZ-1          CALC # OF WORDS IN BLOCK - NO CHECKSUM
         SW,X1    A
         STW,X1   SPACUSD
         LW,X1    FIBUFL
         AI,X1    2
         STW,X1   GRPPTR
*        TEST FOR END OF PAGE
ACCUM1   LW,X2    GRPPTR
         SW,X2    FIBUFL
         CW,X2    SPACUSD
         BGE      FF0106
         CALL     ADDGRP            ADD ONE TO TABLES AND BUMP GRPPTR
         B        ACCUM1
*                                   IN TABLES OCCUR1,OCCUR2
FF0106   EQU     %
         LW,A    LORAN               HAVE WE PROCESSED ALL THE BLOCKS?
         CW,A    HIRAN
         BLEZ    FF0100              NO, GO GET NEXT BLOCK.
         PAGE
*        END OF BLOCK SCAN
FF0106A  LI,X3    8
         LW,X1    BLANKS
         STW,X1   AREAMSG+2,X3
         BDR,X3   %-1               RESET MSG BUFFER
         LI,X3    0
         LB,X3    AREA
         AI,X3    12
         MOVE     AREANAME,AREAMSG+3,*X3
         M:WRITE  M:LO,(BUF,AREAMSG),(SIZE,42),(BTD,0)
         CALL     CLOSE             CLOSE CURRENT AREA
         PAGE
*        END OF AREA
FF0107   MTW,0    ALLAREA
         BNEZ     FF0115            TO NXT AREA VIA SET
         MTW,0    ENSTMNT           END OF STMNT REACHED ?
         BNEZ     FF0116            YES
         CALL     CVTCON            IS THERE A PAIR FOLLOWED ?
         MTW,0    NXTRAN            END OF STMNT REACHED ?
         BL       FF0116            TO NXT COMMAND
         MTW,0   NXTCHR              WAS EOF REACHED?
         BEZ      PREP              EOF - PRINT REPORT
         B        FF0040            TO NXT AREA
*        ALL AREAS - GO TO NEXT AREA
FF0115   EQU     %
         B        FF0036            TO NXT AREA
*        END OF AREA - TRY FOR ANOTHER STATEMENT
FF0116   EQU      %
         CALL     SKIPBL            GET NEW LINE
         MTW,0    NXTCHR            EOF
         BEZ      PREP              EOF - PRINT REPORT
         CALL     ALFSCN
         B        FF0016            TO NXT DIRECTIVE
         PAGE
PREP     CALL     CLOSE             CLOSE CURRENT AREA
         M:WRITE  M:LO,(BUF,TIT1),(SIZE,40)
         CALL     REPORT
         MTW,0    FNEW
         BEZ      PREP1             SKIP NEWSCHEMA REPORT IF NO F:NEWSCHEMA
         LI,R1    -1
         STW,R1   CCB
         LI,R14   0
         BAL,R15  CLOSEDB
         LI,R1    F:NEWSCHE
         STW,R1   DCBPTR
         CALL     OPENSCHE
         M:WRITE  M:LO,(BUF,TIT2),(SIZE,40)
         CALL     REPORT
         LI,R14   0
         BAL,R15  CLOSEDB
PREP1    B        QUIT              END OF REPORT - QUIT
         PAGE
F:NEWSCHE  DSECT  1
F:NEWSCHE  M:DCB  (FILE),(RANDOM),(DIRECT),(SAVE),(IN),(PASS),(SN,10)
         PAGE
LITERALS CSECT    1
         END      DMSSPACE
