C
C         IMPORTANT NAMES & DATES         by Bruce W. Roeckel
C       *--------------------------*                         
C            OPTION #3 & #4
C
$STORAGE:2
C
C
      SUBROUTINE CALEND
C
C           THIS ROUTINE WILL DISPLAY MONTH CALENDAR
C
      COMMON/REVNO/ PGM,AUTHOR,YEAR,DATE,REV
      CHARACTER PGM*21,AUTHOR*21,YEAR*4,DATE*8,REV*2
C
      COMMON/MAIN1/LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
      CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
      CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
      CHARACTER PH1(200)*14,PH2(200)*14
C
      COMMON/MAIN2/ STRID,JULIAN,MNUM
      INTEGER STRID(200),JULIAN(366,5),MNUM
C
      COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
      CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
C
      REAL LEAPYR
      INTEGER DAYS(12),DNUM,TODAY
      CHARACTER OPTION*25,RAMDSK*80,CALEN*8,DAY(7)*3,IMON(12)*6,ANS*1
C
      DATA DAY/'Sun','Mon','Tue','Wed','Thr','Fri','Sat'/
      DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
      DATA IMON/' Jan  ',' Feb  ','March ','April ',' May  ',' June ',
     A          ' July ',' Aug  ',' Sept ',' Oct  ',' Nov  ',' Dec  '/
C
C           SET-UP SCREEN
C
   10 CONTINUE
      OPTION='Monthly Calendar   '
      CALL HEADER(OPTION)
      IV=21
      IH=1
      CALL MOVEIT(IH,IV)
      CALL ULINE
         WRITE(*,'(80X)')
      CALL OFF
C
C            FIGURE OUT WHAT MONTH & YEAR THIS IS
C
   50 CONTINUE
      IH=1
      IV=23
      IANY=0
      CALL MOVEIT(IH,IV)
      WRITE(*,'(15X,A31,\)') 'Enter Month to Display (1-12): '
      READ(*,'(I2)',ERR=890) JMON
      IF(JMON.EQ.0) RETURN
      IF(JMON.LT.1 .OR. JMON.GT.12) GOTO 890
         WRITE(RAMDSK,'(A8)') DATE
         READ(RAMDSK,'(6X,I2)') IYEAR
         LEAPYR = (REAL(IYEAR)/4.0) - INT(REAL(IYEAR)/4.0)
         IF(LEAPYR.EQ.0.0) DAYS(2)=29
         DNUM=DAYS(JMON)
C
C            CALCULATE THE JULIAN DATE OF THE 1ST OF THIS MONTH
C            AND WHAT DAY-OF-WEEK THE FIRST IS ON
C
      WRITE(RAMDSK,'(I2.2,A4,I2.2)') JMON,'/01/',IYEAR
      READ(RAMDSK,'(A8)') CALEN
      CALL DATEJL(CALEN,IJUL)
      CALL DATEDW(CALEN,IDOW)
C
C            NOW, START DISPLAYING CALENDAR
C
      IF(IDOW.GT.0) THEN
         IH=1
         IV=7
         WRITE(RAMDSK,'(A6,I4)') IMON(JMON),IYEAR+1900
         CALL SQUISH(RAMDSK,10)
         CALL UPTOP(IH,IV)
         CALL DHTOP
            WRITE(*,'(13X,A10)') RAMDSK
         CALL DHBOT
            WRITE(*,'(13X,A10)') RAMDSK
         CALL OFF
C
C            DRAW THE DAY DESCRIPTIONS
C
         IV=9
         CALL BOLD
            DO 100 I=1,7
            IH = (I*10) - 1
            CALL UPTOP(IH,IV)
            WRITE(*,'(A3)') DAY(I)
  100       CONTINUE
         CALL OFF
C
C            NOW DRAW IN DAYS 
C
         IH=(IDOW*10) - 2
         IV=10
         K=0
  200    CONTINUE
         K=K+1
         IF(K.GT.DNUM) GOTO 500
C
C            PRINT THIS DAY, BLINKING IF ACTIVITY TODAY
C
         CALL UPTOP(IH,IV)
         IF(JULIAN(IJUL+K-1,1).GT.0) THEN
            IANY=1
            CALL BLINK
            CALL BOLD
            WRITE(*,'(A1,I2,A1)') '[',K,']'
            CALL OFF
         ELSE
            WRITE(*,'(A1,I2,A1)') ' ',K,' '
         ENDIF
C
C            CONTINUE WITH THE NEXT DAY
C
         IH = IH + 10
         IF(IH.GT.70) THEN
            IH = 8
            IV = IV + 2
         ENDIF
         GOTO 200
  500    CONTINUE
C
C            NOW ASK FOR DAY TO BLOW-UP
C
         IF(IANY.LE.0) THEN
            IH=1
            IV=23
            CALL MOVEIT(IH,IV)
            CALL BLINK
            CALL BOLD
            CALL BELL
            WRITE(*,'(5X,A26,\)') 'No Activity This Month ...'
            READ(*,'(A1)') ANS
            RETURN
         ELSE
            CALL BLOWUP(JMON,DNUM,IYEAR)
            GOTO 10
         ENDIF
      ENDIF
  890 CONTINUE
      CALL BELL
      GOTO 50
      END
C
C
C
      SUBROUTINE SUMMAR
C
C           THIS ROUTINE WILL PRINT NAMES&DATES REPORT
C
      COMMON/REVNO/ PGM,AUTHOR,YEAR,DATE,REV
      CHARACTER PGM*21,AUTHOR*21,YEAR*4,DATE*8,REV*2
C
      COMMON/MAIN1/LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
      CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
      CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
      CHARACTER PH1(200)*14,PH2(200)*14
C
      COMMON/MAIN2/ STRID,JULIAN,MNUM
      INTEGER STRID(200),JULIAN(366,5),MNUM
C
      COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
      CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
C
      INTEGER UNIT,PAGE
C
C          SET UP PRINTER
C
      UNIT=6
      PAGE=0
      LINE=0
      IV=21
      IH=1
      CALL MOVEIT(IH,IV)
      CALL BOLD
      CALL BLINK
      WRITE(*,'(A25)') 'Please Wait ... Printing '
      OPEN(UNIT,FILE='PRN')
C
C          PRINT ONLY THE DATA WE HAVE
C
      DO 500 I=1,200
      IF(NAME(1,I).NE.' '.OR.ANIV(I).NE.' '.OR.BDAY(1,I).NE.' '.OR.
     A   XMAS(1,I).NE.' '.OR.XMAS(7,I).NE.' ') THEN
         IF(LINE.LE.0) THEN
            LINE=8
            CALL SWIDTH(UNIT)
            WRITE(UNIT,'(X)')
            CALL PHEAD(PAGE,UNIT,PGM,DATE,YEAR,REV)
            CALL WWIDTH(UNIT)
            WRITE(UNIT,100)
  100       FORMAT(//,
     A        /,5X,' Last Name               Mailing Address        ',
     B             '           Birthdays          Xmas Cards Sent   ',
     C             '  Xmas Cards Rec"d ',
     D        /,5X,'------------    --------------------------------',
     E             '    ---------------------    -----------------  ',
     F             '  -----------------')
         ENDIF
         LINE=LINE-1
         CALL MATCH(I,KCODE)
         WRITE(UNIT,200) (LAST(M,KCODE),M=1,12),
     A      FIRST(KCODE),ANIV(I),BDAY(1,I),NAME(1,I),
     B      (XMAS(M,I),M=1,12),
     C      ADD1(KCODE),BDAY(2,I),NAME(2,I)
  200    FORMAT(5X,12A1,4X,A23,1X,A8,4X,A8,' ',A12,2(4X,5(A2,','),A2),
     A      /,21X,A30,6X,A8,' ',A12)
C
C            IF SECOND ADDRESS BLANK, THEN DON'T PRINT A SPACE
C
         IF(ADD2(KCODE).NE.' ') THEN
            WRITE(UNIT,250) ADD2(KCODE),BDAY(3,I),NAME(3,I),
     A         CITY(KCODE),STATE(KCODE),ZIP(KCODE),BDAY(4,I),NAME(4,I),
     B         BDAY(5,I),NAME(5,I),BDAY(6,I),NAME(6,I)
  250       FORMAT(21X,A30,6X,A8,' ',A12,
     A        /,21X,A23,1X,A2,1X,A5,4X,A8,' ',A12,
     B        /,21X,36X,A8,' ',A12,
     C        /,21X,36X,A8,' ',A12)
         ELSE
            WRITE(UNIT,300) CITY(KCODE),
     A         STATE(KCODE),ZIP(KCODE),BDAY(3,I),NAME(3,I),
     B         BDAY(4,I),NAME(4,I),BDAY(5,I),NAME(5,I),
     C         BDAY(6,I),NAME(6,I)
  300       FORMAT(
     A          21X,A23,1X,A2,1X,A5,4X,A8,' ',A12,
     B        /,21X,36X,A8,' ',A12,
     C        /,21X,36X,A8,' ',A12,
     D        /,21X,36X,A8,' ',A12)
         ENDIF
      ENDIF
  500 CONTINUE
      CALL SWIDTH(UNIT)
      CLOSE(UNIT)
      RETURN
      END
C
C
C
      SUBROUTINE BLOWUP(JMON,DNUM,IYEAR)
C
C         THIS ROUTINE LISTS ANY SINGLE DAY TO THE SCREEN
C
      COMMON/MAIN1/LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
      CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
      CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
      CHARACTER PH1(200)*14,PH2(200)*14
C
      COMMON/MAIN2/ STRID,JULIAN,MNUM
      INTEGER STRID(200),JULIAN(366,5),MNUM
C
      COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
      CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
C
      INTEGER DNUM,CNT
      CHARACTER TYPE*6,TEMP*80
      CHARACTER RAMDSK*80,CALEN*8,DAY(7)*3,IMON(12)*6,ANS*1
C
      DATA DAY/'Sun','Mon','Tue','Wed','Thr','Fri','Sat'/
      DATA IMON/' Jan  ',' Feb  ',' March',' April',' May  ',' June ',
     A          ' July ',' Aug  ',' Sept ',' Oct  ',' Nov  ',' Dec  '/
C
C         ASK WHICH DAY TO BLOW-UP
C
   50 CONTINUE
      IV=23
      IH=1
      CALL MOVEIT(IH,IV)
      WRITE(*,75) 'Enter Day to See in Detail (1-',DNUM,'): '
   75 FORMAT(15X,A30,I2,A3,\)
         READ(*,'(I2)',ERR=890) JDAY
         IF(JDAY.EQ.0) RETURN
         IF(JDAY.GT.0 .AND. JDAY.LE.DNUM) THEN
            WRITE(RAMDSK,'(I2,A1,I2,A1,I2)') JMON,'/',JDAY,'/',IYEAR
            READ(RAMDSK,'(A8)') CALEN
            CALL DATEDW(CALEN,IDOW)
            IF(IDOW.GT.0) THEN
C
C                   GO FIND OUT IF THE MATCHES ARE B'DAYS OR ANIV.
C
               CNT=0
               LHIT=0
               CALL DATEJL(CALEN,IJUL)
               DO 500 K=1,5
               IHIT=JULIAN(IJUL,K)
               IF(IHIT.LE.0) GOTO 500
               IF(IHIT.EQ.LHIT) GOTO 300
C
C                   FIRST, SEE IF POINTER IS FOR ANNIVERSARY
C
               LHIT=IHIT
               CALL FINDA(IHIT,JMON,JDAY,LINE)
               IF(LINE.EQ.0) THEN
                  CALL MATCH(IHIT,KCODE)
                  CALL BOLD
                  CALL MOVEIT(IH,IV)
                  WRITE(RAMDSK,200) DAY(IDOW),CALEN,'Anniversary, ',
     A                         FIRST(KCODE),(LAST(L,KCODE),L=1,12) 
  200             FORMAT(A3,', ',A8,' ... ',A13,A23,12A1)
                  CALL SQUISH(RAMDSK,66)
                  TYPE='CENTER'
                  CALL JUSTIF(TYPE,RAMDSK,66)
                  WRITE(*,'(7X,A66,\)') RAMDSK
                  READ(*,'(A1)') ANS
                  CALL OFF
                  GOTO 500
               ENDIF
C
C                   NOW, LOOK FOR ALL BIRTHDAYS
C
  300          CONTINUE
               LHIT=IHIT
               CNT=CNT+1
               CALL FINDB(CNT,IHIT,JMON,JDAY,LINE)
C
C                 CHECK TO SEE IF IT WAS A BIRTHDAY
C
               IF(LINE.GT.0) THEN
                  CALL MATCH(IHIT,KCODE)
                  CALL BOLD
                  CALL MOVEIT(IH,IV)
                  WRITE(RAMDSK,350) DAY(IDOW),CALEN,'Birthday, ',
     A                         NAME(LINE,IHIT),(LAST(L,KCODE),L=1,12) 
  350             FORMAT(A3,', ',A8,' ... ',A10,A12,12A1)
                  CALL SQUISH(RAMDSK,52)
                  TYPE='CENTER'
                  CALL JUSTIF(TYPE,RAMDSK,52)
                  WRITE(*,'(7X,A52,\)') RAMDSK
                  READ(*,'(A1)') ANS
                  CALL OFF
               ELSEIF(CNT.LT.6) THEN
                  GOTO 300
               ENDIF
  500          CONTINUE
               GOTO 50
            ENDIF
         ENDIF
  890 CONTINUE
      CALL BELL
      GOTO 50
      END
C
C
C
      SUBROUTINE MATCH(I,KCODE)
C
C           WILL FIND MATCHING LAST NAME, BY USING STRUCTURE ID
C
      COMMON/MAIN2/ STRID,JULIAN,MNUM
      INTEGER STRID(200),JULIAN(366,5),MNUM
C
      KCODE=0
      DO 100 K=1,MNUM
      IF(STRID(K).EQ.I) THEN
         KCODE=K
         RETURN
      ENDIF
  100 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE FINDA(IHIT,JMON,JDAY,LINE)
C
C           WILL FIND MATCHING ANNIVERSARIES FOR SELECTED DAY
C
      COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
      CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
C
      CHARACTER RAMDSK*80
C
C            SEARCH NAMES & DATES AND DETERMINE IF ITS AN
C            ANNIVERSARY OR A BIRTHDAY THAT MATCHES
C
      LINE=-1
      WRITE(RAMDSK,'(A8)') ANIV(IHIT)
      READ(RAMDSK,'(I2,1X,I2)',ERR=900) IMON,IDAY
      IF(IMON.EQ.JMON .AND. IDAY.EQ.JDAY) THEN
         LINE=0
         RETURN
      ENDIF
  900 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE FINDB(LOC,IHIT,JMON,JDAY,LINE)
C
C           WILL FIND MATCHING BIRTHDAYS FOR SELECTED DAY
C
      COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
      CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
C
      CHARACTER RAMDSK*80
C
C            SEARCH NAMES & DATES AND DETERMINE IF ITS 
C            A BIRTHDAY THAT MATCHES
C
      LINE=-1
      WRITE(RAMDSK,'(A8)') BDAY(LOC,IHIT)
      READ(RAMDSK,'(I2,1X,I2)',ERR=900) IMON,IDAY
      IF(IMON.EQ.JMON .AND. IDAY.EQ.JDAY) THEN
         LINE=LOC
         RETURN
      ENDIF
  900 CONTINUE
      RETURN
      END