Could someone please post the Gregorian/Julian date conversion pgm's

[A Bend]

TIA

[Boyce G. Williams, Jr.]

re...@end.com (A Bend) wrote:

>TIA

Here's something I've whiped up some time ago:

000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. CBL0071.
000300 INSTALLATION. VIRGINIA COMMONWEALTH UNIVERSITY.
000400 AUTHOR. BOYCE G WILLIAMS, JR.
000500 DATE-WRITTEN. 06/21/96.
000600 DATE-COMPILED.
000700*
000800* COMPUTE JULIAN AND DAYS DIFFERENCE VIA:
000900*
001000* IBM'S INTRINSIC FUNCTIONS
001100* (GOOD FOR COBOL/390 )
001200* WELBURN
001300* (ADVANCED STRUCTURED COBOL,ISBN 0-87484-558-0)
001400* BROWN
001500* (ADVANCED ANSI COBOL ..., ISBN 0-471-54786-7 )
001600*
001700* EXAMPLE OF EXPECTED RESULTS:
001800*
001900* TODAY'S DATE: 19960621
002000* TODAY'S JULIAN DATE: 96173
002100* FROM INTRINSIC FUNCTIONS: 1996173
002200* FROM WELBURN ROUTINE: 1996173
002300* FROM BROWN ROUTINE: 1996173
002400*
002500* SAMPLE FIRST DATE: 19950415
002600* NBR DAYS BETWEEN CURRENT AND FIRST DATES INCLUSIVE
002700* VIA INTRINSIC: 0000434
002800* VIA WELBURN ROUTINE: 434
002900* VIA BROWN ROUTINE: 434
003000*
003100* COMPUTER DAY OF WEEK: FRIDAY
003200* WELBURN DAY OF WEEK: FRIDAY
003300*
003400*
003500*
003600 ENVIRONMENT DIVISION.
003700*
003800*
003900 CONFIGURATION SECTION.
004000*
004100 SOURCE-COMPUTER. IBM-370.
004200 OBJECT-COMPUTER. IBM-370.
004300*
004400*
004500*
004600 DATA DIVISION.
004700*
004800*
004900 WORKING-STORAGE SECTION.
005000*
005100*
005200 01 WS-COMPILED-INFO.
005300 05 WS-PGM-NAME PIC X(09) VALUE 'CBL0071 '.
005400 05 FILLER PIC X(20) VALUE ' LAST COMPILED'.
005500 05 WS-WHEN-COMPILED PIC X(20) VALUE SPACES.
005600*
005700*
005800 01 WS-WORK-AREAS.
005900 05 WS-FIRST-DATE-A.
006000 10 WS-FIRST-DATE PIC 9(08)
006100 VALUE 19950415.
006200 05 WS-NBR-DAYS PIC Z(06).
006300*
006400*
006500 01 SYST-SYSTEM-DERIVED-CONTROL.
006600 05 SYST-JULI-DATE.
006700 10 SYST-JULI-DATE-YY PIC X(02).
006800 10 SYST-JULI-DATE-DDD PIC X(03).
006900 05 SYST-CURR-DATE.
007000 10 SYST-CURR-DATE-A.
007100 15 SYST-CURR-DATE-N PIC 9(08).
007200 10 FILLER PIC X(13).
007300 05 SYST-DAY PIC 9(01).
007400 05 SYST-DAY-DATA.
007500 10 FILLER PIC X(10) VALUE '1MONDAY '.
007600 10 FILLER PIC X(10) VALUE '2TUESDAY '.
007700 10 FILLER PIC X(10) VALUE '3WEDNESDAY'.
007800 10 FILLER PIC X(10) VALUE '4THURSDAY '.
007900 10 FILLER PIC X(10) VALUE '5FRIDAY '.
008000 10 FILLER PIC X(10) VALUE '6SATURDAY '.
008100 10 FILLER PIC X(10) VALUE '7SUNDAY '.
008200 05 FILLER REDEFINES SYST-DAY-DATA
008300 OCCURS 7 TIMES.
008400 10 SYST-DAY-N PIC 9(01).
008500 10 SYST-DAY-ENTRY PIC X(09).
008600*
008700*
008800 01 INTR-INTRINSIC-CONTROLS.
008900 05 INTR-GREG-DATE PIC 9(08).
009000 05 INTR-FIRST-DATE PIC 9(08).
009100 05 INTR-JULI-DATE PIC 9(07).
009200 05 INTR-LAST-DATE PIC 9(07).
009300 05 INTRS-FIRST-DATE PIC 9(07).
009400 05 INTR-NBR-DAYS PIC 9(07).
009500*
009600*
009700 01 BRN01-BROWN-NBR-DAYS-CONTROL.
009800 05 BRN01-FIRST-DATE.
009900 10 BRN01-FD-CCYY PIC 9(04).
010000 10 BRN01-FD-MM PIC 9(02).
010100 10 BRN01-FD-DD PIC 9(02).
010200 05 BRN01-LAST-DATE.
010300 10 BRN01-LD-CCYY PIC 9(04).
010400 10 BRN01-LD-MM PIC 9(02).
010500 10 BRN01-LD-DD PIC 9(02).
010600 05 BRN01-NBR-DAYS PIC S9(09) BINARY.
010700 05 BRN01-FIRST-YRNDAY.
010800 10 BRN01-FIRST-CCYY PIC 9(04).
010900 10 BRN01-FIRST-DDD PIC S9(04) BINARY.
011000 05 BRN01-LAST-YRNDAY.
011100 10 BRN01-LAST-CCYY PIC 9(04).
011200 10 BRN01-LAST-DDD PIC S9(04) BINARY.
011300 05 BRN01-HOLD-CCYY PIC 9(04).
011400 05 BRN01-DAYS-IN-YEAR PIC S9(04) BINARY.
011500 05 BRN01-LEAP-YEAR PIC S9(04) BINARY.
011600*
011700*
011800 01 BRN02-BROWN-JULIAN-DATE-CNTL.
011900 05 BRN02-CURRENT-DATE.
012000 10 BRN02-CD-CCYY PIC 9(04).
012100 10 BRN02-CD-MM PIC 99.
012200 10 BRN02-CD-DD PIC 99.
012300 05 BRN02-YRNDAY-DATE.
012400 10 BRN02-YRNDAY-CCYY PIC 9(04).
012500 10 BRN02-YRNDAY-DDD PIC 999.
012600 05 BRN02-DAYS-IN-YEAR PIC S9(04) BINARY.
012700 05 BRN02-LEAP-YEAR PIC S9(04) BINARY.
012800 05 BRN02-MONTH-DATA.
012900 10 FILLER PIC S9(04) BINARY VALUE 31.
013000 10 FILLER PIC S9(04) BINARY VALUE 28.
013100 10 FILLER PIC S9(04) BINARY VALUE 31.
013200 10 FILLER PIC S9(04) BINARY VALUE 30.
013300 10 FILLER PIC S9(04) BINARY VALUE 31.
013400 10 FILLER PIC S9(04) BINARY VALUE 30.
013500 10 FILLER PIC S9(04) BINARY VALUE 31.
013600 10 FILLER PIC S9(04) BINARY VALUE 31.
013700 10 FILLER PIC S9(04) BINARY VALUE 30.
013800 10 FILLER PIC S9(04) BINARY VALUE 31.
013900 10 FILLER PIC S9(04) BINARY VALUE 30.
014000 10 FILLER PIC S9(04) BINARY VALUE 31.
014100 05 FILLER REDEFINES BRN02-MONTH-DATA.
014200 10 BRN02-MONTH-ENTRY OCCURS 12 TIMES
014300 INDEXED BY BRN02-MX.
014400 15 BRN02-MONTH-DAYS PIC S9(04) BINARY.
014500*
014600*
014700 01 BRN03-BROWN-LEAP-YEAR-CONTROL.
014800 05 BRN03-TEMP-NUM PIC S9(04) BINARY.
014900 05 BRN03-THE-YEAR PIC 9(04).
015000 05 BRN03-DAYS-IN-YEAR PIC S9(04) BINARY.
015100 05 BRN03-LEAP-YEAR PIC S9(04) BINARY.
015200*
015300*
015400 01 WEL01-WELBURN-NBR-DAYS-CONTROL.
015500 05 WEL01-FIRST-DATE.
015600 10 WEL01-FD-CCYY PIC 9(04).
015700 10 WEL01-FD-MM PIC 9(02).
015800 10 WEL01-FD-DD PIC 9(02).
015900 05 WEL01-LAST-DATE.
016000 10 WEL01-LD-CCYY PIC 9(04).
016100 10 WEL01-LD-MM PIC 9(02).
016200 10 WEL01-LD-DD PIC 9(02).
016300 05 WEL01-NBR-DAYS PIC S9(06).
016400 05 WEL01-FIRST-YRNDAY.
016500 10 WEL01-FIRST-CCYY PIC 9(04).
016600 10 WEL01-FIRST-DDD PIC 9(03).
016700 05 WEL01-LAST-YRNDAY.
016800 10 WEL01-LAST-CCYY PIC 9(04).
016900 10 WEL01-LAST-DDD PIC 9(03).
017000 05 WEL01-YEAR-SPAN PIC S9(04).
017100 05 WEL01-YEARS-LEFT PIC S9(04).
017200 05 WEL01-QUOTENT PIC S9(04).
017300 05 WEL01-REMAINDER PIC S9(04).
017400*
017500*
017600 01 WEL02-WELBURN-JULIAN-DATE-CNTL.
017700 05 WEL02-GREG-DATE.
017800 10 WEL02-GREG-CCYY PIC 9(04).
017900 10 WEL02-GREG-MM PIC 9(02).
018000 10 WEL02-GREG-DD PIC 9(02).
018100 05 WEL02-JULI-DATE.
018200 10 WEL02-JULI-CCYY PIC 9(04).
018300 10 WEL02-JULI-DDD PIC 9(03).
018400 05 WEL02-QUOTENT PIC 9(04).
018500 05 WEL02-REMAINDER PIC 9(04).
018600 05 WEL02-LEAP-YEAR-SWITCH PIC X(01) VALUE 'N'.
018700 88 WEL02-LEAP-YEAR VALUE 'Y'.
018800 05 WEL02-MONTH-DATA.
018900 10 FILLER PIC X(14) VALUE 'JANUARY 01000'.
019000 10 FILLER PIC X(14) VALUE 'FEBURARY 02031'.
019100 10 FILLER PIC X(14) VALUE 'MARCH 03059'.
019200 10 FILLER PIC X(14) VALUE 'APRIL 04090'.
019300 10 FILLER PIC X(14) VALUE 'MAY 05120'.
019400 10 FILLER PIC X(14) VALUE 'JUNE 06151'.
019500 10 FILLER PIC X(14) VALUE 'JULY 07181'.
019600 10 FILLER PIC X(14) VALUE 'AUGUST 08212'.
019700 10 FILLER PIC X(14) VALUE 'SEPTEMBER09243'.
019800 10 FILLER PIC X(14) VALUE 'OCTOBER 10273'.
019900 10 FILLER PIC X(14) VALUE 'NOVEMBER 11304'.
020000 10 FILLER PIC X(14) VALUE 'DECEMBER 12334'.
020100 05 FILLER REDEFINES WEL02-MONTH-DATA.
020200 10 WEL02-MONTH-ENTRY OCCURS 12 TIMES.
020300 15 WEL02-MONTH-NAME PIC X(09).
020400 15 WEL02-MONTH-NBR PIC 9(02).
020500 15 WEL02-DAYS-BEFORE PIC 9(03).
020600*
020700*
020800 01 WEL03-WELBURN-DAY-OF-WEEK-CNTL.
020900 05 WEL03-DATE.
021000 10 WEL03-DATE-CC PIC 9(02).
021100 10 WEL03-DATE-YY PIC 9(02).
021200 10 WEL03-DATE-DDD PIC 9(03).
021300 05 WEL03-DAY-WORK PIC 9(04).
021400 05 WEL03-DAY-VALUE PIC 9(01).
021500 05 WEL03-QUOTENT PIC 9(04).
021600 05 WEL03-CC-COEFFICIENT-DATA.
021700 10 FILLER PIC X(03) VALUE '000'.
021800 10 FILLER PIC X(03) VALUE '011'.
021900 10 FILLER PIC X(03) VALUE '022'.
022000 10 FILLER PIC X(03) VALUE '033'.
022100 10 FILLER PIC X(03) VALUE '044'.
022200 10 FILLER PIC X(03) VALUE '055'.
022300 10 FILLER PIC X(03) VALUE '066'.
022400 10 FILLER PIC X(03) VALUE '077'.
022500 10 FILLER PIC X(03) VALUE '088'.
022600 10 FILLER PIC X(03) VALUE '099'.
022700 10 FILLER PIC X(03) VALUE '108'.
022800 10 FILLER PIC X(03) VALUE '117'.
022900 10 FILLER PIC X(03) VALUE '126'.
023000 10 FILLER PIC X(03) VALUE '135'.
023100 10 FILLER PIC X(03) VALUE '144'.
023200 10 FILLER PIC X(03) VALUE '153'.
023300 10 FILLER PIC X(03) VALUE '166'.
023400 10 FILLER PIC X(03) VALUE '174'.
023500 10 FILLER PIC X(03) VALUE '182'.
023600 10 FILLER PIC X(03) VALUE '190'.
023700 10 FILLER PIC X(03) VALUE '206'.
023800 10 FILLER PIC X(03) VALUE '214'.
023900 10 FILLER PIC X(03) VALUE '222'.
024000 10 FILLER PIC X(03) VALUE '230'.
024100 05 FILLER REDEFINES WEL03-CC-COEFFICIENT-DATA.
024200 10 WEL03-CC-COEFFICIENT-ENTRY OCCURS 24 TIMES.
024300 15 WEL03-CC PIC X(02).
024400 15 WEL03-CC-COEFFICIENT PIC 9(01).
024500 05 WEL03-DAY-CODE-DATA.
024600 10 FILLER PIC X(10) VALUE '0SATURDAY '.
024700 10 FILLER PIC X(10) VALUE '1SUNDAY '.
024800 10 FILLER PIC X(10) VALUE '2MONDAY '.
024900 10 FILLER PIC X(10) VALUE '3TUESDAY '.
025000 10 FILLER PIC X(10) VALUE '4WEDNESDAY'.
025100 10 FILLER PIC X(10) VALUE '5THURSDAY '.
025200 10 FILLER PIC X(10) VALUE '6FRIDAY '.
025300 05 FILLER REDEFINES WEL03-DAY-CODE-DATA.
025400 10 WEL03-DAY-CODE-ENTRY OCCURS 7 TIMES.
025500 15 WEL03-DAY-CODE-N PIC 9(01).
025600 15 WEL03-DAY-NAME PIC X(09).
025700*
025800*
025900*
026000 PROCEDURE DIVISION.
026100*
026200*
026300 000-START-PROGRAM-CBL0071.
026400*
026500 MOVE WHEN-COMPILED TO WS-WHEN-COMPILED
026600 DISPLAY WS-COMPILED-INFO
026700*
026800 DISPLAY ' '
026900 MOVE FUNCTION CURRENT-DATE TO SYST-CURR-DATE
027000 DISPLAY 'TODAY''S DATE: ' SYST-CURR-DATE-N
027100*
027200 ACCEPT SYST-JULI-DATE FROM DAY
027300 DISPLAY 'TODAY''S JULIAN DATE: ' SYST-JULI-DATE
027400*
027500 MOVE SYST-CURR-DATE-N TO INTR-GREG-DATE
027600 PERFORM 200-CAL-INTRINSIC-JULIAN-DATE
027700 DISPLAY ' FROM INTRINSIC FUNCTIONS: ' INTR-JULI-DATE
027800*
027900 MOVE SYST-CURR-DATE-A TO WEL02-GREG-DATE
028000 PERFORM 220-CAL-WELBURN-JULIAN-DATE
028100 DISPLAY ' FROM WELBURN ROUTINE: ' WEL02-JULI-DATE
028200*
028300 MOVE SYST-CURR-DATE-A TO BRN02-CURRENT-DATE
028400 PERFORM 250-CAL-BROWN-JULIAN-DATE
028500 DISPLAY ' FROM BROWN ROUTINE: ' BRN02-YRNDAY-DATE
028600*
028700 DISPLAY ' '
028800 DISPLAY 'SAMPLE FIRST DATE: ' WS-FIRST-DATE
028900 DISPLAY 'NBR DAYS BETWEEN CURRENT AND FIRST DATES
INCLUSIVE'
029000*
029100 MOVE SYST-CURR-DATE-N TO INTR-GREG-DATE
029200 MOVE WS-FIRST-DATE TO INTR-FIRST-DATE
029300 PERFORM 230-CAL-INTRINSIC-NBR-DAYS
029400 DISPLAY ' VIA INTRINSIC: ' INTR-NBR-DAYS
029500*
029600 MOVE SYST-CURR-DATE-A TO WEL01-LAST-DATE
029700 MOVE WS-FIRST-DATE-A TO WEL01-FIRST-DATE
029800 PERFORM 210-CAL-WELBURN-NBR-DAYS
029900 MOVE WEL01-NBR-DAYS TO WS-NBR-DAYS
030000 DISPLAY ' VIA WELBURN ROUTINE: ' WS-NBR-DAYS
030100*
030200 MOVE SYST-CURR-DATE-A TO BRN01-LAST-DATE
030300 MOVE WS-FIRST-DATE-A TO BRN01-FIRST-DATE
030400 PERFORM 240-CAL-BROWN-NBR-DAYS
030500 MOVE BRN01-NBR-DAYS TO WS-NBR-DAYS
030600 DISPLAY ' VIA BROWN ROUTINE: ' WS-NBR-DAYS
030700*
030800 DISPLAY ' '
030900 ACCEPT SYST-DAY FROM DAY-OF-WEEK
031000 DISPLAY 'COMPUTER DAY OF WEEK: '
031100 SYST-DAY-ENTRY (SYST-DAY )
031200*
031300 MOVE INTR-JULI-DATE TO WEL03-DATE
031400 PERFORM 270-CAL-WELBURN-DAY-OF-WEEK
031500 DISPLAY 'WELBURN DAY OF WEEK: '
031600 WEL03-DAY-NAME (WEL03-DAY-VALUE + 1 )
031700 STOP RUN
031800 .
031900*
032000*
032100 200-CAL-INTRINSIC-JULIAN-DATE.
032200*
032300 COMPUTE INTR-JULI-DATE
032400 = FUNCTION DAY-OF-INTEGER
032500 (FUNCTION INTEGER-OF-DATE (INTR-GREG-DATE ) )
032600 .
032700*
032800*
032900 210-CAL-WELBURN-NBR-DAYS.
033000*
033100 MOVE ZEROS TO WEL01-YEAR-SPAN
033200 MOVE ZEROS TO WEL01-NBR-DAYS
033300 MOVE ZEROS TO WEL01-QUOTENT
033400 MOVE ZEROS TO WEL01-REMAINDER
033500*
033600 MOVE WEL01-FIRST-DATE TO WEL02-GREG-DATE
033700 PERFORM 220-CAL-WELBURN-JULIAN-DATE
033800 MOVE WEL02-JULI-DATE TO WEL01-FIRST-YRNDAY
033900*
034000 MOVE WEL01-LAST-DATE TO WEL02-GREG-DATE
034100 PERFORM 220-CAL-WELBURN-JULIAN-DATE
034200 MOVE WEL02-JULI-DATE TO WEL01-LAST-YRNDAY
034300*
034400 SUBTRACT WEL01-FIRST-CCYY
034500 FROM WEL01-LAST-CCYY
034600 GIVING WEL01-YEAR-SPAN
034700 COMPUTE WEL01-NBR-DAYS
034800 = WEL01-LAST-DDD - WEL01-FIRST-DDD + 1
034900 IF WEL01-YEAR-SPAN IS NOT EQUAL TO ZEROS
035000 THEN
035100 COMPUTE WEL01-NBR-DAYS
035200 = WEL01-NBR-DAYS + (WEL01-YEAR-SPAN * 365 )
035300 DIVIDE WEL01-YEAR-SPAN BY 4
035400 GIVING WEL01-QUOTENT
035500 REMAINDER WEL01-REMAINDER
035600 ADD WEL01-QUOTENT TO WEL01-NBR-DAYS
035700 MOVE WEL01-REMAINDER TO WEL01-YEARS-LEFT
035800 DIVIDE WEL01-FIRST-CCYY BY 4
035900 GIVING WEL01-QUOTENT
036000 REMAINDER WEL01-REMAINDER
036100 SUBTRACT WEL01-REMAINDER FROM WEL01-YEARS-LEFT
036200 IF WEL01-YEARS-LEFT IS GREATER THAN ZEROS
036300 THEN
036400 ADD 1 TO WEL01-NBR-DAYS
036500 END-IF
036600 END-IF
036700 .
036800*
036900*
037000 220-CAL-WELBURN-JULIAN-DATE.
037100*
037200 MOVE ZEROS TO WEL02-QUOTENT
037300 MOVE ZEROS TO WEL02-REMAINDER
037400 MOVE WEL02-GREG-CCYY TO WEL02-JULI-CCYY
037500 MOVE WEL02-DAYS-BEFORE (WEL02-GREG-MM ) TO WEL02-JULI-DDD
037600 ADD WEL02-GREG-DD TO WEL02-JULI-DDD
037700 DIVIDE WEL02-JULI-CCYY BY 4
037800 GIVING WEL02-QUOTENT
037900 REMAINDER WEL02-REMAINDER
038000 IF WEL02-REMAINDER IS EQUAL TO ZEROS
038100 THEN
038200 SET WEL02-LEAP-YEAR TO TRUE
038300 ELSE
038400 MOVE 'N' TO WEL02-LEAP-YEAR-SWITCH
038500 END-IF
038600 DIVIDE WEL02-JULI-CCYY BY 400
038700 GIVING WEL02-QUOTENT
038800 REMAINDER WEL02-REMAINDER
038900 IF WEL02-LEAP-YEAR
039000 AND WEL02-JULI-CCYY (3:2 ) IS EQUAL TO ZEROS
039100 AND WEL02-REMAINDER IS NOT EQUAL TO ZEROS
039200 THEN
039300 MOVE 'N' TO WEL02-LEAP-YEAR-SWITCH
039400 END-IF
039500 IF WEL02-LEAP-YEAR
039600 AND WEL02-GREG-MM IS GREATER THAN 02
039700 THEN
039800 ADD 1 TO WEL02-JULI-DDD
039900 END-IF
040000 .
040100*
040200*
040300 230-CAL-INTRINSIC-NBR-DAYS.
040400*
040500 COMPUTE INTR-LAST-DATE
040600 = FUNCTION INTEGER-OF-DATE (INTR-GREG-DATE )
040700 COMPUTE INTRS-FIRST-DATE
040800 = FUNCTION INTEGER-OF-DATE (INTR-FIRST-DATE )
040900 COMPUTE INTR-NBR-DAYS
041000 = INTR-LAST-DATE - INTRS-FIRST-DATE + 1
041100 .
041200*
041300*
041400 240-CAL-BROWN-NBR-DAYS.
041500*
041600 MOVE ZEROS TO BRN01-NBR-DAYS
041700 MOVE BRN01-FIRST-DATE TO BRN02-CURRENT-DATE
041800 PERFORM 250-CAL-BROWN-JULIAN-DATE
041900 MOVE BRN02-YRNDAY-CCYY TO BRN01-FIRST-CCYY
042000 MOVE BRN02-YRNDAY-DDD TO BRN01-FIRST-DDD
042100*
042200 MOVE BRN01-LAST-DATE TO BRN02-CURRENT-DATE
042300 PERFORM 250-CAL-BROWN-JULIAN-DATE
042400 MOVE BRN02-YRNDAY-CCYY TO BRN01-LAST-CCYY
042500 MOVE BRN02-YRNDAY-DDD TO BRN01-LAST-DDD
042600*
042700 IF BRN01-LAST-CCYY IS EQUAL TO BRN01-FIRST-CCYY
042800 THEN
042900 COMPUTE BRN01-NBR-DAYS
043000 = BRN01-LAST-DDD - BRN01-FIRST-DDD
043100 ELSE
043200 MOVE BRN01-FIRST-CCYY TO BRN01-HOLD-CCYY
043300 PERFORM UNTIL BRN01-HOLD-CCYY = BRN01-LAST-CCYY
043400 MOVE BRN01-HOLD-CCYY TO BRN03-THE-YEAR
043500 PERFORM 260-CAL-BROWN-LEAP-YEAR
043600 MOVE BRN03-DAYS-IN-YEAR TO BRN01-DAYS-IN-YEAR
043700 MOVE BRN03-LEAP-YEAR TO BRN01-LEAP-YEAR
043800 IF BRN01-HOLD-CCYY IS EQUAL TO BRN01-FIRST-CCYY
043900 THEN
044000 COMPUTE BRN01-NBR-DAYS
044100 = BRN01-DAYS-IN-YEAR + 1 - BRN01-FIRST-DDD
044200 ELSE
044300 COMPUTE BRN01-NBR-DAYS
044400 = BRN01-NBR-DAYS + BRN01-DAYS-IN-YEAR
044500 END-IF
044600 ADD 1 TO BRN01-HOLD-CCYY
044700 END-PERFORM
044800 ADD BRN01-LAST-DDD TO BRN01-NBR-DAYS
044900 END-IF
045000 .
045100*
045200*
045300 250-CAL-BROWN-JULIAN-DATE.
045400*
045500 MOVE ZEROS TO BRN02-YRNDAY-CCYY
045600 MOVE ZEROS TO BRN02-YRNDAY-DDD
045700 MOVE BRN02-CD-CCYY TO BRN03-THE-YEAR
045800 PERFORM 260-CAL-BROWN-LEAP-YEAR
045900 MOVE BRN03-DAYS-IN-YEAR TO BRN02-DAYS-IN-YEAR
046000 MOVE BRN03-LEAP-YEAR TO BRN02-LEAP-YEAR
046100 IF BRN02-LEAP-YEAR IS EQUAL TO ZEROS
046200 THEN
046300 MOVE 29 TO BRN02-MONTH-DAYS (02 )
046400 ELSE
046500 MOVE 28 TO BRN02-MONTH-DAYS (02 )
046600 END-IF
046700 MOVE ZEROS TO BRN02-YRNDAY-DDD
046800 PERFORM VARYING BRN02-MX FROM 1 BY 1
046900 UNTIL BRN02-MX IS EQUAL TO BRN02-CD-MM
047000 ADD BRN02-MONTH-DAYS (BRN02-MX ) TO BRN02-YRNDAY-DDD
047100 END-PERFORM
047200 ADD BRN02-CD-DD TO BRN02-YRNDAY-DDD
047300 MOVE BRN02-CD-CCYY TO BRN02-YRNDAY-CCYY
047400 .
047500*
047600*
047700 260-CAL-BROWN-LEAP-YEAR.
047800*
047900 MOVE ZEROS TO BRN03-DAYS-IN-YEAR
048000 MOVE ZEROS TO BRN03-LEAP-YEAR
048100 MOVE ZEROS TO BRN03-TEMP-NUM
048200 DIVIDE BRN03-THE-YEAR BY 4 GIVING BRN03-TEMP-NUM
048300 REMAINDER BRN03-LEAP-YEAR
048400 IF BRN03-LEAP-YEAR IS EQUAL TO ZEROS
048500 THEN
048600 MOVE 366 TO BRN03-DAYS-IN-YEAR
048700 ELSE
048800 MOVE 365 TO BRN03-DAYS-IN-YEAR
048900 END-IF
049000 .
049100*
049200*
049300 270-CAL-WELBURN-DAY-OF-WEEK.
049400*
049500 MOVE ZEROS TO WEL03-DAY-WORK
049600 MOVE ZEROS TO WEL03-DAY-VALUE
049700 MOVE WEL03-CC-COEFFICIENT (WEL03-DATE-CC + 1 )
049800 TO WEL03-DAY-WORK
049900 ADD WEL03-DATE-YY TO WEL03-DAY-WORK
050000 COMPUTE WEL03-DAY-WORK
050100 = WEL03-DAY-WORK + WEL03-DATE-YY / 4
050200 ADD WEL03-DATE-DDD TO WEL03-DAY-WORK
050300 DIVIDE WEL03-DAY-WORK BY 7
050400 GIVING WEL03-QUOTENT
050500 REMAINDER WEL03-DAY-VALUE
050600 .
050700*
050800* END PROGRAM CBL0071
050900*

Julian to Gregorian date conversions are left as an excersize for the
reader.

Boyce G. Williams, Jr.

.---------------------------------------------------------------------.
| "People should have two virtues: purpose- the courage to envisage |
| and pursue valued goals uninhibited by the defeat of infantile |
| fantasies, by guilt and the failing fear punishment; and wisdom- a |
| detached concern with life itself, in the face of death itself." |
| Norman F. Dixon |
'---------------------------------------------------------------------'