C CH413 - A Sample FORTRAN Code - Change the file name extension to  .FOR
C
C************CALEN.FOR****************************************************
C Calendar : ref., The Hindu - Young World, 31/12/94
C For one full month, input 0 for date
C For one full year calendar, input 0 for date and month and
C print the output file (CALEN) choosing 71 lines per page (3 pages)
C**********mvr/October,1997***********************************************
C
      DIMENSION D(7),CM(12)
      CHARACTER*10 D,CM
      DATA D/'Monday','Tuesday','Wednesday','Thursday','Friday',
     1       'Saturday','Sunday'/
      DATA CM/'January','February','March','April','May','June',
     1        'July','August','September','October','November',
     2        'December'/
      WRITE(*,9)
  50  WRITE(*,10)
      READ(*,*,END=1)LD,M,LY
      IF(LD.LT.0) THEN
      WRITE(*,42)
      GOTO 50
      ENDIF
      IF(((LD.NE.0).AND.(M.LT.0)).OR.(M.GT.12)) THEN
      WRITE(*,41)
      GOTO 50
      ENDIF
      IF(LY.LT.100)LY=1900+LY
      IF(LY.LT.1583) THEN
      WRITE(*,40)
      GOTO 50
      ENDIF
      IF((M.LT.7).AND.(MOD(M,2).EQ.0).AND.(LD.GT.30)) THEN
      WRITE(*,42)
      GOTO 50
      ELSEIF (LD.GT.31) THEN
      WRITE(*,42)
      GOTO 50
      ENDIF
      LZ=1
      IF(LD.EQ.0) THEN
        IF(M.LT.0) THEN
        WRITE(*,41)
        GOTO 50
        ENDIF
      LZ=0
      LD=1
      ENDIF
      IF(M.EQ.0)GOTO 70
      CALL DAY(LD,M,LY,K,LP)
      IF(LZ.EQ.0)GOTO 60
      IF(M.EQ.2) THEN
        IF((LP.EQ.0).AND.(LD.GT.28)) THEN
        WRITE(*,42)
        GOTO 50
        ELSEIF (LD.GT.29) THEN
        WRITE(*,42)
        GOTO 50
        ENDIF
      ENDIF
      WRITE(*,15) D(K),LD,M,LY
      GOTO 50
   60 WRITE(*,22) CM(M),LY
      CALL MONTH(M,K,LP,0)
      GOTO 50
    1 STOP
   70 OPEN(3,FILE='CALEN',STATUS='NEW')
      WRITE(3,16)LY
      DO 71 I=1,12
      WRITE(3,18)
	WRITE(3,17)CM(I)
	CALL DAY(1,I,LY,K,LP)
	CALL MONTH(I,K,LP,1)
      WRITE(3,19)
   71 CONTINUE		
      WRITE(*,21)
    9 FORMAT(3X,'Give 0 for date to view one full month'/
     1       3X,'Give 0 for both date and month for one full year calend
     2ar'/)
   10 FORMAT(35X, 'Date, Month, Year ?')
   15 FORMAT(5X,A10,4X,I2,'/',I2,'/',I4)
   16 FORMAT(20X,I4)
   17 FORMAT(18X,A10)
   18 FORMAT(/5X,'---------------------------------')
   19 FORMAT(5X,'----------------------------------'/)
   21 FORMAT(/3X,'Print the output file CALEN choosing 71 lines per page
     1'//)
   22 FORMAT(/5X,A10,1X,I5)
   40 FORMAT(30X, 'Gregorian Calendar with Leap Year Rule'/
     1       30X, 'Started in 1582 !'/)	
   41 FORMAT(30X, 'Invalid month !'/)
   42 FORMAT(30X, 'Invalid date !'/)
      END	
C
      SUBROUTINE DAY(LD,M,LY,K,LP)
      DIMENSION MC(12),LC(4)
      DATA MC/0,3,3,6,1,4,6,2,5,0,3,5/
      DATA LC/0,6,4,2/
      LA=MOD(LY,100)
      LP=LEAP(LY,LA,M)
      NC=(LY/100)-14
      NC=MOD(NC,4)
      IF(NC.EQ.0)NC=4
      IA=MOD(LA,7)
      IB=LA/4
      IC=MOD(LD,7)
      ID=MC(M)
      IT=IA+IB+IC+ID
      K=MOD(IT,7)
      IF(K.EQ.0)K=7
      K=K-LP+LC(NC)
      K=MOD(K,7)
      IF(K.EQ.0)K=7
      RETURN 
      END
C
      SUBROUTINE MONTH(M,K,LP,LF)
      DIMENSION LC(31),L(7)
      CHARACTER*2 LC,L
      DATA LC/'1 ','2 ','3 ','4 ','5 ','6 ','7 ',
     *        '8 ','9 ','10','11','12','13','14',
     *        '15','16','17','18','19','20','21',
     *        '22','23','24','25','26','27','28',
     *        '29','30','31'/
      IF(M.LT.8)THEN
        IF(MOD(M,2).EQ.0)THEN
        LM=30
        ELSE
        LM=31
        ENDIF
      ELSE
        IF(MOD(M,2).EQ.0)THEN
        LM=31
        ELSE
        LM=30
        ENDIF
      ENDIF
      IF(M.EQ.2)THEN
        IF(LP.EQ.0)THEN
        LM=28
        ELSE
        LM=29
        ENDIF
      ENDIF
      WRITE(*,41)
	IF(LF.EQ.1)WRITE(3,41)
      K=K+1
      IF(K.EQ.8)K=1
      LL=1
      KK=K
   62 DO 66 I=1,7
      L(I)=' '
   66 CONTINUE
      DO 61 I=KK,7
      L(I)=LC(LL)
      LL=LL+1
      IF(LL.GT.LM)GOTO 63
   61 CONTINUE
   63 WRITE(*,42)(L(I),I=1,7)
      IF(LF.EQ.1)WRITE(3,42)(L(I),I=1,7)
      IF(LL.GT.LM)GOTO 64
      KK=1
      GOTO 62	
   64 WRITE(*,43)
   41 FORMAT(/5X,'Sun  Mon  Tue  Wed  Thu  Fri  Sat')   
   42 FORMAT(/5X,7(1X,A2,2X))   
   43 FORMAT(/)
      RETURN
      END
C	  
      FUNCTION LEAP(LY,LA,M)
      LEAP=0
	IF(M.GT.2)RETURN
	IF(LA.EQ.0) GOTO 20
      IF(MOD(LY,4).EQ.0) LEAP=1
	RETURN
   20 IF(MOD(LY,400).EQ.0) LEAP=1	
      RETURN
	END