PROGRAM DAY C C W. DWYNE C STELCO INC. C C FOR DAY,NL:=DAY C SY:DAY/CP,NL:=SY:DAY C DR0:[1,1]FOROTS/LB C / C LIBR = FORRES:RO C ACTFIL = 1 C UNITS = 1 C ASG = TI:1 C MAXBUF = 133 C // C C C C THIS PROGRAM WILL PROVIDE THE DAY OF THE WEEK FROM THE CURRENT DATE. C IT WILL ALSO DETERMINE IF THE CURRENT DAY IS A STAT HOLIDAY. C C RESTRICTIONS: The date must be between 1-JAN-1982 AND 31-DEC-2081 C (This is a restriction imposed by idate.) c dates previous to 1-jan-82 are presumed to be from c the year 20xx C C C These routines are believed to be accurate for dates between 1760 and C 2100 (approx). However the calculation of the current year (from the C value returned by IDATE) would have to be changed, also the leap year C check. C C If you are interested in dates less than 1760 bear in mind the following. C C The year 707 (46bc) contained 445 days (known as the year of C confussion) this restored the Spring Equinox to 21 March and was the C the start of Julian Calendar. By the 16th century the Spring Equinox C had agian shifted (from the 21 to the 10). In 1577 the Gregorian Calendar C was introduced (adopted 1582). In 1582 10 days were dropped after the 4th C of Oct, the 15th being the next day. C C Protestant countries did not adopt the Gregorian Calendar till the 18th C Century (Engalnd 1752). C C 1983 is the secound revolution of the Gregorian Calendar. C C Every 100th year is not a leap year, only the fourth hundred. C ie. 1600(leap) 1700(not) 1800(not) 1900(not) 2000(leap). Divisible by 400. C C TO DETERMINE DAY OF THE WEEK C C TABLE 1 TABLE 2 TABLE 3 C MONTH KEYS CENTURY KEYS DAY KEYS C JAN 1 (0 IF LEAP) 17xx add 4 SUN 1 C FEB 4 (3 IF LEAP) 18xx add 2 MON 2 C MAR 4 19xx add 0 TUES 3 C APR 0 20xx add 6 WED 4 C MAY 2 21xx add 4 THURS 5 C JUN 5 FRI 6 C JUL 0 SAT 0 C AUG 3 C SEP 6 C OCT 1 C NOV 4 C DEC 6 C C C METHOD eg. for December 25 1958 C C 1: Take last 2 figures of Year. 58 C 2: Divide by 4 and discard remainder. 14 C 3: Take Month key number from Table 1. 6 C 4: Take the Day number of the Month. 25 C 5: Add the results of steps 1 - 4. 103 C 6: Add Century key value from Table 2. 0 C 7: Divide by 7 the result from step 6. 14 with remainder of 5 C 8: Take the remainder and using Table 3 C find corresponding Day THURSDAY (5) C C C c COMMON/yourcommon/NDAY,IHOL REAL*8 THEDAY(7) INTEGER CENTRY,DAY BYTE XX(9),YY(8) DIMENSION MON(12),CENTRY(5),MCR(4) DATA MON/1,4,4,0,2,5,0,3,6,1,4,6/ 1 ,CENTRY/4,2,0,6,4/ DATA THEDAY/' SUN',' MON',' TUES',' WEDNES' 1 ,' THURS',' FRI',' SATUR'/ DAY=0 D WRITE(1,1000) D1000 FORMAT(1H ,3X,'ENTER MON (2) ',$) D READ(1,1001)MON(2) D1001 FORMAT(I1) WRITE(1,12) 12 FORMAT(1H ,5(/)) CALL IDATE(MONTH,IDAY,IYEAR) IF(IYEAR.LT.82) IYEAR = IYEAR + 100 ! LOOKING AFTER THE KIDS IYEAR=IYEAR+1900 YEAR=IYEAR IF(((YEAR/4)-(IYEAR/4)).GT.0) GO TO 15 IF(MONTH.LT.3)MONTH=MONTH+6 !FOR NON-LEAP YEAR 15 JYEAR=YEAR*.01 D WRITE(1,1010)MON(2),MONTH D1010 FORMAT(1H ,3X,'MON(3) = ',I2,' MONTH= ',I2) JCEN=JYEAR*100 DAY=(IYEAR-JCEN)/4 DAY=DAY+MON(MONTH)+IDAY+CENTRY(JYEAR-16)+(IYEAR-JCEN) DAY=DAY-((DAY/7)*7) IF(DAY.GE.0.AND.DAY.LE.6) GOTO 16 WRITE(1,21) 21 FORMAT(1H ,T15,'[1,3]DAY.FTN FAILED TO DETERMINE DAY OF WEEK') GOTO 99 16 IF(DAY.EQ.0)DAY=7 C C UPDATE THE DAY POINTER IN COMMON C NDAY = DAY C C CALL SUBROUTINE HOLDAY TO CHECK IF TODAY IS A STAT HOLIDAY. C IF TRUE SET THE COMMON POINTER IHOL. IF IHOL IS SET TO 1000 DO NOT CALL C CALL HOLDAY (THIS IS USED TO INDICATE AN EXTENDED SHUTDOWN) C IF(IHOL.NE.1000) CALL HOLDAY(IHOL,DAY) C C CALL DATE(XX) CALL TIME(YY) WRITE(1,20)THEDAY(DAY),(XX(I),I=1,9),(YY(J),J=1,8) 20 FORMAT(1H ,3(/),T10,'This is',A8,'DAY',//,T35,'the ',9A1,// 1 ,T58,'at ',8A1,8(/)) 99 CALL EXIT END C C SUB HOLIDAYS CHECKS FOR STAT HOLIDAYS C SUBROUTINE HOLDAY(IHOL,DAY) C C THIS SUBROUTINE CHECKS FOR STAT HOLIDAYS. IF THE CURRENT DAY IS A STATUATORY C HOLIDAY COMMON LOCATION 10 (IHOL) IS SET PER THE FOLLOWING TABLE. C C HOLIDAY VALUE IN IHOL C C NEW YEARS DAY 10 C GOOD FRIDAY 20 C VICTORIA DAY 30 C DOMINION DAY 40 C CIVIC HOLIDAY 50 C LABOUR DAY 60 C THANKSGIVING DAY 70 C CHRISTMAS DAY 80 C BOXING DAY 90 C HERITAGE DAY 100 C C DO NOT CHANGE 1000 C INTEGER EDAY,EMON,DAY REAL*8 HOL1(10),HOL2(10) DATA HOL1/'NEW YEAR','GOOD FRI','VICTORIA','DOMINION' 1 ,'CIVIC HO','LABOUR D','THANKSGI','CHRISTMA','BOXING D' 1 ,'HERITAGE'/ DATA HOL2/'S DAY ','DAY ',' DAY ',' DAY ' 1 ,'LIDAY ','AY ','VING DAY','S DAY ','AY ' 1 ,' DAY '/ C C C C CHECK FOR THE (EASY) HOLIDAYS C D WRITE(1,1000)IHOL,DAY D1000 FORMAT(1H ,3X,'IHOL =',I6,' DAY =',I6) CALL IDATE(IMON,IDAY,IYEAR) D WRITE(1,1010)IMON,IDAY,IYEAR D1010 FORMAT(1H ,3X,'IMON =',I6,' IDAY =',I6,' IYEAR=',I6) C IHOL = 0 C IF(IMON.EQ.11) GOTO 99 ! NO HOLIDAYS IF(IMON.EQ.1.AND.IDAY.EQ.1) IHOL = 10 ! NEW YEARS IF(IMON.EQ.7.AND.IDAY.EQ.1) IHOL = 40 ! DOMINION DAY IF(IMON.EQ.12.AND.IDAY.EQ.25) IHOL = 80 ! XMAS IF(IMON.EQ.12.AND.IDAY.EQ.26) IHOL = 90 ! BOXING DAY IF(IHOL.GT.0) GOTO 98 C C IF(DAY.NE.6) GOTO 10 ! EASTER IF(IMON.EQ.3.OR.IMON.EQ.4) GOTO 11 GOTO 10 11 CALL EASTER(EDAY,EMON) EDAY = EDAY - 2 ! BACKUP TWO IF(EDAY.GT.0) GOTO 12 EDAY = EDAY + 31 ! BACK A MONTH EMON = EMON - 1 12 IF(IDAY.EQ.EDAY.AND.IMON.EQ.EMON) IHOL = 20 D WRITE(1,13)IDAY,EDAY,IMON,EMON D13 FORMAT(1H ,' IDAY =',I2,' EDAY =',I2,' IMON =',I2,' EMON=',I2) GO TO 98 C 10 IF(DAY.NE.2) GOTO 99 ! THE REST ARE MONDAYS C IF(IMON.NE.2) GOTO 15 ! HERITAGE DAY IF(IDAY.GE.18.AND.IDAY.LE.24) IHOL = 100 GOTO 98 C 15 IF(IMON.NE.5) GOTO 20 ! VICTORIA DAY IF(IDAY.GE.18.AND.IDAY.LE.24) IHOL = 30 GOTO 98 C 20 IF(IMON.NE.8) GOTO 30 ! CIVIC HOLIDAY IF(IDAY.GE.1.AND.IDAY.LE.7) IHOL = 50 GOTO 98 C 30 IF(IMON.NE.9) GOTO 40 ! LABOUR DAY IF(IDAY.GE.1.AND.IDAY.LE.7) IHOL = 60 GOTO 98 C 40 IF(IMON.NE.10) GOTO 99 ! THANKSGIVING IF(IDAY.GE.8.AND.IDAY.LE.14) IHOL = 70 98 IF(IHOL.GT.0)WRITE(1,200)HOL1(IHOL/10),HOL2(IHOL/10) 200 FORMAT(1H ,T36,A8,A8) C 99 RETURN END C SUBROUTINE EASTER(EDAY,EMON) C Calculates Easter day. C IMPLICIT INTEGER (A-Z) DIMENSION EASTER(7,19,2),SHIFT(7) DATA EASTER/ 1 16,17,18,19,20,21,15, 2 9,10,4,5,6,7,8, 3 26,27,28,29,30,24,25, 4 16,17,18,12,13,14,15, 5 2,3,4,5,6,7,1, 6 23,24,25,19,20,21,22, 7 9,10,11,12,13,14,15, 8 2,3,4,29,30,31,1, 9 23,17,18,19,20,21,22, 1 9,10,11,12,6,7,8, 1 26,27,28,29,30,31,1, 2 16,17,18,19,20,14,15, 3 9,3,4,5,6,7,8, 4 26,27,28,29,23,24,25, 5 16,17,11,12,13,14,15, 6 2,3,4,5,6,31,1, 7 23,24,18,19,20,21,22, 8 9,10,11,12,13,14,8, 9 2,3,28,29,30,31,1, 1 4,4,4,4,4,4,4, 2 4,4,4,4,4,4,4, 3 3,3,3,3,3,3,3, 4 4,4,4,4,4,4,4, 5 4,4,4,4,4,4,4, 6 4,4,4,4,4,4,4, 7 4,4,4,4,4,4,4, 8 4,4,4,3,3,3,4, 9 4,4,4,4,4,4,4, 1 4,4,4,4,4,4,4, 1 3,3,3,3,3,3,4, 2 4,4,4,4,4,4,4, 3 4,4,4,4,4,4,4, 4 3,3,3,3,3,3,3, 5 4,4,4,4,4,4,4, 6 4,4,4,4,4,3,4, 7 4,4,4,4,4,4,4, 8 4,4,4,4,4,4,4, 9 4,4,3,3,3,3,4/ C DATA SHIFT/1,7,6,5,4,3,2/ C C CALL IDATE(MONTH,XDAY,YEAR) IF(YEAR.LT.82) YEAR = YEAR + 100 YEAR = YEAR + 1900 C C GET THE GOLDEN YEAR C GYEAR = ( YEAR+1 ) - ((( YEAR+1 ) / 19 ) * 19 ) IF(GYEAR.LT.0.OR.GYEAR.GT.18) GOTO 500 ! FAILED IF(GYEAR.EQ.0) GYEAR = 19 C C GET THE SUNDAY POINTER C C IF(YEAR.GE.1600) SNUM = 2 C IF(YEAR.GE.1700) SNUM = 1 IF(YEAR.GE.1800) SNUM = 0 IF(YEAR.GE.1900) SNUM = 6 C IF(YEAR.GE.2100) SNUM = 5 C IF(YEAR.GE.2200) SNUM = 4 C IF YEAR.GE.2300) SNUM = 3 C IF(YEAR.GE.2500) SNUM = 2 C FOURTH = (YEAR * .25) + SNUM ! 1/4 THE YEAR SUNP = (YEAR+FOURTH) - (((YEAR+FOURTH)/7)*7) C C D WRITE(1,26)YEARF,YEARFD D26 FORMAT(1H ,' YEAR + FOURTH =',I4,' YEAR + FOURTH DIV =',I4) C IF(SUNP.LT.0.OR.SUNP.GT.6) GOTO 510 ! FAILED D WRITE(1,105)SUNP D105 FORMAT(1H ,' SUNP BEFORE SHIFT = ',I2) SUNP = SHIFT(SUNP+1) EDAY = EASTER(SUNP,GYEAR,1) ! EASTER DAY EMON = EASTER(SUNP,GYEAR,2) ! EASTER MONTH 3 = MAR D WRITE(1,10)EDAY,EMON D10 FORMAT(1H ,3X,'EDAY =',I2,' EMON =',I2) GOTO 99 500 WRITE(1,501) 501 FORMAT(1H ,3X,'EASTER FAILED TO CALCULATE GOLDEN YEAR') GOTO 99 510 WRITE(1,511) 511 FORMAT(1H ,3X,'EASTER FAILED TO CALCULATE SUNDAY POINTER') 99 RETURN END