PDP-10 Archive: uetp/lib/rmtmki.cbl from bb-r775c-bm_tops20_ks_upd

Trailing-Edge - PDP-10 Archives - bb-r775c-bm_tops20_ks_upd_3 - uetp/lib/rmtmki.cbl
There are 16 other files named rmtmki.cbl in the archive. Click here to see a list.
ID DIVISION.
PROGRAM-ID. RTEST - RMS TEST FOR COBOL.
*
*
*			  COPYRIGHT (c) 1983 BY
*	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
*
* THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
* ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
* INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR  ANY  OTHER
* COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
* OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
* TRANSFERRED.
*
* THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE  WITHOUT  NOTICE
* AND  SHOULD  NOT  BE  CONSTRUED  AS  A COMMITMENT BY DIGITAL EQUIPMENT
* CORPORATION.
*
* DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF  ITS
* SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
*
*
* THIS IS A SIMPLE TEST OF THE VARIOUS RMS FUNCTIONS NEEDED FOR COBOL.
* IT TRIES TO TEST A LITTLE OF EVERYTHING.
ENVIRONMENT DIVISION.
I-O SECTION.
FILE-CONTROL.
	SELECT FILE-1 ASSIGN TO DSK;
		ORGANIZATION IS RMS INDEXED;
		ACCESS MODE IS DYNAMIC;
		RECORD KEY IS RK1;
		ALTERNATE RECORD KEY IS AK1-1;
		ALTERNATE RECORD KEY IS AK1-2 WITH DUPLICATES.
	SELECT FILE-2 ASSIGN TO DSK;
		ORGANIZATION IS RMS INDEXED;
		ACCESS MODE IS SEQUENTIAL;
		RECORD KEY IS RK2;
		ALTERNATE RECORD KEY IS AK2-1;
		ALTERNATE RECORD KEY IS AK2-2.
DATA DIVISION.
FILE SECTION.
FD FILE-1 VALUE OF ID IS "RMTF1 RMS".
01 REC-1 DISPLAY-7.
	02 RK1 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(5).
	02 RK2 PIC X(5).
	02 AK2-1 PIC X(5).
	02 AK2-2 PIC 9(5).
	02 FILLER PIC X(5).
WORKING-STORAGE SECTION.
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 I-O FILE-1.
	OPEN OUTPUT FILE-2.
S-1.
	WRITE REC-1 FROM F1R1
		INVALID KEY DISPLAY "?S-1".
S-2.
	WRITE REC-1 FROM F1R2
		INVALID KEY DISPLAY "?S-2".
S-3.
	WRITE REC-1 FROM F1R3
		INVALID KEY DISPLAY "?S-3".
S-4.
	WRITE REC-1 FROM F1R4
		INVALID KEY DISPLAY "?S-4".
S-5.
	WRITE REC-1 FROM F1R5
		INVALID KEY DISPLAY "?S-5".
S-6.
	CLOSE FILE-1.
	OPEN INPUT FILE-1.
S-7.
	WRITE REC-2 FROM F2R1
		INVALID KEY DISPLAY "?S-7".
S-8.
	WRITE REC-2 FROM F2R2
		INVALID KEY DISPLAY "?S-8".
S-9.
	WRITE REC-2 FROM F2R3
		INVALID KEY DISPLAY "?S-9".
S-10.
	WRITE REC-2 FROM F2R4
		INVALID KEY DISPLAY "?S-10".
S-11.
	WRITE REC-2 FROM F2R5
		INVALID KEY DISPLAY "?S-11".
S-12.
	CLOSE FILE-2.
	OPEN INPUT FILE-2.
S-13.
	MOVE F1R1 TO REC-1.
	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 F1R4 TO REC-1.
	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 F1R4 TO REC-1.
	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 F1R4 TO REC-1.
	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 = F1R5 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 F1R3 TO REC-1.
	DELETE FILE-1 INVALID KEY DISPLAY "?S-45".
S-46.
	MOVE F1R4 TO REC-1.
	MOVE 00000 TO AK1-2.
	REWRITE REC-1 INVALID KEY DISPLAY "?S-46".
S-47.
	MOVE 00000 TO AK1-2.
	START FILE-1 KEY = AK1-2 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-50.
	READ FILE-1 NEXT RECORD AT END DISPLAY "?S-50".
S-51.
	IF REC-1 NOT = F1R1 DISPLAY "?S-51".
S-52.
	READ FILE-1 NEXT RECORD AT END DISPLAY "?S-52".
S-53.
	IF REC-1 NOT = F1R2 DISPLAY "?S-53".
S-54.
	READ FILE-1 NEXT RECORD AT END DISPLAY "?S-54".
S-55.
	IF RK1 NOT = "EEEEE" DISPLAY "?S-55".
S-56.
	MOVE "XXXXX" TO RK1.
	READ FILE-1 INVALID KEY GO TO S-57.
	DISPLAY "?S-56".
S-57.
	MOVE F1R5 TO REC-1.
	READ FILE-1 INVALID KEY DISPLAY "?S-57".
S-58.
	MOVE "DDDDD" TO AK1-1.
	REWRITE REC-1 INVALID KEY GO TO S-59.
	DISPLAY "?S-58".
S-59.
	CLOSE FILE-1, FILE-2.
T-DONE.
	DISPLAY "[RMS - COBOL - Test completed]".
	STOP RUN.