|
midrange.com
Try this, it's based on the famous "Doomsday" algorithm by JH Conway:
100
**************************************************************************
200 ***
300 *** Program Name -- DOWK
400 *** Description -- Calculate Day of Week from Gregorian
500 *** Date
600 *** Author -- Christopher J. Devous
700 ***
800 *** Algorithm --
900 ***
1000 *** The last of February, of January will do
1100 *** (Except that in Leap Years it's Jan 32)
1200 *** Then for even months use the month's own day
1300 *** And for odd ones add four, or take it away*
1400 ***
1500 *** Now to work out your doomsday the orthodox way
1600 *** Three things you should add to the century day
1700 *** Dozens, remainder, and fours in the latter,
1800 *** (If you alter by sevens of course it won't matter)
1900 ***
2000 *** In Julian times, lackaday, lackaday
2100 *** Zero was Sunday, centuries fell back a day
2200 *** But Gregorian four hundreds are always a Tues
2300 *** And now centuries extra will take us back twos.
2400 ***
2500 *** *According to length or simply remember
2600 *** you only subtract for September or November
2700 ***
2800 *** --J.H. Conway
2900 ***
3000
**************************************************************************
3100 *** A R R A Y S P E C I F I C A T I O N S
3200
**************************************************************************
3300 E DAR 7 7 10
3400 E SAR 7 7 10
3500
**************************************************************************
3600 *** D A T A S T R U C T U R E S
3700
**************************************************************************
3800 I DS
3900 I 1 8 RTDATE
4000 I 1 2 RTMM
4100 I 3 4 RTDD
4200 I 5 6 RTCN
4300 I 7 8 RTYN
4400 I 5 8 RTYR
4500
**************************************************************************
4600 *** M A I N L I N E P R O C E S S I N G
4700
**************************************************************************
4800 *
4900 C RESET#C1
5000 C RESET#R1
5100 *
5200 * But Gregorian four hundreds are always a Tues
5300 * And now centuries extra will take us back twos.
5400 *
5500 C #CN DIV 4 #C1
5600 C MVR #R1
5700 C MULT 2 #R1
5800 *
5900 C #R1 IFGT 2
6000 C 10 SUB #R1 #CD
6100 C ELSE
6200 C 3 SUB #R1 #CD
6300 C ENDIF
6400 *
6500 * Now to work out your doomsday the orthodox way
6600 * Three things you should add to the century day
6700 * Dozens, remainder, and fours in the latter,
6800 * (If you alter by sevens of course it won't matter)
6900 *
7000 C #YN DIV 12 #C1
7100 C MVR #R1
7200 C #R1 DIV 4 #DD1
7300 *
7400 C ADD #R1 #DD1
7500 C ADD #C1 #DD1
7600 C ADD #CD #DD1
7700 *
7800 C #DD1 DOWGT7
7900 C SUB 7 #DD1
8000 C ENDDO
8100 *
8200 * The last of February, of January will do
8300 * (Except that in Leap Years it's Jan 32)
8400 * Then for even months use the month's own day
8500 * And for odd ones add four, or take it away*
8600 *
8700 C SELEC
8800 *
8900 C #MM WHEQ 01
9000 C #MM OREQ 02
9100 C EXSR JANFEB
9200 *
9300 * And for odd ones add four, or take it away*
9400 *
9500 C #MM WHEQ 03
9600 C #MM OREQ 05
9700 C #MM OREQ 07
9800 C #MM ADD 4 #MDN
9900 *
10000 * *According to length or simply remember
10100 * you only subtract for September or November
10200 *
10300 C #MM WHEQ 09
10400 C #MM OREQ 11
10500 C #MM SUB 4 #MDN
10600 *
10700 * Then for even months use the month's own day
10800 *
10900 C OTHER
11000 C Z-ADD#MM #MDN
11100 *
11200 C ENDSL
11300 *
11400 C #DD COMP #MDN 999897
11500 *
11600 C SELEC
11700 C *IN99 WHEQ *ON
11800 C #DD SUB #MDN #DIF
11900 *
12000 C *IN98 WHEQ *ON
12100 C #MDN SUB #DD #DIF
12200 *
12300 C *IN97 WHEQ *ON
12400 C Z-ADD*ZERO #DIF
12500 *
12600 C ENDSL
12700 *
12800 C #DIF IFGT 7
12900 C #DIF DIV 7 #C1
13000 C MVR #R1
13100 C Z-ADD#R1 #DIF
13200 C ENDIF
13300 *
13400 C SELEC
13500 C *IN99 WHEQ *ON
13600 C ADD #DIF #DD1
13700 *
13800 C *IN98 WHEQ *ON
13900 C #DIF IFGE #DD1
14000 C ADD 7 #DD1
14100 C ENDIF
14200 C SUB #DIF #DD1
14300 *
14400 C ENDSL
14500 *
14600 C #DD1 DOWGT7
14700 C SUB 7 #DD1
14800 C ENDDO
14900 *
15000 C RTLONG IFEQ 'Y'
15100 C MOVE DAR,#DD1 RTDOW
15200 C ELSE
15300 C MOVE SAR,#DD1 RTDOW
15400 C ENDIF
15500 *
15600 C MOVE *ON *INLR
15700
**************************************************************************
15800 *** S U B R O U T I N E S
15900
**************************************************************************
16000
**************************************************************************
16100 *** I N I T I A L I Z A T I O N
16200
**************************************************************************
16300 CSR *INZSR BEGSR
16400 *
16500 C *ENTRY PLIST
16600 C PARM PDATE 8
16700 C PARM RTLONG 1
16800 C PARM RTDOW 10
16900 *
17000 C MOVE PDATE RTDATE
17100 C MOVE RTMM #MM 20
17200 C MOVE RTDD #DD 20
17300 C MOVE RTCN #CN 20
17400 C MOVE RTYN #YN 20
17500 C MOVE RTYR #YR 40
17600 *
17700 * Variable Declarations
17800 *
17900 C Z-ADD*ZERO #C1 20
18000 C Z-ADD*ZERO #R1 20
18100 C Z-ADD*ZERO #CD 20
18200 C Z-ADD*ZERO #DD1 20
18300 C Z-ADD*ZERO #MDN 20
18400 C Z-ADD*ZERO #DIF 20
18500 C MOVE *OFF #LY 1
18600 *
18700 * Is the year of the date passed a leap year?
18800 * Leap years are years that are evenly divisible by four,
18900 * unless they are evenly divisible by 100.
19000 *
19100 * If a year is evenly divisible by 100, it must be evenly
19200 * divisible by 400 to be a leap year. This is the change
19300 * to the Julian calendar implemented by Pope Gregory XIII.
19400 * Hence, the Gregorian calendar.
19500 *
19600 C #YR DIV 100 #C1
19700 C MVR #R1
19800 *
19900 C #R1 IFEQ 0
20000 C #YR DIV 400 #C1
20100 C MVR #R1
20200 C #R1 IFEQ 0
20300 C MOVE *ON #LY
20400 C ENDIF
20500 C ELSE
20600 C #YR DIV 4 #C1
20700 C MVR #R1
20800 C #R1 IFEQ *ZERO
20900 C MOVE *ON #LY
21000 C ENDIF
21100 C ENDIF
21200 *
21300 CSR ENDSR
21400
**************************************************************************
21500 *** J A N F E B -- January or February
21600
**************************************************************************
21700 *
21800 * The last of February, of January will do
21900 * (Except that in Leap Years it's Jan 32)
22000 *
22100 CSR JANFEB BEGSR
22200 *
22300 C SELEC
22400 *
22500 C #MM WHEQ 01
22600 C #LY ANDEQ*ON
22700 C SUB 1 #DD1
22800 C Z-ADD31 #MDN
22900 *
23000 C #MM WHEQ 01
23100 C #LY ANDEQ*OFF
23200 C Z-ADD31 #MDN
23300 *
23400 C #MM WHEQ 02
23500 C #LY ANDEQ*ON
23600 C Z-ADD29 #MDN
23700 *
23800 C #MM WHEQ 02
23900 C #LY ANDEQ*OFF
24000 C Z-ADD28 #MDN
24100 *
24200 C ENDSL
24300 *
24400 CSR ENDSR
24500
**************************************************************************
24600 *** E N D O F S O U R C E
24700
**************************************************************************
24800 ** DAR Long Day Names
24900 Sunday Monday Tuesday Wednesday Thursday Friday Saturday
25000 ** SAR Short Day Names
25100 Sun Mon Tue Wed Thu Fri Sat
* * * * E N D O F S O U R C E * * * *
On Tuesday, May 15, 2001 13:44, Jade Richtsmeier
[SMTP:jade.richtsmeier@mcis.cog.mn.us] wrote:
> One our projects here prints a letter and we need to be able to print the
> day of the week of a given date. I know that the system value QDAYOFWEEK
> tells me what the day of the week is for today, but how can I find out the
> day of the week for a given date?
>
> BTW, the letter program is written in RPG - (just to confirm that it belongs
> on the RPG400-L list :).
>
> TIA,
> Jade Richtsmeier
> jade.richtsmeier@mcis.cog.mn.us
>
>
> +---
> | This is the RPG/400 Mailing List!
> | To submit a new message, send your mail to RPG400-L@midrange.com.
> | To subscribe to this list send email to RPG400-L-SUB@midrange.com.
> | To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
> | Questions should be directed to the list owner/operator: david@midrange.com
> +---
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
