*** Top of Data *** IDENTIFICATION DIVISION. PROGRAM-ID. CALENDAR. AUTHOR. STEVEN LANDOVITZ. **************************************************************** *** THIS PROGRAM PRINTS CALENDARS FOR ALL YEARS LISTED IN THE *** INPUT FILE. **************************************************************** ENVIRONMENT DIVISION. CONFIGURATION SECTION. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT INPUT-FILE ASSIGN TO INFILE FILE STATUS IS INPUT-FILE-STATUS. SELECT REPORT-FILE ASSIGN TO RPTFILE FILE STATUS IS REPORT-FILE-STATUS. DATA DIVISION. FILE SECTION. **************************************************************** *** INPUT FILE **************************************************************** FD INPUT-FILE LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS. 01 INPUT-REC. 05 INPUT-DATE. 10 INPUT-YEAR PIC 9(4). 10 INPUT-BC-IND PIC X(1). 88 INPUT-YEAR-BC VALUE 'B'. 05 FILLER PIC X(75). **************************************************************** *** REPORT FILE **************************************************************** FD REPORT-FILE LABEL RECORDS ARE STANDARD BLOCK CONTAINS 0 RECORDS. 01 REPORT-REC PIC X(133). EJECT WORKING-STORAGE SECTION. 01 FILLER. 05 ABEND-CODE PIC S9(4) COMP VALUE +0. 05 SUB PIC S9(4) COMP. 05 INPUT-FILE-STATUS PIC X(2). 88 INPUT-STATUS-OK VALUE '00'. 88 INPUT-STATUS-EOF VALUE '10'. 05 REPORT-FILE-STATUS PIC X(2). 88 REPORT-STATUS-OK VALUE '00'. 05 WS-INPUT-OPEN-SW PIC X(1) VALUE SPACE. 88 INPUT-OPEN VALUE 'Y'. 05 WS-REPORT-OPEN-SW PIC X(1) VALUE SPACE. 88 REPORT-OPEN VALUE 'Y'. 05 WS-AD-ERA PIC X(6) VALUE 'A.D. '. 05 WS-BC-ERA PIC X(6) VALUE 'B.C. '. 05 WS-MONTH-TABLE. 10 FILLER PIC X(14) VALUE '0131 JANUARY'. 10 FILLER PIC X(14) VALUE '0228 FEBRUARY'. 10 FILLER PIC X(14) VALUE '0331 MARCH'. 10 FILLER PIC X(14) VALUE '0430 APRIL'. 10 FILLER PIC X(14) VALUE '0531 MAY'. 10 FILLER PIC X(14) VALUE '0630 JUNE'. 10 FILLER PIC X(14) VALUE '0731 JULY'. 10 FILLER PIC X(14) VALUE '0831 AUGUST'. 10 FILLER PIC X(14) VALUE '0930 SEPTEMBER'. 10 FILLER PIC X(14) VALUE '1031 OCTOBER'. 10 FILLER PIC X(14) VALUE '1130 NOVEMBER'. 10 FILLER PIC X(14) VALUE '1231 DECEMBER'. 05 WS-MONTH-TAB REDEFINES WS-MONTH-TABLE OCCURS 12 INDEXED BY MON-IDX. 10 WS-TAB-MON PIC 9(2). 10 WS-TAB-DAY PIC 9(2). 10 FILLER PIC X(1). 10 WS-TAB-MONTH PIC X(9). 05 FILLER REDEFINES WS-MONTH-TABLE. 10 FILLER PIC X(14). 10 WS-FEB PIC X(4). 05 WS-DATE. 10 WS-MONTH PIC 9(2). 10 WS-DAY PIC 9(2). 10 WS-YEAR PIC 9(6). 05 FEB PIC S9(1) COMP-3. 05 LEAP PIC S9(5) COMP-3. 05 LEAPS4 PIC S9(5) COMP-3. 05 LEAPS100 PIC S9(5) COMP-3. 05 LEAPS400 PIC S9(5) COMP-3. 05 ABSDAYS PIC S9(7) COMP-3. 05 JULDATE. 10 JULYEAR PIC 9(4). 10 JULDAYS PIC 9(3). 05 WEEKDAY PIC S9(5) COMP-3. 01 MONTH-LINE. 05 FILLER PIC X(1) VALUE '1'. 05 FILLER PIC X(59) VALUE SPACES. 05 TITLE-MONTH PIC X(9). 05 FILLER PIC X(1) VALUE SPACE. 05 TITLE-YEAR PIC Z(4). 05 FILLER PIC X(1) VALUE SPACE. 05 TITLE-ERA PIC X(6). 05 FILLER PIC X(52) VALUE SPACES. 01 DASH-TOP-LINE. 05 FILLER PIC X(1) VALUE '0'. 05 FILLER PIC X(6) VALUE SPACES. 05 FILLER PIC X(120) VALUE ALL '_'. 05 FILLER PIC X(6) VALUE SPACES. 01 DASH-BOTTOM-LINE. 05 FILLER PIC X(1) VALUE SPACE. 05 FILLER PIC X(6) VALUE SPACES. 05 FILLER PIC X(120) VALUE ALL '_'. 05 FILLER PIC X(6) VALUE SPACES. 01 HEADING-LINE. 05 FILLER PIC X(1) VALUE SPACE. 05 FILLER PIC X(6) VALUE SPACES. 05 FILLER PIC X(1) VALUE ALL '|'. 05 FILLER PIC X(17) VALUE ' SUNDAY |'. 05 FILLER PIC X(17) VALUE ' MONDAY |'. 05 FILLER PIC X(17) VALUE ' TUESDAY |'. 05 FILLER PIC X(17) VALUE ' WEDNESDAY |'. 05 FILLER PIC X(17) VALUE ' THURSDAY |'. 05 FILLER PIC X(17) VALUE ' FRIDAY |'. 05 FILLER PIC X(17) VALUE ' SATURDAY |'. 05 FILLER PIC X(6) VALUE SPACES. 01 MIDDLE-LINE. 05 FILLER PIC X(1) VALUE SPACE. 05 FILLER PIC X(6) VALUE SPACES. 05 FILLER PIC X(1) VALUE ALL '|'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(17) VALUE ' |'. 05 FILLER PIC X(6) VALUE SPACES. 01 GREGORIAN-LINE. 05 FILLER PIC X(1) VALUE SPACE. 05 FILLER PIC X(7) VALUE SPACES. 05 FILLER OCCURS 7 TIMES. 10 FILLER PIC X(7). 10 DET-GREG-DAY PIC Z(2). 10 FILLER PIC X(8). 05 FILLER PIC X(6) VALUE SPACES. 01 JULIAN-LINE. 05 FILLER PIC X(1) VALUE SPACE. 05 FILLER PIC X(7) VALUE SPACES. 05 FILLER OCCURS 7 TIMES. 10 FILLER PIC X(6). 10 DET-JULIAN-DAY PIC 9(3). 10 FILLER PIC X(8). 05 FILLER PIC X(6) VALUE SPACES. EJECT LINKAGE SECTION. 01 PARM-FIELD. 05 PARM-LENGTH PIC S9(4) COMP. 05 PARM-ERA-IND PIC X(1). 88 JEWISH-ERAS VALUE 'J'. EJECT PROCEDURE DIVISION USING PARM-FIELD. 0000-BEGIN. IF PARM-LENGTH NOT = ZERO IF JEWISH-ERAS MOVE 'C.E. ' TO WS-AD-ERA MOVE 'B.C.E.' TO WS-BC-ERA END-IF END-IF PERFORM 0100-OPEN-FILES PERFORM UNTIL NOT INPUT-STATUS-OK READ INPUT-FILE IF INPUT-STATUS-OK MOVE INPUT-YEAR TO TITLE-YEAR WS-YEAR MOVE 01 TO WS-MONTH MOVE 01 TO WS-DAY EVALUATE TRUE WHEN INPUT-YEAR-BC MOVE WS-BC-ERA TO TITLE-ERA WHEN INPUT-YEAR < 1000 MOVE WS-AD-ERA TO TITLE-ERA WHEN OTHER MOVE SPACES TO TITLE-ERA END-EVALUATE PERFORM 6000-CONVERT-TO-JULIAN IF LEAP = 1 MOVE '0229' TO WS-FEB ELSE MOVE '0228' TO WS-FEB END-IF PERFORM 1000-YEAR-LOOP PERFORM 10 TIMES DISPLAY SPACE END-PERFORM END-IF END-PERFORM PERFORM 0200-CLOSE-FILES GOBACK. EJECT 0100-OPEN-FILES. **************************************************************** *** OPEN THE FILES **************************************************************** OPEN INPUT INPUT-FILE IF INPUT-STATUS-OK SET INPUT-OPEN TO TRUE ELSE DISPLAY '**************************************' DISPLAY '*** OPEN ERROR - INPUT FILE' DISPLAY '*** FILE STATUS = ' INPUT-FILE-STATUS DISPLAY '**************************************' MOVE +16 TO ABEND-CODE PERFORM 0200-CLOSE-FILES END-IF OPEN OUTPUT REPORT-FILE IF REPORT-STATUS-OK SET REPORT-OPEN TO TRUE ELSE DISPLAY '**************************************' DISPLAY '*** OPEN ERROR - REPORT FILE' DISPLAY '*** FILE STATUS = ' REPORT-FILE-STATUS DISPLAY '**************************************' MOVE +16 TO ABEND-CODE PERFORM 0200-CLOSE-FILES END-IF. EJECT 0200-CLOSE-FILES. **************************************************************** *** CLOSE THE FILES **************************************************************** IF INPUT-OPEN CLOSE INPUT-FILE IF NOT INPUT-STATUS-OK DISPLAY '**************************************' DISPLAY '*** CLOSE ERROR - INPUT FILE' DISPLAY '*** FILE STATUS = ' INPUT-FILE-STATUS DISPLAY '**************************************' MOVE +16 TO ABEND-CODE END-IF END-IF IF REPORT-OPEN CLOSE REPORT-FILE IF NOT REPORT-STATUS-OK DISPLAY '**************************************' DISPLAY '*** CLOSE ERROR - REPORT FILE' DISPLAY '*** FILE STATUS = ' REPORT-FILE-STATUS DISPLAY '**************************************' MOVE +16 TO ABEND-CODE END-IF END-IF IF ABEND-CODE NOT = ZERO CALL 'ILBOABN0' USING ABEND-CODE END-IF. EJECT 1000-YEAR-LOOP. **************************************************************** *** LOOP THRU THE MONTH TABLE **************************************************************** PERFORM VARYING MON-IDX FROM +1 BY +1 UNTIL MON-IDX > +12 DISPLAY SPACE MOVE WS-TAB-MONTH (MON-IDX) TO TITLE-MONTH MOVE MONTH-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE DASH-TOP-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE HEADING-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE DASH-BOTTOM-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE MIDDLE-LINE TO GREGORIAN-LINE JULIAN-LINE MOVE WS-TAB-MON (MON-IDX) TO WS-MONTH PERFORM VARYING WS-DAY FROM +1 BY +1 UNTIL WS-DAY > WS-TAB-DAY (MON-IDX) MOVE INPUT-YEAR TO WS-YEAR PERFORM 4000-FIND-DAY-OF-WEEK MOVE WEEKDAY TO SUB MOVE WS-DAY TO DET-GREG-DAY (SUB) MOVE JULDAYS TO DET-JULIAN-DAY (SUB) IF SUB = +7 PERFORM 8000-PRINT-LINE END-IF END-PERFORM IF SUB NOT = +7 PERFORM 8000-PRINT-LINE END-IF END-PERFORM. EJECT 4000-FIND-DAY-OF-WEEK. **************************************************************** *** FIND THE DAY OF THE WEEK *** *** DEC 31, 1 B.C. FELL ON A SUNDAY. **************************************************************** PERFORM 5000-COMPUTE-ABSOLUTE-DAYS DIVIDE ABSDAYS BY +7 GIVING ABSDAYS REMAINDER WEEKDAY IF INPUT-YEAR-BC COMPUTE WEEKDAY = 8 - WEEKDAY ELSE ADD +1 TO WEEKDAY END-IF DIVIDE WEEKDAY BY +8 GIVING ABSDAYS REMAINDER WEEKDAY COMPUTE WEEKDAY = WEEKDAY + ABSDAYS. EJECT 5000-COMPUTE-ABSOLUTE-DAYS. **************************************************************** *** COMPUTE THE NUMBER OF DAYS AWAY FROM DEC 31, 1 B.C. *** *** THE NUMBER OF DAYS IN THE YEAR Y B.C. IS THE SAME AS FOR *** (399 + Y) A.D. THEREFORE, THE TOTAL DAYS IN THE PERIODS *** 1 B.C. - Y B.C., AND 400 A.D. - (399 + Y) A.D. ARE EQUAL. *** THIS EQUALS THE TOTAL DAYS IN 1 A.D. - (399 + Y) A.D. *** MINUS 145731 DAYS FOR YEARS 1 A.D. - 399 A.D. **************************************************************** PERFORM 6000-CONVERT-TO-JULIAN IF INPUT-YEAR-BC COMPUTE LEAPS4 = WS-YEAR / 4 COMPUTE LEAPS100 = WS-YEAR / 100 COMPUTE LEAPS400 = WS-YEAR / 400 COMPUTE ABSDAYS = 365 * WS-YEAR - JULDAYS - 145731 + LEAPS4 - LEAPS100 + LEAPS400 ELSE COMPUTE ABSDAYS = 365 * (WS-YEAR - 1) + JULDAYS + LEAPS4 - LEAPS100 + LEAPS400 END-IF. EJECT 6000-CONVERT-TO-JULIAN. **************************************************************** *** CONVERT CCYYMMDD TO CCYYDDD *** *** TOT DAYS 30 * IF M > 2 *** MONTH BEFORE (M - 1) DIFF DIFF + 2 5 * M / 9 *** ----- -------- ------- ---- --------- --------- *** 1 0 0 0 0 0 *** 2 31 30 1 1 1 *** 3 59 60 -1 1 1 *** 4 90 90 0 2 2 *** 5 120 120 0 2 2 *** 6 151 150 1 3 3 *** 7 181 180 1 3 3 *** 8 212 210 2 4 4 *** 9 243 240 3 5 5 *** 10 273 270 3 5 5 *** 11 304 300 4 6 6 *** 12 334 330 4 6 6 *** *** FEB = (M + 10) / 13 = 0, FOR M < 3 *** = 1, FOR M NOT < 3 *** *** LEAP = 0, FOR NOT LEAP YEAR *** = 1, FOR LEAP YEAR *** *** TOTAL DAYS BEFORE MONTH M = *** 30 * (M - 1) + 5 * M / 9 - FEB * (2 - LEAP) *** **************************************************************** MOVE WS-YEAR TO JULYEAR IF INPUT-YEAR-BC ADD +399 TO WS-YEAR END-IF COMPUTE FEB = (WS-MONTH + 10) / 13 COMPUTE LEAPS4 = WS-YEAR / 4 COMPUTE LEAPS100 = WS-YEAR / 100 COMPUTE LEAPS400 = WS-YEAR / 400 COMPUTE LEAP = LEAPS4 - LEAPS100 + LEAPS400 COMPUTE LEAPS4 = (WS-YEAR - 1) / 4 COMPUTE LEAPS100 = (WS-YEAR - 1) / 100 COMPUTE LEAPS400 = (WS-YEAR - 1) / 400 COMPUTE LEAP = LEAP - (LEAPS4 - LEAPS100 + LEAPS400) COMPUTE JULDAYS = WS-DAY - 30 + (275 * WS-MONTH) / 9 - FEB * (2 - LEAP). EJECT 8000-PRINT-LINE. **************************************************************** *** PRINT A CALENDAR LINE **************************************************************** MOVE MIDDLE-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE GREGORIAN-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE JULIAN-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE MIDDLE-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE DASH-BOTTOM-LINE TO REPORT-REC PERFORM 9800-WRITE-REPORT MOVE MIDDLE-LINE TO GREGORIAN-LINE JULIAN-LINE. EJECT 9800-WRITE-REPORT. **************************************************************** *** WRITE THE REPORT FILE REC **************************************************************** WRITE REPORT-REC IF NOT REPORT-STATUS-OK DISPLAY '**************************************' DISPLAY '*** WRITE ERROR - REPORT FILE' DISPLAY '*** FILE STATUS = ' REPORT-FILE-STATUS DISPLAY '**************************************' MOVE +16 TO ABEND-CODE PERFORM 0200-CLOSE-FILES END-IF. *** Bottom of Data ***

Copyright © 2003 The Stevens Computing Services Company, Inc.  All rights reserved.