      BLOCK DATA
C     RENBR(/FIXED INFORMATION FOR CALENDAR PROGRAM)
C
C     DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C     CHARACTERS TO SHIFT DIABLO TYPING 1/120 INCH FOR BOLDING
      COMMON/CALONE/LTRDRK(7)
C
C     LTRDRK = SEQUENCE TO MOVER DIABLO PRINTHEAD 1/120 INCH
C     THIS IS DONE BY CHANGING WIDTH OF EACH CHARACTER TO 1/120 INCH
C     TYPING A SPACE, THEN CHANGING WIDTH BACK TO 1/12 INCH
C     ESC, ^- OR US, ^B, SPACE, ESC, ^-, VT OR WHATEVER HAS CODE 11
      DATA LTRDRK/
     1"155004020100,"175004020100,"011004020100,
     21H ,
     3"155004020100,"175004020100,"055004020100/
      END
C     RENBR(WEEKLY/MERGE DAILY SCHEDULES INTO WEEKLY SCHEDULE)
C
C     DONALD BARTH, YALE UNIVERSITY, SOM
C
C     THIS PROGRAM READS 6 FILES CONTAINING DAILY SCHEDULES
C     FOR THE DAYS MONDAY THROUGH SATURDAY.  THE FIRST LINE
C     IN EACH FILE FOR A PARTICULAR TIME SHOULD CONTAIN THAT
C     TIME IN THE FORM HH:MM AT THE START OF THE LINE.
C     THE PROGRAM WILL SORT THROUGH THE FILES, PUTTING THE
C     INFORMATION FOR A PARTICULAR TIME TOGETHER ON THE SAME
C     LINE IN THE OUTPUT.  EACH LINE OF THE DAILY FILES SHOULD
C     BE NO WIDER THAN 25 CHARACTERS.
C
C     FOLLOWING STORE INFORMATION ABOUT EACH COLUMN
C     LNGCLM = NUMBER OF LINS STORED FOR EACH COLUMN
C     KLOSE  = CLOSING TIME BEING REPRESENTED IN EACH COLUMN
C     NOWLIN = LINE NUMBER TO NEXT BE REPRESENTED IN EACH COLUMN
C     JFBOLD = 0 IF NORMAL DENSITY, 1 IF DARK
C     DIMENSION LNGCLM(LMTCLM),NOWLIN(LMTCLM)
      DIMENSION LNGCLM(7),KLOSE(7),NOWLIN(7),JFBOLD(7)
C
C     FOLLOWING STORES INFORMATION ABOUT EACH LINE IN EACH COLUMN
C     ITIME  = STARTING TIME IF ONE IS GIVEN, -1 OTHERWISE
C     JTIME  = ENDING TIME IF ONE IS GIVEN, -1 OTHERWISE
C     KTIME  = FOR WEEKENDS, 0=SATURDAY EVENT, 1=SUNDAY, 2=BOTH DAYS
C     IFBOLD = 0 FOR NORMAL LINES, 1 FOR BOLD LINES
C     DIMENSION ITIME(LMTCLM,LMTLIN),JTIME(LMTCLM,LMTLIN)
      DIMENSION ITIME(7,500),JTIME(7,500),KTIME(500),IFBOLD(7,500)
C
C     FOLLOWING STORES PORTION OF SINGLE LINE IN SINGLE COLUMN
C     WHILE THIS IS A1 PACKED BEFORE IT IS A5 PACKED
C     DIMENSION LTRONE(LMTWRD*LMTBYT)
      DIMENSION LTRONE(25)
C
C     FOLLOWING STORES A SINGLE OUTPUT LINE
C     DIMENSION LTRLIN((LMTWRD*LMTBYT*LMTCLM)+LMTCLM)
      DIMENSION LTRLIN(182)
C
C     FOLLOWING STORE CHARACTERS PACKED 5 PER COMPUTER WORD
C     LA5ONE = STORES CHARACTERS ON 1 LINE IN A SINGLE COLUMN
C              BEFORE THESE ARE STORED IN LA5ALL ARRAY
C     LA5LIN = ACCUMULATES A SINGLE OUTPUT LINE FOR ALL COLUMNS
C     LA5ALL = STORES ENTIRE SCHEDULE FOR 1 WEEK
C     DIMENSION LA5ONE(LMTWRD),LA5LIN(LMTWRD*LMTCLM),
C    1LA5ALL(LMTCLM,LMTWRD,LMTLIN)
      DIMENSION LA5ONE(5),LA5LIN(35),LA5ALL(7,5,500)
C
C     FOLLOWING STORE CHARACTERS USED IN CONSTRUCTIONS
C     LTRDGT = THE DIGITS ZERO THROUGH NINE
C     LTRMTH = THE 3 LETTER ABBREVIATIONS OF THE MONTHS
      DIMENSION LTRDGT(10),LTRMTH(36),LWRMTH(36),LTRDAY(24),
     1LTREND(29),LNGEND(3),LTRAM(5),LWRAM(5),LNGAM(3)
C
C     LTRDAT = ARRAY INTO WHICH STARTING DATE IS READ
C     LTRPRF = ARRAY INTO WHICH EACH LINE OF PROFILE FILE IS READ
C     LTRFIL = ARRAY IN WHICH FILE NAME IS CONSTRUCTED
C     LTRRAW  = ARRAY INTO WHICH EACH LINE OF SCHEDULE IS READ
C     EACH LINE IS READ INTO LTRRAW, TIME STAMPS STRIPPED OFF AND
C     STORED IN LTRONE, PACKED INTO LTRCLM, THEN STORED IN LA5ALL
C     UNTIL PRINTING WHEN AN OUTPUT LINE IS CONSTRUCTED IN LA5LIN.
C     LTRTOP = ARRAY USED TO HOLD TOP LINES WRITTEN ABOVE CALENDAR
      DIMENSION LTRFIL(10),LTRRAW(80),LTRDAT(40),LTRPRF(80),
     1LTRTOP(158)
C
C     VOCABULAR OF WORDS WHICH CAN APPEAR IN LISTS OF DATES
      DIMENSION LTRTO(19),LWRTO(19),LNGTO(6)
C
C     LETTERS USED FOR MOVING PRINTHEAD 1/120 INCH ON DIABLO
C     TERMINAL FOR USE IN GETTING BOLDFACE EVENT NAMES
      COMMON/CALONE/LTRDRK(7)
C
C     INPUT AND OUTPUT FILE NAMES PACKED BY 1A10 FORMAT
      DOUBLE PRECISION FILINP,FILOUT
C
C     LMTLIN = MAXIMUM NUMBER OF LINES FOR 1 WEEK
C     LMTRAW = MAXIMUM NUMBER OF CHARACTERS IN A SINGLE LINE READ
C              FROM THE SCHEDULE FILE
C     LMTDAT = MAXIMUM NUMBER OF CHARACTERS IN STARTING DATE
C     LMTPRF = MAXIMUM NUMBER OF CHARACTERS IN A LINE
C              READ FROM THE PROFILE FILE WHICH SELECTS
C              REPEATING FILES
C     LMTCLM = MAXIMUM NUMBER OF COLUMNS.  AS DISTRIBUTED
C              THIS PROGRAM PRODUCES 6 PARALLEL COLUMNS,
C              PLACING SATURDAY AND SUNDAY TOGETHER IN THE
C              SIXTH COLUMN.  IF THE OUTPUT PRINTER CAN
C              MORE CHARACTERS ACROSS THE WIDTH OF THE PAGE,
C              THEN LMTCLM CAN BE SET TO 7 AND KLMEND THEN
C              SHOULD BE SET TO 8 SO THAT THE RIGHT COLUMN
C              IS NOT TAKEN AS A COMBINED WEEKEND COLUMN.
C     LMTWRD = NUMBER OF COMPUTER WORDS INTO WHICH THE
C              CHARACTERS TO BE IN A COLUMN ARE STORED.
C              THESE ARE READ WITH A MULTIPLE OF A1 FORMAT
C              THEN STORED WITH A MULTIPLE OF A5 FORMAT.
C     LMTBYT = NUMBER OF CHARACTERS WHICH CAN BE PACKED
C              INTO A SINGLE COMPUTER WORD
C     KLMEND = COLUMN NUMBER OF COLUMN TO BE TAKEN AS THE
C              COMBINED SATURDAY/SUNDAY WEEKEND COLUMN.  IF
C              THE OUTPUT DEVICE CAN DISPLAY ENOUGH CHARACTERS
C              TO HAVE SATURDAY AND SUNDAY IN SEPARATE COLUMNS,
C              THEN KLMEND SHOULD BE SET TO 1 MORE THAN LMTCLM.
C
      DATA LMTLIN,LMTRAW,LMTDAT,LMTPRF,LMTCLM,LMTWRD,
     1 LMTBYT,KLMEND,LMTTOP/
     2 500,80,40,80,6,5,5,6,158/
C
C     SHORT NAMES OF DAYS OF WEEK
      DATA LTRDAY/
     11HS,1Hu,1Hn,  1HM,1Ho,1Hn,  1HT,1Hu,1He,
     21HW,1He,1Hd,  1HT,1Hh,1Hu,  1HF,1Hr,1Hi,
     31HS,1Ha,1Ht,  1HS,1H/,1HS/
C
C     WEEKEND DAY IDENTIFICATIONS
      DATA LTREND/
     11H ,1H ,1HS,1Ha,1Ht,1Hu,1Hr,1Hd,1Ha,1Hy,
     21H ,1H ,1HS,1Hu,1Hn,1Hd,1Ha,1Hy,
     31H ,1H ,1HB,1Ho,1Ht,1Hh,1H ,1Hd,1Ha,1Hy,1Hs/
      DATA LNGEND/10,8,11/
C
C     AM, M, PM
      DATA LTRAM/1HA,1HM,1HM,1HP,1HM/
      DATA LWRAM/1Ha,1Hm,1Hm,1Hp,1Hm/
      DATA LNGAM/2,1,2/
      DATA LMTAM/3/
C
C     DATE SEPARATOR WORDS
      DATA LTRTO/
     11HT,1HO,
     21HT,1HH,1HR,1HU,
     31HT,1HH,1HR,1HO,1HU,1HG,1HH,
     41HA,1HN,1HD,
     51HO,1HR,
     61H,/
      DATA LWRTO/
     11Ht,1Ho,
     21Ht,1Hh,1Hr,1Hu,
     31Ht,1Hh,1Hr,1Ho,1Hu,1Hg,1Hh,
     41Ha,1Hn,1Hd,
     51Ho,1Hr,
     61H,/
      DATA LNGTO/2,4,7,3,2,1/
      DATA LMTTO/6/
C
C     DIGITS ZERO THROUGH NINE
      DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C     SHORT FORM OF DATES OF MONTHS
      DATA LTRMTH/
     1 1HJ,1HA,1HN,  1HF,1HE,1HB,  1HM,1HA,1HR,
     2 1HA,1HP,1HR,  1HM,1HA,1HY,  1HJ,1HU,1HN,
     3 1HJ,1HU,1HL,  1HA,1HU,1HG,  1HS,1HE,1HP,
     4 1HO,1HC,1HT,  1HN,1HO,1HV,  1HD,1HE,1HC/
      DATA LWRMTH/
     1 1HJ,1Ha,1Hn,  1HF,1He,1Hb,  1HM,1Ha,1Hr,
     2 1HA,1Hp,1Hr,  1HM,1Ha,1Hy,  1HJ,1Hu,1Hn,
     3 1HJ,1Hu,1Hl,  1HA,1Hu,1Hg,  1HS,1He,1Hp,
     4 1HO,1Hc,1Ht,  1HN,1Ho,1Hv,  1HD,1He,1Hc/
      DATA LTRSPA,LTREXC,LTRSTA/1H ,1H!,1H*/
C
C     UNIT NUMBERS
      DATA ITTY,IDISK,JDISK,KDISK/5,1,20,21/
C
C     CALCULATE NUMBER OF BYTES ACROSS A SINGLE COLUMN
      LMTPAC=LMTWRD*LMTBYT
C
C     TURN OFF USE OF RIGHT COLUMN AS COMBINED SATURDAY
C     SUNDAY COLUMN IF OUTPUT DEVICE CAN SHOW MORE CHRACTERS
      IF(LMTCLM.GE.7)KLMEND=LMTCLM+1
C
C     TELL USER WHAT PROGRAM THIS IS
      WRITE(ITTY,1)
    1 FORMAT(' WEEKLY'/
     1' Merges daily schedules into weekly calendar'/1X)
C
C     ASK USER FOR STARTING DATE
    2 WRITE(ITTY,3)
    3 FORMAT(' Starting date (a Monday)? ',$)
      READ(ITTY,4)LTRDAT
    4 FORMAT(80A1)
      LOWBFR=1
      CALL DADATE(1,LTRDAT,80,LOWBFR,KIND,
     1IDAY,IMONTH,IYEAR,LCNBFR)
      IF(IDAY.LT.0)GO TO 5
      IF(IMONTH.LT.0)GO TO 5
      IF(IYEAR.LT.0)GO TO 5
      IF(IYEAR.LE.80)IYEAR=IYEAR+2000
      IF(IYEAR.LT.100)IYEAR=IYEAR+1900
      GO TO 7
    5 WRITE(ITTY,6)
    6 FORMAT(' Date must include day, month and year'/
     1' Use any conventional notation such as'/
     2' October 20, 82 or 20 October 82 or 10/20/82')
      GO TO 2
    7 CALL DAWEEK(0,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
      K=3*IMONTH
      J=K-2
      M=3*IWEEK
      L=M-2
      WRITE(ITTY,8)(LTRDAY(I),I=L,M),IDAY,
     1(LWRMTH(I),I=J,K),IYEAR
    8 FORMAT(' ',3A1,' ',1I2,'-',3A1,'-',1I4)
      IF(IWEEK.EQ.2)GO TO 10
      WRITE(ITTY,9)
    9 FORMAT(' Starting date must be a Monday')
      GO TO 2
C
C     ASK USER HOW MANY WEEKS ARE TO BE IN CALENDAR
   10 WRITE(ITTY,11)
   11 FORMAT(' Show how many weeks? ',$)
      READ(ITTY,12)MAXWEK
   12 FORMAT(I)
      IF(MAXWEK.LE.0)GO TO 10
C
C     GET NAME OF OUTPUT FILE AND OPEN IT
   13 WRITE(ITTY,14)
   14 FORMAT(' Name of output file? ',$)
      READ(ITTY,15)LTRPRF
   15 FORMAT(80A1)
      MAXPRF=LMTPRF
   16 IF(LTRPRF(MAXPRF).NE.LTRSPA)GO TO 18
      MAXPRF=MAXPRF-1
      IF(MAXPRF.GT.0)GO TO 16
      WRITE(ITTY,17)
   17 FORMAT(' File name must be specified')
      GO TO 13
   18 LOWPRF=0
   19 LOWPRF=LOWPRF+1
      IF(LTRPRF(LOWPRF).EQ.LTRSPA)GO TO 19
      IFILE=1
      GO TO 116
   20 WRITE(ITTY,21)
   21 FORMAT(' File cannot be written')
      GO TO 13
   22 WRITE(ITTY,23)
   23 FORMAT(' File name must be 1 to 6 letters or digits,'/
     1' optionally followed by period and 0 to 3 letters or digits')
      GO TO 13
   24 CONTINUE
C
C     ASK IF DIABLO OR DECWRITER OUTPUT IS DESIRED
      WRITE(ITTY,25)
   25 FORMAT(' Answer 0 if on Decwriter, 1 if on Diablo'/
     1' Will calendar be printed on Decwriter or Diablo? ',$)
      READ(ITTY,26)KNDDRK
   26 FORMAT(I)
C
C     START OF WEEK LOOP
      DO 178 NOWWEK=1,MAXWEK
C
C     READ IN COLUMN OF TEXT FOR EACH DAY OF WEEK
      MAXLIN=0
      IWHICH=0
      MAXSHO=0
      DO 125 KOLUMN=1,LMTCLM
      LINE=0
      LNGCLM(KOLUMN)=0
   27 IPASS=0
C
C     CONVERT SMITHSONIAN DATE TO DAY, MONTH YEAR AND DAY OF WEEK
      CALL DAWEEK(-1,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
C
C     INSERT DATE INTO LINE TO BE WRITTEN ACROSS TOP OF ALL COLUMNS
      MIDSHO=MAXSHO+(LMTPAC/2)
      DO 28 I=1,LMTPAC
      MAXSHO=MAXSHO+1
      LTRLIN(MAXSHO)=LTRSPA
   28 CONTINUE
      I=IDAY/10
      J=IDAY-(10*I)
      LTRLIN(MIDSHO-4)=LTRDGT(I+1)
      LTRLIN(MIDSHO-3)=LTRDGT(J+1)
      LTRLIN(MIDSHO-2)='-'
      I=3*IMONTH-2
      LTRLIN(MIDSHO-1)=LWRMTH(I)
      LTRLIN(MIDSHO)=LWRMTH(I+1)
      LTRLIN(MIDSHO+1)=LWRMTH(I+2)
      LTRLIN(MIDSHO+2)='-'
      I=IYEAR/100
      J=IYEAR/10
      I=J-(10*I)
      J=IYEAR-(10*J)
      LTRLIN(MIDSHO+3)=LTRDGT(I+1)
      LTRLIN(MIDSHO+4)=LTRDGT(J+1)
C
C     GET NAME OF NEXT FILE NAMED BY PROFILE FILE FOR DESIRED DATE
      OPEN(UNIT=JDISK,FILE='WEEKLY.DAY',ACCESS='SEQIN')
   29 CALL PROFIL(IWHICH,ISMITH,ITTY,JDISK,LMTPRF,
     1LTRPRF,LOWPRF,MAXPRF,KNDDAY)
      IF(IWHICH.EQ.0)GO TO 103
C
C     REMOVE WEEDEND AND ALL ENTRIES FOR SUNDAY
      IF(IWEEK.NE.1)GO TO 30
      IF(KNDDAY.NE.1)GO TO 29
C
C     OPEN THE FILE NAMED BY THE PROFILE FILE
   30 IFILE=2
      GO TO 116
   31 WRITE(ITTY,32)(LTRPRF(I),I=1,MAXPRF)
   32 FORMAT(
     1' Incorrect file name in line in calendar profile:'/
     21X,80A1)
      GO TO 29
   33 WRITE(ITTY,34)(LTRPRF(I),I=1,MAXPRF)
   34 FORMAT(
     1' Cannot read file specified by line in calendar profile:'/
     21X,80A1)
      GO TO 29
C
C     CONSTRUCT NAME OF DATED INPUT FILE AND OPEN IT
C     THE FILE NAME IS SIMILAR TO 12NOV.82 FOR NOVEMBER 12, 1982
   35 I=IDAY/10
      J=IDAY-(10*I)
      LTRPRF(1)=LTRDGT(I+1)
      LTRPRF(2)=LTRDGT(J+1)
      I=3*IMONTH-2
      LTRPRF(3)=LTRMTH(I)
      LTRPRF(4)=LTRMTH(I+1)
      LTRPRF(5)=LTRMTH(I+2)
      I=IYEAR/100
      J=IYEAR/10
      I=J-(10*I)
      J=IYEAR-(10*J)
      LTRPRF(6)='.'
      LTRPRF(7)=LTRDGT(I+1)
      LTRPRF(8)=LTRDGT(J+1)
      LOWPRF=1
      MAXPRF=8
      IFILE=3
      GO TO 116
C
C     GET NEXT LINE FROM INPUT FILE
C     INCR   = -1, IGNORE LINES TILL NEXT TIMESTAMP, DATE NOT
C                  IN RANGE INDICATED
C            = 0, FIRST LINE IN EVENT DESCRIPTION
C            = 1, SUBSEQUENT LINE IN EVENT DESCRIPTION
C            = 2, NO TIMESTAMP YET FOUND IN INPUT FILE
C     IPASS  = 0, READ ITEMS FROM FILES NAMED IN PROFILE FILE
C            = 1, READ ITEMS FROM DATED FILE
C     JPASS  = 0, CHECK FOR FIRST TIMESTAMP ON LINE
C            = 1, CHECK FOR SECOND TIMESTAMP ON LINE
C     KPASS  = -1, NO DATE FOUND ON LINE AFTER TIMESTAMP
C            = 0, UNKNOWN ITEM FOUND WHEN CHECKING FOR THE
C                 WORDS TO OR AND.  CHECK IF THIS IS A DATE
C            = 1, A KNOWN ITEM, EITHER A DATE OR A WORD, WAS
C                 THE LAST ITEM FOUND
   36 INCR=2
      MINLIN=LINE+1
   37 READ(IDISK,38,END=104)LTRRAW
   38 FORMAT(80A1)
      MAXRAW=LMTRAW
   39 IF(LTRRAW(MAXRAW).NE.LTRSPA)GO TO 40
      MAXRAW=MAXRAW-1
      IF(MAXRAW.GT.0)GO TO 39
      GO TO 37
   40 MAXUSE=1
   41 IF(LTRRAW(MAXUSE).EQ.LTREXC)GO TO 42
      MAXUSE=MAXUSE+1
      IF(MAXUSE.LE.MAXRAW)GO TO 41
   42 MAXUSE=MAXUSE-1
      IF(MAXUSE.LE.0)GO TO 37
C
C     EVALUATE THE TIMESTAMP
      LOWBFR=1
      JPASS=0
   43 IHOUR=-1
      IMINUT=-1
      IFAMPM=0
   44 IF(LOWBFR.GT.MAXUSE)GO TO 37
      IF(LTRRAW(LOWBFR).NE.1H )GO TO 46
      LOWBFR=LOWBFR+1
      GO TO 44
   45 LOWBFR=LOWBFR+1
      IF(LOWBFR.GT.MAXUSE)GO TO 83
   46 LTRNOW=LTRRAW(LOWBFR)
      IF(LTRNOW.EQ.1H:)GO TO 48
      DO 47 I=1,10
      IF(LTRNOW.NE.LTRDGT(I))GO TO 47
      IF(IHOUR.LT.0)IHOUR=0
      IHOUR=(10*IHOUR)+I-1
      GO TO 45
   47 CONTINUE
      GO TO 83
   48 LOWBFR=LOWBFR+1
      IF(LOWBFR.GT.MAXUSE)GO TO 59
      LTRNOW=LTRRAW(LOWBFR)
      DO 49 I=1,10
      IF(LTRNOW.NE.LTRDGT(I))GO TO 49
      IF(IMINUT.LT.0)IMINUT=0
      IMINUT=(10*IMINUT)+I-1
      GO TO 48
   49 CONTINUE
      IFAMPM=0
      J=0
   50 IFAMPM=IFAMPM+1
      IF(IFAMPM.GT.LMTAM)GO TO 58
      K=J
      J=J+LNGAM(IFAMPM)
      L=LOWBFR-1
   51 K=K+1
      L=L+1
      IF(K.GT.J)GO TO 52
      IF(L.GT.MAXUSE)GO TO 50
      LTRNOW=LTRRAW(L)
      IF(LTRNOW.EQ.LTRAM(K))GO TO 51
      IF(LTRNOW.EQ.LWRAM(K))GO TO 51
      GO TO 50
   52 LOWBFR=L
      GO TO(53,54,55),IFAMPM
C     12:00 AM (MIDNIGHT) TO 12:59 AM SUBTRACT 12 FROM HOURS
   53 IF(IHOUR.EQ.12)IHOUR=IHOUR-12
      GO TO 59
C     12:00 (NOON) IS ONLY POSSIBLE USE OF M BY ITSELF
   54 IF(IHOUR.NE.12)GO TO 57
      IF(IMINUT.NE.0)GO TO 57
      GO TO 59
C     12:01 PM TO 12:59 PM UNCHANGED
C     1:00 PM TO 12:00 PM (MIDNIGHT) ADD ON 12 TO HOURS
   55 IF(IHOUR.LT.12)GO TO 56
      IF(IMINUT.GT.0)GO TO 59
   56 IHOUR=IHOUR+12
      GO TO 59
   57 LOWBFR=LOWBFR-1
   58 IFAMPM=0
   59 IF(IHOUR.LT.0)GO TO 83
      IF(IMINUT.LT.0)GO TO 83
      IF(JPASS.NE.0)GO TO 65
      IF(LINE.GE.LMTLIN)GO TO 104
      IF(INCR.NE.0)LINE=LINE+1
      INCR=0
C
C     STORE STARTING TIME
      ITIME(KOLUMN,LINE)=(100*IHOUR)+IMINUT
      JTIME(KOLUMN,LINE)=-1
      IFBOLD(KOLUMN,LINE)=-1
      IF(IPASS.NE.0)IFBOLD(KOLUMN,LINE)=1
      IF(IWEEK.EQ.1)GO TO 60
      IF(IWEEK.EQ.7)GO TO 61
      GO TO 62
   60 KTIME(LINE)=1
      GO TO 62
   61 KTIME(LINE)=0
      IF(KNDDAY.GE.9)KTIME(LINE)=2
   62 IF(LOWBFR.GT.MAXUSE)GO TO 101
      IF(LTRRAW(LOWBFR).EQ.1H )LOWBFR=LOWBFR+1
      INIBFR=LOWBFR
   63 IF(LOWBFR.GE.MAXUSE)GO TO 101
      IF(LTRRAW(LOWBFR).NE.1H )GO TO 64
      LOWBFR=LOWBFR+1
      GO TO 63
C
C     CHECK FOR SECOND TIME STAMP ON LINE
   64 IF(LTRRAW(LOWBFR).NE.1H-)GO TO 68
      LOWBFR=LOWBFR+1
      INIBFR=LOWBFR
      JPASS=1
      GO TO 43
C
C     STORE ENDING TIME
   65 LTIME=(100*IHOUR)+IMINUT
      IF(LTIME.GE.ITIME(KOLUMN,LINE))GO TO 66
      IHOUR=IHOUR+12
      GO TO 65
   66 JTIME(KOLUMN,LINE)=LTIME
      IF(LOWBFR.GT.MAXUSE)GO TO 101
      IF(LTRRAW(LOWBFR).EQ.1H )LOWBFR=LOWBFR+1
      INIBFR=LOWBFR
   67 IF(LOWBFR.GE.MAXUSE)GO TO 101
      IF(LTRRAW(LOWBFR).NE.1H )GO TO 68
      LOWBFR=LOWBFR+1
      GO TO 67
C
C     GET FIRST DATE IN DATE RANGE
   68 KPASS=-1
C
C     EVALUATE DATE
   69 IF(LOWBFR.GT.MAXUSE)GO TO 101
      IF(LTRRAW(LOWBFR).NE.LTRSPA)GO TO 70
      LOWBFR=LOWBFR+1
      GO TO 69
   70 INIBFR=LOWBFR
      CALL DADATE(1,LTRRAW,MAXUSE,LOWBFR,KIND,
     1JDAY,JMONTH,JYEAR,LCNBFR)
      IF(KIND.LE.3)GO TO 81
      IF(KIND.GE.18)GO TO 81
      IF(JDAY.LT.0)GO TO 81
      IF(JMONTH.LT.0)GO TO 81
      IF(JYEAR.LT.0)GO TO 81
      IF(JYEAR.LE.80)JYEAR=JYEAR+2000
      IF(JYEAR.LT.100)JYEAR=JYEAR+1900
      CALL DAWEEK(0,KSMITH,JDAY,JMONTH,JYEAR,JWEEK)
      IF(KPASS.GT.0)GO TO 78
      KPASS=1
C
C     LOOK FOR SEPARATING WORDS TO, THROUGH, AND, COMMA
   71 JSMITH=KSMITH
      ICHECK=LOWBFR-1
   72 ICHECK=ICHECK+1
      IF(ICHECK.GT.MAXUSE)GO TO 76
      IF(LTRRAW(ICHECK).EQ.LTRSPA)GO TO 72
      KMDTO=0
      ICHECK=ICHECK-1
      KCHECK=0
   73 KMDTO=KMDTO+1
      IF(KMDTO.GT.LMTTO)GO TO 77
      JCHECK=ICHECK
      LCHECK=KCHECK
      KCHECK=KCHECK+LNGTO(KMDTO)
   74 LCHECK=LCHECK+1
      JCHECK=JCHECK+1
      IF(LCHECK.GT.KCHECK)GO TO 75
      IF(JCHECK.GT.MAXUSE)GO TO 73
      IF(LTRTO(LCHECK).EQ.LTRRAW(JCHECK))GO TO 74
      IF(LWRTO(LCHECK).EQ.LTRRAW(JCHECK))GO TO 74
      GO TO 73
   75 LOWBFR=JCHECK
      GO TO(69,69,69,78,78,78),KMDTO
C
C     CHECK IF DESIRED DATE IS IN INDICATED RANGE
   76 LOWBFR=MAXUSE+1
   77 KPASS=0
   78 IF(ISMITH.LT.JSMITH)GO TO 79
      IF(ISMITH.GT.KSMITH)GO TO 79
      GO TO 80
   79 IF(LOWBFR.GT.MAXUSE)GO TO 101
      IF(KPASS.EQ.0)GO TO 69
      GO TO 71
C
C     REMOVE AN ITEM FROM THE CALENDAR
   80 LINE=LINE-1
      INCR=-1
      GO TO 37
C
C     UNKNOWN ITEM FOUND TO RIGHT OF TIME OR TIME RANGE
   81 IF(KPASS.LT.0)GO TO 84
      WRITE(ITTY,82)FILINP
   82 FORMAT(
     1' Item right of date taken as event description in file: ',1A10)
      GO TO 86
C
C     UNKNOWN ITEM FOUND INSTEAD OF TIME STAMP
   83 IF(INCR.LT.0)GO TO 37
      IF(JPASS.EQ.0)GO TO 88
   84 WRITE(ITTY,85)FILINP
   85 FORMAT(
     1' Item right of time taken as event description in file: ',1A10)
   86 WRITE(ITTY,87)(LTRRAW(I),I=1,MAXRAW)
   87 FORMAT(1X,80A1)
      J=INIBFR-1
      WRITE(ITTY,87)(LTRSPA,I=1,J),(LTRSTA,I=INIBFR,MAXUSE)
      GO TO 89
C
C     SHIFT STUFF RIGHT OF DATE AND STORE
   88 INIBFR=1
   89 IF(INIBFR.GT.MAXUSE)GO TO 37
      IF(LTRRAW(INIBFR).NE.LTRSPA)GO TO 90
      INIBFR=INIBFR+1
      GO TO 89
   90 ISHIFT=0
      IF(INCR.EQ.1)ISHIFT=2
      DO 93 I=1,LMTPAC
      IF(ISHIFT.NE.0)GO TO 91
      IF(INIBFR.GT.MAXUSE)GO TO 92
      LTRONE(I)=LTRRAW(INIBFR)
      INIBFR=INIBFR+1
      GO TO 93
   91 ISHIFT=ISHIFT-1
   92 LTRONE(I)=' '
   93 CONTINUE
      IF(INIBFR.GT.MAXUSE)GO TO 95
      WRITE(ITTY,94)FILINP
   94 FORMAT(
     1' Excess characters discarded in line read from file: ',1A10)
      WRITE(ITTY,87)(LTRRAW(I),I=1,MAXRAW)
      J=INIBFR-1
      WRITE(ITTY,87)(LTRSPA,I=1,J),(LTRSTA,I=INIBFR,MAXUSE)
   95 CONTINUE
C
C     PACK THE LINE AS THOUGH READ BY 5A5 FORMAT
      ENCODE(LMTPAC,96,LA5ONE)LTRONE
   96 FORMAT(25A1)
C
C     STORE THE LINE
      IF(INCR.EQ.0)GO TO 99
      IF(LINE.GE.LMTLIN)GO TO 104
      LINE=LINE+1
      ITIME(KOLUMN,LINE)=-1
      IF(LINE.GT.MINLIN)ITIME(KOLUMN,LINE)=ITIME(KOLUMN,LINE-1)
      JTIME(KOLUMN,LINE)=-1
      IF(LINE.GT.MINLIN)JTIME(KOLUMN,LINE)=JTIME(KOLUMN,LINE-1)
      IFBOLD(KOLUMN,LINE)=0
      IF(IWEEK.EQ.1)GO TO 97
      IF(IWEEK.EQ.7)GO TO 98
      GO TO 99
   97 KTIME(LINE)=1
      GO TO 99
   98 KTIME(LINE)=0
      IF(KNDDAY.GE.9)KTIME(LINE)=2
   99 IF(INCR.EQ.0)INCR=1
      DO 100 J=1,LMTWRD
      LA5ALL(KOLUMN,J,LINE)=LA5ONE(J)
  100 CONTINUE
      GO TO 37
C
C     STORE BLANK LINE IF ONLY TIMESTAMP ON LINE
  101 DO 102 J=1,LMTWRD
      LA5ALL(KOLUMN,J,LINE)='     '
  102 CONTINUE
      GO TO 37
C
C     CLOSE THE PROFILE FILE
  103 CLOSE(UNIT=JDISK)
      IPASS=1
      KNDDAY=IWEEK
      GO TO 35
C
C     DONE READING THE SCHEDULE FILE
  104 CLOSE(UNIT=IDISK)
      IF(IPASS.EQ.0)GO TO 29
  105 CONTINUE
      LNGCLM(KOLUMN)=LINE
      IF(LINE.GT.MAXLIN)MAXLIN=LINE
      IF(IWEEK.EQ.7)GO TO 115
C
C     SUMMARIZE
      M=3*IWEEK
      IF(KOLUMN.EQ.KLMEND)M=3*8
      L=M-2
      K=3*IMONTH
      J=K-2
      WRITE(ITTY,106)(LTRDAY(I),I=L,M),
     1IDAY,(LWRMTH(I),I=J,K),IYEAR,LINE
  106 FORMAT(' ',3A1,1X,1I2,'-',3A1,'-',1I4,', Lines:',1I5)
C
C     SORT THE ITEMS FOR THIS COLUMN
      IF(LINE.LE.0)GO TO 115
      DO 114 IOUTER=1,LINE
      KOMPAR=ITIME(KOLUMN,IOUTER)
      LOWEST=IOUTER
      DO 108 INNER=IOUTER,LINE
      IF(ITIME(KOLUMN,INNER).GT.KOMPAR)GO TO 108
      IF(ITIME(KOLUMN,INNER).LT.KOMPAR)GO TO 107
      IF(JTIME(KOLUMN,INNER).GT.JTIME(KOLUMN,LOWEST))GO TO 108
      IF(JTIME(KOLUMN,INNER).LT.JTIME(KOLUMN,LOWEST))GO TO 107
      IF(KOLUMN.NE.KLMEND)GO TO 108
      IF(KTIME(INNER).GE.KTIME(LOWEST))GO TO 108
  107 KOMPAR=ITIME(KOLUMN,INNER)
      LOWEST=INNER
  108 CONTINUE
      IF(LOWEST.LE.IOUTER)GO TO 114
      ISAVE=ITIME(KOLUMN,LOWEST)
      JSAVE=JTIME(KOLUMN,LOWEST)
      IF(KOLUMN.EQ.KLMEND)KSAVE=KTIME(LOWEST)
      LSAVE=IFBOLD(KOLUMN,LOWEST)
      DO 109 I=1,LMTWRD
      LA5ONE(I)=LA5ALL(KOLUMN,I,LOWEST)
  109 CONTINUE
  110 IF(LOWEST.LE.IOUTER)GO TO 112
      ITIME(KOLUMN,LOWEST)=ITIME(KOLUMN,LOWEST-1)
      JTIME(KOLUMN,LOWEST)=JTIME(KOLUMN,LOWEST-1)
      IF(KOLUMN.EQ.KLMEND)KTIME(LOWEST)=KTIME(LOWEST-1)
      IFBOLD(KOLUMN,LOWEST)=IFBOLD(KOLUMN,LOWEST-1)
      DO 111 I=1,LMTWRD
      LA5ALL(KOLUMN,I,LOWEST)=LA5ALL(KOLUMN,I,LOWEST-1)
  111 CONTINUE
      LOWEST=LOWEST-1
      GO TO 110
  112 ITIME(KOLUMN,LOWEST)=ISAVE
      JTIME(KOLUMN,LOWEST)=JSAVE
      IF(KOLUMN.EQ.KLMEND)KTIME(LOWEST)=KSAVE
      IFBOLD(KOLUMN,LOWEST)=LSAVE
      DO 113 I=1,LMTWRD
      LA5ALL(KOLUMN,I,LOWEST)=LA5ONE(I)
  113 CONTINUE
  114 CONTINUE
  115 ISMITH=ISMITH+1
      MAXSHO=MAXSHO+1
      LTRLIN(MAXSHO)=LTRSPA
      IF(KOLUMN.NE.KLMEND)GO TO 125
      IF(IWEEK.EQ.1)GO TO 125
      IWEEK=1
      GO TO 27
C
C     *******************************************************
C     *                                                     *
C     *  PACK FILE NAME SPECIFIED BY USER OR FILE AND OPEN  *
C     *                                                     *
C     *******************************************************
C
  116 MAXPRT=0
      LOCDOT=0
      LOCEND=0
      DO 119 I=1,10
      LTRFIL(I)=' '
      IF(LOWPRF.LE.MAXPRF)LTRFIL(I)=LTRPRF(LOWPRF)
      LOWPRF=LOWPRF+1
      IF(LTRFIL(I).EQ.1H )GO TO 118
      IF(LOCEND.NE.0)GO TO 124
      MAXPRT=I
      IF(LTRFIL(I).NE.1H.)GO TO 117
      IF(LOCDOT.NE.0)GO TO 124
      IF(I.GT.7)GO TO 124
      LOCDOT=1
      GO TO 119
  117 IF(I.LT.7)GO TO 119
      IF(LOCDOT.EQ.0)GO TO 124
      GO TO 119
  118 LOCEND=1
  119 CONTINUE
      IF(LOCDOT.EQ.0)LTRFIL(MAXPRT+1)='.'
      GO TO(120,122,123),IFILE
  120 ENCODE(10,121,FILOUT)LTRFIL
  121 FORMAT(10A1)
C     TTYSIM ON SOME SYSTEMS SPECIFIES THAT FILES WRITTEN
C     ON UNIT GIVEN AS ARGUMENT HAVE LEFT CHARACTER IN EACH
C     LINE CONVERTED DIRECTLY TO THE CARRIAGE CONTROL.
      CALL TTYSIM(KDISK)
      OPEN(UNIT=KDISK,FILE=FILOUT,ACCESS='SEQOUT',
     1CARRIAGECONTROL='FORTRAN',ERR=20)
      GO TO 24
  122 ENCODE(10,121,FILINP)LTRFIL
      OPEN(UNIT=IDISK,FILE=FILINP,ACCESS='SEQIN',ERR=33)
      GO TO 36
  123 ENCODE(10,121,FILINP)LTRFIL
      OPEN(UNIT=IDISK,FILE=FILINP,ACCESS='SEQIN',ERR=105)
      GO TO 36
C
C     BRANCH TO ERROR MESSAGES IF ERROR IN FILE NAME
  124 GO TO(22,31,105),IFILE
C
C     **************************************************
C     *                                                *
C     *  ALL FILE DESCRIBING THIS WEEK HAVE BEEN READ  *
C     *                                                *
C     **************************************************
C
  125 CONTINUE
C
C     ************************
C     *                      *
C     *  PRINT THE CALENDAR  *
C     *                      *
C     ************************
C
C     LABEL THE COLUMNS
      IF(MAXLIN.LE.0)GO TO 178
      WRITE(KDISK,126)
  126 FORMAT(1H1)
      OPEN(UNIT=IDISK,FILE='WEEKLY.TOP',ACCESS='SEQIN',ERR=133)
  127 READ(IDISK,128,END=132)LTRTOP
  128 FORMAT(158A1)
      MAXTOP=LMTTOP
  129 IF(LTRTOP(MAXTOP).NE.LTRSPA)GO TO 130
      MAXTOP=MAXTOP-1
      IF(MAXTOP.GT.1)GO TO 129
  130 WRITE(KDISK,131)(LTRTOP(I),I=1,MAXTOP)
  131 FORMAT(1X,158A1)
      GO TO 127
  132 CLOSE(UNIT=IDISK)
      WRITE(KDISK,136)
  133 WRITE(KDISK,134)
C    1'ABCDEFGHIJKLMLKJIHGFEDCBA ',
  134 FORMAT(1H ,
     1'        Monday            ',
     2'        Tuesday           ',
     3'       Wednesday          ',
     4'       Thursday           ',
     5'        Friday            ',
     6'       Saturday')
      WRITE(KDISK,135)(LTRLIN(I),I=1,130)
  135 FORMAT(1X,130A1,'      and Sunday')
      WRITE(KDISK,136)
  136 FORMAT(1X)
C
C     PREPARE TO CONSTRUCT NEXT LINE OF OUTPUT FILE
      DO 137 KOLUMN=1,LMTCLM
      NOWLIN(KOLUMN)=1
      KLOSE(KOLUMN)=-1
  137 CONTINUE
      IWKEND=-1
      INITIM=-1
      LSTTIM=-1
C
C     CHECK FOR LOWEST TIME NOT YET DISPLAYED
  138 MINMUM=-1
      DO 139 KOLUMN=1,LMTCLM
      IF(NOWLIN(KOLUMN).GT.LNGCLM(KOLUMN))GO TO 139
      LINE=NOWLIN(KOLUMN)
      IF(ITIME(KOLUMN,LINE).LT.0)GO TO 139
      IF(MINMUM.LT.0)MINMUM=ITIME(KOLUMN,LINE)
      IF(MINMUM.GT.ITIME(KOLUMN,LINE))MINMUM=ITIME(KOLUMN,LINE)
  139 CONTINUE
C
C     WRITE RULE IF HOUR IS CHANGING
      IF(INITIM.EQ.MINMUM)GO TO 145
      IF(INITIM.GE.0)GO TO 140
      IF(MINMUM.GE.0)GO TO 141
  140 I=INITIM/100
      J=MINMUM/100
      IF(I.EQ.J)GO TO 145
  141 IWIDTH=0
      DO 143 KOLUMN=1,LMTCLM
      DO 142 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)='-'
  142 CONTINUE
      IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)='+'
  143 CONTINUE
      WRITE(KDISK,144)(LTRLIN(I),I=1,IWIDTH)
  144 FORMAT(1X,'+',182A1)
  145 IF(MINMUM.LT.0)GO TO 178
C
C     CHECK IF ITEM IN COLUMN GOES ON LINE NOW
      IWIDTH=0
      DO 165 KOLUMN=1,LMTCLM
      NOWCLM=5*(KOLUMN-1)
      LINE=NOWLIN(KOLUMN)
      LSTTIM=-1
      IF(LNGCLM(KOLUMN).LT.LINE)GO TO 162
      IF(ITIME(KOLUMN,LINE).GT.MINMUM)GO TO 162
C
C     INSERT TIME STAMP INTO CURRENT LINE
      IF(ITIME(KOLUMN,LINE).LT.0)GO TO 158
      IF(INITIM.NE.MINMUM)GO TO 146
      IF(KLOSE(KOLUMN).NE.JTIME(KOLUMN,LINE))GO TO 146
      IF(KOLUMN.NE.KLMEND)GO TO 158
      IF(IWKEND.NE.KTIME(LINE))GO TO 146
      GO TO 158
  146 KLOSE(KOLUMN)=JTIME(KOLUMN,LINE)
      IF(KOLUMN.EQ.KLMEND)IWKEND=KTIME(LINE)
      LTIME=ITIME(KOLUMN,LINE)
      KOLON=IWIDTH+2
      JPASS=0
  147 J=LTIME
      IF(J.LT.100)J=J+1200
      IF(J.GE.1300)J=J-1200
      IF(J.GE.1300)J=J-1200
      IF(J.GE.1000)KOLON=KOLON+1
      I=KOLON+2
  148 K=J/10
      J=J-(10*K)
      LTRLIN(I)=LTRDGT(J+1)
      J=K
      I=I-1
      IF(I.EQ.KOLON)I=KOLON-1
      IF(J.GT.0)GO TO 148
      IF(I.GT.(KOLON-2))GO TO 148
      LTRLIN(KOLON)=':'
      IF(JPASS.NE.0)GO TO 149
      IF(JTIME(KOLUMN,LINE).LT.0)GO TO 149
      LTRLIN(KOLON+3)='-'
      LTIME=JTIME(KOLUMN,LINE)
      KOLON=KOLON+5
      JPASS=1
      GO TO 147
  149 KOLON=KOLON+2
      LTRLIN(KOLON+1)=LTRSPA
      KOLON=KOLON+1
      IF(LTIME.GT.2400)LTIME=LTIME-2400
      IF(LTIME.GT.1200)GO TO 151
      IF(LTIME.EQ.1200)GO TO 150
      LTRLIN(KOLON+1)='a'
      LTRLIN(KOLON+2)='m'
      KOLON=KOLON+2
      GO TO 152
  150 LTRLIN(KOLON+1)='m'
      KOLON=KOLON+1
      GO TO 152
  151 LTRLIN(KOLON+1)='p'
      LTRLIN(KOLON+2)='m'
      KOLON=KOLON+2
      GO TO 152
  152 IF(KOLUMN.NE.KLMEND)GO TO 156
      I=0
      K=0
  153 IF(I.GT.KTIME(LINE))GO TO 154
      I=I+1
      J=K+1
      K=K+LNGEND(I)
      GO TO 153
  154 DO 155 I=J,K
      KOLON=KOLON+1
      LTRLIN(KOLON)=LTREND(I)
  155 CONTINUE
  156 DO 157 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      IF(IWIDTH.GT.KOLON)LTRLIN(IWIDTH)=' '
  157 CONTINUE
      JFBOLD(KOLUMN)=0
      GO TO 164
C
C     ADD A SCHEDULE ITEM TO THE OUTPUT LINE
  158 DO 159 I=1,LMTWRD
      LA5ONE(I)=LA5ALL(KOLUMN,I,LINE)
  159 CONTINUE
      DECODE(LMTPAC,160,LA5ONE)LTRONE
  160 FORMAT(25A1)
      DO 161 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)=LTRONE(I)
  161 CONTINUE
      KLOSE(KOLUMN)=JTIME(KOLUMN,LINE)
      IF(KOLUMN.EQ.KLMEND)IWKEND=KTIME(LINE)
      JFBOLD(KOLUMN)=IFBOLD(KOLUMN,LINE)
      LINE=LINE+1
      NOWLIN(KOLUMN)=LINE
      GO TO 164
C
C     INSERT BLANKS IF NEXT TIME STAMP BEYOND CURRENT
  162 DO 163 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)=' '
  163 CONTINUE
      JFBOLD(KOLUMN)=0
C
C     INSERT SINGLE RULING BETWEEN COLUMNS
  164 IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)='|'
  165 CONTINUE
      INITIM=MINMUM
C
C     WRITE LINE TO OUTPUT FILE
      WRITE(KDISK,166)(LTRLIN(I),I=1,IWIDTH)
  166 FORMAT(1X,'|',182A1)
      IWIDTH=0
      MAXBLD=0
      DO 173 KOLUMN=1,LMTCLM
C     IF(JFBOLD(KOLUMN).LT.0)GO TO 1640
      IF(JFBOLD(KOLUMN).GT.0)GO TO 170
      DO 167 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)=LTRSPA
  167 CONTINUE
      GO TO 172
  168 JDARK=1
      DO 169 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      IF(LTRLIN(IWIDTH).EQ.1H,)JDARK=0
      IF(JDARK.EQ.0)LTRLIN(IWIDTH)=LTRSPA
      IF(LTRLIN(IWIDTH).NE.LTRSPA)MAXBLD=IWIDTH
  169 CONTINUE
      GO TO 172
  170 DO 171 I=1,LMTPAC
      IWIDTH=IWIDTH+1
      IF(LTRLIN(IWIDTH).NE.LTRSPA)MAXBLD=IWIDTH
  171 CONTINUE
  172 IWIDTH=IWIDTH+1
      LTRLIN(IWIDTH)=LTRSPA
  173 CONTINUE
      IF(MAXBLD.LE.0)GO TO 177
      IF(KNDDRK.NE.0)GO TO 175
C     BOLDFACE ON DECWRITER (MATRIX) PRINTER
      WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
      WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
      WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
      WRITE(KDISK,174)(LTRLIN(I),I=1,MAXBLD)
  174 FORMAT('+ ',182A1)
      GO TO 177
C     BOLDFACE ON DIABLO (PRECISION) PRINTER
  175 WRITE(KDISK,176)(LTRLIN(I),I=1,MAXBLD)
      WRITE(KDISK,176)LTRDRK,(LTRLIN(I),I=1,MAXBLD)
  176 FORMAT('+ ',182A1)
  177 GO TO 138
C
C     ALL DONE PROCESSING FILES
  178 CONTINUE
      WRITE(KDISK,179)
  179 FORMAT('1')
      CLOSE(UNIT=KDISK)
      WRITE(ITTY,180)
  180 FORMAT(1X)
C
C     CALENDAR COMPLETED
  181 STOP
      END
      SUBROUTINE PROFIL(IWHICH,ISMITH,ITTY,JDISK,
     1LMTPRF,LTRPRF,LOWPRF,MAXPRF,KNDDAY)
C     RENBR(/FIND LINE IN PROFILE FOR DESIRED DATE)
C
C     DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C     IWHICH = SHOULD BE SET TO ZERO BEFORE THIS ROUTINE IS
C              FIRST CALLED FOR A NEW DATE.  THEREAFTER, IWHICH
C              SHOULD BE SENT BACK TO THIS ROUTINE UNCHANGED
C              UNTIL IT IS RETURNED AGAIN SET TO ZERO.
C     IWHICH = 0 RETURNED, IF END-OF-FILE WAS READ.  DO NOT
C                CALL THIS ROUTINE AGAIN FOR THIS DATE.
C            = 1 RETURNED, IF RETURNING FILE SPECIFICATION
C                FOR A SPECIAL SCHEDULE, BUT NO REGULAR
C                SCHEDULE HAS YET BEEN FOUND FOR THIS DATE.
C            = 2 RETURNED, IF RETURNING FILE SPECIFICATION
C                FOR A SPECIAL SCHEDULE, AND A REGULAR
C                SCHEDULE WAS FOUND EARLIER FOR THIS DATE.
C                NOTE THAT THIS DOES NOT MEAN THAT THIS ROUTINE
C                ACTUALLY RETURNED AN ITEM IN A REGULAR
C                SCHEDULE FOR THE DESIRED DATE, SINCE THE REGULAR
C                SCHEDULE FOR THIS DATE MIGHT HAVE NEGLECTED TO
C                DEFINE A FILE SPECIFICATION FOR THE CORRESPONDING
C                DAY OF THE WEEK AND SO WAS HANDLED INTERNALLY.
C            = 3 RETURNED, IF RETURNING A REGULAR SCHEDULE.
C     ISMITH = INPUT CONTAINING DESIRED SMITHSONIAN DATE
C     IWEEK  = DAY OF WEEK, 1=SUNDAY, 7=SATURDAY
C     ITTY   = UNIT NUMBER ON WHICH TO WRITE ERROR MESSAGES.
C     JDISK  = UNIT NUMBER FROM WHICH TO READ PROFILE FILE.
C     LMTPRF = DIMENSION OF LTRPRF ARRAY IN WHICH THE LINE
C              OF THE FILE FOR DESIRED DATE IS RETURNED
C     LTRPRF = RETURNED CONTAINING THE TEXT OF THE LINE FOUND FOR
C              THE DESIRED DATE.
C     LOWPRF = RETURNED POINTING TO FIRST PRINTING CHARACTER TO
C              RIGHT OF DAY OF WEEK NAME IN TEXT RETURNED IN LTRPRF.
C     MAXPRF = RETURNED POINTING TO RIGHTMOST PRINTING CHARACTER
C              IN LTRPRF ARRAY, EXCLUDING COMMENT IF ANY.
C     KNDDAY = RETURNED IDENTIFYING WORD WHICH APPEARS AT START
C              OF LINE CONTAINING FILE SPECIFICATION
C              = 1 THRU 7, SUNDAY: THRU SATURDAY:
C              = WEEKDAY:
C              = WEEKEND:
C              = ALL:
C
      DIMENSION LTRCMD(104),LWRCMD(104),LTRPRF(LMTPRF),LNGCMD(13),
     1LTRTO(19),LWRTO(19),LNGTO(6)
      DATA LTRCMD/
     11HS,1HU,1HN,1HD,1HA,1HY,1H:,
     21HM,1HO,1HN,1HD,1HA,1HY,1H:,
     31HT,1HU,1HE,1HS,1HD,1HA,1HY,1H:,
     41HW,1HE,1HD,1HN,1HE,1HS,1HD,1HA,1HY,1H:,
     51HT,1HH,1HU,1HR,1HS,1HD,1HA,1HY,1H:,
     61HF,1HR,1HI,1HD,1HA,1HY,1H:,
     71HS,1HA,1HT,1HU,1HR,1HD,1HA,1HY,1H:,
     81HW,1HE,1HE,1HK,1HD,1HA,1HY,1H:,
     91HW,1HE,1HE,1HK,1HE,1HN,1HD,1H:,
     11HA,1HL,1HL,1H:,
     21HR,1HE,1HG,1HU,1HL,1HA,1HR,1H:,
     31HS,1HP,1HE,1HC,1HI,1HA,1HL,1H:,
     41HE,1HN,1HD,1H-,1HO,1HF,1H-,1HF,1HI,1HL,1HE/
      DATA LWRCMD/
     11Hs,1Hu,1Hn,1Hd,1Ha,1Hy,1H:,
     21Hm,1Ho,1Hn,1Hd,1Ha,1Hy,1H:,
     31Ht,1Hu,1He,1Hs,1Hd,1Ha,1Hy,1H:,
     41Hw,1He,1Hd,1Hn,1He,1Hs,1Hd,1Ha,1Hy,1H:,
     51Ht,1Hh,1Hu,1Hr,1Hs,1Hd,1Ha,1Hy,1H:,
     61Hf,1Hr,1Hi,1Hd,1Ha,1Hy,1H:,
     71Hs,1Ha,1Ht,1Hu,1Hr,1Hd,1Ha,1Hy,1H:,
     81Hw,1He,1He,1Hk,1Hd,1Ha,1Hy,1H:,
     91Hw,1He,1He,1Hk,1He,1Hn,1Hd,1H:,
     11Ha,1Hl,1Hl,1H:,
     21Hr,1He,1Hg,1Hu,1Hl,1Ha,1Hr,1H:,
     31Hs,1Hp,1He,1Hc,1Hi,1Ha,1Hl,1H:,
     41He,1Hn,1Hd,1H-,1Ho,1Hf,1H-,1Hf,1Hi,1Hl,1He/
      DATA LNGCMD/7,7,8,10,9,7,9,8,8,4,8,8,11/
      DATA LMTCMD/13/
C
C     DATE SEPARATOR WORDS
      DATA LTRTO/
     11HT,1HO,
     21HT,1HH,1HR,1HU,
     31HT,1HH,1HR,1HO,1HU,1HG,1HH,
     41HA,1HN,1HD,
     51HO,1HR,
     61H,/
      DATA LWRTO/
     11Ht,1Ho,
     21Ht,1Hh,1Hr,1Hu,
     31Ht,1Hh,1Hr,1Ho,1Hu,1Hg,1Hh,
     41Ha,1Hn,1Hd,
     51Ho,1Hr,
     61H,/
      DATA LNGTO/2,4,7,3,2,1/
      DATA LMTTO/6/
C
C     LTREXC = THE EXCLAMATION POINT USED TO INDICATE THAT
C              THE REST OF THE LINE IS A COMMENT TO BE IGNORED
C     LTRSPA = THE SPACE CHARACTER
      DATA LTREXC,LTRSPA,LTRCOM/1H!,1H ,1H,/
C
C     DETERMINE WHICH DAY OF WEEK CORRESPONDS TO DATE
      CALL DAWEEK(-1,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
C
C     INDICATE IF CONTINUING PREVIOUS SPECIAL OR REGULAR SCHEDULE
      IRANGE=0
      IF(IWHICH.EQ.1)IRANGE=-1
      IF(IWHICH.EQ.2)IRANGE=-1
      IF(IWHICH.EQ.3)IRANGE=1
C
C     READ NEXT LINE FROM FILE
    1 READ(JDISK,2,END=32)LTRPRF
    2 FORMAT(80A1)
C
C     FIND RIGHTMOST PRINTING CHARACTER
      MAXPRT=LMTPRF
    3 IF(MAXPRT.LE.0)GO TO 1
      IF(LTRPRF(MAXPRT).NE.LTRSPA)GO TO 4
      MAXPRT=MAXPRT-1
      GO TO 3
C
C     LOOK FOR INITIAL KEYWORD
    4 ICHECK=0
    5 ICHECK=ICHECK+1
      IF(ICHECK.GT.MAXPRT)GO TO 1
      IF(LTRPRF(ICHECK).EQ.LTRSPA)GO TO 5
      IF(LTRPRF(ICHECK).EQ.LTREXC)GO TO 1
      KOMAND=0
      ICHECK=ICHECK-1
      KCHECK=0
    6 KOMAND=KOMAND+1
      IF(KOMAND.GT.LMTCMD)GO TO 20
      JCHECK=ICHECK
      LCHECK=KCHECK
      KCHECK=KCHECK+LNGCMD(KOMAND)
    7 LCHECK=LCHECK+1
      JCHECK=JCHECK+1
      IF(LCHECK.GT.KCHECK)GO TO 8
      IF(JCHECK.GT.MAXPRT)GO TO 6
      IF(LTRCMD(LCHECK).EQ.LTRPRF(JCHECK))GO TO 7
      IF(LWRCMD(LCHECK).EQ.LTRPRF(JCHECK))GO TO 7
      GO TO 6
C
C     DETERMINE WHETHER DATE RANGE IS ALLOWED
    8 IF(KOMAND.EQ.13)GO TO 32
      IF(KOMAND.LE.10)GO TO 22
      IF(IRANGE.GT.0)IWHICH=2
      IRANGE=0
      IF(IWHICH.LE.1)GO TO 9
      IF(KOMAND.EQ.11)GO TO 1
C
C     GET FIRST DATE IN DATE RANGE
    9 LOWPRF=JCHECK
      KPASS=0
C
C     EVALUATE DATE
   10 CALL DADATE(1,LTRPRF,LMTPRF,LOWPRF,KIND,
     1IDAY,IMONTH,IYEAR,LCNBFR)
      IF(KIND.LE.3)GO TO 20
      IF(KIND.GE.18)GO TO 20
      IF(IDAY.LT.0)GO TO 20
      IF(IMONTH.LT.0)GO TO 20
      IF(IYEAR.LT.0)GO TO 20
      IF(IYEAR.LE.80)IYEAR=IYEAR+2000
      IF(IYEAR.LT.100)IYEAR=IYEAR+1900
      CALL DAWEEK(0,KSMITH,IDAY,IMONTH,IYEAR,JWEEK)
      IF(KPASS.NE.0)GO TO 18
      KPASS=1
C
C     LOOK FOR SEPARATING WORDS TO, THROUGH, AND, COMMA
   11 JSMITH=KSMITH
      ICHECK=LOWPRF-1
   12 ICHECK=ICHECK+1
      IF(ICHECK.GT.MAXPRT)GO TO 16
      IF(LTRPRF(ICHECK).EQ.LTRSPA)GO TO 12
      IF(LTRPRF(ICHECK).EQ.LTREXC)GO TO 16
      KMDTO=0
      ICHECK=ICHECK-1
      KCHECK=0
   13 KMDTO=KMDTO+1
      IF(KMDTO.GT.LMTTO)GO TO 17
      JCHECK=ICHECK
      LCHECK=KCHECK
      KCHECK=KCHECK+LNGTO(KMDTO)
   14 LCHECK=LCHECK+1
      JCHECK=JCHECK+1
      IF(LCHECK.GT.KCHECK)GO TO 15
      IF(JCHECK.GT.MAXPRT)GO TO 13
      IF(LTRTO(LCHECK).EQ.LTRPRF(JCHECK))GO TO 14
      IF(LWRTO(LCHECK).EQ.LTRPRF(JCHECK))GO TO 14
      GO TO 13
   15 LOWPRF=JCHECK
      GO TO(10,10,10,18,18,18),KMDTO
C
C     CHECK IF DESIRED DATE IS IN INDICATED RANGE
   16 LOWPRF=MAXPRT+1
   17 KPASS=0
   18 IF(ISMITH.LT.JSMITH)GO TO 19
      IF(ISMITH.GT.KSMITH)GO TO 19
      IRANGE=1
      IF(KOMAND.EQ.12)IRANGE=-1
      GO TO 1
   19 IF(LOWPRF.GT.MAXPRT)GO TO 1
      IF(KPASS.EQ.0)GO TO 10
      GO TO 11
C
C     ERROR IN PROFILE FILE
   20 WRITE(ITTY,21)(LTRPRF(I),I=1,MAXPRT)
   21 FORMAT(
     1' Calendar profile contains following unrecognizable line:'/
     21X,80A1)
      GO TO 1
C
C     RETURN THE TEXT TO RIGHT OF DAY OF WEEK NAME
   22 IF(IRANGE.EQ.0)GO TO 1
      IF(KOMAND.LE.7)GO TO 25
      IF(KOMAND.EQ.8)GO TO 23
      IF(KOMAND.EQ.9)GO TO 24
C     ALL:
      GO TO 26
C     WEEKDAYS:
   23 IF(IWEEK.EQ.1)GO TO 1
      IF(IWEEK.EQ.7)GO TO 1
      GO TO 26
C     WEEKEND:
   24 IF(IWEEK.EQ.1)GO TO 26
      IF(IWEEK.EQ.7)GO TO 26
      GO TO 1
C     SPECIFIC DAY
   25 IF(KOMAND.NE.IWEEK)GO TO 1
   26 LOWPRF=JCHECK
   27 IF(LOWPRF.GT.MAXPRT)GO TO 1
      IF(LTRPRF(LOWPRF).EQ.LTREXC)GO TO 1
      IF(LTRPRF(LOWPRF).NE.LTRSPA)GO TO 28
      LOWPRF=LOWPRF+1
      GO TO 27
   28 MAXPRF=LOWPRF
   29 MAXPRF=MAXPRF+1
      IF(MAXPRF.GT.MAXPRT)GO TO 30
      IF(LTRPRF(MAXPRF).NE.LTREXC)GO TO 29
   30 MAXPRF=MAXPRF-1
      IF(LTRPRF(MAXPRF).EQ.LTRSPA)GO TO 30
      KNDDAY=KOMAND
      IF(IRANGE.LT.0)GO TO 31
      IWHICH=3
      GO TO 33
   31 IF(IWHICH.EQ.0)IWHICH=1
      IF(IWHICH.EQ.3)IWHICH=2
      GO TO 33
C
C     END-OF-FILE READ
   32 IWHICH=0
C
C     RETURN TO CALLING PROGRAM
   33 RETURN
      END
      SUBROUTINE DADATE(IALLOW,IBUFFR,MAXBFR,LOWBFR,KIND  ,
     1   IDAY  ,IMONTH,IYEAR ,LCNBFR)
C
C     DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C     IALLOW = 0, ACCEPT NUMBER, DATE, TIME OR DAY OF WEEK.
C              SINGLE NUMBER IS RETURNED IN IYEAR
C            = 1, ACCEPT NUMBER OR DATE ONLY.
C              SINGLE NUMBER IS RETURNED IN IYEAR
C            = 2, ACCEPT NUMBER OR TIME ONLY.
C              SINGLE NUMBER IS RETURNED IN IDAY
C            = 3, ACCEPT DAY OF WEEK ONLY
C     KIND   = 1, NOTHING FOUND
C            = 2, UNKNOWN ITEM
C            = 3, SINGLE NUMBER
C            = 4, OCTOBER
C            = 5, 20 OCTOBER
C            = 6, 20-OCTOBER OR 20/OCTOBER
C            = 7, 10-20 OR 10/20
C            = 8, OCTOBER 20
C            = 9, OCTOBER-20 OR OCTOBER/20
C            = 10, OCTOBER,81
C            = 11, 20 OCTOBER 81
C            = 12, 20 OCTOBER,81
C            = 13, 20-OCT-81 OR 20/OCT/81
C            = 14, 10-20-81 OR 10/20/81
C            = 15, OCTOBER 20 81
C            = 16, OCTOBER 20, 81
C            = 17, OCTOBER-20-81 OR OCTOBER/20/81
C            = 18, 11:00
C            = 19, AM OR PM OR NOON OR MIDNIGHT
C            = 20, 11 AM OR 11 PM OR 12 NOON OR 12 MIDNIGHT
C            = 21, 11:00 AM OR 11:00 PM OR 12:00 NOON
C                  OR 12:00 MIDNIGHT
C            = 22, SATURDAY
C     IDAY   = IF DATE, RETURNED WITH DAY OF MONTH
C            = IF NAME OF DAY, 1 IF SUNDAY, 7 IF SATURDAY
C            = IF TIME, RETURNED WITH HOUR
C            = IF NUMBER AND IALLOW IS 2, RETURND WITH VALUE
C     IMONTH = IF DATE, 1 IF JANUARY, 12 IF DECEMBER
C            = IF TIME, RETURNED WITH MINUTES
C     IYEAR  = IF DATE, RETURNED WITH YEAR
C            = IF TIME, 1 IF AM, 2 IF PM, 3 IF M OR NOON,
C              4 IF MIDNIGHT
C            = IF NUMBER AND IALLOW IS 0 OR 1, RETURND WITH VALUE
C
      DIMENSION LTRMTH(151),LWRMTH(151),LNGMTH(27),LTRDGT(10),
     1IBUFFR(MAXBFR)
      DATA LTRMTH/1HJ,1HA,1HN,1HU,1HA,1HR,1HY,    1HF,1HE,
     11HB,1HR,1HU,1HA,1HR,1HY,    1HM,1HA,1HR,1HC,1HH,1HA,
     21HP,1HR,1HI,1HL,    1HM,1HA,1HY,    1HJ,1HU,1HN,1HE,
     3    1HJ,1HU,1HL,1HY,    1HA,1HU,1HG,1HU,1HS,1HT,
     41HS,1HE,1HP,1HT,1HE,1HM,1HB,1HE,1HR,    1HO,1HC,1HT,
     51HO,1HB,1HE,1HR,    1HN,1HO,1HV,1HE,1HM,1HB,1HE,1HR,
     6    1HD,1HE,1HC,1HE,1HM,1HB,1HE,1HR,    1HA,1HM,
     71HP,1HM,    1HN,1HO,1HO,1HN,    1HM,1HI,1HD,1HN,1HI,
     81HG,1HH,1HT,    1HA,1H.,1HM,1H.,    1HP,1H.,1HM,1H.,
     9    1HM,1H.,    1HM,    1HS,1HU,1HN,1HD,1HA,1HY,
     11HM,1HO,1HN,1HD,1HA,1HY,    1HT,1HU,1HE,1HS,1HD,1HA,
     21HY,    1HW,1HE,1HD,1HN,1HE,1HS,1HD,1HA,1HY,    1HT,
     31HH,1HU,1HR,1HS,1HD,1HA,1HY,    1HF,1HR,1HI,1HD,1HA,
     41HY,    1HS,1HA,1HT,1HU,1HR,1HD,1HA,1HY/
      DATA LWRMTH/1Hj,1Ha,1Hn,1Hu,1Ha,1Hr,1Hy,    1Hf,1He,
     11Hb,1Hr,1Hu,1Ha,1Hr,1Hy,    1Hm,1Ha,1Hr,1Hc,1Hh,1Ha,
     21Hp,1Hr,1Hi,1Hl,    1Hm,1Ha,1Hy,    1Hj,1Hu,1Hn,1He,
     3    1Hj,1Hu,1Hl,1Hy,    1Ha,1Hu,1Hg,1Hu,1Hs,1Ht,
     41Hs,1He,1Hp,1Ht,1He,1Hm,1Hb,1He,1Hr,    1Ho,1Hc,1Ht,
     51Ho,1Hb,1He,1Hr,    1Hn,1Ho,1Hv,1He,1Hm,1Hb,1He,1Hr,
     6    1Hd,1He,1Hc,1He,1Hm,1Hb,1He,1Hr,    1Ha,1Hm,
     71Hp,1Hm,    1Hn,1Ho,1Ho,1Hn,    1Hm,1Hi,1Hd,1Hn,1Hi,
     81Hg,1Hh,1Ht,    1Ha,1H.,1Hm,1H.,    1Hp,1H.,1Hm,1H.,
     9    1Hm,1H.,    1Hm,    1Hs,1Hu,1Hn,1Hd,1Ha,1Hy,
     11Hm,1Ho,1Hn,1Hd,1Ha,1Hy,    1Ht,1Hu,1He,1Hs,1Hd,1Ha,
     21Hy,    1Hw,1He,1Hd,1Hn,1He,1Hs,1Hd,1Ha,1Hy,    1Ht,
     31Hh,1Hu,1Hr,1Hs,1Hd,1Ha,1Hy,    1Hf,1Hr,1Hi,1Hd,1Ha,
     41Hy,    1Hs,1Ha,1Ht,1Hu,1Hr,1Hd,1Ha,1Hy/
      DATA LNGMTH/7,8,5,5,3,4,4,6,9,7,8,8,
     12,2,4,8,4,4,2,1,
     26,6,7,9,8,6,8/
C     INISFX = SUBSCRIPT IN LTRMTH OF START OF SUFFIXES
C     INIDAY = SUBSCRIPT IN LTRMTH OF START OF DAY NAMES
C     LMTMTH = SUBSCRIPT IN LNGMTH OF END OF MONTH NAME LENGTHS
C     LMTMTH = SUBSCRIPT IN LNGMTH OF END OF SUFFIX LENGTHS
C     LMTMTH = SUBSCRIPT IN LNGMTH OF END OF DAY NAME LENGTHS
      DATA INISFX,INIDAY/74,101/
      DATA LMTMTH,LMTSFX,LMTDAY/12,20,27/
C
      DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
      DATA ITAB/"045004020100/
      DATA IBLANK/1H /
      DATA IMINUS,ISLASH,ICOMMA,ICOLON/1H-,1H/,1H,,1H:/
C
C     SEARCH FOR FIRST PRINTING CHARACTER
      IDAY=-1
      IMONTH=-1
      IYEAR=-1
      KIND=1
      GO TO 2
    1 LOWBFR=LOWBFR+1
    2 IF(LOWBFR.GT.MAXBFR)GO TO 65
      NOWLTR=IBUFFR(LOWBFR)
      IF(NOWLTR.EQ.IBLANK)GO TO 1
      IF(NOWLTR.EQ.ITAB)GO TO 1
      LCNBFR=LOWBFR
      NOWBFR=LOWBFR
C
C     TEST FOR LEADING NUMBER
      IFIRST=0
      ISECON=0
      ITHIRD=0
      KIND=2
      ISEPAR=0
      IF(IALLOW.EQ.3)GO TO 16
      GO TO 4
    3 NOWBFR=NOWBFR+1
      LSTBFR=NOWBFR
      IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
    4 DO 5 I=1,10
      IF(NOWLTR.NE.LTRDGT(I))GO TO 5
      IFIRST=(10*IFIRST)+I-1
      KIND=3
      GO TO 3
    5 CONTINUE
      IF(KIND.EQ.2)GO TO 13
C
C     LOOK FOR SLASH OR MINUS AFTER NUMBER
      IF(IALLOW.EQ.2)GO TO 8
      IF(NOWLTR.NE.IMINUS)GO TO 6
      ISEPAR=1
      GO TO 7
    6 IF(NOWLTR.NE.ISLASH)GO TO 8
      ISEPAR=2
    7 NOWBFR=NOWBFR+1
      GO TO 13
    8 IF(IALLOW.EQ.1)GO TO 12
      IF(NOWLTR.NE.ICOLON)GO TO 12
C
C     LOOK FOR NUMBER AFTER COLON
      KIND=18
      IDAY=IFIRST
    9 NOWBFR=NOWBFR+1
      LSTBFR=NOWBFR
      IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
      DO 10 I=1,10
      IF(NOWLTR.NE.LTRDGT(I))GO TO 10
      ISECON=(10*ISECON)+I-1
      IMONTH=ISECON
      GO TO 9
   10 CONTINUE
      GO TO 12
C
C     LOOK FOR FIRST PRINTING CHARACTER AFTER NUMBER
   11 NOWBFR=NOWBFR+1
      IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
   12 IF(NOWLTR.EQ.IBLANK)GO TO 11
      IF(NOWLTR.EQ.ITAB)GO TO 11
C
C     LOOK FOR ALPHABETIC WORD
C     NO NUMBER    = LOOK FOR ANY WORD
C     NUMBER       = LOOK FOR MONTH OR AM OR A.M.
C     NUMBER SLASH = LOOK FOR MONTH
C     NUMBER COLON = LOOK FOR AM OR A.M.
   13 IF(IALLOW.EQ.2)GO TO 15
      ITEST=0
      ILOOP=1
      JLOOP=LMTDAY
      IF(IALLOW.EQ.1)GO TO 14
      IF(KIND.EQ.2)GO TO 17
      IF(KIND.EQ.18)GO TO 15
      IF(ISEPAR.NE.0)GO TO 14
      ILOOP=1
      JLOOP=LMTSFX
      GO TO 17
   14 ILOOP=1
      JLOOP=LMTMTH
      GO TO 17
   15 ILOOP=LMTMTH+1
      JLOOP=LMTSFX
      ITEST=INISFX
      GO TO 17
   16 ILOOP=LMTSFX+1
      JLOOP=LMTDAY
      ITEST=INIDAY
   17 LONGER=0
      IUNIQU=0
      JUNIQU=0
      DO 23 JTEST=ILOOP,JLOOP
      MATCHD=0
      KTEST=ITEST
      ITEST=ITEST+LNGMTH(JTEST)
      LTEST=NOWBFR
   18 KTEST=KTEST+1
      IF(KTEST.GT.ITEST)GO TO 23
      IF(LTRMTH(KTEST).EQ.IBUFFR(LTEST))GO TO 19
      IF(LWRMTH(KTEST).EQ.IBUFFR(LTEST))GO TO 19
      GO TO 23
   19 MATCHD=MATCHD+1
      IF(MATCHD.LT.LONGER)GO TO 22
      IF(MATCHD.GT.LONGER)GO TO 20
      IF(KTEST.LT.ITEST)GO TO 21
   20 LONGER=MATCHD
      IUNIQU=JTEST
      JUNIQU=ITEST-KTEST
      GO TO 22
   21 IF(JUNIQU.NE.0)IUNIQU=0
   22 LTEST=LTEST+1
      IF(LTEST.LE.MAXBFR)GO TO 18
   23 CONTINUE
      IF(IUNIQU.NE.0)GO TO 24
      IF(KIND.EQ.2)GO TO 65
      IF(KIND.EQ.18)GO TO 64
      IF(ISEPAR.NE.0)GO TO 34
      GO TO 46
   24 NOWBFR=NOWBFR+LONGER
      LSTBFR=NOWBFR
      IF(KIND.EQ.2)GO TO 26
      IF(IUNIQU.LE.LMTMTH)GO TO 25
      IF(KIND.EQ.18)GO TO 61
      GO TO 60
   25 KIND=5
      ISECON=IUNIQU
      GO TO 36
   26 IF(IUNIQU.LE.LMTMTH)GO TO 27
      IF(IUNIQU.LE.LMTSFX)GO TO 59
      GO TO 62
   27 KIND=4
      IFIRST=IUNIQU
C
C     LOOK FOR / OR - IMMEDIATELY AFTER MONTH NAME
      IF(IBUFFR(NOWBFR).NE.IMINUS)GO TO 28
      ISEPAR=1
      GO TO 29
   28 IF(IBUFFR(NOWBFR).NE.ISLASH)GO TO 30
      ISEPAR=2
   29 NOWBFR=NOWBFR+1
      IF(KIND.EQ.5)GO TO 44
      GO TO 34
   30 IF(ISEPAR.NE.0)GO TO 46
      GO TO 32
C
C     SEARCH FOR FIRST PRINTING CHARACTER AFTER MONTH
   31 NOWBFR=NOWBFR+1
   32 IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
      IF(NOWLTR.EQ.IBLANK)GO TO 31
      IF(NOWLTR.EQ.ITAB)GO TO 31
      GO TO 34
C
C     LOOK FOR SECOND NUMBER AFTER NUMBER- OR NUMBER/
   33 NOWBFR=NOWBFR+1
      LSTBFR=NOWBFR
   34 IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
      DO 35 I=1,10
      IF(NOWLTR.NE.LTRDGT(I))GO TO 35
      ISECON=(10*ISECON)+I-1
      IF(KIND.EQ.3)KIND=7
      IF(KIND.EQ.4)KIND=8
      GO TO 33
   35 CONTINUE
C       KIND = 3, NUMBER/
C            = 4, OCT OR OCT/
C            = 7, 20/10
C            = 8, OCT 20 OR OCT/20
      IF(KIND.EQ.7)GO TO 37
      IF(KIND.EQ.8)GO TO 36
      IF(KIND.EQ.3)GO TO 46
      IF(ISEPAR.NE.0)GO TO 46
      GO TO 41
C
C     LOOK FOR / OR - AFTER SECOND NUMBER
   36 IF(ISEPAR.EQ.0)GO TO 41
   37 IF(ISEPAR.NE.1)GO TO 38
      IF(IBUFFR(NOWBFR).NE.IMINUS)GO TO 46
      GO TO 39
   38 IF(ISEPAR.NE.2)GO TO 46
      IF(IBUFFR(NOWBFR).NE.ISLASH)GO TO 46
   39 NOWBFR=NOWBFR+1
      GO TO 44
C
C     LOOK FOR COMMA AFTER MONTH NAME AND NUMBER
   40 NOWBFR=NOWBFR+1
   41 IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
      IF(NOWLTR.EQ.IBLANK)GO TO 40
      IF(NOWLTR.EQ.ITAB)GO TO 40
      IF(NOWLTR.NE.ICOMMA)GO TO 44
      ISEPAR=-1
C
C     LOOK FOR FIRST PRINTING CHARACTER AFTER COMMA AFTER MONTH
   42 NOWBFR=NOWBFR+1
      IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
      IF(NOWLTR.EQ.IBLANK)GO TO 42
      IF(NOWLTR.EQ.ITAB)GO TO 42
      GO TO 44
C
C     LOOK FOR 3RD NUMBER
   43 NOWBFR=NOWBFR+1
      LSTBFR=NOWBFR
   44 IF(NOWBFR.GT.MAXBFR)GO TO 46
      NOWLTR=IBUFFR(NOWBFR)
      DO 45 I=1,10
      IF(NOWLTR.NE.LTRDGT(I))GO TO 45
      ITHIRD=(10*ITHIRD)+I-1
      IF(KIND.EQ.4)KIND=10
      IF(KIND.EQ.7)KIND=14
      IF(KIND.EQ.5)KIND=11
      IF(KIND.EQ.8)KIND=15
      GO TO 43
   45 CONTINUE
C
C     DATE COMPLETED
C
C     DIAGONAL OR HORIZONTAL LINE INDICATES NEXT CHARACTER
C     NUMBERS IN PARENTHESES ARE THE VALUE OF KIND BEFORE
C     AND AFTER ADJUSTING FOR THE SEPARATING CHARACTERS/-,
C
C
C                    10(7) ------ / ----- 81(14)
C                   *
C                  *
C     20(3) ----- / ----- OCT(5/6) ----- / ----- 81(11/13)
C      *
C       *
C        OCT(5) ----- , ----- 81(11/12)
C         *
C          *
C           81(11)
C
C
C           81(15)
C          *
C         *
C        20(8) ----- , ----- 81(15/16)
C       *
C      *
C     OCT(4) ----- / ----- 20(8/9) ----- / ----- 81(15/17)
C      *
C       *
C        , ----- 81(10)
C
C     ISEPAR = 0, NO PRINTING SEPARATOR CHARACTERS FOUND
C            = -1, COMMA FOUND
C            = 1, SLASH FOUND
C            = 2, MINUS SIGN FOUND
C
C     ADJUST FOR THE SEPARATING CHARACTERS / - AND ,
   46 IF(KIND.EQ.3)GO TO 51
      IF(KIND.EQ.4)GO TO 53
      IF(KIND.EQ.5)GO TO 47
      IF(KIND.EQ.7)GO TO 55
      IF(KIND.EQ.8)GO TO 48
      IF(KIND.EQ.10)GO TO 56
      IF(KIND.EQ.11)GO TO 49
      IF(KIND.EQ.14)GO TO 58
      IF(KIND.EQ.15)GO TO 50
      GO TO 64
C     CONVERT KIND=5
   47 IF(ISEPAR.NE.0)KIND=6
      GO TO 54
C     CONVERT KIND=8
   48 IF(ISEPAR.NE.0)KIND=9
      GO TO 55
C     CONVERT KIND=11
   49 IF(ISEPAR.LT.0)KIND=12
      IF(ISEPAR.GT.0)KIND=13
      GO TO 57
C     CONVERT KIND=15
   50 IF(ISEPAR.LT.0)KIND=16
      IF(ISEPAR.GT.0)KIND=17
      GO TO 58
C
C     YEAR
   51 IF(IALLOW.EQ.2)GO TO 52
      IYEAR=IFIRST
      GO TO 64
   52 IDAY=IFIRST
      GO TO 64
C
C     MONTH
   53 IMONTH=IFIRST
      GO TO 64
C
C     DAY MONTH
   54 IDAY=IFIRST
      IMONTH=ISECON
      GO TO 64
C
C     MONTH DAY
   55 IDAY=ISECON
      IMONTH=IFIRST
      GO TO 64
C
C     MONTH YEAR
   56 IMONTH=IFIRST
      IYEAR=ITHIRD
      GO TO 64
C
C     DAY MONTH YEAR
   57 IDAY=IFIRST
      IMONTH=ISECON
      IYEAR=ITHIRD
      GO TO 64
C
C     MONTH DAY YEAR
   58 IDAY=ISECON
      IMONTH=IFIRST
      IYEAR=ITHIRD
      GO TO 64
C
C     AM OR PM
   59 KIND=19
      GO TO 63
C
C     NUMBER AM
   60 KIND=20
      IDAY=IFIRST
      GO TO 63
C
C     NUMBER COLON AM
   61 KIND=21
      GO TO 63
C
C     WEEKDAY
   62 KIND=22
      IDAY=IUNIQU-LMTSFX
      GO TO 64
C
C     HANDLE EQUIVALENT SUFFIXES
C     A.M. = AM, P.M. = PM, M = NOON
   63 IYEAR=IUNIQU-LMTMTH
      IF(IYEAR.EQ.8)IYEAR=3
      IF(IYEAR.GT.4)IYEAR=IYEAR-4
      GO TO 64
C
C     RETURN TO CALLING PROGRAM
   64 LOWBFR=LSTBFR
   65 RETURN
      END
      SUBROUTINE DAWEEK(IWHICH,ISMITH,IDAY,IMONTH,IYEAR,IWEEK)
C     RENBR(/INTERCONVERT CONVENTIONAL AND SMITHSONIAN DATES)
C
C     DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C     IWHICH = 0, 1, 2, 3, CONVERT DAY, MONTH AND YEAR INPUT
C              IN IDAY, IMONTH AND IYEAR TO SMITHSONIAN DATE.
C            = 3, CHECK CURRENT DAY, MONTH AND YEAR.  RETURN
C              THESE AS IDAY, IMONTH, IYEAR
C            = 2, CHECK DAY, MONTH AND YEAR BEFORE COMPUTING
C              SMITHSONIAN DATE.  IF DAY IS MISSING (-1 OR 0)
C              SET TO END OF MONTH.  IF MONTH IS MISSING, SET
C              TO DECEMBER.  IF YEAR IS MISSING, SET TO CURRENT
C              YEAR IF DAY IS TODAY OR LATER, OR ELSE TO NEXT
C              YEAR.  THE NEWDAT ROUTINE IS CALLED TO OBTAIN
C              THE CURRENT DATE.  NEWDAT RETURNS THE FOLLOWING
C              INFORMATION AS INTEGER VALUES.
C                1ST ARGUMENT = DAY OF CURRENT MONTH
C                2ND ARGUMENT = MONTH OF CURRENT YEAR
C                3RD ARGUMENT = CURRENT YEAR, INCLUDING THE
C                               CENTURIAL AND MILLENNIAL DIGITS.
C            = 1, SIMILAR TO IWHICH=2, EXCEPT THAT A MISSING
C              DAY IS SET TO START OF MONTH AND MISSING MONTH
C              IS SET TO JANUARY.
C            = 0, DO NOT CHECK DAY, MONTH AND YEAR.
C            = -1, CONVERT SMITHSONIAN DATE INPUT IN ISMITH
C              TO DAY, MONTH AND YEAR.
C     ISMITH = NUMBER OF DAYS SINCE 18 NOVEMBER 1858 TAKING
C              THAT BASE DATE AS DAY 1.
C              THIS ROUTINE DEFINES ISMITH IF IWHICH=0, 1 OR 2.
C              ISMITH IS USED TO COMPUTE THE DAY, MONTH AND
C              YEAR IF IWHICH=-1.
C     IDAY   = DAY OF MONTH.  IDAY=1 IS FIRST DAY OF MONTH.
C              IDAY, IMONTH AND IYEAR ARE USED TO COMPUTE
C              THE SMITHSONIAN DATE IF IWHICH=0, 1 OR 2.
C              THE SMITHSONIAN DATE IS USED TO COMPUTE
C              IDAY, IMONTH AND IYEAR IF IWHICH=-1.
C     IMONTH = SERIAL NUMBER OF MONTH IN  YEAR,  SUCH  THAT
C              1=JANUARY AND 12=DECEMBER.
C     IYEAR  = YEAR.  THIS CONTAINS ALL 4 DIGITS, NOT JUST
C              THE RIGHT 2 DIGITS.  FOR DATE 12-FEB-1980,
C                   IDAY=12
C                   IMONTH=2
C                   IYEAR=1980
C     IWEEK  = RETURNED CONTAINING THE DAY OF THE WEEK  FOR
C              THE  REQUESTED  DATE, SUCH THAT 1=SUNDAY AND
C              7=SATURDAY.  IWEEK IS RETURNED SET BY THIS
C              ROUTINE REGARDLESS OF THE VALUE OF IWHICH.
C
C     NUMBER OF DAYS IN NONLEAP YEAR PRIOR TO EACH MONTH
      DIMENSION LOCMTH(12)
      DATA LOCMTH/0,31,59,90,120,151,181,212,243,273,304,
     1334/
      IF(IWHICH.LT.0)GO TO 14
      IF(IWHICH.EQ.0)GO TO 12
C
C     ************************************
C     *                                  *
C     *  CHECK DATE AND INSERT DEFAULTS  *
C     *                                  *
C     ************************************
C
C     IWHICH = 2, FILL IN WITH LAST MONTH OF YEAR
C              OR WITH LAST DAY OF MONTH
C            = 1, FILL IN WITH FIRST MONTH OF YEAR
C              OR WITH FIRST DAY OF MONTH
      CALL NEWDAT(JDAY,JMONTH,JYEAR)
      IF(IWHICH.LT.3)GO TO 1
      IDAY=JDAY
      IMONTH=JMONTH
      IYEAR=JYEAR
      GO TO 12
    1 KDAY=0
      IF(IYEAR.GE.0)GO TO 5
      IF(IMONTH.LE.0)GO TO 3
      IF(IMONTH.LT.JMONTH)GO TO 4
      IF(IMONTH.GT.JMONTH)GO TO 3
      IF(IDAY.GT.0)GO TO 2
      KDAY=1
      GO TO 3
    2 IF(IDAY.LT.JDAY)GO TO 4
    3 IYEAR=JYEAR
      GO TO 5
    4 IYEAR=JYEAR+1
    5 IF(IYEAR.GE.100)GO TO 6
      IYEAR=IYEAR+(100*(JYEAR/100))
      IF(IYEAR.LT.JYEAR)IYEAR=IYEAR+100
    6 IF(IMONTH.GT.0)GO TO 7
      IMONTH=1
      IF(IWHICH.EQ.2)IMONTH=12
    7 IF(IMONTH.GT.12)IMONTH=12
      LDAY=31
      IF(IMONTH.LT.12)LDAY=LOCMTH(IMONTH+1)-LOCMTH(IMONTH)
      IF(IMONTH.NE.2)GO TO 9
      ILEAP=IYEAR/4
      JLEAP=IYEAR/100
      KLEAP=IYEAR/400
      LLEAP=IYEAR/4000
      IF(IYEAR.NE.(4*ILEAP))GO TO 9
      IF(IYEAR.EQ.(4000*LLEAP))GO TO 9
      IF(IYEAR.EQ.(400*KLEAP))GO TO 8
      IF(IYEAR.EQ.(100*JLEAP))GO TO 9
    8 LDAY=29
    9 IF(IDAY.GT.0)GO TO 10
      IDAY=1
      IF(IWHICH.EQ.2)IDAY=LDAY
      IF(KDAY.EQ.0)GO TO 10
      IF(IDAY.LT.JDAY)IYEAR=IYEAR+1
   10 IF(IDAY.GT.LDAY)IDAY=LDAY
      IF(IYEAR.GT.1858)GO TO 12
      IF(IYEAR.LT.1858)GO TO 11
      IF(IMONTH.GT.11)GO TO 12
      IF(IMONTH.LT.11)GO TO 11
      IF(IDAY.GE.18)GO TO 12
   11 IDAY=18
      IMONTH=11
      IYEAR=1858
C
C     **************************************************
C     *                                                *
C     *  CONVERT DAY, MONTH, YEAR TO SMITHSONIAN DATE  *
C     *                                                *
C     **************************************************
C
C     COMPUTE YEARS DIVISIBLE BY 4, 100, 400 AND 4000
   12 ILEAP=IYEAR/4
      JLEAP=IYEAR/100
      KLEAP=IYEAR/400
      LLEAP=IYEAR/4000
C
C     COMPUTE DAYS SINCE END OF FIRST WEEK BEFORE BASE
C     YEAR ASSUMING FOLLOWING RULES WERE ALWAYS APPLIED.
C     1. ANY YEAR DIVISIBLE BY 4 IS A LEAP YEAR EXCEPT
C        CENTURIES NOT DIVISIBLE BY 400 ARE NOT LEAP YEARS
C        MILLENNIUMS DIVISIBLE BY 4000 ARE NOT LEAP YEARS
C     2. ALL NONLEAP YEARS CONTAIN 365 DAYS AND ALL
C        LEAP YEARS CONTAIN 366 DAYS.
C     OFFSET OF 771 ADJUSTS FOR LEAP YEARS FROM YEAR ZERO
C     TO BASE YEAR AND LENGTH OF FIRST WEEK IN BASE YEAR
      ISMITH=(365*(IYEAR-1858))+ILEAP-JLEAP+KLEAP-LLEAP
     1+LOCMTH(IMONTH)+IDAY-771
C
C     SUBTRACT 1 IF THIS IS LEAP YEAR BUT NOT YET IN MARCH
      IF(IYEAR.NE.(4*ILEAP))GO TO 24
      IF(IYEAR.EQ.(4000*LLEAP))GO TO 24
      IF(IYEAR.EQ.(400*KLEAP))GO TO 13
      IF(IYEAR.EQ.(100*JLEAP))GO TO 24
   13 IF(IMONTH.LE.2)ISMITH=ISMITH-1
      GO TO 24
C
C     **************************************************
C     *                                                *
C     *  CONVERT SMITHSONIAN DATE TO DAY, MONTH, YEAR  *
C     *                                                *
C     **************************************************
C
C     DETERMINE YEAR IF NO YEARS WERE LEAP YEARS
   14 IYEAR=1858+((ISMITH+321)/365)
C
C     ADJUST YEAR BY NUMBER OF LEAP YEARS FROM YEAR 0
      ILEAP=IYEAR/4
      JLEAP=IYEAR/100
      KLEAP=IYEAR/400
      LLEAP=IYEAR/4000
      JSMITH=ISMITH-ILEAP+JLEAP-KLEAP+LLEAP
      IYEAR=1858+((JSMITH+770)/365)
C
C     AT THIS POINT, THE YEAR IS CORRECT FOR ALL BUT
C     THE 31ST OF DECEMBER OF A YEAR PRECEDING A LEAP YEAR
      IYEAR=IYEAR+1
      IF(IYEAR.NE.(4*ILEAP))GO TO 16
      IF(IYEAR.EQ.(4000*LLEAP))GO TO 16
      IF(IYEAR.EQ.(400*KLEAP))GO TO 15
      IF(IYEAR.EQ.(100*JLEAP))GO TO 16
   15 JSMITH=JSMITH+1
   16 IYEAR=1858+((JSMITH+770)/365)
C
C     DETERMINE THE LOCATION OF THE DAY WITHIN THE YEAR
C     INYEAR = 1 THROUGH 365 IF YEAR IS NOT LEAP YEAR.
C            = 0 THROUGH 365 IF YEAR IS LEAP YEAR.
      ILEAP=IYEAR/4
      JLEAP=IYEAR/100
      KLEAP=IYEAR/400
      LLEAP=IYEAR/4000
      INYEAR=ISMITH-(365*(IYEAR-1858))
     1-ILEAP+JLEAP-KLEAP+LLEAP+771
      IF(IYEAR.NE.(4*ILEAP))GO TO 21
      IF(IYEAR.EQ.(4000*LLEAP))GO TO 21
      IF(IYEAR.EQ.(400*KLEAP))GO TO 17
      IF(IYEAR.EQ.(100*JLEAP))GO TO 21
C
C     CONVERT DAY IN LEAP YEAR TO MONTH AND DAY IN MONTH
   17 IMONTH=0
   18 IMONTH=IMONTH+1
      IF(IMONTH.GT.12)GO TO 20
      IF(IMONTH.GT.2)GO TO 19
      IF(INYEAR.GE.LOCMTH(IMONTH))GO TO 18
      GO TO 20
   19 IF(INYEAR.GT.LOCMTH(IMONTH))GO TO 18
   20 IMONTH=IMONTH-1
      IDAY=INYEAR-LOCMTH(IMONTH)
      IF(IMONTH.LE.2)IDAY=IDAY+1
      GO TO 24
C
C     CONVERT DAY NOT IN LEAP YEAR TO MONTH AND DAY
   21 IMONTH=0
   22 IMONTH=IMONTH+1
      IF(IMONTH.GT.12)GO TO 23
      IF(INYEAR.GT.LOCMTH(IMONTH))GO TO 22
   23 IMONTH=IMONTH-1
      IDAY=INYEAR-LOCMTH(IMONTH)
C
C     CONVERT SMITHSONIAN DATE TO DAY OF WEEK
   24 JSMITH=ISMITH+3
      IWEEK=JSMITH/7
      IWEEK=JSMITH-(7*IWEEK)+1
   25 RETURN
      END
      SUBROUTINE NEWDAT(IDAY,IMONTH,IYEAR)
      DOUBLE PRECISION LTRDAT
      DIMENSION NAMMTH(12)
      DATA NAMMTH/'Jan','Feb','Mar','Apr','May','Jun',
     1'Jul','Aug','Sep','Oct','Nov','Dec'/
      CALL DATE(LTRDAT)
      DECODE(9,1,LTRDAT)IDAY,LTRMTH,IYEAR
    1 FORMAT(I2,1X,A3,1X,I2)
      IYEAR=IYEAR+1900
      DO 2 I=1,12
      IF(LTRMTH.NE.NAMMTH(I))GO TO 2
      IMONTH=I
      GO TO 3
    2 CONTINUE
      IMONTH=0
    3 RETURN
      END
      SUBROUTINE TTYSIM(IDISK)
C     RENBR(/REPLACE FIRST CHARACTERS BY CARRIAGE CONTROLS)
C
C     ***************************
C     *                         *
C     * THIS IS A DUMMY ROUTINE *
C     *                         *
C     ***************************
C
C     THE ASSEMBLY VERSION OF THIS ROUTINE CAUSES THE FIRST
C     CHARACTER ON EACH LINE OF THE NEXT FILE WRITTEN ONTO
C     UNIT IDISK TO BE CONVERTED DIRECTLY TO THE CARRIAGE
C     CONTROL CHARACTER GIVING THE PROPER LINE SPACING.
C
C     THIS IS NO LONGER NEEDED IN VERSION 7 OF FORTRAN ON
C     THE DECSYSTEM10 OR DECSYSTEM20 SINCE IT HAS BEEN
C     REPLACED BY CARRIAGECONTROL='FORTRAN' IN THE OPEN
C     STATEMENTS OF THE FILES NEEDING THIS CONVERSION.
C
      RETURN
      END
