Trailing-Edge
-
PDP-10 Archives
-
decuslib20-07
-
decus/20-0174/admlib.for
There is 1 other file named admlib.for in the archive. Click here to see a list.
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