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.