PROGRAM AGCAL C C Program : AGCAL C C Purpose : This program will provide the user with an "Aggie" C Calender for any year between 1901 and 2000. The user C need only respond to the question of the year number C ( the last two numbers are sufficient ). To stop the C program enter ^Z to the question. C AGCAL will create a file called AGXXXX.CAL under the C default directory ( XXXX is the input year number ). C C Misc : Written in DEC Fortran 77 Version 5.0. C To build enter the following commands : C C >F77 AGCAL,AGCAL=AGCAL C >TKB AGCAL=AGCAL C C Author : Richard Crawford ( Texas A&M '79 ) C C Date : November 10, 1984 C INTEGER DAY, YEAR, CAL(7,12,5) LOGICAL*1 LEAP, OK, STOPIT C C Suppress certain Fortran Error Messages : C CALL ERRSET(24,.TRUE.,.FALSE.,.TRUE.,.FALSE.,15) !EOF CALL ERRSET(38,.TRUE.,.FALSE.,.TRUE.,.FALSE.,15) !Read Error CALL ERRSET(39,.TRUE.,.FALSE.,.TRUE.,.FALSE.,15) !Write Error CALL ERRSET(59,.TRUE.,.FALSE.,.TRUE.,.FALSE.,15) !I/O Error C C Display the Header : C CALL HEADER STOPIT = .FALSE. 100 OK = .TRUE. C C Get the year number from the user : C CALL INPUT ( YEAR, OK, STOPIT ) C C Let the user know what we are working : C IF ( OK .AND. .NOT.STOPIT ) WRITE(5,1000) C C Determine if this is a leap year or not : C CALL LOOK ( LEAP, YEAR, OK ) C C Get the day of the week for January 1 of the input year : C CALL GET ( DAY, YEAR, OK ) C C Fillup the array CAL : C CALL FILLUP ( CAL, DAY, LEAP, OK ) C C Output the calender : C CALL OUTPUT ( YEAR, CAL, OK ) IF ( .NOT. STOPIT ) GOTO 100 CALL EXIT 1000 FORMAT(1X,' -- Working -- ') END SUBROUTINE HEADER C C Display a header to the user. C WRITE(5,1000) 1000 FORMAT(/,1X,'This is an Aggie Calender Generator.' 1 ,/,1X,'Please enter a year between 1901 and 2000' 2 ,/,1X,'( Note : You can just enter the last two digits )') RETURN END SUBROUTINE INPUT ( YEAR, OK, STOPIT ) C C Get the year number from the user. C INTEGER YEAR LOGICAL*1 OK, STOPIT WRITE(5,1000) READ(5,*,ERR=500,END=510)YEAR IF ( YEAR .LT. 0 ) THEN WRITE(5,1010)YEAR OK = .FALSE. ELSE IF ( YEAR .LT. 100 ) THEN YEAR = YEAR + 1900 ELSE IF ( YEAR .LT. 1000 ) THEN YEAR = YEAR + 1000 END IF IF ( OK ) THEN IF ( YEAR .LT. 1901 .OR. YEAR .GT. 2000 ) THEN WRITE(5,1020)YEAR OK = .FALSE. END IF END IF RETURN 500 WRITE(5,1030) OK = .FALSE. RETURN 510 OK = .FALSE. STOPIT = .TRUE. C C Format Statements : C 1000 FORMAT(1X,/,1X,$'Please enter year ( ^Z to exit ) : ') 1010 FORMAT(1X,'Negative years are not allowed : ',I4 ) 1020 FORMAT(1X,'Year must be between 1901 and 2000 : ',I4 ) 1030 FORMAT(1X,'Please reenter a number between 1901 and 2000') END SUBROUTINE LOOK ( LEAP, YEAR, OK ) C C This subroutine will determine if a given year is a leap year. C INTEGER YEAR, TEST LOGICAL*1 LEAP, OK IF ( OK ) THEN TEST = 4 * ( YEAR / 4 ) IF ( TEST .EQ. YEAR ) THEN LEAP = .TRUE. ELSE LEAP = .FALSE. END IF END IF RETURN END SUBROUTINE GET ( DAY, YEAR, OK ) C C This subroutine will get the first day of the user input year. C The value of DAY is : C C 1 - Sunday C 2 - Monday C 3 - Tuesday C 4 - Wednesday C 5 - Thursday C 6 - Friday C 7 - Saturday C INTEGER DAY, YEAR, D, M, Y LOGICAL*1 OK DATA D, M / 1, 13 / IF ( OK ) THEN C C The general equation for finding the day of the week for C a date in the 20th century is : C C Day = K - ( ( K/7 ) * 7 ) + 1 C C where C C K = D + ( 2*M ) + ( ( 3*M + 3 ) / 5 ) + Y C + ( Y/4 ) + ( Y/100 ) + 1 C C and Day = 1 means Monday. C C If the month is January or February then use the previous C year and add 12 to the month ( ie for Jan. 1984 let C M = 13 and Y = 1983 ). C C For this implementation we changed the expression for C Day so that Day = 1 means Sunday. C Y = YEAR - 1 K = D + ( 2*M ) + ( ( 3*M + 3 ) / 5 ) + Y 1 + ( Y/4 ) + ( Y/100 ) + 1 DAY = K - ( ( K/7 ) * 7 ) + 2 IF ( DAY .EQ. 8 ) DAY = 1 END IF RETURN END SUBROUTINE FILLUP ( CAL, DAY, LEAP, OK ) C C This subroutine will fill-up the array CAL : C INTEGER CAL( 7, 12, 5 ), DAY, DAYS(12), IROW(7) LOGICAL*1 LEAP, OK DATA DAYS / 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / IF ( OK ) THEN C C First clear out CAL : C DO 90 I = 1, 7 DO 90 J = 1, 12 DO 90 K = 1, 5 CAL(I, J, K ) = 0 90 CONTINUE C C Now fill CAL up : C DO 110 MONTH = 1, 12 NUMDAY = DAYS( MONTH ) IF ( MONTH .EQ. 2 .AND. LEAP ) NUMDAY = 29 DO 105 I = 1, 7 IROW(I) = 1 105 CONTINUE DO 100 ICOUNT = 1, NUMDAY CAL ( DAY, MONTH, IROW(DAY) ) = ICOUNT IROW(DAY) = IROW(DAY) + 1 DAY = DAY + 1 IF ( DAY .GE. 8 ) DAY = 1 100 CONTINUE 110 CONTINUE END IF RETURN END SUBROUTINE OUTPUT ( YEAR, CAL, OK ) C C This subroutine will output the Aggie Calender to the file C AGXXXX.CAL where XXXX is the year number. C CHARACTER*10 NAME INTEGER YEAR, CAL( 7, 12, 5 ) LOGICAL*1 OK DATA NAME / 'AG .CAL' / IF ( OK ) THEN ENCODE ( 4, 1000, NAME(3:6) ) YEAR OPEN(UNIT=1,NAME=NAME,TYPE='NEW',CARRIAGECONTROL='FORTRAN') C C Output the Calender Banner : C CALL BANNER ( YEAR ) C C Output each day in succession : C DO 100 I = 1, 7 CALL OUTDAY ( I, CAL ) 100 CONTINUE CLOSE(UNIT=1) WRITE(5,1010)NAME END IF 1000 FORMAT(I4.4) 1010 FORMAT(1X,' The Calender is in the file ',A10 ) RETURN END SUBROUTINE BANNER ( YEAR ) C C This outputs the Banner for the Aggie Calender in big letters. C INTEGER YEAR CHARACTER*4 CYEAR ENCODE(4,1000,CYEAR)YEAR WRITE(1,1030) !Form Feed WRITE(1,1010) !5 Blank Lines CALL OUTLET ( CYEAR, 4 ) WRITE(1,1020) !4 Blank Lines CALL OUTLET ( 'AGGIE', 5 ) WRITE(1,1020) !4 Blank Lines CALL OUTLET ( 'CALENDER', 8 ) 1000 FORMAT(I4.4) 1010 FORMAT(1X,/////) 1020 FORMAT(1X,////) 1030 FORMAT('1') RETURN END SUBROUTINE OUTDAY ( DAY, CAL ) C C This subroutine will output the months and days that occur for C this day in the year. C INTEGER DAY, CAL(7,12,5) CHARACTER*9 DAYLET IF ( DAY .EQ. 1 ) THEN DAYLET = 'SUNDAY' ICOUNT = 6 ELSE IF ( DAY .EQ. 2 ) THEN DAYLET = 'MONDAY' ICOUNT = 6 ELSE IF ( DAY .EQ. 3 ) THEN DAYLET = 'TUESDAY' ICOUNT = 7 ELSE IF ( DAY .EQ. 4 ) THEN DAYLET = 'WEDNESDAY' ICOUNT = 9 ELSE IF ( DAY .EQ. 5 ) THEN DAYLET = 'THURSDAY' ICOUNT = 8 ELSE IF ( DAY .EQ. 6 ) THEN DAYLET = 'FRIDAY' ICOUNT = 6 ELSE IF ( DAY .EQ. 7 ) THEN DAYLET = 'SATURDAY' ICOUNT = 8 END IF WRITE(1,1000) !7 Blank Lines CALL OUTLET ( DAYLET, ICOUNT ) CALL OUTCAL ( CAL, DAY ) 1000 FORMAT('1',1X,///////) RETURN END SUBROUTINE OUTLET(STRING,NUMBER) C C This subroutine will output a string of letters and/or numbers C in big characters ( 10 x 14 ). C BYTE BTEMP CHARACTER*1 CTEMP CHARACTER*9 STRING CHARACTER*132 LINE INTEGER*2 NUMBER, POINTR, POS, LENGTH, OFFSET EQUIVALENCE ( BTEMP , CTEMP ) INCLUDE 'LETTER.FTN/NOLIST' LENGTH = 10*NUMBER + 3*(NUMBER-1) OFFSET = ( 132 - LENGTH ) / 2 DO 110 I = 1, 7 LINE = ' ' POS = OFFSET DO 100 J = 1, NUMBER IF ( STRING(J:J).GE.'0' .AND. STRING(J:J).LE.'9' ) THEN DECODE(1,1020,STRING(J:J))POINTR LINE(POS:POS+9) = NUMR(POINTR,I) POS = POS + 13 ELSE CTEMP = STRING(J:J) ITEMP = BTEMP POINTR = IAND ( ITEMP , '037'O ) LINE(POS:POS+9) = LETR(POINTR,I) POS = POS + 13 END IF 100 CONTINUE WRITE(1,1010)LINE WRITE(1,1010)LINE 110 CONTINUE RETURN 1010 FORMAT(1X,A) 1020 FORMAT(I1.1) END SUBROUTINE OUTCAL ( CAL, DAY ) C C This subroutine will output the dates in a year corresponding C to a day. C CHARACTER*132 LINE INTEGER DAY, MONTH, ROW, CAL(7,12,5) DO 100 MONTH = 1, 12, 4 IF ( MONTH .EQ. 1 ) WRITE(1,1000) IF ( MONTH .EQ. 5 ) WRITE(1,1010) IF ( MONTH .EQ. 9 ) WRITE(1,1020) DO 100 ROW = 1, 5 LINE = ' ' ENCODE(2,1040,LINE( 26: 27)) CAL(DAY,MONTH,ROW) IF ( CAL(DAY,MONTH,ROW) .EQ. 0 ) LINE( 26: 27) = ' ' ENCODE(2,1040,LINE( 53: 54)) CAL(DAY,MONTH+1,ROW) IF ( CAL(DAY,MONTH+1,ROW) .EQ. 0 ) LINE( 53: 54) = ' ' ENCODE(2,1040,LINE( 80: 81)) CAL(DAY,MONTH+2,ROW) IF ( CAL(DAY,MONTH+2,ROW) .EQ. 0 ) LINE( 80: 81) = ' ' ENCODE(2,1040,LINE(107:108)) CAL(DAY,MONTH+3,ROW) IF ( CAL(DAY,MONTH+3,ROW) .EQ. 0 ) LINE(107:108) = ' ' WRITE(1,1030)LINE 100 CONTINUE RETURN 1000 FORMAT(1X,////////,1X,T24,'JANUARY',T51,'FEBRUARY',T79, 1 'MARCH',T106,'APRIL',/) 1010 FORMAT(1X,///,1X,T26,'MAY',T53,'JUNE',T80,'JULY',T106,'AUGUST',/) 1020 FORMAT(1X,///,1X,T23,'SEPTEMBER',T51,'OCTOBER',T78,'NOVEMBER', 1 T105,'DECEMBER',/) 1030 FORMAT(1X,A110) 1040 FORMAT(I2) END