home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug004.ark / CALENDAR.FOR < prev    next >
Encoding:
Text File  |  1984-04-29  |  3.5 KB  |  153 lines
  1.     IOUT = 6
  2.     WRITE(1,200)
  3. 200    FORMAT('1','ENTER YEAR (4 DIGITS)')
  4.     READ (1,100) IYR
  5. 100    FORMAT(I4)
  6.     CALL OPEN (IOUT,11HCALENDAR   ,0)
  7.     WRITE(IOUT,300)
  8. 300    FORMAT(1H1)
  9.     CALL NPRINT(IYR,IOUT)
  10.     WRITE(IOUT,301)
  11. 301    FORMAT(' ')
  12.     CALL CALNDR(IYR,IOUT)
  13.     END
  14.     SUBROUTINE CALNDR(INYEAR,IOUT)
  15.     DIMENSION KDATES(7,6,12),KPRINT(504),KHARS(32)
  16.     DATA KHARS /
  17.      1    '  ',' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9',
  18.      2    '10','11','12','13','14','15','16','17','18','19',
  19.      3    '20','21','22','23','24','25','26','27','28','29',
  20.      4    '30','31' /
  21.     DO 10 I=1,7
  22.     DO 10 J=1,6
  23.     DO 10 K=1,12
  24. 10    KDATES(I,J,K) = 0
  25.     IDAYW = 0
  26.     IDAYR = 1
  27.     ILINE = 0
  28. 20    CALL IDATE1(INYEAR,IDAYR,IMON,IDAYM)
  29.     IF(IMON .GT. 12 .OR. IMON .LT. 1) GO TO 999
  30.     IDAYW = IDATE3(INYEAR,IMON,IDAYM) + 1
  31.     IF(IDAYW .EQ. 1) ILINE = ILINE + 1
  32.     IF(IDAYM .EQ. 1) ILINE = 1
  33.     KDATES(IDAYW,ILINE,IMON) = IDAYM
  34.     IDAYR = IDAYR + 1
  35.     IF (IDAYR .LE. 366) GO TO 20
  36. 999    ICTR = 1
  37.     DO 30 J=3,12,3
  38.     M=J-2
  39.     DO 30 L=1,6
  40.     DO 30 K=M,J
  41.     DO 30 N=1,7
  42.     MNUM=KDATES(N,L,K) + 1
  43.     KPRINT(ICTR) = KHARS(MNUM)
  44. 30    ICTR = ICTR + 1
  45.     WRITE(IOUT,2000)
  46.     WRITE(IOUT,3000)
  47.     WRITE(IOUT,6000)
  48.     DO 40 I=1,6
  49.     L=((I-1)*21) + 1
  50.     K=L + 20
  51. 40    WRITE(IOUT,4000) (KPRINT(J),J=L,K)
  52.     WRITE(IOUT,2200)
  53.     WRITE(IOUT,3000)
  54.     WRITE(IOUT,6000)
  55.     DO 50 I=1,6
  56.     L=((I-1)*21)+(7*6*3)+1
  57.     K=L+20
  58. 50    WRITE(IOUT,4000) (KPRINT(J),J=L,K)
  59.     WRITE(IOUT,2500)
  60.     WRITE(IOUT,3000)
  61.     WRITE(IOUT,6000)
  62.     DO 60 I=1,6
  63.     L=((I-1)*21)+(7*6*3*2)+1
  64.     K=L+20
  65. 60    WRITE(IOUT,4000) (KPRINT(J),J=L,K)
  66.     WRITE(IOUT,2700)
  67.     WRITE(IOUT,3000)
  68.     WRITE(IOUT,6000)
  69.     DO 70 I=1,6
  70.     L=((I-1)*21)+(7*6*3*3)+1
  71.     K=L+20
  72. 70    WRITE(IOUT,4000) (KPRINT(J),J=L,K)
  73.     RETURN
  74. 2000    FORMAT(1H0,
  75.      1    '    J A N U A R Y     ',
  76.      2    '   F E B R U A R Y    ',
  77.      3    '      M A R C H       ')
  78. 2200    FORMAT(1H0,
  79.      4    '      A P R I L       ',
  80.      5    '        M A Y         ',
  81.      6    '       J U N E        ')
  82. 2500    FORMAT(1H0,
  83.      1    '       J U L Y        ',
  84.      2    '     A U G U S T      ',
  85.      3    '  S E P T E M B E R   ')
  86. 2700    FORMAT(1H0,
  87.      4    '    O C T O B E R     ',
  88.      5    '   N O V E M B E R    ',
  89.      6    '   D E C E M B E R    ')
  90. 3000    FORMAT(1H0,3(' S  M  T  W  T  F  S  '))
  91. 4000    FORMAT(1H ,7(A2,1X),1X,7(A2,1X),1X,7(A2,1X),1X)
  92. 6000    FORMAT(1H )
  93.     END
  94.  
  95.     SUBROUTINE IDATE1(IYEAR,IDAY,IMON,IDY)
  96. C
  97. C    THIS SUBROUTINE RETURNS MM/DD WHEN GIVEN YYY/DD
  98. C
  99. C    IYEAR = YEAR (INPUT
  100. C    IDAY  = DAY WITHIN YEAR(I-366, INPUT)
  101. C
  102. C    IMON  = MONTH (OUTPUT)
  103. C    IDY   = DAY WITHIN MONTH (1-31) OUTPUT
  104. C
  105.     IT = 0
  106.     IF ((IYEAR/4)*4 .EQ. IYEAR) IT = 1
  107.     IF ((IYEAR/400)*400 .EQ. IYEAR .OR.
  108.      1       (IYEAR/100)*100 .NE. IYEAR) GO TO 20
  109.     IT = 0
  110. 20    ITEMP = 0
  111.     IF (IDAY .GT. (59+IT)) ITEMP = 2 - IT
  112.     IDY = IDAY + ITEMP
  113.     IMON = IFIX((FLOAT(IDY+91) * 100.)/3055.)
  114.     IDY = IDY+91-(IFIX(FLOAT(IMON)*3055./100.))
  115.     IMON = IMON - 2
  116.     RETURN
  117.     END
  118.  
  119.     FUNCTION IDATE3(I,J,K)
  120. C
  121. C    IDATE3 RETURNS DATE OF WEEK (0-6) GIVVEN YY/MM/DD
  122. C
  123. C    I=YEAR, J=MONTH, K=DAY
  124. C
  125.     IDATE3=MOD((13*(J+10-(J+10)/13*12)-1)/5+K+77
  126.      1          +5*(I+(J-14)/12-(I+(J-14)/12)/100*100)/4
  127.      2          +(I+(J-14)/12)/400-(I+(J-14)/12)/100*2,7)
  128.     RETURN
  129.     END
  130.  
  131.     SUBROUTINE NPRINT(INUM,IOUT)
  132.     LOGICAL CH(5,7,4)
  133.     DIMENSION N(4)
  134.     NUM=INUM
  135.     ITEN = 1000
  136.     DO 4 I=1,4
  137.     NTEMP = NUM/ITEN
  138.     N(I) = NTEMP
  139.     NTEMP = NTEMP*ITEN
  140.     NUM = NUM - NTEMP
  141.     ITEN = ITEN / 10
  142. 4    CONTINUE
  143.     DO 10 I=1,7
  144.     J=I-1
  145.     DO 11 K=1,4
  146. 11    CALL NUMBER(CH(1,I,K),N(K),J)
  147.     WRITE(IOUT,200) ((CH(I1,I,I3),I1=1,5),I3=1,4)
  148. 200    FORMAT(' ','                    ',4(A1,A1,A1,A1,A1,3X))
  149. 10    CONTINUE
  150.     RETURN
  151.     END
  152.  
  153.