home *** CD-ROM | disk | FTP | other *** search
/ ftp.update.uu.se / ftp.update.uu.se.2014.03.zip / ftp.update.uu.se / pub / rainbow / msdos / decus / RB113 / names.for < prev    next >
Text File  |  1995-05-28  |  8KB  |  348 lines
  1. C
  2. C         IMPORTANT NAMES & DATES         by Bruce W. Roeckel
  3. C       *--------------------------*                         
  4. C
  5. $STORAGE:2
  6. C
  7. C
  8.       COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
  9.       CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
  10.       CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
  11.       CHARACTER PH1(200)*14,PH2(200)*14
  12. C
  13.       COMMON/MAIN2/ STRID,JULIAN,MNUM
  14.       INTEGER STRID(200),JULIAN(366,5),MNUM
  15. C
  16.       COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
  17.       CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
  18. C
  19.       COMMON /REVNO/ PGM,AUTHOR,YEAR,DATE,REV
  20.       CHARACTER PGM*21,AUTHOR*21,YEAR*4,DATE*8,REV*2
  21. C
  22.       COMMON/LETT/ALPHA,ALPH2
  23.       CHARACTER*1 ALPHA(26),ALPH2(26)
  24. C
  25.       CHARACTER OPTION*25,TEST*8,KEY*1,SEL*2
  26.       LOGICAL*2 CHECK
  27. C
  28. C           SET UP COMMON BLOCK OF ALPHABET
  29. C
  30.       ALPHA(1)='A'
  31.       ALPHA(2)='B'
  32.       ALPHA(3)='C'
  33.       ALPHA(4)='D'
  34.       ALPHA(5)='E'
  35.       ALPHA(6)='F'
  36.       ALPHA(7)='G'
  37.       ALPHA(8)='H'
  38.       ALPHA(9)='I'
  39.       ALPHA(10)='J'
  40.       ALPHA(11)='K'
  41.       ALPHA(12)='L'
  42.       ALPHA(13)='M'
  43.       ALPHA(14)='N'
  44.       ALPHA(15)='O'
  45.       ALPHA(16)='P'
  46.       ALPHA(17)='Q'
  47.       ALPHA(18)='R'
  48.       ALPHA(19)='S'
  49.       ALPHA(20)='T'
  50.       ALPHA(21)='U'
  51.       ALPHA(22)='V'
  52.       ALPHA(23)='W'
  53.       ALPHA(24)='X'
  54.       ALPHA(25)='Y'
  55.       ALPHA(26)='Z'
  56.       ALPH2(1)='a'
  57.       ALPH2(2)='b'
  58.       ALPH2(3)='c'
  59.       ALPH2(4)='d'
  60.       ALPH2(5)='e'
  61.       ALPH2(6)='f'
  62.       ALPH2(7)='g'
  63.       ALPH2(8)='h'
  64.       ALPH2(9)='i'
  65.       ALPH2(10)='j'
  66.       ALPH2(11)='k'
  67.       ALPH2(12)='l'
  68.       ALPH2(13)='m'
  69.       ALPH2(14)='n'
  70.       ALPH2(15)='o'
  71.       ALPH2(16)='p'
  72.       ALPH2(17)='q'
  73.       ALPH2(18)='r'
  74.       ALPH2(19)='s'
  75.       ALPH2(20)='t'
  76.       ALPH2(21)='u'
  77.       ALPH2(22)='v'
  78.       ALPH2(23)='w'
  79.       ALPH2(24)='x'
  80.       ALPH2(25)='y'
  81.       ALPH2(26)='z'
  82. C
  83. C           DISPLAY ROCKSOFT HEADER
  84. C
  85.       PGM='Names & Dates        '
  86.       AUTHOR='Bruce W. Roeckel     '
  87.       YEAR='1986'
  88.       REV='05'
  89.       CALL MHEAD(PGM,AUTHOR,YEAR,REV,DATE)
  90.       CALL TOP(PGM,DATE)
  91. C
  92. C           READ THE DATABASE INTO CORE
  93. C
  94.       CALL RDMAST
  95.       CALL RDDATE
  96.       CALL FILLUP
  97. C
  98. C           CHECK FOR HELP DOCUMENT FILE
  99. C
  100.       IHLP=0
  101.       INQUIRE(FILE='NAMES.HLP',EXIST=CHECK)
  102.       IF(CHECK .EQV. .TRUE.) THEN
  103.          IHLP=1
  104.          OPEN(15,FILE='NAMES.HLP')
  105.       ENDIF
  106. C
  107. C           NOW DISPLAY MAIN MENU
  108. C
  109.   100 CONTINUE
  110.       OPTION='Main Menu'
  111.       CALL HEADER(OPTION)
  112.          WRITE(*,150)
  113.   150    FORMAT(/,3X,'Total Entries in',
  114.      A          /,3X,'Master File: ',\)
  115.          CALL BOLD
  116.          WRITE(*,'(I3)') MNUM
  117.          CALL OFF
  118.       WRITE(*,200) 
  119.   200 FORMAT(  
  120.      A    ////,20X,' 1. Browse Entire Master File   ',
  121.      B       /,20X,' 2. Edit Names & Dates Info     ',
  122.      C       /,20X,' 3. Display Monthly Calendar    ',
  123.      D       /,20X,' 4. Print Names & Dates Data    ')
  124. C
  125. C            ASK FOR SELECTION, THEN BRANCH BASED ON INPUT
  126. C
  127.   300 CONTINUE
  128.       IV=21
  129.       IH=1
  130.       CALL MOVEIT(IH,IV)
  131.       WRITE(*,'(/,5X,A37,\)') 'Enter Menu Choice (H=Help, Q=Quit) : '
  132.          READ(*,'(A2)',ERR=100) SEL 
  133.          CALL OFF
  134.          IF (SEL.EQ.' ') THEN
  135.             GOTO 300
  136.          ELSEIF((SEL.EQ.'H') .OR. (SEL.EQ.'h')) THEN
  137.             KEY=' '
  138.             LU=15
  139.             CALL HELP(KEY,LU)
  140.          ELSEIF(SEL.EQ.'1') THEN
  141.             CALL LOOK
  142.          ELSEIF(SEL.EQ.'2') THEN
  143.             CALL UPDATE
  144.          ELSEIF(SEL.EQ.'3') THEN
  145.             CALL CALEND
  146.          ELSEIF(SEL.EQ.'4') THEN
  147.             CALL SUMMAR
  148.          ELSEIF((SEL.EQ.'Q') .OR. (SEL.EQ.'q')) THEN
  149.             IF(IHLP.EQ.1) CLOSE(15)
  150.             CALL CLS
  151.             STOP
  152.          ENDIF
  153.       GOTO 100
  154.       END
  155. C
  156. C
  157. C
  158.       SUBROUTINE RDMAST
  159. C
  160.       COMMON/MAIN1/ LAST,FIRST,ADD1,ADD2,CITY,STATE,ZIP,PH1,PH2
  161.       CHARACTER LAST(12,200)*1,FIRST(200)*23,ADD1(200)*30,ADD2(200)*30
  162.       CHARACTER CITY(200)*23,STATE(200)*2,ZIP(200)*5
  163.       CHARACTER PH1(200)*14,PH2(200)*14
  164. C
  165.       COMMON/MAIN2/ STRID,JULIAN,MNUM
  166.       INTEGER STRID(200),JULIAN(366,5),MNUM
  167. C
  168.       CHARACTER*25 OPTION
  169. C
  170. C            OPEN FILE FOR INPUT
  171. C
  172.       OPTION='Loading Master File .....'
  173.       CALL HEADER(OPTION)
  174.       CALL KEYOFF
  175.       OPEN(20,FILE='ADDRESS.DAT')
  176. C
  177. C            READ ALL DATA FROM MASTER FILE
  178. C
  179.       I=0
  180.   100 CONTINUE
  181.       I=I+1
  182.       IF(I.GT.200) THEN
  183.          WRITE(*,'(A33)') 'Program Aborted Reading Master   '
  184.          STOP
  185.       ENDIF
  186.       READ(20,200,END=300) (LAST(K,I),K=1,12),
  187.      A                     FIRST(I),ADD1(I),ADD2(I),CITY(I),
  188.      A                     STATE(I),ZIP(I),PH1(I),PH2(I),
  189.      A                     STRID(I)
  190.   200 FORMAT(12A1,A23,A30,A30,A23,A2,A5,A14,A14,8X,I3)
  191.       GOTO 100
  192.   300 CONTINUE
  193.       MNUM=I-1
  194.       CLOSE(20)
  195.       CALL KEYON
  196.       RETURN
  197.       END
  198. C
  199. C
  200. C
  201.       SUBROUTINE RDDATE
  202. C
  203. C               THIS ROUTINE READS IN THE NAMES&DATES DATABASE
  204. C
  205.       COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
  206.       CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
  207. C
  208.       CHARACTER OPTION*25
  209. C
  210. C            OPEN FILE FOR INPUT
  211. C
  212.       OPTION='Loading Names & Dates ...'
  213.       CALL HEADER(OPTION)
  214.       CALL KEYOFF
  215. C
  216. C            CLEAR ARRAYS FIRST
  217. C
  218.       DO 20 K=1,200
  219.       ANIV(K)=' '
  220.       DO 20 J=1,6
  221.       NAME(J,K)=' '
  222.       BDAY(J,K)=' '
  223.       XMAS(J,K)=' '
  224.       XMAS(J+6,K)=' '
  225.    20 CONTINUE
  226.       OPEN(20,FILE='NAMES.DAT')
  227. C
  228. C            READ ALL DATA FROM FILE
  229. C
  230.   100 CONTINUE
  231.       READ(20,200,END=300) I,(NAME(K,I),K=1,6),
  232.      A                       (BDAY(K,I),K=1,6),
  233.      B                       (XMAS(K,I),K=1,12),ANIV(I)
  234.   200 FORMAT(I3,6A12,6A8,12A2,A8)
  235.       GOTO 100
  236.   300 CONTINUE
  237.       CLOSE(20)
  238.       CALL KEYON
  239.       RETURN
  240.       END
  241. C
  242. C
  243. C
  244.       SUBROUTINE FILLUP
  245. C
  246. C               THIS ROUTINE CALCULATES THE JULIAN DATES      
  247. C
  248.       COMMON/MAIN2/ STRID,JULIAN,MNUM
  249.       INTEGER STRID(200),JULIAN(366,5),MNUM
  250. C
  251.       COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
  252.       CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
  253. C
  254.       COMMON /REVNO/ PGM,AUTHOR,YEAR,DATE,REV
  255.       CHARACTER PGM*21,AUTHOR*21,YEAR*4,DATE*8,REV*2
  256. C
  257.       CHARACTER OPTION*25,TDATE*8
  258. C
  259. C            DISPLAY MESSAGE TO SCREEN
  260. C
  261.       OPTION='Calculating Julian Dates '
  262.       CALL HEADER(OPTION)
  263.       CALL KEYOFF
  264. C
  265. C            EXTRACT THE YEAR FROM TODAYS DATE
  266. C
  267.       WRITE(OPTION,'(A8)') DATE
  268.       READ(OPTION,'(6X,I2)') IYY
  269. C
  270. C            CLEAR JULIAN DATE ARRAY FIRST
  271. C
  272.       DO 10 K=1,366
  273.       DO 10 L=1,5
  274.       JULIAN(K,L)=0
  275.    10 CONTINUE
  276. C
  277. C            BUZZ THROUGH ENTIRE DATABASE, STORE STRUCTURE ID IN ARRAY
  278. C
  279.       DO 300 I=1,200
  280.       DO 250 L=1,7
  281.       IF(L.LE.6) THEN
  282.          IF(BDAY(L,I).EQ.' ') GOTO 250
  283.          WRITE(OPTION,'(A8)') BDAY(L,I)
  284.       ELSE
  285.          IF(ANIV(I).EQ.' ') GOTO 250
  286.          WRITE(OPTION,'(A8)') ANIV(I)
  287.       ENDIF
  288.       READ(OPTION,'(I2,1X,I2)',ERR=250) IMM,IDD
  289.       WRITE(OPTION,'(I2,A1,I2,A1,I2)') IMM,'/',IDD,'/',IYY
  290.       READ(OPTION,'(A8)') TDATE
  291. C
  292. C           GO GET THE JULIAN EQUIVILANT DATE
  293. C
  294.       CALL DATEJL(TDATE,IDAY)
  295.       IF(IDAY.LE.0) THEN    
  296.          WRITE(*,'(///,10X,A26)') 'JULIAN DATE MISCALCULATION'
  297.          WRITE(*,'(4I4,A10)') I,L,IYY,IDAY,TDATE
  298.          STOP
  299.       ENDIF
  300. C
  301. C           FIND NEXT AVAILABLE SLOT IN ARRAY FOR STORAGE
  302. C
  303.       DO 230 M=1,5
  304.       IF(JULIAN(IDAY,M).EQ.0) THEN
  305.          JULIAN(IDAY,M) = I
  306.          GOTO 250
  307.       ENDIF
  308.   230 CONTINUE
  309.       WRITE(*,'(///,10X,A27)') 'OUT OF ARRAY SPACE - JULIAN'
  310.       STOP
  311.   250 CONTINUE
  312.   300 CONTINUE
  313.       CALL KEYON
  314.       RETURN
  315.       END
  316. C
  317. C
  318. C
  319.       SUBROUTINE WRDATE
  320. C
  321.       COMMON/MAIN3/ NAME,ANIV,BDAY,XMAS
  322.       CHARACTER NAME(6,200)*12,ANIV(200)*8,BDAY(6,200)*8,XMAS(12,200)*2
  323. C
  324.       CHARACTER*25 OPTION
  325. C
  326. C            OPEN FILE FOR OUTPUT
  327. C
  328.       OPTION='Storing Names & Dates ...'
  329.       CALL HEADER(OPTION)
  330.       CALL KEYOFF
  331.       OPEN(20,FILE='NAMES.DAT')
  332. C
  333. C            STORE ALL DATA IN FILE
  334. C
  335.       DO 200 I=1,200
  336.       IF(NAME(1,I).NE.' '.OR.XMAS(1,I).NE.' '.OR.XMAS(7,I).NE.' '.OR.  
  337.      A   BDAY(1,I).NE.' '.OR.ANIV(I).NE.' ') THEN
  338.          WRITE(20,100) I,(NAME(K,I),K=1,6),
  339.      A                   (BDAY(K,I),K=1,6),
  340.      B                   (XMAS(K,I),K=1,12),ANIV(I)
  341.   100    FORMAT(I3,6A12,6A8,12A2,A8)
  342.       ENDIF   
  343.   200 CONTINUE
  344.       CLOSE(20)
  345.       CALL KEYON
  346.       RETURN
  347.       END
  348.