-ADD SYS9TMEM,PSWD=40EF,ARC,SEQ=/1,6,100,100/
-DESC SYSTABLE READ SEQ TBL TO ALLOC MEMORY
-PGMR RYDER  JSR SYSTEMS
-LANG COB
000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.     SYS9TMEM.
000300*AUTHOR.     STEVE RYDER.
000400*DATE-WRITTEN.   MARCH 1999.   CLONED FROM SYSTREAD.
000500*
000600*REMARKS. CALLED BY SYSTABLE TO READ TABLE FILES.
000700*         DETERMINE THE FILE TYPE AND FILE TO LOAD FROM BY
000800*         SPECIFYING THE PROPER DDNAMES.  SYS9TMEM LOOKS FOR
000900*         DDNAMES IN THE FOLLOWING ORDER:
001000*         - FIRST 8 BYTES OF TABLE-ID REPLACING '-' WITH '@'
001100*           TABLE IS SEQUENTIAL
001200*         IF ABOVE NOT FOUND, RETURN STATUS=TFNF
001300*            AND SYSTABLE WILL READ TABLE FROM DDNAME=TABL.
001400*----------
001500*MODIFICATION HISTORY :
001600*  DATE   PROGRAMMER     CHANGE
001700*
001800*
001900*
002000*
002100*
002200*
002300****************************************************************
002400 ENVIRONMENT DIVISION.
002500 CONFIGURATION SECTION.
002600 OBJECT-COMPUTER.    IBM-370.
002700 INPUT-OUTPUT SECTION.
002800 FILE-CONTROL.
002900     SELECT  TABLE-FILE
003000         ASSIGN TO  UT-S-XXXXXXXX.
003100*                        DDNAME TO BE FILLED IN BY SYSDDNAM.
003200 DATA DIVISION.
003300 FILE SECTION.
003400 FD  TABLE-FILE
003500     RECORDING MODE IS F
003600     LABEL RECORDS ARE STANDARD
003700     RECORD CONTAINS 0 CHARACTERS
003800     BLOCK CONTAINS 0 RECORDS
003900     DATA RECORD IS TABLE-RECORD.
004000 01  TABLE-RECORD.
004100     05  TABLE-CHAR              PIC X(01) OCCURS 289 TIMES
004200                                 INDEXED BY  TABLE-LEFT,
004300                                             TABLE-RIGHT.
004400 WORKING-STORAGE SECTION.
004500 01  MY-PROGRAM-ID               PIC X(08) VALUE 'SYS9TMEM'.
004600 01  SYSLOG-ID                   PIC X(08) VALUE 'SYSLOG  '.
004700 01  SYSDDNAM-ID                 PIC X(08) VALUE 'SYSDDNAM'.
004800 01  SYSJFCB-ID                  PIC X(08) VALUE 'SYSJFCB '.
004900 01  SYSMOVE-ID                  PIC X(08) VALUE 'SYSMOVE '.
005000 01  CEEGTST                     PIC X(08) VALUE 'CEEGTST '.
005100 01  CEEFRST                     PIC X(08) VALUE 'CEEFRST '.
005200 01  GET-STORAGE-HEAPID          PIC S9(9) BINARY.
005300 01  GET-STORAGE-NBYTES          PIC S9(9) BINARY.
005400 01  GET-STORAGE-FEEDBACK.
005500     05  FILLER                  PIC X(08) VALUE '********'.
005600         88  CEE000                        VALUE LOW-VALUES.
005700     05  FILLER                  PIC X(04) VALUE '****'.
005800     05  FILLER                  PIC X(04) VALUE '****'.
005900 01  GET-STORAGE-ADDRESS         USAGE IS POINTER VALUE NULL.
006000 01  TABLE-HEADER.
006100*    FIRST CARD OF TABLE-FILE MUST BE TABLE-HEADER.
006200*    COLUMNS     CONTENTS
006300*    03-10       ALTERNATE TABLE DDNAME.
006400*                       - IF 3-10 OF TABLE HEADER RECORD IS NOT
006500*                         BLANK, DO SYSJFCB, IF DDNAME EXISTS
006600*                         OPEN IT AS ALTERNATE.  THIS WILL ALLOW
006700*                         TABLE DETAIL RECORDS TO BE SHORTER
006800*                         THAN HEADER RECORD.
006900*    12-26       TABLE-ID
007000*    28-31       MAXIMUM ENTRIES IN TABLE
007100*    32-35       LENGTH OF LEFT  SIDE DATA
007200*    36-39       LENGTH OF RIGHT SIDE DATA
007300*    40-43       LEFTMOST POSITION OF LEFT  DATA IN SEQ REC.
007400*    44-47       LEFTMOST POSITION OF RIGHT DATA IN SEQ REC.
007500*    51-55       MAXIMUM ENTRIES IF > 9999 AND 28-31 = 0000.
007600     05  FILLER                  PIC X(02).
007700     05  TABLE-ALT-DDNAME        PIC X(08).
007800     05  FILLER                  PIC X(01).
007900     05  TABLE-ID.
008000         10  TABLE-8             PIC X(08) VALUE SPACES.
008100             88  FIRST-CALL                VALUE SPACES.
008200         10  TABLE-7             PIC X(07) VALUE SPACES.
008300     05  FILLER                  PIC X(01).
008400     05  TABLE-MAX-ENTRIES       PIC 9(4).
008500     05  TABLE-LENGTH-LEFT       PIC 9(4).
008600     05  TABLE-LENGTH-RIGHT      PIC 9(4).
008700     05  TABLE-POSITION-LEFT     PIC 9(4).
008800     05  TABLE-POSITION-RIGHT    PIC 9(4).
008900     05  FILLER                  PIC X(03).
009000     05  TABLE-MAX-5-DIGIT       PIC 9(05).
009100 01  WS-POINTERS                 USAGE IS BINARY.
009200     05  WS-MAX-ENTRIES          PIC S9(4).
009300     05  WS-LENGTH-LEFT          PIC S9(4).
009400     05  WS-LENGTH-RIGHT         PIC S9(4).
009500*---
009600     COPY 'SYSLLOG'.
009700 05  LOG-MESSAGE-X REDEFINES LOG-MESSAGE.
009800         10  FILLER                   PIC X(08).
009900         10  LOG-TABLE-ID             PIC X(15).
010000         10  FILLER                   PIC X(05).
010100         10  LOG-MAX-ENTRIES          PIC ZZZZZ.
010200         10  FILLER                   PIC X(05).
010300         10  LOG-LENGTH-LEFT          PIC ZZZ.
010400         10  FILLER                   PIC X(01).
010500         10  LOG-LENGTH-RIGHT         PIC ZZZ.
010600         10  FILLER                   PIC X(01).
010700         10  LOG-MEMBER               PIC X(09).
010800         10  LOG-DSN-44               PIC X(44).
010900         10  FILLER                   PIC X(01).
011000     COPY 'SYSLJFCB'.
011100     COPY 'SYSBITWS'.
011200 LINKAGE SECTION.
011300 01  TABL-ALLOCATION.
011400     05  TABL-MAX-ENTRIES        PIC S9(4) BINARY.
011500     05  TABL-LENGTH-LEFT        PIC S9(4) BINARY.
011600     05  TABL-LENGTH-RIGHT       PIC S9(4) BINARY.
011700     05  TABL-ENTRY              OCCURS 1 TO 32000 TIMES
011800                                 DEPENDING ON WS-MAX-ENTRIES
011900                                 INDEXED BY TABL-X.
012000         10  TABL-LEFT.
012100             15  TABL-LEFT-CHAR  PIC X(01) OCCURS 1 TO 20 TIMES
012200                                 DEPENDING ON WS-LENGTH-LEFT.
012300         10  TABL-RIGHT.
012400             15  TABL-RT-CHAR    PIC X(01) OCCURS 1 TO 250 TIMES
012500                                 DEPENDING ON WS-LENGTH-RIGHT.
012600 01  LK-COMMANDS.
012700     05  LK-FUNCTION             PIC X(08).
012800         88  LK-READ             VALUE 'READ '.
012900         88  LK-READX            VALUE 'READX'.
013000***          READX IS TO READ THE KEY FIELD ONLY
013100***          READ  IS TO READ THE KEY AND OBJECT FIELDS
013200***      DETERMINED BY SYSTABLE DEPENDING ON PRESENCE OF
013300***      THIRD PARAMETER.
013400     05  LK-STATUS               PIC X(04).
013500         88  LK-STATUS-OK        VALUE '****'.
013600     05  LK-TABLE-ID.
013700         10  LK-TABLE-8          PIC X(08).
013800         10  LK-TABLE-7          PIC X(07).
013900 01  LK-POINTER                  USAGE IS POINTER.
014000 PROCEDURE DIVISION  USING LK-COMMANDS LK-POINTER.
014100 0000-ENTRY.
014200     IF  LK-FUNCTION = 'FREE    '
014300         CALL 'CEEFRST' USING LK-POINTER
014400                              GET-STORAGE-FEEDBACK
014500         GOBACK
014600     .
014700     MOVE '****' TO LK-STATUS
014800     PERFORM 0700-OPEN
014900     IF  LK-STATUS = '****'
015000*--------ALLOCATE SPACE HERE.
015100         PERFORM 9100-GET-STORAGE
015200         SET TABL-X TO 1
015300         PERFORM 0100-READ
015400             UNTIL LK-STATUS NOT = '****'
015500     .
015600     IF  LK-STATUS = 'END.'
015700         MOVE '****' TO LK-STATUS
015800     .
015810     IF  LK-STATUS NOT = 'TFNF'
015900         PERFORM 0800-CLOSE-TABLE-FILE
015910     .
016000     GOBACK
016100     .
016200 0100-READ.
016300     PERFORM 0400-READ-TABLE-FILE
016400     SUBTRACT 1 FROM WS-MAX-ENTRIES
016500     IF  LK-STATUS IS     EQUAL TO 'END.'
016600         NEXT SENTENCE
016700     ELSE
016800     IF  WS-MAX-ENTRIES IS LESS THAN ZERO
016900         MOVE 'TFUL' TO LK-STATUS
017000         MOVE 'TABLE EXCEEDS MAX ENTRIES' TO LOG-MESSAGE
017100         MOVE LK-STATUS    TO LOG-STATUS
017200         CALL SYSLOG-ID USING LOG-LINKAGE-AREA
017300     ELSE
017400         PERFORM 0110-MOVE-DATA
017500         SET TABL-X UP BY 1
017600     .
017700 0110-MOVE-DATA.
017800     IF  LK-READ AND WS-LENGTH-RIGHT IS EQUAL TO ZERO
017900         MOVE 'TNRS' TO LK-STATUS
018000         MOVE 'TABLE HAS NO RIGHT SIDE  ' TO LOG-MESSAGE
018100         MOVE LK-STATUS    TO LOG-STATUS
018200         CALL SYSLOG-ID USING LOG-LINKAGE-AREA
018300     ELSE
018400         CALL SYSMOVE-ID USING WS-LENGTH-LEFT,
018500                             TABLE-CHAR (TABLE-LEFT)
018600                             TABL-LEFT  (TABL-X)
018700         IF  LK-READ
018800             CALL SYSMOVE-ID USING WS-LENGTH-RIGHT
018900                                 TABLE-CHAR (TABLE-RIGHT)
019000                                 TABL-RIGHT (TABL-X)
019100     .
019200     IF  TABL-X > 1
019300         IF  TABL-LEFT (TABL-X) NOT > TABL-LEFT (TABL-X - 1)
019400             MOVE 'TSEQ' TO LK-STATUS
019500             MOVE 'TABLE OUT OF SEQUENCE' TO LOG-MESSAGE
019600             MOVE LK-STATUS    TO LOG-STATUS
019700             CALL SYSLOG-ID USING LOG-LINKAGE-AREA
019800     .
019900 0400-READ-TABLE-FILE.
020000     READ TABLE-FILE
020100         AT END
020200         MOVE 'END.' TO LK-STATUS
020300     .
020400 0700-OPEN.
020500     IF  LK-TABLE-8 IS EQUAL TO SPACES
020600         MOVE 'TFNF' TO LK-STATUS
020700     ELSE
020800         MOVE LK-TABLE-8 TO JFCB-DDNAME
020900****     LOOK FOR USER SUPPLIED SEQUENTIAL TABLE FILE
021000         INSPECT
021100             JFCB-DDNAME REPLACING ALL '-' BY '@'
021200         CALL SYSJFCB-ID USING JFCB-COMMAND
021300                              JFCB-AREA
021400         IF JFCB-GOOD-STATUS
021500             PERFORM 0710-OPEN-SEQUENTIAL
021600         ELSE
021700             MOVE 'TFNF' TO LK-STATUS
021800     .
021900 0710-OPEN-SEQUENTIAL.
022000     CALL SYSDDNAM-ID USING JFCB-DDNAME TABLE-FILE
022100**** JFCB-DDNAME HAS '@' IN PLACE OF LK-TABLE-8'S '-'
022200     OPEN INPUT TABLE-FILE
022300     PERFORM 0400-READ-TABLE-FILE
022400     MOVE 47 TO WS-MAX-ENTRIES
022500     CALL SYSMOVE-ID USING
022600         WS-MAX-ENTRIES, TABLE-CHAR (01), TABLE-HEADER
022700     IF  LK-TABLE-ID = TABLE-ID
022800     AND TABLE-MAX-ENTRIES    IS NUMERIC
022900     AND TABLE-LENGTH-LEFT    IS NUMERIC
023000     AND TABLE-LENGTH-RIGHT   IS NUMERIC
023100     AND TABLE-POSITION-LEFT  IS NUMERIC
023200     AND TABLE-POSITION-RIGHT IS NUMERIC
023300     AND TABLE-POSITION-LEFT > ZERO
023400         MOVE TABLE-MAX-ENTRIES  TO WS-MAX-ENTRIES
023500         PERFORM 0711-CHECK-MAX-GT-9999
023600         MOVE TABLE-LENGTH-LEFT  TO WS-LENGTH-LEFT
023700         MOVE TABLE-LENGTH-RIGHT TO WS-LENGTH-RIGHT
023800         SET TABLE-LEFT          TO TABLE-POSITION-LEFT
023900         SET TABLE-RIGHT         TO TABLE-POSITION-RIGHT
024000         PERFORM 0715-SETUP-LK-MESSAGE
024100     ELSE
024200         MOVE ZERO TO WS-MAX-ENTRIES
024300                      WS-LENGTH-LEFT WS-LENGTH-RIGHT
024400         PERFORM 0715-SETUP-LK-MESSAGE
024500         MOVE 'TBAD' TO LK-STATUS
024600         MOVE 'TABLE HEADER INCORRECTLY FORMATTED '
024700               TO LOG-MESSAGE
024800         MOVE LK-STATUS    TO LOG-STATUS
024900         CALL SYSLOG-ID USING LOG-LINKAGE-AREA
025000     .
025100     IF  LK-STATUS = '****'
025200     AND TABLE-ALT-DDNAME NOT = SPACES
025300         MOVE TABLE-ALT-DDNAME TO JFCB-DDNAME
025400****     LOOK FOR ALTERNATE DDNAME
025500         CALL SYSJFCB-ID USING JFCB-COMMAND
025600                              JFCB-AREA
025700         IF  JFCB-GOOD-STATUS
025800             CLOSE      TABLE-FILE
025900             CALL SYSDDNAM-ID USING JFCB-DDNAME TABLE-FILE
026000             OPEN INPUT TABLE-FILE
026100*------------PERFORM 0715-SETUP-LK-MESSAGE, NOT HERE!!!
026200     .
026300 0711-CHECK-MAX-GT-9999.
026400     IF  TABLE-MAX-ENTRIES = ZERO
026500         MOVE 5 TO WS-MAX-ENTRIES
026600         CALL SYSMOVE-ID USING
026700             WS-MAX-ENTRIES TABLE-CHAR(51) TABLE-MAX-5-DIGIT
026800         IF  TABLE-MAX-5-DIGIT IS NOT NUMERIC
026900         OR  TABLE-MAX-5-DIGIT > 32767
027000             MOVE ZERO TO WS-MAX-ENTRIES
027100                          WS-LENGTH-LEFT WS-LENGTH-RIGHT
027200             PERFORM 0715-SETUP-LK-MESSAGE
027300             MOVE 'TBAD' TO LK-STATUS
027400             MOVE 'TABLE HEADER INCORRECTLY FORMATTED '
027500                   TO LOG-MESSAGE
027600             MOVE LK-STATUS    TO LOG-STATUS
027700             CALL SYSLOG-ID USING LOG-LINKAGE-AREA
027800         ELSE
027900             MOVE TABLE-MAX-5-DIGIT TO WS-MAX-ENTRIES
028000     .
028100 0715-SETUP-LK-MESSAGE.
028200     MOVE 'LOADING                 MAX=      LEN=   /'
028300                 TO LOG-MESSAGE
028400     MOVE TABLE-ID        TO LOG-TABLE-ID
028500     MOVE WS-MAX-ENTRIES  TO LOG-MAX-ENTRIES
028600     MOVE WS-LENGTH-LEFT  TO LOG-LENGTH-LEFT
028700     MOVE WS-LENGTH-RIGHT TO LOG-LENGTH-RIGHT
028800     MOVE JFCB-DATA-MGT TO BIT-TO-BYTE-X1
028900     PERFORM 9000-BIT-TO-BYTE
029000     IF  BYTE-2 IS EQUAL TO '1'
029100         MOVE 'DD * FILE'   TO LOG-MEMBER
029200     ELSE
029300         MOVE JFCB-DSN      TO LOG-DSN-44
029400         MOVE JFCB-MEMBER   TO LOG-MEMBER
029500     .
029600     MOVE 'SYSTABLE'   TO LOG-PROGRAM-ID
029700     MOVE 'SYSLOG  '   TO LOG-DEVICE
029800     MOVE '****'       TO LOG-STATUS
029900     CALL SYSLOG-ID USING LOG-LINKAGE-AREA
030000     .
030100 0800-CLOSE-TABLE-FILE.
030200     CLOSE TABLE-FILE
030300     .
030400 9000-BIT-TO-BYTE.
030500     COPY SYSBITPR.
030600 9100-GET-STORAGE.
030700*+++ DISPLAY 'SYS9TMEM-MAX/LENL/LENR: '  WS-MAX-ENTRIES '/'
030800*+++                                     WS-LENGTH-LEFT '/'
030900*+++                                     WS-LENGTH-RIGHT '.'
031000*+++ DISPLAY 'SYS9TMEM-LENGTH OF TABLE:' LENGTH OF TABL-ALLOCATION
031100     COMPUTE GET-STORAGE-NBYTES =        LENGTH OF TABL-ALLOCATION
031200     CALL 'CEEGTST' USING GET-STORAGE-HEAPID
031300                          GET-STORAGE-NBYTES
031400                          GET-STORAGE-ADDRESS
031500                          GET-STORAGE-FEEDBACK
031600     IF  CEE000 THEN
031700         SET ADDRESS OF TABL-ALLOCATION TO GET-STORAGE-ADDRESS
031800         SET LK-POINTER                 TO GET-STORAGE-ADDRESS
031900         MOVE ALL '9'          TO TABL-ALLOCATION
032000         MOVE WS-MAX-ENTRIES   TO TABL-MAX-ENTRIES
032100         MOVE WS-LENGTH-LEFT   TO TABL-LENGTH-LEFT
032200         MOVE WS-LENGTH-RIGHT  TO TABL-LENGTH-RIGHT
032300     ELSE
032400         MOVE 'NSTG' TO LK-STATUS
032500         MOVE 'NOT ENOUGH STORAGE AVAILABLE' TO LOG-MESSAGE
032600         MOVE LK-STATUS    TO LOG-STATUS
032700         CALL SYSLOG-ID USING LOG-LINKAGE-AREA
032800     .
032900 END PROGRAM SYS9TMEM.
-END
