Trailing-Edge
-
PDP-10 Archives
-
k20v7d
-
uetp/lib/rmtcbr.cbl
There are 4 other files named rmtcbr.cbl in the archive. Click here to see a list.
ID DIVISION.
PROGRAM-ID. RMTCBR.
* RMS TEST FOR COBOL.
* THIS IS A SIMPLE TEST OF THE VARIOUS RMS FUNCTIONS NEEDED FOR COBOL.
* IT TRIES TO TEST A LITTLE OF EVERYTHING FOR RMS RELATIVE FILES.
*
* COPYRIGHT (c) 1984 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
*
ENVIRONMENT DIVISION.
I-O SECTION.
FILE-CONTROL.
SELECT FILE-1 ASSIGN TO DSK;
ORGANIZATION IS RMS RELATIVE;
ACCESS MODE IS DYNAMIC;
RELATIVE KEY IS RK1.
SELECT FILE-2 ASSIGN TO DSK;
ORGANIZATION IS RMS RELATIVE;
ACCESS MODE IS SEQUENTIAL;
RELATIVE KEY IS RK2.
DATA DIVISION.
FILE SECTION.
FD FILE-1 VALUE OF ID IS "RMTF1 RMS".
01 REC-1 DISPLAY-7.
02 FILLER PIC X(5).
02 AK1-1 PIC X(5).
02 AK1-2 PIC 9(5).
02 FILLER PIC X(10).
FD FILE-2 VALUE OF ID IS "RMTF2 RMS".
01 REC-2.
02 FILLER PIC X(10).
02 AK2-1 PIC X(5).
02 AK2-2 PIC 9(5).
02 FILLER PIC X(5).
WORKING-STORAGE SECTION.
01 RK1 PIC 9(5) COMP.
01 RK2 PIC 9(5) COMP.
01 F1R1 PIC X(25) VALUE "AAAAADDDDD11111XXXXXXXXXX".
01 F1R2 PIC X(25) VALUE "BBBBBEEEEE11111XXXXXXXXXX".
01 F1R3 PIC X(25) VALUE "CCCCCFFFFF22222XXXXXXXXXX".
01 F1R4 PIC X(25) VALUE "DDDDDGGGGG22222XXXXXXXXXX".
01 F1R5 PIC X(25) VALUE "EEEEEHHHHH11111YYYYYYYYYY".
01 F2R1 PIC X(25) VALUE "XXXXXAAAAADDDDD55555XXXXX".
01 F2R2 PIC X(25) VALUE "YYYYYBBBBBEEEEE66666XYXYX".
01 F2R3 PIC X(25) VALUE "XXXXYCCCCCFFFFF77777XXYXX".
01 F2R4 PIC X(25) VALUE "XXYYXDDDDDGGGGG88888YXYXY".
01 F2R5 PIC X(25) VALUE "YYXXYEEEEEHHHHH99999YYYYX".
PROCEDURE DIVISION.
STARTER.
OPEN OUTPUT FILE-1.
OPEN OUTPUT FILE-2.
S-1.
ADD 1 TO RK1.
WRITE REC-1 FROM F1R1
INVALID KEY DISPLAY "?S-1".
S-2.
ADD 1 TO RK1.
WRITE REC-1 FROM F1R2
INVALID KEY DISPLAY "?S-2".
S-3.
ADD 1 TO RK1.
WRITE REC-1 FROM F1R3
INVALID KEY DISPLAY "?S-3".
S-4.
ADD 1 TO RK1.
WRITE REC-1 FROM F1R4
INVALID KEY DISPLAY "?S-4".
S-5.
ADD 1 TO RK1.
WRITE REC-1 FROM F1R5
INVALID KEY DISPLAY "?S-5".
S-6.
CLOSE FILE-1.
OPEN INPUT FILE-1.
S-7.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R1
INVALID KEY DISPLAY "?S-7".
S-8.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R2
INVALID KEY DISPLAY "?S-8".
S-9.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R3
INVALID KEY DISPLAY "?S-9".
S-10.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R4
INVALID KEY DISPLAY "?S-10".
S-11.
ADD 1 TO RK2.
WRITE REC-2 FROM F2R5
INVALID KEY DISPLAY "?S-11".
S-12.
CLOSE FILE-2.
OPEN INPUT FILE-2.
S-13.
MOVE 1 TO RK1.
READ FILE-1 INVALID KEY DISPLAY "?S-13".
S-14.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-14".
S-15.
IF REC-1 NOT = F1R2 DISPLAY "?S-15".
S-16.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-16".
S-17.
IF REC-1 NOT = F1R3 DISPLAY "?S-17".
S-18.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-18".
S-19.
IF REC-1 NOT = F1R4 DISPLAY "?S-19".
S-20.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-20".
S-21.
IF REC-1 NOT = F1R5 DISPLAY "?S-21".
S-22.
READ FILE-1 NEXT RECORD AT END GO TO S-23.
DISPLAY "?S-22".
S-23.
CLOSE FILE-1.
OPEN I-O FILE-1.
S-24.
MOVE 4 TO RK1.
START FILE-1 KEY = RK1 INVALID KEY DISPLAY "?S-24".
S-25.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-25".
S-25A.
IF REC-1 NOT = F1R4 DISPLAY "?S-25A".
S-26.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-26".
S-27.
MOVE 4 TO RK1.
START FILE-1 KEY NOT LESS RK1 INVALID KEY DISPLAY "?S-27".
S-28.
READ FILE-1 NEXT AT END DISPLAY "?S-28".
S-29.
IF REC-1 NOT = F1R4 DISPLAY "?S-29".
S-30.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-30".
S-31.
MOVE 4 TO RK1.
START FILE-1 KEY GREATER RK1 INVALID KEY DISPLAY "?S-31".
S-32.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-32".
S-33.
IF REC-1 NOT = F1R4 DISPLAY "?S-33".
S-34.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-34".
S-35.
IF REC-2 NOT = F2R1 DISPLAY "?S-35".
S-36.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-36".
S-37.
IF REC-2 NOT = F2R2 DISPLAY "?S-37".
S-38.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-38".
S-39.
IF REC-2 NOT = F2R3 DISPLAY "?S-39".
S-40.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-40".
S-41.
IF REC-2 NOT = F2R4 DISPLAY "?S-41".
S-42.
READ FILE-2 NEXT RECORD AT END DISPLAY "?S-42".
S-43.
IF REC-2 NOT = F2R5 DISPLAY "?S-43".
S-44.
READ FILE-2 NEXT RECORD AT END GO TO S-45.
DISPLAY "?S-44".
S-45.
MOVE 3 TO RK1.
DELETE FILE-1 INVALID KEY DISPLAY "?S-45".
S-46.
MOVE 4 TO RK1.
MOVE 00000 TO AK1-2.
REWRITE REC-1 INVALID KEY DISPLAY "?S-46".
S-47.
MOVE 4 TO RK1.
START FILE-1 KEY = RK1 INVALID KEY DISPLAY "?S-47".
S-48.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-48".
S-48A.
IF AK1-2 NOT = 00000 DISPLAY "?S-48A".
S-49.
MOVE 22222 TO AK1-2.
IF REC-1 NOT = F1R4 DISPLAY "?S-49".
S-49A.
MOVE 4 TO RK1.
START FILE-1 KEY = RK1 INVALID KEY DISPLAY "?S-49A"
GO TO S-55.
S-50.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-50"
GO TO S-55.
S-51.
MOVE 22222 TO AK1-2.
IF REC-1 NOT = F1R4 DISPLAY "?S-51".
S-52.
READ FILE-1 NEXT RECORD AT END DISPLAY "?S-52"
GO TO S-55.
S-53.
IF REC-1 NOT = F1R5 DISPLAY "?S-53".
S-54.
READ FILE-1 NEXT RECORD AT END GO TO S-55.
S-54A.
DISPLAY "?S-54A".
S-55.
IF RK1 NOT = 5 DISPLAY "?S-55".
S-56.
MOVE 6 TO RK1.
READ FILE-1 INVALID KEY GO TO S-57.
DISPLAY "?S-56".
S-57.
MOVE 5 TO RK1.
READ FILE-1 INVALID KEY DISPLAY "?S-57".
S-58.
MOVE "DDDDD" TO AK1-1.
REWRITE REC-1 INVALID KEY DISPLAY "?S-58".
S-59.
CLOSE FILE-1, FILE-2.
S-60.
OPEN I-O FILE-1 FOR ANY OTHERS ANY
UNAVAILABLE DISPLAY "?S-60"
GO TO S-61.
CLOSE FILE-1.
S-61.
T-DONE.
DISPLAY "[RMS/COBOL - Completed test for Relative Files]".
STOP RUN.