入力ファイルIN-FILEからEnglish,Japanese,Mathematicsの得点を入力し,3教科の平均点を表示するプログラムです。
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. AVERAGE.
000030
000040 ENVIRONMENT DIVISION.
000050 INPUT-OUTPUT SECTION.
000060 FILE-CONTROL.
000070 SELECT IN-FILE ASSIGN TO SYS001
000080 ORGANIZATION IS LINE SEQUENTIAL.
000090 SELECT OUT-FILE ASSIGN TO SYS002.
000100 DATA DIVISION.
000110 FILE SECTION.
000120 FD IN-FILE.
000130 01 IN-REC.
000140 02 IN-POINT PIC 9(9).
000150 02 FILLER PIC X.
000160 FD OUT-FILE LABEL RECORD OMITTED.
000170 01 OUT-REC PIC X(80).
000180 WORKING-STORAGE SECTION.
000190 01 PR-REC.
000200 02 FILLER PIC X(13) VALUE SPACE.
000210 02 E-POINT PIC Z(3)9.
000220 02 FILLER PIC X(6) VALUE SPACE.
000230 02 K-POINT PIC Z(3)9.
000240 02 FILLER PIC X(8) VALUE SPACE.
000250 02 S-POINT PIC Z(3)9.
000260 02 FILLER PIC X(5) VALUE SPACE.
000270 02 A-POINT PIC Z(3)9.
000280 02 FILLER PIC X(31) VALUE SPACE.
000290 01 TITLE.
000300 02 FILLER PIC X(10) VALUE SPACE.
000310 02 T-REC PIC X(40)
000320 VALUE 'English Japanese Mathematics Average'.
000330 02 FILLER PIC X(30) VALUE SPACE.
000340 01 ERR-MSG.
000350 02 FILLER PIC X(10) VALUE SPACE.
000360 02 ERMSG PIC X(34)
000370 VALUE '** Error: Input data is mistaken.'.
000380 02 ERMSG2 PIC X(18) VALUE ' ==> error data:'.
000390 02 ER-REC.
000400 03 ER-DATA PIC 9(9).
000410 02 FILLER PIC X(9) VALUE SPACE.
000420 01 NO-MSG.
000430 02 FILLER PIC X(10) VALUE SPACE.
000440 02 NMSG PIC X(40)
000450 VALUE '** Information: There is no input data.'.
000460 02 FILLER PIC X(30) VALUE SPACE.
000470 77 ENDM PIC X(3).
000480 88 END-OF-FIL VALUE 'EOF'.
000490 01 WORK-TBL.
000500 02 W-TBL OCCURS 20.
000510 03 W-REC.
000520 04 WE-P PIC 9(3).
000530 04 WK-P PIC 9(3).
000540 04 WS-P PIC 9(3).
000550 03 WA-P PIC 9(4).
000560 03 R-CODE PIC 9.
000570 77 I PIC 9(3).
000580 77 J PIC 9(3).
000590*
000600 PROCEDURE DIVISION.
000610 MAIN-PROCESS SECTION.
000620 OPEN-FILE.
000630 OPEN INPUT IN-FILE
000640 OUTPUT OUT-FILE.
000650 MAKING-WTBL.
000660 READ IN-FILE
000670 AT END MOVE 'EOF' TO ENDM.
000680 PERFORM VARYING I FROM 1 BY 1 UNTIL END-OF-FIL
000690 MOVE IN-POINT TO W-REC(I)
000700 READ IN-FILE AT END MOVE 'EOF' TO ENDM
000710 END-READ
000720 END-PERFORM.
000730 ZERO-CHECK.
000740 COMPUTE I = I - 1.
000750 IF I = 0
000760 WRITE OUT-REC FROM NO-MSG AFTER 1
000770 GO TO CLOSE-FILE
000780 ELSE
000790 CONTINUE
000800 END-IF.
000810 CALCULATE.
000820 CALL 'SUBAV' USING WORK-TBL I.
000830 PRINTING-DATA.
000840 PERFORM DATA-PUT.
000850 CLOSE-FILE.
000860 CLOSE IN-FILE OUT-FILE.
000870 STOP RUN.
000880*
000890 DATA-PUT SECTION.
000900 PRINTING-TITLE.
000910 WRITE OUT-REC FROM TITLE AFTER 1.
000920 PRINTING-AVERAGE.
000930 PERFORM VARYING J FROM 1 BY 1 UNTIL J > I
000940 IF R-CODE(J) = 8
000950 MOVE W-REC(J) TO ER-REC
000960 WRITE OUT-REC FROM ERR-MSG AFTER 1
000970 ELSE
000980 MOVE WE-P(J) TO E-POINT
000990 MOVE WK-P(J) TO K-POINT
001000 MOVE WS-P(J) TO S-POINT
001010 MOVE WA-P(J) TO A-POINT
001020 WRITE OUT-REC FROM PR-REC AFTER 1
001030 END-IF
001040 END-PERFORM.
001050 END PROGRAM AVERAGE.
平均点を計算するプログラムです。
000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. SUBAV.
000030 ENVIRONMENT DIVISION.
000040 DATA DIVISION.
000050 WORKING-STORAGE SECTION.
000060 77 I PIC S9(8) COMP.
000070 77 J PIC S9(8) COMP.
000080 77 K PIC S9(8) COMP.
000090 77 L PIC S9(8) COMP.
000100 77 M PIC S9(8) COMP.
000110 77 MM PIC S9(8) COMP.
000120 77 CHGSW PIC X VALUE LOW-VALUE.
000130 88 NO-CHANGE VALUE HIGH-VALUE.
000140 88 ALL-CHANGE VALUE LOW-VALUE.
000150 01 SORT-TBL.
000160 02 S-TBL OCCURS 20 INDEXED BY DATA-INDEX
000170 COMP-INDEX1
000180 COMP-INDEX2.
000190 03 S-P.
000200 04 FILLER PIC 9(9).
000210 03 SA-P PIC 9(4).
000220 03 FILLER PIC 9.
000230 01 SW-TBL.
000240 02 SORT-ITEM INDEX OCCURS 20 INDEXED BY SORT-INDEX.
000250 LINKAGE SECTION.
000260 01 WORK-TBL.
000270 02 W-TBL OCCURS 20.
000280 03 W-REC.
000290 04 WE-P PIC 9(3).
000300 04 WK-P PIC 9(3).
000310 04 WS-P PIC 9(3).
000320 03 WA-P PIC 9(4).
000330 03 R-CODE PIC 9.
000340 77 KOSU PIC 9(3).
000350*
000360 PROCEDURE DIVISION USING WORK-TBL KOSU.
000370 MAIN-PROCESS SECTION.
000380 DATA-CHEK-AND-COMPUTE.
000390 PERFORM VARYING I FROM 1 BY 1 UNTIL I > KOSU
000400 MOVE ZERO TO WA-P(I)
000410 IF WE-P(I) > 100 OR
000420 WK-P(I) > 100 OR
000430 WS-P(I) > 100
000440 MOVE 8 TO R-CODE(I)
000450 ELSE
000460 MOVE 0 TO R-CODE(I)
000470 COMPUTE WA-P(I) ROUNDED
000480 = (WE-P(I) + WK-P(I) + WS-P(I)) / 3
000490 END-IF
000500 MOVE W-TBL(I) TO S-TBL(I)
000510 END-PERFORM.
000520 PERFORM DATA-SORT.
000530 EXIT PROGRAM.
000540*
000550 DATA-SORT SECTION.
000560 IF KOSU = 1 THEN
000570 GO TO DATA-SORT-EXIT
000580 ELSE
000590 CONTINUE
000600 END-IF.
000610 PERFORM VARYING I FROM 1 BY 1 UNTIL I > 20
000620 SET DATA-INDEX TO I
000630 SET SORT-ITEM(I) TO DATA-INDEX
000640 END-PERFORM.
000650 MOVE 2 TO M.
000660 PERFORM UNTIL M > KOSU
000670 COMPUTE M = M * 2
000680 END-PERFORM.
000690 COMPUTE M = M / 2 - 1.
000700 PERFORM UNTIL M < 1
000710 PERFORM VARYING I FROM 1 BY 1 UNTIL I > M
000720 PERFORM VARYING J FROM I BY M UNTIL J + M > KOSU
000730 COMPUTE K = J + M
000740 SET COMP-INDEX1 TO SORT-ITEM(J)
000750 SET COMP-INDEX2 TO SORT-ITEM(K)
000760 IF SA-P(COMP-INDEX1) < SA-P(COMP-INDEX2) THEN
000770 SET SORT-ITEM(K) TO COMP-INDEX1
000780 MOVE LOW-VALUE TO CHGSW
000790 COMPUTE MM = - M
000800 PERFORM VARYING K FROM J BY MM
000810 UNTIL K - M < I OR NO-CHANGE
000820 COMPUTE L = K - M
000830 SET COMP-INDEX1 TO SORT-ITEM(L)
000840 IF SA-P(COMP-INDEX1) < SA-P(COMP-INDEX2) THEN
000850 SET SORT-ITEM(K) TO COMP-INDEX1
000860 ELSE
000870 SET SORT-ITEM(K) TO COMP-INDEX2
000880 MOVE HIGH-VALUE TO CHGSW
000890 END-IF
000900 END-PERFORM
000910 IF ALL-CHANGE THEN
000920 IF J = I THEN
000930 SET SORT-ITEM(J) TO COMP-INDEX2
000940 ELSE
000950 SET SORT-ITEM(L) TO COMP-INDEX2
000960 END-IF
000970 ELSE
000980 CONTINUE
000990 END-IF
001000 ELSE
001010 CONTINUE
001020 END-IF
001030 END-PERFORM
001040 END-PERFORM
001050 COMPUTE M = M / 2
001060 END-PERFORM.
001070 PERFORM VARYING J FROM 1 BY 1 UNTIL J > KOSU
001080 SET DATA-INDEX TO SORT-ITEM(J)
001090 MOVE S-TBL(DATA-INDEX) TO W-TBL(J)
001100 END-PERFORM.
001110 DATA-SORT-EXIT.
001120 EXIT.
001130 END PROGRAM SUBAV.