Trailing-Edge
-
PDP-10 Archives
-
BB-H580C-SB_1981
-
xtbl09.cbl
There are 20 other files named xtbl09.cbl in the archive. Click here to see a list.
* 24 JULY 75
ID DIVISION.
PROGRAM-ID. XTBL09.
* XTBL09 SAMPLES ALL STATEMENTS USING REFERENCES TO
* A THREE DIMENSIONAL TABLE IN ALL POSITIONS IN
* WHICH SUBSCRIPTING IS ALLOWED. SUBSCRIPTS ARE LITERAL,
* IDENTIFIERS (COMP AND DISPLAY) AND RELATIVE (COMP
* AND DISPLAY). THE INTENT IS TO INSURE THAT ALL VERB
* PROCESSORS ALLOW THE FULL RANGE OF SUBSCRIPT
* POSSIBILITIES IMPLIED BY THE WORD 'IDENTIFIER'.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT TESTFILE ASSIGN TO DSK.
SELECT SORTFILE ASSIGN TO DSK DSK DSK.
SELECT PRNTFILE ASSIGN TO DSK.
DATA DIVISION.
FILE SECTION.
FD TESTFILE LABEL RECORDS STANDARD
VALUE OF ID "XTBL09DAT".
01 TESTREC PIC X(5) DISPLAY-7.
FD PRNTFILE LABEL RECORDS STANDARD
VALUE OF ID "PRNTFILE ".
01 PRINTREC PIC X(25) DISPLAY-7.
SD SORTFILE.
01 SORTREC.
03 5CHARS PIC X(5).
WORKING-STORAGE SECTION.
01 SORTTABLES VALUE
"010201010101020201020101000000010102010202020102020202000000".
03 SORTGRP1 PIC 999999 OCCURS 5 TIMES.
03 SORTGRP2 PIC 999999 OCCURS 5 TIMES.
01 3SUBS.
03 SUB1 PIC 99.
03 SUB2 PIC 99.
03 SUB3 PIC 99.
01 SSUB PIC 9.
01 SD0 PIC S9(4) VALUE 0.
01 SD1 PIC S9(4) VALUE 1.
01 SD2 PIC S9(4) VALUE 2.
01 SC0 PIC S9(4) COMP VALUE 0.
01 SC1 PIC S9(4) COMP VALUE 1.
01 SC2 PIC S9(4) COMP VALUE 2.
01 ONE PIC S9(4) COMP VALUE 1.
01 TWO PIC S9(4) COMP VALUE 2.
01 DUMMY PIC 99.
01 A5 PIC XX.
01 T DISPLAY-7.
03 FILLER PIC X(20).
03 TN PIC 99.
03 TSWITCH PIC X.
88 TS VALUE SPACE.
01 ASET PIC X(55) VALUE
"####AA#BB01#01#
- "##CC#DD04#08#
- "###EE#FF09#27#
- "##GG#HH16#64#".
01 BSET PIC X(55) VALUE
"00*00**00*00*
- "00*00**00*00**
- "00*00**00*00*
- "00*00**00*00***".
01 BINIT DISPLAY-7 PIC X(55) VALUE
"AA*BB**01*01*
- "CC*DD**04*08**
- "EE*FF**09*27*
- "GG*HH**16*64***".
01 A.
03 FILLER PIC X.
03 1L OCCURS 2 INDEXED BY I.
05 FILLER PIC X.
05 2L OCCURS 2 INDEXED BY J.
07 FILLER PIC X.
07 3LA OCCURS 2 INDEXED BY K ASCENDING AN OF A.
09 FILLER PIC X.
09 AN PIC XX.
07 3LB OCCURS 2.
09 NUM PIC 99.
09 FILLER PIC X.
01 B DISPLAY-7.
03 1L OCCURS 2.
05 2L OCCURS 2.
07 3LA OCCURS 2.
09 AN PIC XX.
09 FILLER PIC X.
07 3LB OCCURS 2.
09 FILLER PIC X.
09 NUM PIC 99.
07 FILLER PIC X.
05 FILLER PIC X.
03 FILLER PIC X.
PROCEDURE DIVISION.
P0.
* FIRST, TEST MOVES TO SEE IF SIMPLE ACCESS
*TO TABLE A IS POSSIBLE AND IF TABLE A IS
*MAPPED CORRECTLY.
MOVE ALL "#" TO A.
MOVE "AA" TO AN OF A (1 1 1).
MOVE "BB" TO AN OF A (1 1 2).
MOVE "CC" TO AN OF A (1 2 1).
MOVE "DD" TO AN OF A (1 2 2).
MOVE "EE" TO AN OF A (2 1 1).
MOVE "FF" TO AN OF A (2 1 2).
MOVE "GG" TO AN OF A (2 2 1).
MOVE "HH" TO AN OF A (2 2 2).
MOVE 01 TO NUM OF A (1 1 1).
MOVE 01 TO NUM OF A (1 1 2).
MOVE 04 TO NUM OF A (1 2 1).
MOVE 08 TO NUM OF A (1 2 2).
MOVE 09 TO NUM OF A (2 1 1).
MOVE 27 TO NUM OF A (2 1 2).
MOVE 16 TO NUM OF A (2 2 1).
MOVE 64 TO NUM OF A (2 2 2).
IF A NOT = ASET
DISPLAY "? TABLE A CANNOT BE CORRECTLY INITIALIZED."
DISPLAY " TABLE SHOULD CONTAIN:"
DISPLAY ASET
DISPLAY " TABLE INSTEAD CONTAINS:"
DISPLAY A
DISPLAY "TEST TERMINATED EARLY."
STOP RUN.
*NEXT TEST WHETHER THE SUBPROGRAM CAN BE USED TO
*CHECK THE RESULTS OF ALL FIELDS IN TABLE B.
MOVE BSET TO B.
MOVE "AA" TO AN OF B (1 1 1).
MOVE "BB" TO AN OF B (1 1 2).
MOVE "CC" TO AN OF B (1 2 1).
MOVE "DD" TO AN OF B (1 2 2).
MOVE "EE" TO AN OF B (2 1 1).
MOVE "FF" TO AN OF B (2 1 2).
MOVE "GG" TO AN OF B (2 2 1).
MOVE "HH" TO AN OF B (2 2 2).
MOVE 01 TO NUM OF B (1 1 1).
MOVE 01 TO NUM OF B (1 1 2).
MOVE 04 TO NUM OF B (1 2 1).
MOVE 08 TO NUM OF B (1 2 2).
MOVE 09 TO NUM OF B (2 1 1).
MOVE 27 TO NUM OF B (2 1 2).
MOVE 16 TO NUM OF B (2 2 1).
MOVE 64 TO NUM OF B (2 2 2).
IF B NOT = BINIT
DISPLAY "? TABLE B CANNOT BE CORRECTLY INITIALIZED"
DISPLAY " TABLE SHOULD CONTAIN:"
DISPLAY BINIT
DISPLAY " TABLE INSTEAD CONTAINS:"
DISPLAY B
DISPLAY "TEST TERMINATED EARLY."
STOP RUN.
MOVE "? INITIAL TEST FAILS" TO T.
MOVE "AA" TO A5.
IF TS CALL PAN USING T B ONE ONE ONE A5.
MOVE "BB" TO A5.
IF TS CALL PAN USING T B ONE ONE TWO A5.
MOVE "CC" TO A5.
IF TS CALL PAN USING T B ONE TWO ONE A5.
MOVE "DD" TO A5.
IF TS CALL PAN USING T B ONE TWO TWO A5.
MOVE "EE" TO A5.
IF TS CALL PAN USING T B TWO ONE ONE A5.
MOVE "FF" TO A5.
IF TS CALL PAN USING T B TWO ONE TWO A5.
MOVE "GG" TO A5.
IF TS CALL PAN USING T B TWO TWO ONE A5.
MOVE "HH" TO A5.
IF TS CALL PAN USING T B TWO TWO TWO A5.
MOVE "01" TO A5.
IF TS CALL PNUM USING T B ONE ONE ONE A5.
IF TS CALL PNUM USING T B ONE ONE TWO A5.
MOVE "04" TO A5.
IF TS CALL PNUM USING T B ONE TWO ONE A5.
MOVE "08" TO A5.
IF TS CALL PNUM USING T B ONE TWO TWO A5.
MOVE "09" TO A5.
IF TS CALL PNUM USING T B TWO ONE ONE A5.
MOVE "27" TO A5.
IF TS CALL PNUM USING T B TWO ONE TWO A5.
MOVE "16" TO A5.
IF TS CALL PNUM USING T B TWO TWO ONE A5.
MOVE "64" TO A5.
IF TS CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
* NOW ONCE MORE TO BE SURE THAT PTABLE REALLY DID RESET
* TABLE B VALUES AND THAT IT FINDS THEM RESET.
CALL PTABLE USING T B.
IF NOT TS
DISPLAY "? SUBROUTINE CHECK NOT WORKING."
DISPLAY " TEST TERMINATED EARLY."
STOP RUN.
*IF WE REACHED THIS POINT ASSUME THAT THE TABLES ARE
*MAPPED OK AND THAT SIMPLE IF AND MOVE OPERATIONS
*WORK OK, AND THE SUBPROGRAM CAN BE USED TO TEST THEM.
*NOW BEGIN ACTUAL STATEMENT TESTS.
*ACCEPT
DISPLAY "ACCEPT TEST".
*SUBSCRIPTING ON OP OF "ACCEPT OP".
MOVE "? ACCEPT FAILS" TO T.
MOVE 1 TO TN.
MOVE "X " TO A5.
DISPLAY "TYPE X<CR> TWICE".
ACCEPT AN OF B (SC1 + 1 2 SD2).
CALL PAN USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
ACCEPT AN OF B (2 SD2 SC1 + 1).
CALL PAN USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
DISPLAY "TYPE 1<CR> TWICE".
MOVE "01" TO A5.
ACCEPT NUM OF B (SD2 SC1 + 1 2).
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
ACCEPT NUM OF B (SD0 + 2 SC0 + 2 SC2).
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*ADD
DISPLAY "ADD TEST".
*SUBSCRIPTING ON OPS OF "ADD OP OP ... TO OP".
MOVE "? ADD FAILS" TO T.
MOVE 1 TO TN.
MOVE "66" TO A5.
ADD NUM OF A (1 SC1 SD1)
NUM OF A (SD2 SC2 2)
NUM OF A (SC2 - 1 SD2 - 1 2) TO
NUM OF B (1 SC2 SD1).
CALL PNUM USING T B ONE TWO ONE A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON RECEIVING FIELDS OF "ADD ... TO OP OP ...".
MOVE "03" TO A5.
ADD ONE TWO TO
NUM OF B (1 SC1 SD1) ROUNDED
NUM OF B (2 SC2 SD2)
NUM OF B (SC0 + 2 SD1 + 1 1).
CALL PNUM USING T B ONE ONE ONE A5.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PNUM USING T B TWO TWO ONE A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "ADD OP OP GIVING OP OP...".
ADD NUM OF A (SC0 + 1 SD0 + 1 SD2 - 1)
NUM OF A (SC2 - 1 SD2 - 1 SC0 + 1) GIVING
NUM OF B (1 SC1 SC1)
NUM OF B (SD1 SC1 2) ROUNDED
NUM OF B (SC1 2 SD1).
MOVE "02" TO A5.
CALL PNUM USING T B ONE ONE ONE A5.
CALL PNUM USING T B ONE ONE TWO A5.
CALL PNUM USING T B ONE TWO ONE A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "ADD CORR OP TO OP".
MOVE "04" TO A5.
ADD CORR 3LB OF A (SC1 2 SD0 + 1) TO
3LB OF B (SD1 + 1 SC1 1).
CALL PNUM USING T B TWO ONE ONE A5.
CALL PTABLE USING T B.
*COMPUTE
DISPLAY "COMPUTE TEST".
*SUBSCRIPTING ON OPS OF "COMPUTE OP = OP".
MOVE "? COMPUTE FAILS" TO T.
MOVE 1 TO TN.
COMPUTE NUM OF B (SC1 SD2 1) = NUM OF A (1 SD1 SC2).
MOVE "01" TO A5.
CALL PNUM USING T B ONE TWO ONE A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "COMPUTE OP = (ARITHMETIC EXPRESSION OF OPS)".
MOVE "11" TO A5.
COMPUTE NUM OF B (SD0 + 2 SC2 SC2) =
(NUM OF A (SC2 SD2 1) *
NUM OF A (1 2 SD2 - 1) -
NUM OF A (SC1 SD0 + 1 2))/
NUM OF A (SC0 + 2 SC1 SD1) +
NUM OF A (SD0 + 1 2 SD0 + 1).
*THE ABOVE EXPRESSION IS (16*4-1)/9+4 = 11.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*DISPLAY
DISPLAY "DISPLAY TEST".
*SUBSCRIPTING ON OPS OF "DISPLAY OP, OP ...".
DISPLAY "DISPLAY FAILS IF NEXT TWO LINES ARE NOT IDENTICAL".
MOVE SPACE TO TSWITCH.
DISPLAY "AA BB CC DD".
DISPLAY AN OF A (SC1 SD1 1) SPACE
AN OF A (SD1 1 SC2) " "
AN OF A (SD0 + 1 SC2 SC2 - 1) TSWITCH
AN OF A (SD2 - 1 2 SC0 + 2).
*DIVIDE
DISPLAY "DIVIDE TEST".
*SUBSCRIPTING ON OPS OF "DIVIDE OP INTO OP REMAINDER OP".
MOVE "? DIVIDE FAILS" TO T.
MOVE 1 TO TN.
MOVE 27 TO NUM OF B (2 1 1).
DIVIDE NUM OF A (SC0 + 1 SD2 1) INTO
NUM OF B (SD0 + 2 SD2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2).
*(THE ARITHMETIC IS 27/4 = 6 WITH REMAINDER 3).
MOVE "06" TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
MOVE "03" TO A5.
CALL PNUM USING T B TWO ONE TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "DIVIDE OP BY OP REMAINDER OP".
MOVE 4 TO NUM OF B (2 1 1).
DIVIDE NUM OF A (SD0 + 2 SD2 - 1 2) BY
NUM OF B (SD0 + 2 SD2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2).
MOVE "06" TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
MOVE "03" TO A5.
CALL PNUM USING T B TWO ONE TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "DIVIDE OP INTO OP GIVING OP REMAINDER OP".
DIVIDE NUM OF A (SC0 + 1 SD2 1) INTO
NUM OF A (SD0 + 2 SD2 - 1 2) GIVING
NUM OF B (SD0 + 2 SD2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2).
MOVE "06" TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
MOVE "03" TO A5.
CALL PNUM USING T B TWO ONE TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "DIVIDE OP BY OP GIVING OP REMAINDER OP".
DIVIDE NUM OF A (SD0 + 2 SD2 - 1 2) BY
NUM OF A (SC0 + 1 SD2 1) GIVING
NUM OF B (SD0 + 2 SD2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2).
MOVE "06" TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
MOVE "03" TO A5.
CALL PNUM USING T B TWO ONE TWO A5.
CALL PTABLE USING T B.
*EXAMINE
DISPLAY "EXAMINE TEST".
*SUBSCRIPTING ON OPS OF "EXAMINE OP ...".
MOVE "? EXAMINE FAILS" TO T.
MOVE 1 TO TN.
EXAMINE 3LA OF B (SC0 + 1 SC2 - 1 SD2)
TALLYING UNTIL FIRST "*" REPLACING BY "1".
MOVE "11" TO A5.
CALL PAN USING T B ONE ONE TWO A5.
CALL PTABLE USING T B.
EXAMINE 2L OF B (SC2 - 1 SD0 + 2)
TALLYING ALL "0" REPLACING BY "7".
IF TALLY NOT = 8
DISPLAY T "TALLY COUNTER IS: " TALLY ", SHOULD BE 8".
MOVE "77" TO A5.
CALL PAN USING T B ONE TWO ONE A5.
CALL PAN USING T B ONE TWO TWO A5.
CALL PNUM USING T B ONE TWO ONE A5.
CALL PNUM USING T B ONE TWO TWO A5.
CALL PTABLE USING T B.
EXAMINE 1L OF B (SD1 + 1)
REPLACING ALL "0" BY "9".
MOVE "99" TO A5.
CALL PAN USING T B TWO ONE ONE A5.
CALL PAN USING T B TWO ONE TWO A5.
CALL PAN USING T B TWO TWO ONE A5.
CALL PAN USING T B TWO TWO TWO A5.
CALL PNUM USING T B TWO ONE ONE A5.
CALL PNUM USING T B TWO ONE TWO A5.
CALL PNUM USING T B TWO TWO ONE A5.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*GO TO ... DEPENDING
*SUBSCRIPTING ON OP OF "GO TO ... DEPENDING ON OP".
DISPLAY "GO ... DEP TEST".
GO TO GTD1
GTD2
GTD3
DEPENDING ON NUM OF A (SD0 + 1 SD2 - 1 SC2).
DISPLAY "? GO TO FAILS, FALL THROUGH".
GO TO GTD1.
GTD3.
DISPLAY "? GO TO FAILS, WENT TO GTD3.".
GO TO GTD1.
GTD2.
DISPLAY "? GO TO FAILS, WENT TO GTD2.".
GTD1.
*MOVE
*SUBSCRIPTING ON OPS OF MOVE OP TO OP OP ...".
DISPLAY "MOVE TEST".
MOVE "? MOVE FAILS" TO T.
MOVE 1 TO TN.
MOVE AN OF A (SC0 + 2 SD1 + 1 SD0 + 1) TO
AN OF B (SC1 SC0 + 1 SD2 - 1)
AN OF B (SD1 SD1 + 1 2)
AN OF B (2 SD1 1)
AN OF B (SC0 + 2 SD0 + 2 SD0 + 1).
MOVE "GG" TO A5.
CALL PAN USING T B ONE ONE ONE A5.
CALL PAN USING T B ONE TWO TWO A5.
CALL PAN USING T B TWO ONE ONE A5.
CALL PAN USING T B TWO TWO ONE A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "MOVE CORR OP TO OP".
MOVE "? MOVE CORR FAILED" TO T.
MOVE 1 TO TN.
MOVE CORR 3LA OF A (SD2 SC1 SC0 + 2) TO
3LA OF B (SD0 + 1 2 SD1).
MOVE "FF" TO A5.
CALL PAN USING T B ONE TWO ONE A5.
CALL PTABLE USING T B.
MOVE CORR 2L OF A(SC2 1) TO 2L OF B (2 SD0 + 2).
*SINCE ALL ITEMS HAVE OCCURS CLAUSES, NOTHING SHOULD BE MOVED.
CALL PTABLE USING T B.
*MULTIPLY
*SUBSCRIPTING ON OPS OF "MULTIPLY OP BY OP".
DISPLAY "MULTIPLY TEST".
MOVE "? MULTIPLY FAILS" TO T.
MOVE 1 TO TN.
MOVE 4 TO NUM OF B (1 2 2).
MULTIPLY NUM OF A (SC2 SD0 + 1 SD1) BY
NUM OF B (1 SC1 + 1 SD0 + 2).
IF NUM OF A (2 1 1) NOT = 9
DISPLAY T "MULTIPLY OP A BY OP B"
DISPLAY " CLOBBERED OP A VALUE"
DISPLAY " OP A VALUE IS " NUM OF A (2 1 1) ", IT SHOULD BE 09".
MOVE "36" TO A5.
CALL PNUM USING T B ONE TWO TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "MULTIPLY OP BY OP GIVING OP".
MULTIPLY NUM OF A (2 SC1 SD0 + 1) BY
NUM OF A (SD1 SD1 + 1 SD0 + 1) GIVING
NUM OF B (1 SC0 + 1 SD1 + 1).
MOVE "36" TO A5.
CALL PNUM USING T B ONE ONE TWO A5.
CALL PTABLE USING T B.
*PERFORM
*SUBSCRIPTING ON OPS OF PERFORM ... OP TIMES.
DISPLAY "PERFORM TEST".
MOVE "? PERFORM FAILS" TO T.
MOVE 1 TO TN.
MOVE 0 TO SUB1.
DISPLAY "STARTING VARIABLE PERFORM TEST 1".
PERFORM P2 NUM OF A (SD1 + 1 1 SC0 + 1) TIMES.
DISPLAY " PERFORM TEST 1 FINISHED".
IF SUB1 NOT = 9
DISPLAY T "COUNT OF EXECUTIONS IS:"
DISPLAY SUB1 ", AND SHOULD BE 09".
ADD 1 TO TN.
*SUBSCRIPTING ON OPS OF THE CONDITION IN PERFORM ... UNTIL COND".
MOVE 0 TO SUB1.
DISPLAY "STARTING VARIABLE PERFORM TEST 2".
PERFORM P2 UNTIL SUB1 = NUM OF A (SC0 + 2 SD1 1).
DISPLAY " PERFORM TEST 2 FINISHED".
IF SUB1 NOT = 9
DISPLAY T "COUNT OF EXECUTIONS IS:"
DISPLAY SUB1 ", AND SHOULD BE 09".
ADD 1 TO TN.
*SUBSCRIPTING ON OPS OF THE CONDITION IN "PERFORM ...
* UNTIL COND" WHERE THE SUBSCRIPT ITSELF IS THE VARIABLE.
MOVE 1 TO SUB1.
MOVE 2 TO NUM OF B (2 1 1).
DISPLAY "STARTING VARIABLE PERFORM TEST 3".
PERFORM P2 UNTIL 2 = NUM OF B (SUB1 SC0 + 1 SD1)
DISPLAY " PERFORM TEST 3 FINISHED".
MOVE BSET TO B.
IF SUB1 NOT = 2
DISPLAY T "VALUE OF SUB1 IS:"
DISPLAY SUB1 ", AND SHOULD BE 2".
ADD 1 TO TN.
*SUBSCRIPTING ON OPS OF "PERFORM ... VARYING OP FROM OP BY OP
* UNTIL OP = OP AFTER ...".
DISPLAY "STARTING VARIABLE PERFORM TEST 4".
MOVE 0 TO SUB1.
PERFORM P2 VARYING NUM OF B (SC0 + 1 SD1 1)
FROM NUM OF A (1 SD1 SD2 - 1)
BY NUM OF A (SC0 + 1 1 SD2)
UNTIL NUM OF B (1 SD1 SC0 + 1)
> NUM OF A (1 SC2 SD1)
AFTER VARYING NUM OF B (SD2 SD2 - 1 SD2 - 1)
FROM NUM OF B (SC1 SC0 + 1 SC1 + 1)
BY NUM OF A (SC1 SC2 SC1)
UNTIL 15 < NUM OF B (SC2 SC2 - 1 SC2 - 1)
AFTER VARYING NUM OF B (2 SD0 + 2 SC1 + 1)
FROM NUM OF B (2 2 1)
BY NUM OF A (2 2 1)
UNTIL NUM OF A (SC2 SD2 2)
= NUM OF B (SC0 + 2 2 2).
DISPLAY " PERFORM TEST 4 FINISHED".
IF SUB1 NOT = 64
DISPLAY T
DISPLAY "SUB1 VALUE IS: " SUB1 ", SHOULD BE 64".
MOVE ZERO TO A5.
CALL PNUM USING T B TWO TWO TWO A5.
MOVE ZERO TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
MOVE "05" TO A5.
CALL PNUM USING T B ONE ONE ONE A5.
CALL PTABLE USING T B.
*WRITE
*SUBSCRIPTING ON OP OF "WRITE REC FROM OP".
DISPLAY "WRITE TEST".
OPEN OUTPUT TESTFILE.
WRITE TESTREC FROM AN OF A (SC0 + 1 SD1 SC1).
WRITE TESTREC FROM AN OF A (SD1 + 1 SD0 + 1 SD1).
WRITE TESTREC FROM AN OF A (SC2 2 SD2).
CLOSE TESTFILE.
OPEN INPUT TESTFILE.
MOVE "? WRITE FAILS" TO T.
READ TESTFILE AT END DISPLAY T "AT END ON 1ST READ" GO TO WRITE1.
IF TESTREC NOT = "AA "
DISPLAY T "RECORD 1 IS: " TESTREC.
READ TESTFILE AT END DISPLAY T "AT END ON 2ND READ" GO TO WRITE1.
IF TESTREC NOT = "EE "
DISPLAY T "RECORD 2 IS: " TESTREC.
READ TESTFILE AT END DISPLAY T "AT END ON 3RD READ" GO TO WRITE1.
IF TESTREC NOT = "HH "
DISPLAY T "RECORD 3 IS: " TESTREC.
READ TESTFILE AT END GO TO WRITE1.
DISPLAY T "NO AT END ON 4TH READ".
WRITE1.
CLOSE TESTFILE.
*SUBSCRIPTING ON OP OF "WRITE ... ADVANCING OP".
OPEN OUTPUT PRNTFILE.
MOVE "THREE BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF A (SC0 + 1 SD2 SC2 - 1).
MOVE "15 BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF A (2 SD2 SC2 - 1).
MOVE "NO BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF A (1 1 1).
WRITE PRINTREC BEFORE ADVANCING NUM OF A (SC1 SD1 SD1 + 1).
MOVE "ENDLINE " TO PRINTREC.
WRITE PRINTREC.
CLOSE PRNTFILE.
*READ
*SUBSCRIPTING ON OP OF "READ ... INTO OP".
DISPLAY "READ TEST".
MOVE "? READ FAILS" TO T.
OPEN INPUT TESTFILE.
READ TESTFILE INTO AN OF B (SC0 + 1 SC2 SD2 - 1) AT END
DISPLAY T "CAN'T READ 1ST RECORD OF INPUT FILE"
GO TO READ1.
READ TESTFILE INTO AN OF B (SD0 + 2 1 SC1) AT END
DISPLAY T "CAN'T READ 2ND RECORD OF INPUT FILE"
GO TO READ1.
READ TESTFILE INTO AN OF B (SC2 SD2 SC0 + 1) AT END
DISPLAY T "CAN'T READ 3RD RECORD OF INPUT FILE"
GO TO READ1.
READ TESTFILE AT END GO TO READ1.
DISPLAY "? NO AT END ON FOURTH READ OF INPUT FILE".
READ1.
CLOSE TESTFILE.
MOVE "AA" TO A5.
CALL PAN USING T B ONE TWO ONE A5.
MOVE "EE" TO A5.
CALL PAN USING T B TWO ONE ONE A5.
MOVE "HH" TO A5.
CALL PAN USING T B TWO TWO ONE A5.
CALL PTABLE USING T B.
*RELEASE AND RETURN
*SUBSCRIPTING ON OPS OF "RELEASE ... FROM OP" AND
* "RETURN ... INTO OP".
DISPLAY "RELEASE & RETURN TEST".
MOVE "? SORT FAILS SOMEWHERE" TO T.
SORT SORTFILE ON ASCENDING 5CHARS
INPUT PROCEDURE IS P3 THRU P3A
OUTPUT PROCEDURE IS P4 THRU P4B.
MOVE "AA" TO A5.
CALL PAN USING T B ONE ONE TWO A5.
MOVE "CC" TO A5.
CALL PAN USING T B ONE TWO TWO A5.
MOVE "EE" TO A5.
CALL PAN USING T B TWO ONE TWO A5.
MOVE "GG" TO A5.
CALL PAN USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*SEARCH
*SUBSCRIPTING ON OPS OF "SEARCH ... VARYING OP ...".
DISPLAY "SEARCH TEST".
MOVE 1 TO I J K.
MOVE "? SEARCH FAILS" TO T.
SEARCH 3LA OF A VARYING NUM OF B (SC0 + 1 SD2 SC1 + 1)
WHEN AN OF A (I J K) = "BB" NEXT SENTENCE.
MOVE "02" TO A5.
CALL PNUM USING T B ONE TWO TWO A5.
CALL PTABLE USING T B.
*SET
*SUBSCRIPTING ON OPS OF "SET OP OP ... TO OP".
DISPLAY "SET TEST".
MOVE "? SET FAILS" TO T.
MOVE 1 TO TN.
SET NUM OF B (SC0 + 1 1 SD1)
NUM OF B (2 SD2 - 1 SD0 + 1)
NUM OF B (2 SD1 + 1 SC1 + 1) TO
NUM OF A (SD2 SC2 2).
MOVE "64" TO A5.
CALL PNUM USING T B ONE ONE ONE A5.
CALL PNUM USING T B TWO ONE ONE A5.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "SET OP OP ... UP BY OP".
SET NUM OF B (1 SC0 + 1 1)
NUM OF B (SD2 1 SC1)
NUM OF B (SC2 2 SD2) UP BY
NUM OF A (2 SD2 SC1 + 1).
CALL PNUM USING T B ONE ONE ONE A5.
CALL PNUM USING T B TWO ONE ONE A5.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*SUBTRACT
*SUBSCRIPTING ON OPS OF "SUBTRACT OP OP ... FROM OP OP".
DISPLAY "SUBTRACT TEST".
MOVE "? SUBTRACT FAILS" TO T.
MOVE 1 TO TN.
MOVE 25 TO NUM OF B (1 1 1).
MOVE 37 TO NUM OF B (2 1 1).
MOVE 42 TO NUM OF B (2 2 2).
SUBTRACT NUM OF A (SC0 + 1 SD1 1)
NUM OF A (SC2 - 1 SC2 SD2 - 1)
NUM OF A (SD2 SC2 - 1 SC0 + 1) FROM
NUM OF B (SC1 SD1 1)
NUM OF B (SC1 + 1 SD2 - 1 SD1) ROUNDED
NUM OF B (SC1 + 1 SD1 + 1 SC0 + 2).
MOVE "11" TO A5.
CALL PNUM USING T B ONE ONE ONE A5.
MOVE "23" TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
MOVE "28" TO A5.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "SUBTRACT OP OP FROM OP GIVING OP OP".
SUBTRACT NUM OF A (SD1 + 1 1 SC0 + 1)
NUM OF A (SC2 SD1 SC0 + 1) FROM
NUM OF A (SC0 + 2 SC1 + 1 SC2) GIVING
NUM OF B (SC0 + 1 SC1 SD1)
NUM OF B (SD2 SC2 - 1 SD2 - 1) ROUNDED
NUM OF B (SD2 SC0 + 2 SD0 + 2).
MOVE "46" TO A5.
CALL PNUM USING T B ONE ONE ONE A5.
CALL PNUM USING T B TWO ONE ONE A5.
CALL PNUM USING T B TWO TWO TWO A5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "SUBTRACT CORR OP FROM OP".
MOVE 64 TO NUM OF B (2 1 1).
SUBTRACT CORR 3LB OF A (SD0 + 1 SD2 1) FROM
3LB OF B (SC1 + 1 1 SD2 - 1).
MOVE "60" TO A5.
CALL PNUM USING T B TWO ONE ONE A5.
CALL PTABLE USING T B.
DISPLAY "END OF TESTS".
STOP RUN.
*THIS IS THE PERFORM RANGE FOR PERFORM TESTS.
P2.
ADD 1 TO SUB1.
*THIS IS THE INPUT PROCEDURE FOR THE SORT TEST.
*IT PICKS UP THE 1, 3, 5, AND 7TH ALPHANUMERIC
*ITEMS OUT OF TABLE A (OUT OF ORDER) AND GIVES THEM TO
*THE SORT.
P3.
MOVE 1 TO SSUB.
P3A.
MOVE SORTGRP1 (SSUB) TO 3SUBS.
RELEASE SORTREC FROM AN OF A (SUB1, SUB2, SUB3).
ADD 1 TO SSUB.
IF SSUB < 5 GO TO P3A.
*THIS IS THE OUTPUT PROCEDURE FOR THE SORT TEST.
*IT RETURNS THE FOUR SORTED (ASCENDING) ITEMS TO ALPHANUMERIC
*POSITIONS 2, 4, 6, AND 8 OF TABLE B.
P4.
MOVE 1 TO SSUB.
P4A.
MOVE SORTGRP2 (SSUB) TO 3SUBS.
RETURN SORTFILE INTO AN OF B (SUB1 SUB2 SUB3) AT END
GO TO P4B.
ADD 1 TO SSUB.
GO TO P4A.
P4B.
EXIT.