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

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.