C C IMPORTANT NAMES & DATES by Bruce W. Roeckel C *--------------------------* C $STORAGE:2 C 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 COMMON /REVNO/ PGM,AUTHOR,YEAR,DATE,REV CHARACTER PGM*21,AUTHOR*21,YEAR*4,DATE*8,REV*2 C COMMON/LETT/ALPHA,ALPH2 CHARACTER*1 ALPHA(26),ALPH2(26) C CHARACTER OPTION*25,TEST*8,KEY*1,SEL*2 LOGICAL*2 CHECK C C SET UP COMMON BLOCK OF ALPHABET C ALPHA(1)='A' ALPHA(2)='B' ALPHA(3)='C' ALPHA(4)='D' ALPHA(5)='E' ALPHA(6)='F' ALPHA(7)='G' ALPHA(8)='H' ALPHA(9)='I' ALPHA(10)='J' ALPHA(11)='K' ALPHA(12)='L' ALPHA(13)='M' ALPHA(14)='N' ALPHA(15)='O' ALPHA(16)='P' ALPHA(17)='Q' ALPHA(18)='R' ALPHA(19)='S' ALPHA(20)='T' ALPHA(21)='U' ALPHA(22)='V' ALPHA(23)='W' ALPHA(24)='X' ALPHA(25)='Y' ALPHA(26)='Z' ALPH2(1)='a' ALPH2(2)='b' ALPH2(3)='c' ALPH2(4)='d' ALPH2(5)='e' ALPH2(6)='f' ALPH2(7)='g' ALPH2(8)='h' ALPH2(9)='i' ALPH2(10)='j' ALPH2(11)='k' ALPH2(12)='l' ALPH2(13)='m' ALPH2(14)='n' ALPH2(15)='o' ALPH2(16)='p' ALPH2(17)='q' ALPH2(18)='r' ALPH2(19)='s' ALPH2(20)='t' ALPH2(21)='u' ALPH2(22)='v' ALPH2(23)='w' ALPH2(24)='x' ALPH2(25)='y' ALPH2(26)='z' C C DISPLAY ROCKSOFT HEADER C PGM='Names & Dates ' AUTHOR='Bruce W. Roeckel ' YEAR='1986' REV='05' CALL MHEAD(PGM,AUTHOR,YEAR,REV,DATE) CALL TOP(PGM,DATE) C C READ THE DATABASE INTO CORE C CALL RDMAST CALL RDDATE CALL FILLUP C C CHECK FOR HELP DOCUMENT FILE C IHLP=0 INQUIRE(FILE='NAMES.HLP',EXIST=CHECK) IF(CHECK .EQV. .TRUE.) THEN IHLP=1 OPEN(15,FILE='NAMES.HLP') ENDIF C C NOW DISPLAY MAIN MENU C 100 CONTINUE OPTION='Main Menu' CALL HEADER(OPTION) WRITE(*,150) 150 FORMAT(/,3X,'Total Entries in', A /,3X,'Master File: ',\) CALL BOLD WRITE(*,'(I3)') MNUM CALL OFF WRITE(*,200) 200 FORMAT( A ////,20X,' 1. Browse Entire Master File ', B /,20X,' 2. Edit Names & Dates Info ', C /,20X,' 3. Display Monthly Calendar ', D /,20X,' 4. Print Names & Dates Data ') C C ASK FOR SELECTION, THEN BRANCH BASED ON INPUT C 300 CONTINUE IV=21 IH=1 CALL MOVEIT(IH,IV) WRITE(*,'(/,5X,A37,\)') 'Enter Menu Choice (H=Help, Q=Quit) : ' READ(*,'(A2)',ERR=100) SEL CALL OFF IF (SEL.EQ.' ') THEN GOTO 300 ELSEIF((SEL.EQ.'H') .OR. (SEL.EQ.'h')) THEN KEY=' ' LU=15 CALL HELP(KEY,LU) ELSEIF(SEL.EQ.'1') THEN CALL LOOK ELSEIF(SEL.EQ.'2') THEN CALL UPDATE ELSEIF(SEL.EQ.'3') THEN CALL CALEND ELSEIF(SEL.EQ.'4') THEN CALL SUMMAR ELSEIF((SEL.EQ.'Q') .OR. (SEL.EQ.'q')) THEN IF(IHLP.EQ.1) CLOSE(15) CALL CLS STOP ENDIF GOTO 100 END C C C SUBROUTINE RDMAST 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 CHARACTER*25 OPTION C C OPEN FILE FOR INPUT C OPTION='Loading Master File .....' CALL HEADER(OPTION) CALL KEYOFF OPEN(20,FILE='ADDRESS.DAT') C C READ ALL DATA FROM MASTER FILE C I=0 100 CONTINUE I=I+1 IF(I.GT.200) THEN WRITE(*,'(A33)') 'Program Aborted Reading Master ' STOP ENDIF READ(20,200,END=300) (LAST(K,I),K=1,12), A FIRST(I),ADD1(I),ADD2(I),CITY(I), A STATE(I),ZIP(I),PH1(I),PH2(I), A STRID(I) 200 FORMAT(12A1,A23,A30,A30,A23,A2,A5,A14,A14,8X,I3) GOTO 100 300 CONTINUE MNUM=I-1 CLOSE(20) CALL KEYON RETURN END C C C SUBROUTINE RDDATE C C THIS ROUTINE READS IN THE NAMES&DATES DATABASE 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 OPTION*25 C C OPEN FILE FOR INPUT C OPTION='Loading Names & Dates ...' CALL HEADER(OPTION) CALL KEYOFF C C CLEAR ARRAYS FIRST C DO 20 K=1,200 ANIV(K)=' ' DO 20 J=1,6 NAME(J,K)=' ' BDAY(J,K)=' ' XMAS(J,K)=' ' XMAS(J+6,K)=' ' 20 CONTINUE OPEN(20,FILE='NAMES.DAT') C C READ ALL DATA FROM FILE C 100 CONTINUE READ(20,200,END=300) I,(NAME(K,I),K=1,6), A (BDAY(K,I),K=1,6), B (XMAS(K,I),K=1,12),ANIV(I) 200 FORMAT(I3,6A12,6A8,12A2,A8) GOTO 100 300 CONTINUE CLOSE(20) CALL KEYON RETURN END C C C SUBROUTINE FILLUP C C THIS ROUTINE CALCULATES THE JULIAN DATES 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 COMMON /REVNO/ PGM,AUTHOR,YEAR,DATE,REV CHARACTER PGM*21,AUTHOR*21,YEAR*4,DATE*8,REV*2 C CHARACTER OPTION*25,TDATE*8 C C DISPLAY MESSAGE TO SCREEN C OPTION='Calculating Julian Dates ' CALL HEADER(OPTION) CALL KEYOFF C C EXTRACT THE YEAR FROM TODAYS DATE C WRITE(OPTION,'(A8)') DATE READ(OPTION,'(6X,I2)') IYY C C CLEAR JULIAN DATE ARRAY FIRST C DO 10 K=1,366 DO 10 L=1,5 JULIAN(K,L)=0 10 CONTINUE C C BUZZ THROUGH ENTIRE DATABASE, STORE STRUCTURE ID IN ARRAY C DO 300 I=1,200 DO 250 L=1,7 IF(L.LE.6) THEN IF(BDAY(L,I).EQ.' ') GOTO 250 WRITE(OPTION,'(A8)') BDAY(L,I) ELSE IF(ANIV(I).EQ.' ') GOTO 250 WRITE(OPTION,'(A8)') ANIV(I) ENDIF READ(OPTION,'(I2,1X,I2)',ERR=250) IMM,IDD WRITE(OPTION,'(I2,A1,I2,A1,I2)') IMM,'/',IDD,'/',IYY READ(OPTION,'(A8)') TDATE C C GO GET THE JULIAN EQUIVILANT DATE C CALL DATEJL(TDATE,IDAY) IF(IDAY.LE.0) THEN WRITE(*,'(///,10X,A26)') 'JULIAN DATE MISCALCULATION' WRITE(*,'(4I4,A10)') I,L,IYY,IDAY,TDATE STOP ENDIF C C FIND NEXT AVAILABLE SLOT IN ARRAY FOR STORAGE C DO 230 M=1,5 IF(JULIAN(IDAY,M).EQ.0) THEN JULIAN(IDAY,M) = I GOTO 250 ENDIF 230 CONTINUE WRITE(*,'(///,10X,A27)') 'OUT OF ARRAY SPACE - JULIAN' STOP 250 CONTINUE 300 CONTINUE CALL KEYON RETURN END C C C SUBROUTINE WRDATE 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*25 OPTION C C OPEN FILE FOR OUTPUT C OPTION='Storing Names & Dates ...' CALL HEADER(OPTION) CALL KEYOFF OPEN(20,FILE='NAMES.DAT') C C STORE ALL DATA IN FILE C DO 200 I=1,200 IF(NAME(1,I).NE.' '.OR.XMAS(1,I).NE.' '.OR.XMAS(7,I).NE.' '.OR. A BDAY(1,I).NE.' '.OR.ANIV(I).NE.' ') THEN WRITE(20,100) I,(NAME(K,I),K=1,6), A (BDAY(K,I),K=1,6), B (XMAS(K,I),K=1,12),ANIV(I) 100 FORMAT(I3,6A12,6A8,12A2,A8) ENDIF 200 CONTINUE CLOSE(20) CALL KEYON RETURN END