      SUBROUTINE GETNUM(KONTRL,IBUFFR,MAXBFR,LOWBFR,KIND  ,
     1    IVALUE,VALUE )
C     RENBR(/GET NEXT NUMBER IN SINGLE LINE)
C
C     DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C     KONTRL = 0, RETURN INTEGER AS ARGUMENT IVALUE
C            = 1, RETURN REAL NUMBER IN ARGUMENT VALUE
C     IBUFFR = TEXT TYPED BY USER READ WITH MULTIPLE OF A1
C              FORMAT
C     MAXBFR = NUMBER OF CHARACTERS IN IBUFFR
C     LOWBFR = INITIALLY SHOULD BE INPUT CONTAINING ZERO
C              TO ALLOW INITIAL COMMA TO INDICATE MISSING
C              ITEM.  THEREAFTER SHOULD BE INPUT CONTAINING
C              SUBSCRIPT OF NEXT LOCATION IN IBUFFR ARRAY
C              WHICH IS TO BE EXAMINED.
C            = RETURNED POINTING TO NEXT CHARACTER NOT YET
C              EXAMINED.
C     KIND   = 1, LINE IS EMPTY
C            = 2, ERROR MESSAGE TYPED TO USER
C            = 3, MISSING NUMBER
C            = 4, A NUMBER HAS BEEN EVALUATED
C     IVALUE = RETURNED CONTAINING INTEGER VALUE IF
C              KONTRL=0
C     VALUE  = RETURNED CONTAINING REAL VALUE IF KONTRL=1
C
      DIMENSION IBUFFR(MAXBFR)
      DATA IWHAT/1H?/
      DATA ITTY/5/
C
C     OBTAIN NEXT ITEM IN TEXT BUFFER
      MANY=1
      IF(LOWBFR.GT.0)GO TO 1
      LOWBFR=1
      MANY=0
    1 LOCK=MANY
      CALL DAMISS(KONTRL,1,0,IBUFFR,MAXBFR,
     1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
     2VALUE,MANY,LCNBFR,LCNERR)
      GO TO(5,12,6,6,2,4,14),KIND
C
C     TREAT SEMICOLON LIKE COMMA
    2 IF(LOCK.EQ.0)GO TO 3
      MANY=-1
      GO TO 1
    3 LOWBFR=LOWBFR-1
      GO TO 14
C
C     BUFFER IS EMPTY
    4 IF(MANY.LT.0)GO TO 14
    5 KIND=1
      GO TO 15
C
C     NUMBER FOUND
    6 IF(LSHIFT.LT.0)GO TO 8
      IF(KONTRL.GT.0)GO TO 7
      IF(KSHIFT.LT.0)GO TO 10
    7 KIND=4
      GO TO 15
C
C     ILLEGAL NUMBER REPRESENTATION
    8 LOWBFR=LCNERR
      LCNERR=LCNERR-1
      WRITE(ITTY,9)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
    9 FORMAT(' NUMBER REQUIRED BUT NO VALUE DIGITS IN ',
     1132A1)
      KIND=2
      GO TO 15
   10 LOWBFR=LCNERR
      LCNERR=LCNERR-1
      WRITE(ITTY,11)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
   11 FORMAT(' INTEGER REQUIRED BUT TENTHS SPECIFIED IN ',
     1132A1)
      KIND=2
      GO TO 15
C
C     UNKNOWN INITIAL CHARACTER
   12 LOWBFR=LCNERR
      LCNERR=LCNERR-1
      WRITE(ITTY,13)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
   13 FORMAT(' NUMBER EXPECTED BUT INSTEAD FOUND ',132A1)
      KIND=2
      GO TO 15
C
C     MISSING NUMBER
   14 KIND=3
C
C     RETURN TO CALLING PROGRAM
   15 RETURN
C372999423353?'
      END
      SUBROUTINE DAMISS(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
     1    LOWBFR,KIND  ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
     2    VALUE ,MANY  ,LCNBFR,LCNERR)
C     RENBR(/DELIMITER WRAPPER FOR DAHEFT)
C
C     DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C     DAMISS  EVALUATES  NUMBERS,  ALLOWS  COMMAS   BETWEEN
C     NUMBERS,  IDENTIFIES MISSING ITEMS INDICATED BY EXTRA
C     COMMAS, SKIPS OVER ANY TEXT  WHICH  IS  TO  RIGHT  OF
C     EITHER  EXCLAMATION  POINT  OR AMPERSAND, AND REPORTS
C     ANY SEMICOLONS FOUND IN TEXT BEING EVALUATED.
C
C     ARGUMENT LISTS OF DAMISS  AND  DAHEFT  ARE  IDENTICAL
C     EXCEPT FOR ARGUMENTS MANY, LCNBFR AND LCNERR WHICH DO
C     NOT APPEAR IN DAHEFT ARGUMENT LIST, AND  EXCEPT  THAT
C     DAMISS  CAN  RETURN  ARGUMENT  NAMED  KIND CONTAINING
C     ADDITIONAL VALUES 4, 5, 6 AND 7.  ARGUMENT NAMED MANY
C     MUST BE SET TO ZERO BY CALLING PROGRAM BEFORE CALLING
C     EITHER THIS ROUTINE OR ANY OF OTHER ROUTINES IN  FASP
C     PACKAGE  (SUCH  AS  DANEXT,  DASPAN AND DATEST) WHICH
C     DEFINE THIS ARGUMENT IN  SIMILAR  MANNER.   ARGUMENTS
C     NAMED  KIND  AND  LCNBFR  ARE USED ONLY FOR OUTPUT TO
C     CALLING PROGRAM AND THEIR INPUT VALUES  ARE  IGNORED.
C     THESE  ARGUMENTS  ARE DESCRIBED BELOW.  DOCUMENTATION
C     OF DAHEFT SHOULD BE  CONSULTED  FOR  DESCRIPTIONS  OF
C     REMAINING ARGUMENTS.
C
C     KIND   = 1, NOTHING, EXCEPT PERHAPS COMMENT INDICATED
C              BY  LEADING  EXCLAMATION POINT, WAS FOUND AT
C              OR  TO  RIGHT  OF  IBUFFR(LOWBFR).   CALLING
C              PROGRAM  SHOULD  READ  NEW  LINE INTO IBUFFR
C              ARRAY BEFORE AGAIN CALLING THIS  ROUTINE  IF
C              ADDITIONAL  VALUES  ARE REQUIRED.  LOWBFR IS
C              RETURNED  POINTING  BEYOND  END  OF  BUFFER.
C              MANY  IS  RETURNED  SET TO ZERO.  IVALUE AND
C              VALUE ARE RETURNED UNDEFINED.
C            = 2,  FIRST  PRINTING  CHARACTER  (OTHER  THAN
C              POSSIBLE  COMMA  IF  MANY  WAS INPUT GREATER
C              THAN ZERO) IN OR TO RIGHT OF  IBUFFR(LOWBFR)
C              WAS   NOT   CHARACTER   WHICH   COULD  BEGIN
C              REPRESENTATION OF NUMBER AND WAS NOT  COMMA,
C              SEMICOLON,  AMPERSAND  OR EXCLAMATION POINT.
C              LOWBFR IS RETURNED POINTING TO THIS PRINTING
C              CHARACTER.   IT  IS  EXPECTED  THAT  CALLING
C              PROGRAM WILL OTHERWISE PROCESS THIS PRINTING
C              CHARACTER  SINCE  DAMISS  WOULD  RETURN SAME
C              RESULTS IF CALLED AGAIN WITH SAME  VALUE  OF
C              LOWBFR  AND WITH SAME BUFFER CONTENTS.  MANY
C              IS RETURNED CONTAINING ONE  PLUS  ITS  INPUT
C              ABSOLUTE   VALUE.    IVALUE  AND  VALUE  ARE
C              RETURNED UNDEFINED.
C            = 3, NUMBER WAS FOUND WHICH WAS FOLLOWED BY  A
C              SPACE,   TAB  CHARACTER,  COMMA,  SEMICOLON,
C              EXCLAMATION  POINT  OR  AMPERSAND.  MANY  IS
C              RETURNED   CONTAINING  ONE  PLUS  ITS  INPUT
C              ABSOLUTE VALUE.  LOWBFR IS RETURNED POINTING
C              TO    CHARACTER    TO    RIGHT   OF   NUMBER
C              REPRESENTATION.
C            = 4, NUMBER WAS FOUND WHICH  WAS  FOLLOWED  BY
C              CHARACTER  OTHER  THAN SPACE, TAB CHARACTER,
C              COMMA,  SEMICOLON,  EXCLAMATION   POINT   OR
C              AMPERSAND.   LCNBFR  IS RETURNED POINTING IN
C              BUFFER TO FIRST CHARACTER OF NUMBER.  LOWBFR
C              IS  RETURNED POINTING IN BUFFER TO CHARACTER
C              TO RIGHT  OF  NUMBER.   LCNERR  IS  RETURNED
C              POINTING   IN  BUFFER  TO  NEXT  SPACE,  TAB
C              CHARACTER,  COMMA,  SEMICOLON,   EXCLAMATION
C              POINT OR AMPERSAND TO RIGHT OF NUMBER, OR IS
C              RETURNED POINTING BEYOND END OF BUFFER IF NO
C              SPACE,   TAB  CHARACTER,  COMMA,  SEMICOLON,
C              EXCLAMATION POINT OR AMPERSAND IS  FOUND  TO
C              RIGHT   OF   NUMBER.    MANY   IS   RETURNED
C              CONTAINING  ONE  PLUS  ITS  INPUT   ABSOLUTE
C              VALUE.
C            = 5, SEMICOLON WAS  FOUND  AS  FIRST  PRINTING
C              CHARACTER  AT OR TO RIGHT OF IBUFFR(LOWBFR).
C              LOWBFR  IS   RETURNED   POINTING   TO   NEXT
C              CHARACTER  BEYOND  SEMICOLON.  IT IS ASSUMED
C              THAT CALLING PROGRAM WILL  TREAT  APPEARANCE
C              OF  SEMICOLON  AS  MARKING END OF STATEMENT.
C              MANY IS RETURNED SET TO  ZERO.   IVALUE  AND
C              VALUE ARE RETURNED UNDEFINED.
C            = 6, AMPERSAND WAS  FOUND  AS  FIRST  PRINTING
C              CHARACTER AT OR TO RIGHT OF LOWBFR.  TEXT TO
C              RIGHT OF AMPERSAND IS TAKEN  AS  COMMENT  SO
C              LOWBFR IS RETURNED POINTING BEYOND RIGHT END
C              OF  BUFFER.   IT  IS  ASSUMED  THAT  CALLING
C              PROGRAM WILL READ IN CONTENTS OF NEW BUFFER,
C              THEN AGAIN  REQUEST  NEW  NUMBER  EVALUATION
C              FROM  THIS  ROUTINE.  VALUE OF MANY MUST NOT
C              BE CHANGED BY CALLING PROGRAM PRIOR TO  THIS
C              FOLLOWING CALL.  EFFECT IS NOT QUITE SAME AS
C              IF USER HAD TYPED ALL OF TEXT ON SINGLE LINE
C              SINCE  SINGLE NUMBER  CANNOT BE SPLIT ACROSS
C              LINE BOUNDARY. IVALUE AND VALUE ARE RETURNED
C              UNDEFINED.
C            = 7, NUMBER WAS NOT FOUND, BUT EXTRA COMMA WAS
C              FOUND  INDICATING  MISSING  NUMBER.  MANY IS
C              RETURNED  CONTAINING  ONE  PLUS  ITS   INPUT
C              ABSOLUTE  VALUE.  IVALUE OR VALUE, WHICHEVER
C              IS APPROPRIATE, IS RETURNED SET TO ZERO.
C
C     MANY   = SHOULD BE INPUT CONTAINING  ZERO  EACH  TIME
C              THIS  ROUTINE  IS CALLED TO BEGIN PROCESSING
C              OF NEW  LOGICAL  SECTION  OF  TEXT,  AS  FOR
C              EXAMPLE WHEN BEGINNING PROCESSING OF LINE OF
C              TEXT NOT TIED TO PREVIOUS LINE BY  AMPERSAND
C              AT  END OF PREVIOUS LINE, OR WHEN PROCESSING
C              TEXT TO RIGHT OF SEMICOLON.  INITIAL ZEROING
C              OF  THIS  ARGUMENT  MUST  BE DONE BY CALLING
C              PROGRAM, BUT THEREAFTER  VALUE  RETURNED  BY
C              PREVIOUS CALL TO THIS ROUTINE CAN USUALLY BE
C              USED.  MANY IS RETURNED  SET  TO  ZERO  EACH
C              TIME  SEMICOLON  (KIND=5) IS FOUND, AND EACH
C              TIME END OF LINE NOT TIED TO FOLLOWING  LINE
C              BY  AMPERSAND  (KIND=1)  IS  FOUND.  MANY IS
C              RETURNED  CONTAINING  ONE  PLUS  ITS   INPUT
C              ABSOLUTE  VALUE  EACH  TIME NUMBER IS FOUND,
C              EACH TIME UNKNOWN  CHARACTER  IS  FOUND,  OR
C              EACH  TIME  INDICATION  OF MISSING NUMBER IS
C              FOUND.  KIND IS RETURNED CONTAINING VALUE  6
C              AND  MANY IS RETURNED CONTAINING NEGATIVE OF
C              NUMBER  OF  ITEMS  FOUND  IF  NEXT  PRINTING
C              CHARACTER   FOLLOWING  COMMA  IS  AMPERSAND.
C              MANY  SHOULD  NOT  BE  CHANGED  BY   CALLING
C              PROGRAM IF AMPERSAND (KIND BEING RETURNED=6)
C              IS FOUND INDICATING THAT SUBSEQUENT CALL  TO
C              THIS  ROUTINE IS TO PROCESS TEXT WHICH IS TO
C              BE TREATED AS THOUGH IT APPEARED IN PLACE OF
C              AMPERSAND   AND  CHARACTERS  TO  ITS  RIGHT.
C              EFFECT IS NOT QUITE  SAME  AS  IF  USER  HAD
C              TYPED  ALL  OF  TEXT  ON  SINGLE  LINE SINCE
C              SINGLE NUMBER  CANNOT  BE SPLIT  ACROSS LINE
C              BOUNDARY.
C
C              IF  MANY  IS  INPUT  CONTAINING  ZERO,  THEN
C              INITIAL  COMMA IN INPUT TEXT BUFFER IS TAKEN
C              TO INDICATE INITIAL MISSING ITEM,  AND  MANY
C              IS  THEN  RETURNED CONTAINING 1.  IF MANY IS
C              INPUT GREATER THAN ZERO, THEN INITIAL  COMMA
C              IS  IGNORED  IF FOLLOWED BY NUMBER.  IF MANY
C              IS INPUT GREATER  THAN  ZERO,  THEN  INITIAL
C              COMMA   FOLLOWED   BY   NO   OTHER  PRINTING
C              CHARACTERS, BY SEMICOLON, OR BY  EXCLAMATION
C              POINT  INDICATES  MISSING  ITEM.  IF MANY IS
C              INPUT GREATER THAN ZERO, THEN INITIAL  COMMA
C              FOLLOWED  BY  AMPERSAND WILL CAUSE REMAINING
C              CHARACTERS IN BUFFER TO BE IGNORED, AND MANY
C              WILL  BE RETURNED CONTAINING NEGATIVE OF ITS
C              INPUT VALUE.  IF  MANY  IS  INPUT  NEGATIVE,
C              THEN  IT IS ASSUMED THAT CONTENTS OF CURRENT
C              BUFFER   CONTINUE   PREVIOUS   LINE    WHICH
C              TERMINATED WITH COMMA FOLLOWED BY AMPERSAND,
C              AND MANY IS RETURNED GREATER THAN ZERO.
C
C     LCNBFR = IF  NUMBER  REPRESENTATION  IS  FOUND,  KIND
C              BEING  RETURNED  CONTAINING  EITHER  3 OR 4,
C              THEN LCNBFR IS RETURNED CONTAINING SUBSCRIPT
C              OF  IBUFFR  ARRAY  LOCATION  WHICH  CONTAINS
C              FIRST   (LEFTMOST)   CHARACTER   OF   NUMBER
C              REPRESENTATION. LCNBFR IS RETURNED UNDEFINED
C              IF NUMBER REPRESENTATION IS NOT FOUND.
C
C     LCNERR = IF KIND IS RETURNED SET TO 4 INDICATING THAT
C              NUMBER  WAS  FOLLOWED  BY PRINTING CHARACTER
C              OTHER  THAN  COMMA,  SEMICOLON,  EXCLAMATION
C              POINT  OR  AMPERSAND,  THEN  LCNERR CONTAINS
C              SUBSCRIPT IN IBUFFR ARRAY OF LOCATION  WHICH
C              CONTAINS NEXT  SPACE, TAB CHARACTER,  COMMA,
C              SEMICOLON, EXCLAMATION POINT OR AMPERSAND OR
C              IS SET TO  MAXBFR+1 IF NO  ALLOWED DELIMITER
C              CHARACTERS APPEARS TO RIGHT OF NUMBER.
C
      DIMENSION IBUFFR(MAXBFR)
      DATA KOMENT,IEND,IAND,KOMMA,ISPACE,ITAB/
     11H!,1H;,1H&,1H,,1H ,"045004020100/
      KIND=1
      IF(MANY.GE.0)GO TO 1
      KIND=7
      MANY=-MANY
    1 IF(KONTRL.LE.0)IVALUE=0
      IF(KONTRL.GT.0)VALUE=0.0
      GO TO 3
C
C     IDENTIFY NEXT CHARACTER
    2 LOWBFR=LOWBFR+1
    3 IF(LOWBFR.GT.MAXBFR)GO TO 9
      LETTER=IBUFFR(LOWBFR)
      IF(LETTER.EQ.ISPACE)GO TO 2
      IF(LETTER.EQ.ITAB)GO TO 2
      IF(LETTER.EQ.KOMENT)GO TO 8
      IF(LETTER.EQ.IEND)GO TO 6
      IF(LETTER.EQ.KOMMA)GO TO 5
      IF(LETTER.EQ.IAND)GO TO 7
C
C     TEST IF CHARACTER STARTS A NUMBER
      LCNBFR=LOWBFR
      CALL DAHEFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
     1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
     2VALUE)
      LCNERR=LOWBFR
    4 IF(LCNERR.GT.MAXBFR)GO TO 11
      LETTER=IBUFFR(LCNERR)
      IF(LETTER.EQ.ISPACE)GO TO 11
      IF(LETTER.EQ.ITAB)GO TO 11
      IF(LETTER.EQ.KOMENT)GO TO 11
      IF(LETTER.EQ.IEND)GO TO 11
      IF(LETTER.EQ.KOMMA)GO TO 11
      IF(LETTER.EQ.IAND)GO TO 11
      LCNERR=LCNERR+1
      IF(KIND.EQ.3)KIND=4
      GO TO 4
C
C     TEST IF COMMA CAN PRECEDE A VALUE
    5 IF(KIND.NE.1)GO TO 11
      KIND=7
      IF(MANY.EQ.0)GO TO 11
      GO TO 2
C
C     SEMICOLON FOUND
    6 IF(KIND.NE.1)GO TO 11
      LOWBFR=LOWBFR+1
      KIND=5
      GO TO 10
C
C     AMPERSAND FOUND
    7 IF(KIND.NE.1)MANY=-MANY
      KIND=6
      LOWBFR=MAXBFR+1
      GO TO 12
C
C     EXCLAMATION POINT FOUND
    8 IF(KIND.NE.1)GO TO 11
      LOWBFR=MAXBFR+1
      GO TO 10
C
C     END OF LINE FOUND
    9 IF(KIND.NE.1)GO TO 11
C
C     RETURN TO CALLING ROUTINE
   10 MANY=0
      GO TO 12
   11 MANY=MANY+1
   12 RETURN
C404203515168!;&
      END
      SUBROUTINE DADATE(IALLOW,IBUFFR,MAXBFR,LOWBFR,KIND  ,
     1   IDAY  ,IMONTH,IYEAR ,LCNBFR)
C     RENBR(/EVALUATE DATE SPECIFICATION)
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
