Trailing-Edge
-
PDP-10 Archives
-
k20v7d
-
uetp/lib/xt7409.cbl
There are 7 other files named xt7409.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'.
* TEST MODIFIED 4/2/82. MORE SUBSCRIPTS ADDED.
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(10) 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.
02 S1 PIC X(50) VALUE "01010102010101010101010102020101010201010102010201".
02 S2 PIC X(50) VALUE "01020101010102020201010202010102010102010201010101".
02 S3 PIC X(50) VALUE "02010202010201020101020201020102020101010202020201".
02 S4 PIC X(50) VALUE "02020201010000000000010101010201010102020101020102".
02 S5 PIC X(50) VALUE "01010202020102010102010201020201020201020102020202".
02 S6 PIC X(50) VALUE "02010101020201010202020102010202010202020202010102".
02 S7 PIC X(40) VALUE "0202010202020202010202020202020000000000".
01 SORTTABLE REDEFINES SORTTABLES.
02 SORTGRP1 PIC 9(10) OCCURS 17 TIMES.
02 SORTGRP2 PIC 9(10) OCCURS 17 TIMES.
01 5SUBS.
02 SUB1 PIC 99.
02 SUB2 PIC 99.
02 SUB3 PIC 99.
02 SUB4 PIC 99.
02 SUB5 PIC 99.
01 SSUB PIC 99.
01 SF0 PIC S9(4) COMP VALUE 0.
01 SF1 PIC S9(4) COMP VALUE 1.
01 SF2 PIC S9(4) COMP VALUE 2.
01 SE0 PIC S9(4) COMP VALUE 0.
01 SE1 PIC S9(4) COMP VALUE 1.
01 SE2 PIC S9(4) COMP VALUE 2.
01 SD0 PIC S9(4) COMP VALUE 0.
01 SD1 PIC S9(4) COMP VALUE 1.
01 SD2 PIC S9(4) COMP 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 B5 PIC XX.
01 T DISPLAY-7.
02 FILLER PIC X(20).
02 TN PIC 99.
02 TSWITCH PIC X.
88 TS VALUE SPACE.
01 ASETS.
02 ASET1 PIC X(17) VALUE "######AA#BB01#02#".
02 ASET2 PIC X(13) VALUE "##CC#DD03#04#".
02 ASET3 PIC X(14) VALUE "###EE#FF05#06#".
02 ASET4 PIC X(13) VALUE "##GG#HH07#08#".
02 ASET5 PIC X(15) VALUE "####II#JJ09#10#".
02 ASET6 PIC X(13) VALUE "##KK#LL11#12#".
02 ASET7 PIC X(14) VALUE "###MM#NN13#14#".
02 ASET8 PIC X(13) VALUE "##OO#PP15#16#".
02 ASET9 PIC X(16) VALUE "#####QQ#RR17#18#".
02 ASET10 PIC X(13) VALUE "##SS#TT19#20#".
02 ASET11 PIC X(14) VALUE "###UU#VV21#22#".
02 ASET12 PIC X(13) VALUE "##WW#XX23#24#".
02 ASET13 PIC X(15) VALUE "####YY#ZA25#26#".
02 ASET14 PIC X(13) VALUE "##ZB#ZC27#28#".
02 ASET15 PIC X(14) VALUE "###ZD#ZE29#30#".
02 ASET16 PIC X(13) VALUE "##ZF#ZG31#32#".
01 ASET REDEFINES ASETS PIC X(223).
01 BSETS.
02 BSET1 PIC X(13) VALUE "00*00**00*00*".
02 BSET2 PIC X(14) VALUE "00*00**00*00**".
02 BSET3 PIC X(13) VALUE "00*00**00*00*".
02 BSET4 PIC X(15) VALUE "00*00**00*00***".
02 BSET5 PIC X(13) VALUE "00*00**00*00*".
02 BSET6 PIC X(14) VALUE "00*00**00*00**".
02 BSET7 PIC X(13) VALUE "00*00**00*00*".
02 BSET8 PIC X(16) VALUE "00*00**00*00****".
02 BSET9 PIC X(13) VALUE "00*00**00*00*".
02 BSET10 PIC X(14) VALUE "00*00**00*00**".
02 BSET11 PIC X(13) VALUE "00*00**00*00*".
02 BSET12 PIC X(15) VALUE "00*00**00*00***".
02 BSET13 PIC X(13) VALUE "00*00**00*00*".
02 BSET14 PIC X(14) VALUE "00*00**00*00**".
02 BSET15 PIC X(13) VALUE "00*00**00*00*".
02 BSET16 PIC X(17) VALUE "00*00**00*00*****".
01 BSET REDEFINES BSETS PIC X(223).
01 BINITS DISPLAY-7.
02 BINIT1 PIC X(13) VALUE "AA*BB**01*02*".
02 BINIT2 PIC X(14) VALUE "CC*DD**03*04**".
02 BINIT3 PIC X(13) VALUE "EE*FF**05*06*".
02 BINIT4 PIC X(15) VALUE "GG*HH**07*08***".
02 BINIT5 PIC X(13) VALUE "II*JJ**09*10*".
02 BINIT6 PIC X(14) VALUE "KK*LL**11*12**".
02 BINIT7 PIC X(13) VALUE "MM*NN**13*14*".
02 BINIT8 PIC X(16) VALUE "OO*PP**15*16****".
02 BINIT9 PIC X(13) VALUE "QQ*RR**17*18*".
02 BINIT10 PIC X(14) VALUE "SS*TT**19*20**".
02 BINIT11 PIC X(13) VALUE "UU*VV**21*22*".
02 BINIT12 PIC X(15) VALUE "WW*XX**23*24***".
02 BINIT13 PIC X(13) VALUE "YY*ZA**25*26*".
02 BINIT14 PIC X(14) VALUE "ZB*ZC**27*28**".
02 BINIT15 PIC X(13) VALUE "ZD*ZE**29*30*".
02 BINIT16 PIC X(17) VALUE "ZF*ZG**31*32*****".
01 BINIT REDEFINES BINITS DISPLAY-7 PIC X(223).
01 A.
02 FILLER PIC X.
02 1L OCCURS 2 INDEXED BY I.
03 FILLER PIC X.
03 2L OCCURS 2 INDEXED BY J.
04 FILLER PIC X.
04 3L OCCURS 2 INDEXED BY K.
05 FILLER PIC X.
05 4L OCCURS 2 INDEXED BY L.
06 FILLER PIC X.
06 5LA OCCURS 2 INDEXED BY M ASCENDING AN OF A.
07 FILLER PIC X.
07 AN PIC XX.
06 5LB OCCURS 2.
07 NUM PIC 99.
07 FILLER PIC X.
01 B DISPLAY-7.
02 1L OCCURS 2.
03 2L OCCURS 2.
04 3L OCCURS 2.
05 4L OCCURS 2.
06 5LA OCCURS 2.
07 AN PIC XX.
07 FILLER PIC X.
06 5LB OCCURS 2.
07 FILLER PIC X.
07 NUM PIC 99.
06 FILLER PIC X.
05 FILLER PIC X.
04 FILLER PIC X.
03 FILLER PIC X.
02 FILLER PIC X.
77 TALLY COMP PIC S9(5).
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 1 1).
MOVE "BB" TO AN OF A (1 1 1 1 2).
MOVE "CC" TO AN OF A (1 1 1 2 1).
MOVE "DD" TO AN OF A (1 1 1 2 2).
MOVE "EE" TO AN OF A (1 1 2 1 1).
MOVE "FF" TO AN OF A (1 1 2 1 2).
MOVE "GG" TO AN OF A (1 1 2 2 1).
MOVE "HH" TO AN OF A (1 1 2 2 2).
MOVE "II" TO AN OF A (1 2 1 1 1).
MOVE "JJ" TO AN OF A (1 2 1 1 2).
MOVE "KK" TO AN OF A (1 2 1 2 1).
MOVE "LL" TO AN OF A (1 2 1 2 2).
MOVE "MM" TO AN OF A (1 2 2 1 1).
MOVE "NN" TO AN OF A (1 2 2 1 2).
MOVE "OO" TO AN OF A (1 2 2 2 1).
MOVE "PP" TO AN OF A (1 2 2 2 2).
MOVE "QQ" TO AN OF A (2 1 1 1 1).
MOVE "RR" TO AN OF A (2 1 1 1 2).
MOVE "SS" TO AN OF A (2 1 1 2 1).
MOVE "TT" TO AN OF A (2 1 1 2 2).
MOVE "UU" TO AN OF A (2 1 2 1 1).
MOVE "VV" TO AN OF A (2 1 2 1 2).
MOVE "WW" TO AN OF A (2 1 2 2 1).
MOVE "XX" TO AN OF A (2 1 2 2 2).
MOVE "YY" TO AN OF A (2 2 1 1 1).
MOVE "ZA" TO AN OF A (2 2 1 1 2).
MOVE "ZB" TO AN OF A (2 2 1 2 1).
MOVE "ZC" TO AN OF A (2 2 1 2 2).
MOVE "ZD" TO AN OF A (2 2 2 1 1).
MOVE "ZE" TO AN OF A (2 2 2 1 2).
MOVE "ZF" TO AN OF A (2 2 2 2 1).
MOVE "ZG" TO AN OF A (2 2 2 2 2).
MOVE 01 TO NUM OF A (1 1 1 1 1).
MOVE 02 TO NUM OF A (1 1 1 1 2).
MOVE 03 TO NUM OF A (1 1 1 2 1).
MOVE 04 TO NUM OF A (1 1 1 2 2).
MOVE 05 TO NUM OF A (1 1 2 1 1).
MOVE 06 TO NUM OF A (1 1 2 1 2).
MOVE 07 TO NUM OF A (1 1 2 2 1).
MOVE 08 TO NUM OF A (1 1 2 2 2).
MOVE 09 TO NUM OF A (1 2 1 1 1).
MOVE 10 TO NUM OF A (1 2 1 1 2).
MOVE 11 TO NUM OF A (1 2 1 2 1).
MOVE 12 TO NUM OF A (1 2 1 2 2).
MOVE 13 TO NUM OF A (1 2 2 1 1).
MOVE 14 TO NUM OF A (1 2 2 1 2).
MOVE 15 TO NUM OF A (1 2 2 2 1).
MOVE 16 TO NUM OF A (1 2 2 2 2).
MOVE 17 TO NUM OF A (2 1 1 1 1).
MOVE 18 TO NUM OF A (2 1 1 1 2).
MOVE 19 TO NUM OF A (2 1 1 2 1).
MOVE 20 TO NUM OF A (2 1 1 2 2).
MOVE 21 TO NUM OF A (2 1 2 1 1).
MOVE 22 TO NUM OF A (2 1 2 1 2).
MOVE 23 TO NUM OF A (2 1 2 2 1).
MOVE 24 TO NUM OF A (2 1 2 2 2).
MOVE 25 TO NUM OF A (2 2 1 1 1).
MOVE 26 TO NUM OF A (2 2 1 1 2).
MOVE 27 TO NUM OF A (2 2 1 2 1).
MOVE 28 TO NUM OF A (2 2 1 2 2).
MOVE 29 TO NUM OF A (2 2 2 1 1).
MOVE 30 TO NUM OF A (2 2 2 1 2).
MOVE 31 TO NUM OF A (2 2 2 2 1).
MOVE 32 TO NUM OF A (2 2 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 1 1).
MOVE "BB" TO AN OF B (1 1 1 1 2).
MOVE "CC" TO AN OF B (1 1 1 2 1).
MOVE "DD" TO AN OF B (1 1 1 2 2).
MOVE "EE" TO AN OF B (1 1 2 1 1).
MOVE "FF" TO AN OF B (1 1 2 1 2).
MOVE "GG" TO AN OF B (1 1 2 2 1).
MOVE "HH" TO AN OF B (1 1 2 2 2).
MOVE "II" TO AN OF B (1 2 1 1 1).
MOVE "JJ" TO AN OF B (1 2 1 1 2).
MOVE "KK" TO AN OF B (1 2 1 2 1).
MOVE "LL" TO AN OF B (1 2 1 2 2).
MOVE "MM" TO AN OF B (1 2 2 1 1).
MOVE "NN" TO AN OF B (1 2 2 1 2).
MOVE "OO" TO AN OF B (1 2 2 2 1).
MOVE "PP" TO AN OF B (1 2 2 2 2).
MOVE "QQ" TO AN OF B (2 1 1 1 1).
MOVE "RR" TO AN OF B (2 1 1 1 2).
MOVE "SS" TO AN OF B (2 1 1 2 1).
MOVE "TT" TO AN OF B (2 1 1 2 2).
MOVE "UU" TO AN OF B (2 1 2 1 1).
MOVE "VV" TO AN OF B (2 1 2 1 2).
MOVE "WW" TO AN OF B (2 1 2 2 1).
MOVE "XX" TO AN OF B (2 1 2 2 2).
MOVE "YY" TO AN OF B (2 2 1 1 1).
MOVE "ZA" TO AN OF B (2 2 1 1 2).
MOVE "ZB" TO AN OF B (2 2 1 2 1).
MOVE "ZC" TO AN OF B (2 2 1 2 2).
MOVE "ZD" TO AN OF B (2 2 2 1 1).
MOVE "ZE" TO AN OF B (2 2 2 1 2).
MOVE "ZF" TO AN OF B (2 2 2 2 1).
MOVE "ZG" TO AN OF B (2 2 2 2 2).
MOVE 01 TO NUM OF B (1 1 1 1 1).
MOVE 02 TO NUM OF B (1 1 1 1 2).
MOVE 03 TO NUM OF B (1 1 1 2 1).
MOVE 04 TO NUM OF B (1 1 1 2 2).
MOVE 05 TO NUM OF B (1 1 2 1 1).
MOVE 06 TO NUM OF B (1 1 2 1 2).
MOVE 07 TO NUM OF B (1 1 2 2 1).
MOVE 08 TO NUM OF B (1 1 2 2 2).
MOVE 09 TO NUM OF B (1 2 1 1 1).
MOVE 10 TO NUM OF B (1 2 1 1 2).
MOVE 11 TO NUM OF B (1 2 1 2 1).
MOVE 12 TO NUM OF B (1 2 1 2 2).
MOVE 13 TO NUM OF B (1 2 2 1 1).
MOVE 14 TO NUM OF B (1 2 2 1 2).
MOVE 15 TO NUM OF B (1 2 2 2 1).
MOVE 16 TO NUM OF B (1 2 2 2 2).
MOVE 17 TO NUM OF B (2 1 1 1 1).
MOVE 18 TO NUM OF B (2 1 1 1 2).
MOVE 19 TO NUM OF B (2 1 1 2 1).
MOVE 20 TO NUM OF B (2 1 1 2 2).
MOVE 21 TO NUM OF B (2 1 2 1 1).
MOVE 22 TO NUM OF B (2 1 2 1 2).
MOVE 23 TO NUM OF B (2 1 2 2 1).
MOVE 24 TO NUM OF B (2 1 2 2 2).
MOVE 25 TO NUM OF B (2 2 1 1 1).
MOVE 26 TO NUM OF B (2 2 1 1 2).
MOVE 27 TO NUM OF B (2 2 1 2 1).
MOVE 28 TO NUM OF B (2 2 1 2 2).
MOVE 29 TO NUM OF B (2 2 2 1 1).
MOVE 30 TO NUM OF B (2 2 2 1 2).
MOVE 31 TO NUM OF B (2 2 2 2 1).
MOVE 32 TO NUM OF B (2 2 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.
*PAN IS USED TO CHECK AND ALPHANUMERIC FIELD IN TABLE B.
*PAN IS CONTAINED IN XTBL9S.CBL
MOVE "? INITIAL TEST FAILS" TO T.
MOVE "AA" TO B5.
IF TS CALL PAN USING T B ONE ONE ONE ONE ONE B5.
MOVE "BB" TO B5.
IF TS CALL PAN USING T B ONE ONE ONE ONE TWO B5.
MOVE "CC" TO B5.
IF TS CALL PAN USING T B ONE ONE ONE TWO ONE B5.
MOVE "DD" TO B5.
IF TS CALL PAN USING T B ONE ONE ONE TWO TWO B5.
MOVE "EE" TO B5.
IF TS CALL PAN USING T B ONE ONE TWO ONE ONE B5.
MOVE "FF" TO B5.
IF TS CALL PAN USING T B ONE ONE TWO ONE TWO B5.
MOVE "GG" TO B5.
IF TS CALL PAN USING T B ONE ONE TWO TWO ONE B5.
MOVE "HH" TO B5.
IF TS CALL PAN USING T B ONE ONE TWO TWO TWO B5.
MOVE "II" TO B5.
IF TS CALL PAN USING T B ONE TWO ONE ONE ONE B5.
MOVE "JJ" TO B5.
IF TS CALL PAN USING T B ONE TWO ONE ONE TWO B5.
MOVE "KK" TO B5.
IF TS CALL PAN USING T B ONE TWO ONE TWO ONE B5.
MOVE "LL" TO B5.
IF TS CALL PAN USING T B ONE TWO ONE TWO TWO B5.
MOVE "MM" TO B5.
IF TS CALL PAN USING T B ONE TWO TWO ONE ONE B5.
MOVE "NN" TO B5.
IF TS CALL PAN USING T B ONE TWO TWO ONE TWO B5.
MOVE "OO" TO B5.
IF TS CALL PAN USING T B ONE TWO TWO TWO ONE B5.
MOVE "PP" TO B5.
IF TS CALL PAN USING T B ONE TWO TWO TWO TWO B5.
MOVE "QQ" TO B5.
IF TS CALL PAN USING T B TWO ONE ONE ONE ONE B5.
MOVE "RR" TO B5.
IF TS CALL PAN USING T B TWO ONE ONE ONE TWO B5.
MOVE "SS" TO B5.
IF TS CALL PAN USING T B TWO ONE ONE TWO ONE B5.
MOVE "TT" TO B5.
IF TS CALL PAN USING T B TWO ONE ONE TWO TWO B5.
MOVE "UU" TO B5.
IF TS CALL PAN USING T B TWO ONE TWO ONE ONE B5.
MOVE "VV" TO B5.
IF TS CALL PAN USING T B TWO ONE TWO ONE TWO B5.
MOVE "WW" TO B5.
IF TS CALL PAN USING T B TWO ONE TWO TWO ONE B5.
MOVE "XX" TO B5.
IF TS CALL PAN USING T B TWO ONE TWO TWO TWO B5.
MOVE "YY" TO B5.
IF TS CALL PAN USING T B TWO TWO ONE ONE ONE B5.
MOVE "ZA" TO B5.
IF TS CALL PAN USING T B TWO TWO ONE ONE TWO B5.
MOVE "ZB" TO B5.
IF TS CALL PAN USING T B TWO TWO ONE TWO ONE B5.
MOVE "ZC" TO B5.
IF TS CALL PAN USING T B TWO TWO ONE TWO TWO B5.
MOVE "ZD" TO B5.
IF TS CALL PAN USING T B TWO TWO TWO ONE ONE B5.
MOVE "ZE" TO B5.
IF TS CALL PAN USING T B TWO TWO TWO ONE TWO B5.
MOVE "ZF" TO B5.
IF TS CALL PAN USING T B TWO TWO TWO TWO ONE B5.
MOVE "ZG" TO B5.
IF TS CALL PAN USING T B TWO TWO TWO TWO TWO B5.
*PNUM IS USED TO CHECK A NUMERIC FIELD IN TABLE B.
*PNUM IS CONTAINED IN XTBL9S.CBL
MOVE "01" TO B5.
IF TS CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
MOVE "02" TO B5.
IF TS CALL PNUM USING T B ONE ONE ONE ONE TWO B5.
MOVE "03" TO B5.
IF TS CALL PNUM USING T B ONE ONE ONE TWO ONE B5.
MOVE "04" TO B5.
IF TS CALL PNUM USING T B ONE ONE ONE TWO TWO B5.
MOVE "05" TO B5.
IF TS CALL PNUM USING T B ONE ONE TWO ONE ONE B5.
MOVE "06" TO B5.
IF TS CALL PNUM USING T B ONE ONE TWO ONE TWO B5.
MOVE "07" TO B5.
IF TS CALL PNUM USING T B ONE ONE TWO TWO ONE B5.
MOVE "08" TO B5.
IF TS CALL PNUM USING T B ONE ONE TWO TWO TWO B5.
MOVE "09" TO B5.
IF TS CALL PNUM USING T B ONE TWO ONE ONE ONE B5.
MOVE "10" TO B5.
IF TS CALL PNUM USING T B ONE TWO ONE ONE TWO B5.
MOVE "11" TO B5.
IF TS CALL PNUM USING T B ONE TWO ONE TWO ONE B5.
MOVE "12" TO B5.
IF TS CALL PNUM USING T B ONE TWO ONE TWO TWO B5.
MOVE "13" TO B5.
IF TS CALL PNUM USING T B ONE TWO TWO ONE ONE B5.
MOVE "14" TO B5.
IF TS CALL PNUM USING T B ONE TWO TWO ONE TWO B5.
MOVE "15" TO B5.
IF TS CALL PNUM USING T B ONE TWO TWO TWO ONE B5.
MOVE "16" TO B5.
IF TS CALL PNUM USING T B ONE TWO TWO TWO TWO B5.
MOVE "17" TO B5.
IF TS CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
MOVE "18" TO B5.
IF TS CALL PNUM USING T B TWO ONE ONE ONE TWO B5.
MOVE "19" TO B5.
IF TS CALL PNUM USING T B TWO ONE ONE TWO ONE B5.
MOVE "20" TO B5.
IF TS CALL PNUM USING T B TWO ONE ONE TWO TWO B5.
MOVE "21" TO B5.
IF TS CALL PNUM USING T B TWO ONE TWO ONE ONE B5.
MOVE "22" TO B5.
IF TS CALL PNUM USING T B TWO ONE TWO ONE TWO B5.
MOVE "23" TO B5.
IF TS CALL PNUM USING T B TWO ONE TWO TWO ONE B5.
MOVE "24" TO B5.
IF TS CALL PNUM USING T B TWO ONE TWO TWO TWO B5.
MOVE "25" TO B5.
IF TS CALL PNUM USING T B TWO TWO ONE ONE ONE B5.
MOVE "26" TO B5.
IF TS CALL PNUM USING T B TWO TWO ONE ONE TWO B5.
MOVE "27" TO B5.
IF TS CALL PNUM USING T B TWO TWO ONE TWO ONE B5.
MOVE "28" TO B5.
IF TS CALL PNUM USING T B TWO TWO ONE TWO TWO B5.
MOVE "29" TO B5.
IF TS CALL PNUM USING T B TWO TWO TWO ONE ONE B5.
MOVE "30" TO B5.
IF TS CALL PNUM USING T B TWO TWO TWO ONE TWO B5.
MOVE "31" TO B5.
IF TS CALL PNUM USING T B TWO TWO TWO TWO ONE B5.
MOVE "32" TO B5.
IF TS CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
*PTABLE TESTS ALL REMAINING ITEMS IN THE TABLE B.
*PTABLE IS CONTAINED IN XTBL9S.CBL
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.
DISPLAY "TYPE X<CR> THREE TIMES".
MOVE "X " TO B5.
ACCEPT AN OF B (SC1 + 1 SD1 + 1 2 SE2 SF2).
CALL PAN USING T B TWO TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
ACCEPT AN OF B (SD1 + 0 1 SE1 SF1 SC1 + 0).
CALL PAN USING T B ONE ONE ONE ONE ONE B5.
CALL PTABLE USING T B.
ACCEPT AN OF B (2 SE1 SF1 SC1 + 0 SD1 + 0).
CALL PAN USING T B TWO ONE ONE ONE ONE B5.
CALL PTABLE USING T B.
DISPLAY "TYPE 1<CR> THREE TIMES".
MOVE "01" TO B5.
ACCEPT NUM OF B (SE2 SF2 SC1 + 1 SD1 + 1 2).
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
ACCEPT NUM OF B (SF1 SC1 + 0 SD1 + 0 1 SE1).
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
CALL PTABLE USING T B.
ACCEPT NUM OF B (SC0 + 2 SD0 + 1 SE0 + 1 SF0 + 1 1).
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
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 "35" TO B5.
ADD NUM OF A (1 SC1 SD1 SE1 SF1)
NUM OF A (SF2 SE2 SD2 SC2 2)
NUM OF A (SC2 - 1 SD2 - 1 SE2 - 1 SF2 - 1 2 ) TO
NUM OF B (1 SC1 SD1 SE2 SF1).
CALL PNUM USING T B ONE ONE ONE TWO ONE B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON RECEIVING FIELDS OF "ADD ... TO OP OP ...".
MOVE "02" TO B5.
ADD TWO TO
NUM OF B (1 SC1 SD1 SE1 SF1) ROUNDED
NUM OF B (2 SC2 SD2 SE2 SF2)
NUM OF B (SC0 + 1 SD0 + 1 SE0 + 2 SF1 + 1 1).
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
CALL PNUM USING T B ONE ONE TWO TWO ONE B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "ADD OP OP GIVING OP OP...".
ADD NUM OF A (SC0 + 1 SD0 + 1 SE0 + 1 SF0 + 1 SF2 - 1)
NUM OF A (SC2 - 1 SD2 - 1 SE2 - 1 SF2 - 1 SC0 + 1) GIVING
NUM OF B (1 SC1 SD1 SE1 SF1)
NUM OF B (SF1 SE1 SD1 SC1 2) ROUNDED
NUM OF B (SC1 SD1 SE1 2 SF1).
MOVE "02" TO B5.
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
CALL PNUM USING T B ONE ONE ONE ONE TWO B5.
CALL PNUM USING T B ONE ONE ONE TWO ONE B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "ADD CORR OP TO OP".
MOVE "03" TO B5.
ADD CORR 5LB OF A (SC1 SD0 + 1 SE1 2 SF0 + 1) TO
5LB OF B (SF1 + 1 SE1 SD1 + 1 SC1 1).
CALL PNUM USING T B TWO ONE TWO ONE ONE B5.
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 SD1 SE1 2 SF1) = NUM OF A (1 SF1 SE1 SD1 SC2).
MOVE "02" TO B5.
CALL PNUM USING T B ONE ONE ONE TWO ONE B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "COMPUTE OP = (ARITHMETIC EXPRESSION OF OPS)".
MOVE "18" TO B5.
COMPUTE NUM OF B (SF0 + 2 SE0 + 2 SD2 SC2 SC2) =
(NUM OF A (SC2 SD2 SE1 SF1 1) *
NUM OF A (1 SC1 2 SD2 - 1 SE1) -
NUM OF A (SC1 2 SD0 + 2 SE1 SF1))/
NUM OF A (SC0 + 1 SC1 SD2 SE2 SF2) +
NUM OF A (SF0 + 1 SE0 + 1 SD1 2 SF0 + 2).
*THE ABOVE EXPRESSION IS (25*5-13)/8+4 = 18.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
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 SE1 SF1 1) SPACE
AN OF A (SF1 SE1 SD1 1 SC2) " "
AN OF A (SF0 + 1 SE0 + 1 SD0 + 1 SC2 SC2 - 1) TSWITCH
AN OF A (SF2 - 1 SE2 - 1 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 1 1).
DIVIDE NUM OF A (SC0 + 1 SD0 + 1 SE2 SF0 + 1 1) INTO
NUM OF B (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2 SE0 + 1 SF2).
*(THE ARITHMETIC IS 27/5 = 5 WITH REMAINDER 2).
MOVE "05" TO B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
MOVE "02" TO B5.
CALL PNUM USING T B TWO ONE TWO ONE TWO B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "DIVIDE OP BY OP REMAINDER OP".
* MOVE 5 TO NUM OF B (2 1 1 1 1).
* DIVIDE NUM OF A (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 2) BY
* NUM OF B (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 1) REMAINDER
* NUM OF B (SC2 SC0 + 1 SD2 SE0 + 1 SF2).
* MOVE "03" TO B5.
* CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
* MOVE "03" TO B5.
* CALL PNUM USING T B TWO ONE TWO ONE TWO B5.
* CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "DIVIDE OP INTO OP GIVING OP REMAINDER OP".
DIVIDE NUM OF A (SC0 + 1 SD0 + 1 SE2 SF0 + 1 1) INTO
NUM OF A (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 2) GIVING
NUM OF B (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2 SE0 + 1 SF2).
MOVE "03" TO B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
MOVE "03" TO B5.
CALL PNUM USING T B TWO ONE TWO ONE TWO B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "DIVIDE OP BY OP GIVING OP REMAINDER OP".
DIVIDE NUM OF A (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 2) BY
NUM OF A (SC0 + 1 SD0 + 1 SE2 SF0 + 1 1) GIVING
NUM OF B (SF0 + 2 SE2 - 1 SD2 - 1 SC2 - 1 1) REMAINDER
NUM OF B (SC2 SC0 + 1 SD2 SE0 + 1 SF2).
MOVE "03" TO B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
MOVE "03" TO B5.
CALL PNUM USING T B TWO ONE TWO ONE TWO B5.
CALL PTABLE USING T B.
*inspect
DISPLAY "inspect TEST".
*SUBSCRIPTING ON OPS OF "inspect OP ...".
MOVE "? inspect FAILS" TO T.
MOVE 1 TO TN.
set tally to zero.
inspect 5LA OF B (SC0 + 1 SC2 - 1 SD2 - 1 SE2 - 1 SF2)
TALLYING tally for characters before initial "*"
REPLACING characters BY "1" before initial "*".
MOVE "11" TO B5.
CALL PAN USING T B ONE ONE ONE ONE TWO B5.
CALL PTABLE USING T B.
set tally to zero.
inspect 2L OF B (SC2 - 1 SD0 + 2)
TALLYINg tally for all "0"
REPLACING all "0" BY "7".
IF TALLY NOT = 32
DISPLAY T "TALLY COUNTER IS: " TALLY ", SHOULD BE 32".
MOVE "77" TO B5.
CALL PAN USING T B ONE TWO ONE ONE ONE B5.
CALL PAN USING T B ONE TWO ONE ONE TWO B5.
CALL PAN USING T B ONE TWO ONE TWO ONE B5.
CALL PAN USING T B ONE TWO ONE TWO TWO B5.
CALL PAN USING T B ONE TWO TWO ONE ONE B5.
CALL PAN USING T B ONE TWO TWO ONE TWO B5.
CALL PAN USING T B ONE TWO TWO TWO ONE B5.
CALL PAN USING T B ONE TWO TWO TWO TWO B5.
CALL PNUM USING T B ONE TWO ONE ONE ONE B5.
CALL PNUM USING T B ONE TWO ONE ONE TWO B5.
CALL PNUM USING T B ONE TWO ONE TWO ONE B5.
CALL PNUM USING T B ONE TWO ONE TWO TWO B5.
CALL PNUM USING T B ONE TWO TWO ONE ONE B5.
CALL PNUM USING T B ONE TWO TWO ONE TWO B5.
CALL PNUM USING T B ONE TWO TWO TWO ONE B5.
CALL PNUM USING T B ONE TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
inspect 1L OF B (SD1 + 1)
REPLACING ALL "0" BY "9".
MOVE "99" TO B5.
CALL PAN USING T B TWO ONE ONE ONE ONE B5.
CALL PAN USING T B TWO ONE ONE ONE TWO B5.
CALL PAN USING T B TWO ONE ONE TWO ONE B5.
CALL PAN USING T B TWO ONE ONE TWO TWO B5.
CALL PAN USING T B TWO ONE TWO ONE ONE B5.
CALL PAN USING T B TWO ONE TWO ONE TWO B5.
CALL PAN USING T B TWO ONE TWO TWO ONE B5.
CALL PAN USING T B TWO ONE TWO TWO TWO B5.
CALL PAN USING T B TWO TWO ONE ONE ONE B5.
CALL PAN USING T B TWO TWO ONE ONE TWO B5.
CALL PAN USING T B TWO TWO ONE TWO ONE B5.
CALL PAN USING T B TWO TWO ONE TWO TWO B5.
CALL PAN USING T B TWO TWO TWO ONE ONE B5.
CALL PAN USING T B TWO TWO TWO ONE TWO B5.
CALL PAN USING T B TWO TWO TWO TWO ONE B5.
CALL PAN USING T B TWO TWO TWO TWO TWO B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
CALL PNUM USING T B TWO ONE ONE ONE TWO B5.
CALL PNUM USING T B TWO ONE ONE TWO ONE B5.
CALL PNUM USING T B TWO ONE ONE TWO TWO B5.
CALL PNUM USING T B TWO ONE TWO ONE ONE B5.
CALL PNUM USING T B TWO ONE TWO ONE TWO B5.
CALL PNUM USING T B TWO ONE TWO TWO ONE B5.
CALL PNUM USING T B TWO ONE TWO TWO TWO B5.
CALL PNUM USING T B TWO TWO ONE ONE ONE B5.
CALL PNUM USING T B TWO TWO ONE ONE TWO B5.
CALL PNUM USING T B TWO TWO ONE TWO ONE B5.
CALL PNUM USING T B TWO TWO ONE TWO TWO B5.
CALL PNUM USING T B TWO TWO TWO ONE ONE B5.
CALL PNUM USING T B TWO TWO TWO ONE TWO B5.
CALL PNUM USING T B TWO TWO TWO TWO ONE B5.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
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 (SF0 + 1 SF2 - 1 SE0 + 1 SD0 + 1 SC0 + 1).
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 + 1 SD0 + 1 SE1 + 1 SF1 + 1 SF0 + 1) TO
AN OF B (SC1 SC0 + 1 SD2 - 1 SE1 SF0 + 1)
AN OF B (SF1 SE1 SD1 SD1 + 1 2)
AN OF B (2 SF1 SE1 SD1 + 1 2)
AN OF B (SC0 + 2 SD0 + 2 SD0 + 1 SE0 + 1 SF0 + 1).
MOVE "GG" TO B5.
CALL PAN USING T B ONE ONE ONE ONE ONE B5.
CALL PAN USING T B ONE ONE ONE TWO TWO B5.
CALL PAN USING T B TWO ONE ONE TWO TWO B5.
CALL PAN USING T B TWO TWO ONE ONE ONE B5.
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 5LA OF A (SF2 SE1 SE0 + 2 SD1 SC0 + 2) TO
5LA OF B (SF0 + 1 SE0 + 1 SD0 + 1 2 SC1).
MOVE "VV" TO B5.
CALL PAN USING T B ONE ONE ONE TWO ONE B5.
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 1 1 2 2).
MULTIPLY NUM OF A (SC2 SD0 + 1 SD1 SE0 + 1 SF1) BY
NUM OF B (1 SC1 SD1 SE1 + 1 SF0 + 2).
IF NUM OF A (2 1 1 1 1) NOT = 17
DISPLAY T "MULTIPLY OP A BY OP B"
DISPLAY " CLOBBERED OP A VALUE"
DISPLAY " OP A VALUE IS " NUM OF A (2 1 1 1 1) ", IT SHOULD BE 17".
MOVE "68" TO B5.
CALL PNUM USING T B ONE ONE ONE TWO TWO B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "MULTIPLY OP BY OP GIVING OP".
MULTIPLY NUM OF A (2 SC1 SD0 + 1 SE1 SF0 + 1) BY
NUM OF A (SF1 SE1 SD0 + 1 SE1 + 1 SF2) GIVING
NUM OF B (1 SC0 + 1 SD0 + 1 SE0 + 1 SF1 + 1).
MOVE "68" TO B5.
CALL PNUM USING T B ONE ONE ONE ONE TWO B5.
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 (SF1 SE1 + 1 1 SD0 + 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 + 1 SD0 + 2 SE1 SF1 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 (1 2 1 1 1).
DISPLAY "STARTING VARIABLE PERFORM TEST 3".
PERFORM P2 UNTIL 2 = NUM OF B (SC0 + 1 SUB1 SD1 SE1 SF1)
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 SE1 SF1 1)
FROM NUM OF A (1 SF1 SF2 - 1 SE1 SD1)
BY NUM OF A (SC0 + 1 SD0 + 1 SE0 + 1 SF1 SF0 + 1)
UNTIL NUM OF B (1 SF1 SE0 + 1 SD1 SC1)
> NUM OF A (1 SC1 SD1 SE2 SF2)
AFTER VARYING NUM OF B (SF2 - 1 SF2 SE2 - 1 SD2 - 1 SC2 - 1)
FROM NUM OF B (SC1 SC0 + 1 SD1 SD0 + 1 SE0 + 1)
BY NUM OF A (SC1 SD1 SE1 SF2 SC2)
UNTIL 15 < NUM OF B (SC2 - 1 SC2 SC2 - 1 SC2 - 1 SC1).
DISPLAY " PERFORM TEST 4 FINISHED".
IF SUB1 NOT = 16
DISPLAY T
DISPLAY "SUB1 VALUE IS: " SUB1 ", SHOULD BE 16".
MOVE "04" TO B5.
CALL PNUM USING T B ONE TWO ONE ONE ONE B5.
MOVE "05" TO B5.
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
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 SE1 SF1 SC1).
WRITE TESTREC FROM AN OF A (SF1 SE1 SD1 + 1 SD0 + 1 SC1).
WRITE TESTREC FROM AN OF A (SC2 2 SD2 2 SE2).
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 = "ZG "
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 "TWO BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF
A (SC0 + 1 SD0 + 1 SE0 + 1 SF2 SF2 - 1).
MOVE "SIX BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF A (1 SC1 2 SD2 SE2 - 1).
MOVE "NO BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF A (1 1 1 1 1).
MOVE "14 BLANK LINES FOLLOW" TO PRINTREC.
WRITE PRINTREC BEFORE ADVANCING NUM OF
A (SC1 SD1 + 1 SE1 + 1 SF1 + 1 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 SC1 SD1 SE1 SF1) AT END
DISPLAY T "CAN'T READ 1ST RECORD OF INPUT FILE"
GO TO READ1.
READ TESTFILE INTO AN OF B (SF1 1 SE2 SD1 SC1) AT END
DISPLAY T "CAN'T READ 2ND RECORD OF INPUT FILE"
GO TO READ1.
READ TESTFILE INTO AN OF B (SC2 SD2 SE2 SF2 SC0 + 2) 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 B5.
CALL PAN USING T B ONE ONE ONE ONE ONE B5.
MOVE "EE" TO B5.
CALL PAN USING T B ONE ONE TWO ONE ONE B5.
MOVE "ZG" TO B5.
CALL PAN USING T B TWO TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
*SEARCH
*SUBSCRIPTING ON OPS OF "SEARCH ... VARYING OP ...".
DISPLAY "SEARCH TEST".
MOVE 1 TO I J K L M.
MOVE "? SEARCH FAILS" TO T.
SEARCH 5LA OF A VARYING NUM OF B (SC0 + 1 SD0 + 1 SE0 + 1 SF2 SC1 + 1)
WHEN AN OF A (I J K L M) = "BB" NEXT SENTENCE.
MOVE "02" TO B5.
CALL PNUM USING T B ONE ONE ONE TWO TWO B5.
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 SD1 1 SE0 + 1 SF1)
NUM OF B (2 SF2 - 1 SE0 + 1 SD2 - 1 SC0 + 1)
NUM OF B (2 SF1 + 1 SE1 + 1 SD1 + 1 SC1 + 1) TO
NUM OF A (SF2 SE2 SD2 SC2 2).
MOVE "32" TO B5.
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "SET OP OP ... UP BY OP".
SET NUM OF B (1 SC0 + 1 1 SD0 + 1 1)
NUM OF B (SF2 1 SE1 SD1 SC1)
NUM OF B (SF2 2 SE2 2 SD2) UP BY
NUM OF A (2 SF2 SE1 + 1 SD2 SC1 + 1).
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
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 1 1).
MOVE 37 TO NUM OF B (2 1 1 1 1).
MOVE 42 TO NUM OF B (2 2 2 2 2).
SUBTRACT NUM OF A (SC0 + 1 SD1 1 SE0 + 1 SF1)
NUM OF A (SF2 - 1 SE2 - 1 SD2 - 1 SC2 SC2 - 1)
NUM OF A (SF2 SE2 - 1 SD0 + 1 SC2 - 1 SC0 + 1) FROM
NUM OF B (SC1 SD1 SE1 SF1 1)
NUM OF B (SC1 + 1 SD2 - 1 SE2 - 1 SF2 - 1 SF1) ROUNDED
NUM OF B (SC1 + 1 SD1 + 1 SE1 + 1 SF1 + 1 SC0 + 2).
MOVE "04" TO B5.
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
MOVE "16" TO B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
MOVE "21" TO B5.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "SUBTRACT OP OP FROM OP GIVING OP OP".
SUBTRACT NUM OF A (SF0 + 1 SE1 SD1 + 1 1 SC0 + 1)
NUM OF A (SC1 SD1 SE2 SF0 + 1 SC0 + 1) FROM
NUM OF A (SC0 + 2 SC1 + 1 SC2 SD0 + 2 SD1 + 1) GIVING
NUM OF B (SC0 + 1 SC1 SD1 SE0 + 1 SF1)
NUM OF B (SF2 - 1 SE2 - 1 SD2 SC2 - 1 SC1) ROUNDED
NUM OF B (SF2 SE0 + 2 SD2 SC0 + 2 SF0 + 2).
MOVE "22" TO B5.
CALL PNUM USING T B ONE ONE ONE ONE ONE B5.
CALL PNUM USING T B ONE ONE TWO ONE ONE B5.
CALL PNUM USING T B TWO TWO TWO TWO TWO B5.
CALL PTABLE USING T B.
*SUBSCRIPTING ON OPS OF "SUBTRACT CORR OP FROM OP".
MOVE 64 TO NUM OF B (2 1 1 1 1).
SUBTRACT CORR 5LB OF A (SF0 + 1 SE0 + 1 SD0 + 1 SC2 1) FROM
5LB OF B (SC1 + 1 1 SD2 - 1 SE2 - 1 SF2 - 1).
MOVE "61" TO B5.
CALL PNUM USING T B TWO ONE ONE ONE ONE B5.
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, 7, 9, 11, 13, 15, 17, 19, 21,
*23, 25, 27, 29, AND 31 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 5SUBS.
RELEASE SORTREC FROM AN OF A (SUB1, SUB2, SUB3, SUB4, SUB5).
ADD 1 TO SSUB.
IF SSUB < 17 GO TO P3A.
*THIS IS THE OUTPUT PROCEDURE FOR THE SORT TEST.
*IT RETURNS THE SORTED (ASCENDING) ITEMS TO ALPHANUMERIC
*POSITIONS 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30,
*AND 32 OF TABLE B.
P4.
MOVE 1 TO SSUB.
P4A.
MOVE SORTGRP2 (SSUB) TO 5SUBS.
RETURN SORTFILE INTO AN OF B (SUB1 SUB2 SUB3 SUB4 SUB5) AT END
GO TO P4B.
ADD 1 TO SSUB.
GO TO P4A.
P4B.
EXIT.