Trailing-Edge
-
PDP-10 Archives
-
decuslib20-08
-
decus/20-0175/liball.for
There are 3 other files named liball.for in the archive. Click here to see a list.
SUBROUTINE JOBPRO(NUMWHO,KLASS,ITTY,IDISK,
1 LMTSCH,KNTSLT,LNGSLT,NUMSLT,LMTSLT,MAXSLT,
2 INI060,LMTTIM,MAXTIM,LTRBFR,LMTBFR)
C RENBR(/GET PROFILES OF STARTING TIMES)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C MAXSLT = -2 RETURNED IF TOO MANY PROFILES
C = -3 RETURNED IF TOO MANY TIMES IN ALL PROFILES
C = -4 RETURNED IF TOO MANY TIMES IN ONE PROFILE
C = -5 RETURNED IF ERROR IN TIME SPECIFICATION
C
DIMENSION KNTSLT(LMTSLT),LNGSLT(LMTSLT),
1 NUMSLT(LMTSLT),INI060(LMTTIM),LTRBFR(LMTBFR)
DATA LTREQU,LTRCOM,LTREXC/1H=,1H,,1H!/
C
C INITIALIZE COUNTS
MAXSLT=0
MAXTIM=0
C
C GET NEXT LINE FROM FILE
1 READ(IDISK,2,END=23)LTRBFR
2 FORMAT(80A1)
LOWBFR=1
C
C EVALUATE THE LENGTH
3 CALL DAHEFT(0,0,0,LTRBFR,LMTBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
GO TO(1,4,5),KIND
4 IF(LTRBFR(LOWBFR).EQ.LTREQU)GO TO 23
IF(LTRBFR(LOWBFR).EQ.LTREXC)GO TO 1
IF(LTRBFR(LOWBFR).NE.LTRCOM)GO TO 29
LOWBFR=LOWBFR+1
GO TO 3
5 NUMONE=IVALUE
C
C EVALUATE SCHEDULE NUMBER
6 CALL DAHEFT(0,0,0,LTRBFR,LMTBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
GO TO(1,7,8),KIND
7 IF(LTRBFR(LOWBFR).EQ.LTREXC)GO TO 1
IF(LTRBFR(LOWBFR).NE.LTRCOM)GO TO 29
LOWBFR=LOWBFR+1
GO TO 6
8 NUMTWO=IVALUE
C
C DETERMINE IF ARE CONTINUING PREVIOUS SCHEDULE
NOWSLT=0
L3045=0
9 NOWSLT=NOWSLT+1
K3045=L3045+1
IF(NOWSLT.GT.MAXSLT)GO TO 10
L3045=L3045+KNTSLT(NOWSLT)
IF(NUMONE.NE.LNGSLT(NOWSLT))GO TO 9
IF(NUMTWO.NE.NUMSLT(NOWSLT))GO TO 9
GO TO 11
10 IF(MAXSLT.GE.LMTSLT)GO TO 26
MAXSLT=MAXSLT+1
KNTSLT(NOWSLT)=0
LNGSLT(NOWSLT)=NUMONE
NUMSLT(NOWSLT)=NUMTWO
11 CONTINUE
C
C EVALUATE NEXT TIME
12 CALL DADATE(2,LTRBFR,LMTBFR,LOWBFR,KIND ,
1 IHOUR ,IMINUT,IAMPM ,LCNBFR)
IF(KIND.EQ.1)GO TO 1
IF(KIND.EQ.2)GO TO 22
IF(KIND.EQ.3)GO TO 13
IF(KIND.LT.18)GO TO 29
IF(KIND.GT.21)GO TO 29
IF(IHOUR.LT.0)GO TO 29
13 IF(IMINUT.LT.0)IMINUT=0
C ADUST TIMES SUCH AS 12AM AND 12PM
IF(IHOUR.NE.12)GO TO 16
IF(IAMPM.EQ.3)GO TO 15
IF(IAMPM.EQ.2)GO TO 14
IF(IAMPM.EQ.1)IHOUR=0
GO TO 17
14 IF(IMINUT.EQ.0)IHOUR=24
GO TO 17
15 IF(IMINUT.NE.0)GO TO 29
GO TO 17
16 IF(IAMPM.EQ.2)IHOUR=IHOUR+12
IF(IAMPM.EQ.3)GO TO 29
17 IF(IHOUR.GT.24)GO TO 29
ITIME=(60*IHOUR)+IMINUT
C
C FIND POSITION INTO WHICH TIME IS TO BE PLACED
LOCTIM=K3045
18 IF(LOCTIM.GT.L3045)GO TO 19
IF(INI060(LOCTIM).GT.ITIME)GO TO 19
IF(INI060(LOCTIM).EQ.ITIME)GO TO 12
LOCTIM=LOCTIM+1
GO TO 18
19 CONTINUE
C
C STORE THE TIME
IF(MAXTIM.GE.LMTTIM)GO TO 27
IF(KNTSLT(NOWSLT).GE.LMTSCH)GO TO 28
L3045=L3045+1
KNTSLT(NOWSLT)=KNTSLT(NOWSLT)+1
MAXTIM=MAXTIM+1
I=MAXTIM
20 IF(I.LE.LOCTIM)GO TO 21
INI060(I)=INI060(I-1)
I=I-1
GO TO 20
21 INI060(LOCTIM)=ITIME
GO TO 12
22 IF(LTRBFR(LOWBFR).EQ.LTREXC)GO TO 1
IF(LTRBFR(LOWBFR).NE.LTRCOM)GO TO 29
LOWBFR=LOWBFR+1
GO TO 12
C
C REMOVE ANY ZERO LENGTH SCHEDULES
23 LIMIT=MAXSLT
MAXSLT=0
NOWSLT=0
24 NOWSLT=NOWSLT+1
IF(NOWSLT.GT.LIMIT)GO TO 25
IF(KNTSLT(NOWSLT).EQ.0)GO TO 24
MAXSLT=MAXSLT+1
KNTSLT(MAXSLT)=KNTSLT(NOWSLT)
LNGSLT(MAXSLT)=LNGSLT(NOWSLT)
NUMSLT(MAXSLT)=NUMSLT(NOWSLT)
GO TO 24
25 GO TO 30
C
C ERROR CONDITIONS
26 MAXSLT=-2
GO TO 30
27 MAXSLT=-3
GO TO 30
28 MAXSLT=-4
GO TO 30
29 MAXSLT=-5
30 RETURN
END
SUBROUTINE JOBNOW(NUMWHO,KLASS,ITTY,IDISK,LTRBFR,LMTBFR,
1 IERROR,JMOVE,JPASS,MANNER,KANRUN)
C RENBR(/DETERMINE CURRENT MOVE)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C IERROR = 0 RETURNED, IF LINE FOUND WITH FIRST NUMBER
C MATCHING KLASS.
C = 1 RETURNED, IF LINE NOT FOUND.
C = -1 RETURNED IF FILE COULD NOT BE OPENED.
C JMOVE = RETURNED CONTAINING 2ND NUMBER ON MATCHING LINE.
C JPASS = RETURNED CONTAINING 3ND NUMBER ON MATCHING LINE.
C MANNER = RETURNED CONTAINING 4ND NUMBER ON MATCHING LINE.
C KANRUN = RETURNED CONTAINING 5ND NUMBER ON MATCHING LINE.
C
C UPPER CASE A-Z, LOWER CASE A-Z AND DIGITS 0-9
COMMON/RSMFIV/LTRABC(26),LWRABC(26),LTRDGT(10)
C
DIMENSION LTRBFR(LMTBFR)
C
C LTRMIN = THE MINUS SIGN CHARACTER
C LTRPLU = THE PLUS SIGN CHARACTER
C LTREQU = THE EQUAL SIGN CHARACTER
C LTRSPA = THE SPACE CHARACTER
C LTREXC = THE EXCLAMATION MARK CHARACTER
C
DATA LTRMIN,LTRPLU,LTREQU,LTRSPA,LTREXC,LTRCOM/
1 1H-,1H+,1H=,1H ,1H!,1H,/
C
C OPEN THE FILE DESCRIBING CURRENT MOVE
CALL RSMOPN(5,NUMWHO,KLASS,ITTY,IDISK,IFOPEN)
IF(IFOPEN.EQ.0)GO TO 7
C
C READ NEXT LINE FROM INPUT FILE
1 READ(IDISK,2,END=8)LTRBFR
2 FORMAT(80A1)
C
C CYCLE THROUGH THE 4 NUMBERS AT START OF LINE
LOWBFR=1
DO 6 IPASS=1,5
C
C EVALUATE THE NUMBER
3 CALL DAHEFT(0,0,0,LTRBFR,LMTBFR,
1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2VALUE)
GO TO(1,4,5),KIND
4 IF(LTRBFR(LOWBFR).EQ.LTREQU)GO TO 8
IF(LTRBFR(LOWBFR).EQ.LTREXC)GO TO 1
IF(LTRBFR(LOWBFR).NE.LTRCOM)GO TO 1
LOWBFR=LOWBFR+1
GO TO 3
C
C STORE NUMBER IN PROPER SLOT
5 IF(IPASS.EQ.1)MASTR1=IVALUE
IF(IPASS.EQ.2)JMOVE=IVALUE
IF(IPASS.EQ.3)JPASS=IVALUE
IF(IPASS.EQ.4)MANNER=IVALUE
IF(IPASS.EQ.5)KANRUN=IVALUE
6 CONTINUE
IF(MASTR1.NE.KLASS)GO TO 1
IERROR=0
GO TO 9
C
C END OF FILE REACHED
7 IERROR=-1
GO TO 10
8 IERROR=1
C
C RETURN TO CALLING PROGRAM
9 CALL RSMCLS(5,NUMWHO,KLASS,ITTY,IDISK,IFCLOS)
10 RETURN
END
SUBROUTINE RSMCHK(LTRWHO,LWRWHO,LMTWHO,IPRJCT,IPRGRM, IDISK,
1 IYEAR,ICHECK,IPRINT,JVIDEO,LTRBFR,LMTBFR,ITTY,NUMWHO)
C RENBR(/DETERMINE CLASS OF CURRENT USER)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C THIS ROUTINE IS PART OF THE STUDENT RESUME SYSTEM
C
C THIS ROUTINE MUST RECOGNIZE THE ACCOUNT NAMING
C CONVENTIONS FOR THE COMPUTER BEING USED.
C
C The student resume program and the administrator
C program can only be run from accounts which are
C specified in a validation file which resides in the
C resume storage area. The validation file is named
C RESUME.WHO and contains 1 line for each account, or
C for each group of accounts, from which the programs
C can be run. Lines are read from the validation file
C until a line is found which exactly specifies the
C account from which the program is being run or which
C specifies a group of accounts of which the current
C account is a member. The subsequent lines in the
C validation file are ignored even if they also specify
C the current account. It is thus possible to treat a
C few members of a group of accounts differently than
C the rest of the members of the group by inserting
C lines which specify the special accounts before the
C line which specifies the rest of the group of
C accounts.
C
C The following is a typical validation file.
C
C 1 0 0 2 <S.E.*> !EVEN NUMBER YEAR CLASS
C 2 0 0 2 <S.S.*> !ODD NUMBER YEAR CLASS
C 3 0 0 2 <S.G.*> !GRADUATE STUDENTS
C 4 0 0 2 <S.N.*> !NON-MAJORS
C -1 999 999 2 <S.P.ADMIN> !FORESTRY SCHOOL ADMINISTRA
C 999 1 0 2 <S.P.FORESTRY> !FORESTRY SCHOOL STUDENTS
C 998 1 1 2 <S.D.SMITH> !TESTING
C -3 0 999 2 <S.D.BARTH> !ADMINISTRATOR
C -2 0 999 2 <S.W.JONES> !WORD PROCESSING
C 0 0 0 2 <S.*> !ALL OTHERS
C =
C
C The general form of an entry in the RESUME.WHO file
C is
C NUMBER1 NUMBER2 NUMBER3 NUMBER4 <ACCOUNT.NAME>
C or if accounts are identified by project number and
C programmer number
C NUMBER1 NUMBER2 NUMBER3 NUMBER4 [PROJECT,PROGRAMMER]
C Where
C NUMBER1 -1 or less enables administrator functions
C =-3 allows all administrator funtions
C = -2 allows production of proofs and
C unsubmitting of submitted resumes
C = -1 allows editing of submitted resumes
C = 0 through 999 places account into class
C having this value
C = 1000 or greater prevents use of the student
C resume program
C NUMBER2 = for administrator is lowest class which can
C be processed
C = 0 for others indicates each user has own
C account
C = 1 for others indicates all users use same
C account and give passwords they select
C = 2 for others indicates all users use same
C account and give passwords assigned to them
C NUMBER3 = for administrator is highest class which
C can be processed
C = 0 for others indicates output will be on
C letter quality printer
C = 1 for others indicates ultimate output will
C be typeset
C NUMBER4 = 0, terminal used to run program types on
C paper
C = 1, video terminal which scrolls
C = 2, video terminal on which form feed clears
C screen
C
C Anything which appears to the right of an exclamation
C point is treated as a comment and is ignored. The
C end of the file is marked by a line which starts with
C an equal sign. The line which starts with an equal
C sign and all lines which follow the line which starts
C with an equal sign are ignored.
C
C The accounts which can be used to run the programs
C are specified by name on the DECsystem20. Account
C are arranged in a tree structure with periods
C separating the list of nodes. The account names
C which appear to the right of the numbers in the
C validation file should be preceded by a less than
C sign and followed by a greater than sign although any
C sequence of printing characters which does not start
C with a left square bracket is also taken to be an
C account name. An asterisk can be included at right
C end of the account name if any sequence of nodes is
C to be allowed starting at that point. A period can
C appear between the names of the nodes to the left and
C the asterisk but is not required. In order to be
C matched, the name of the account being used must
C include a node at the location of the asterisk. An
C account name consisting only of nodes to the left of
C the location of the asterisk will not be matched.
C For example
C
C 1 0 0 0 <*> !allows any account
C 1 0 0 0 <S.O> !allows <S.O> but not <S.O.SMITH>
C !or <S.O.JONES>
C 1 0 0 0 <S.O.*> !allows <S.O.SMITH> and
C !<S.O.JONES> but not <S.O>
C 1 0 0 0 <S.O*> !same as the above
C 1 0 0 0 <S.O.SMITH> !allows <S.O.SMITH> but not <S.O>
C !or <S.O.JONES>
C
C The accounts which can be used to run the program are
C specified by numbers on the DECsystem10. Each
C purpose for which the computer can be used is
C assigned a project number and these project numbers
C are paired with a programmer number which identifies
C a particular user. The project and programmer
C numbers are octal numbers, and never include either
C of the decimal digits 8 or 9. Accounts are specified
C in the validation file by a left square bracket,
C followed by the project number, a comma, the
C programmer number and a right square bracket. Spaces
C can appear on either side of the numbers and can
C replace the separating comma. A question mark can
C appear anywhere in either number where any digit is
C to be allowed. An asterisk can appear instead of a
C number if any number is to be allowed. A comma can
C separate the asterisk from the other number but is
C not necessary. For example,
C
C 1 0 0 0 [201,3556] !allows programmer 3556 to use
C !project 201
C 1 0 0 0 [*,3556] !allows programmer 3556 to use
C !any project
C 1 0 0 0 [*3556] !same as the above
C 1 0 0 0 [201,*] !allows any programmer to use
C !project 201
C 1 0 0 0 [?01,*] !allows any programmer to use
C !project 1 or 101 or 201 or 301
C !or 401 or 501 or 601 or 701
C 1 0 0 0 [?01*] !same as the above
C
C
C Description of the arguments of this routine
C
C LTRWHO = input containing the name of the account
C from which this proram is being run. The
C LTRWHO array should be defined as though
C read by a multiple of an A1 format. This
C will be matched against lines in the file
C which contain account names starting with
C less than signs. LTRWHO can start with a
C less than sign, but it is not necessary.
C LMTWHO = input containing the number of characters in
C the LTRWHO array. This number can include
C rightmost blanks.
C IPRJCT = input containing the DECsystem10 project
C number from which this program is being run.
C This will be matched against the first
C number to the right of a left square bracket
C in any line in the input file.
C IPRGRM = input containing the DECsystem10 programmer
C number from which this program is being run.
C This will be matched against the second
C number to the right of a left square bracket
C in any line in the input file.
C IDISK = input containing the number of the input
C device from which the input file is to be
C read.
C IYEAR = returned containing the class number
C = -3 all administrator functions are enabled
C = -2 can proof and unsubmit any submitted
C resume
C = -1 can edit any submitted resume
C = 0 through 999, returned with class number
C = 1000 if the user is not allowed to run the
C program
C ICHECK = returned indicating if the calling program
C must ask for a password
C = 0, do not require that the user supply a
C password
C = 1, require that the user supply a password
C = if IYEAR is -1 or less, then ICHECK is
C lowest class number which can be processed
C IPRINT = returned indicating if the final resume will
C be typeset
C = 0, the final resume will be typed on a
C letter quality terminal
C = 1, the final resume will be typeset
C = if IYEAR is -1 or less, then IPRINT is
C highest class number which can be processed
C JVIDEO = returned indicating the type of terminal
C which will be used
C = 0, terminal types onto paper
C = 1, scrolling video terminal which cannot
C clear screen when form feed is received
C = 2, scrolling video terminal which clears
C screen when form feed is received
C LTRBFR = array into which each line of the input file
C can be read
C
C UPPER CASE A-Z, LOWER CASE A-Z AND DIGITS 0-9
COMMON/RSMFIV/LTRABC(26),LWRABC(26),LTRDGT(10)
C
DIMENSION LTRWHO(LMTWHO),LWRWHO(LMTWHO),LTRBFR(LMTBFR)
C
C LTRSTA = THE ASTERISK CHARACTER
C LTRQUE = THE PERCENT SIGN CHARACTER
C LTRMIN = THE MINUS SIGN CHARACTER
C LTRPLU = THE PLUS SIGN CHARACTER
C LTREQU = THE EQUAL SIGN CHARACTER
C LTRSPA = THE SPACE CHARACTER
C LTREXC = THE EXCLAMATION MARK CHARACTER
C LTRLTS = THE LESS THAN SIGN CHARACTER
C LTRGTS = THE GREATER THAN SIGN CHARACTER
C LTRLSB = THE LEFT SQUARE BRACKET CHARACTER
C LTRRSB = THE RIGHT SQUARE BRACKET CHARACTER
C LTRCOM = THE COMMA CHARACTER
C LTRDOT = THE PERIOD
C
DATA LTRSTA,LTRQUE,LTRMIN,LTRPLU,LTREQU,LTRSPA,LTREXC,
1 LTRLTS,LTRGTS,LTRLSB,LTRRSB,LTRCOM,LTRDOT/
2 1H*,1H?,1H-,1H+,1H=,1H ,1H!,1H<,1H>,1H[,1H],1H,,1H./
C
C GET LOWER CASE FORMS OF LETTERS IN ACCOUNT NAME
IF(LMTWHO.LE.0)GO TO 4
DO 3 I=1,LMTWHO
LTRNOW=LTRWHO(I)
LWRWHO(I)=LTRNOW
IF(LTRNOW.EQ.LTRSPA)GO TO 3
DO 2 J=1,26
IF(LTRNOW.EQ.LTRABC(J))GO TO 1
IF(LTRNOW.EQ.LWRABC(J))GO TO 1
GO TO 2
1 LTRWHO(I)=LTRABC(J)
LWRWHO(I)=LWRABC(J)
GO TO 3
2 CONTINUE
3 CONTINUE
4 CONTINUE
C
C OPEN THE FILE DESCRIBING KNOWN ACCOUNTS
CALL RSMOPN(1,NUMWHO,IYEAR,ITTY,IDISK,IFOPEN)
IF(IFOPEN.EQ.0)GO TO 32
C
C READ NEXT LINE FROM INPUT FILE
5 READ(IDISK,6,END=33)LTRBFR
6 FORMAT(80A1)
C
C CYCLE THROUGH THE 4 NUMBERS AT START OF LINE
IFIRST=0
DO 12 IPASS=1,4
C
C GET NEXT PRINTING CHARACTER IN LINE
7 IFIRST=IFIRST+1
IF(IFIRST.GT.LMTBFR)GO TO 5
LTRNOW=LTRBFR(IFIRST)
IF(LTRNOW.EQ.LTRSPA)GO TO 7
IF(LTRNOW.EQ.LTREXC)GO TO 5
IF(LTRNOW.EQ.LTREQU)GO TO 33
MINUS=0
IF(LTRNOW.EQ.LTRPLU)GO TO 8
IF(LTRNOW.NE.LTRMIN)GO TO 9
MINUS=1
8 IFIRST=IFIRST+1
C
C EVALUATE NUMBER
9 IVALUE=0
10 IF(IFIRST.GT.LMTBFR)GO TO 5
LTRNOW=LTRBFR(IFIRST)
DO 11 I=1,10
IF(LTRNOW.NE.LTRDGT(I))GO TO 11
IVALUE=(10*IVALUE)+I-1
IFIRST=IFIRST+1
GO TO 10
11 CONTINUE
IFIRST=IFIRST-1
IF(MINUS.NE.0)IVALUE=-IVALUE
C
C STORE NUMBER IN PROPER SLOT
IF(IPASS.EQ.1)IYEAR=IVALUE
IF(IPASS.EQ.2)ICHECK=IVALUE
IF(IPASS.EQ.3)IPRINT=IVALUE
IF(IPASS.EQ.4)JVIDEO=IVALUE
12 CONTINUE
C
C LOOK FOR NEXT PRINTING CHARACTER
13 IFIRST=IFIRST+1
IF(IFIRST.GT.LMTBFR)GO TO 5
LTRNOW=LTRBFR(IFIRST)
IF(LTRNOW.EQ.LTRSPA)GO TO 13
IF(LTRNOW.EQ.LTRLTS)GO TO 25
IF(LTRNOW.EQ.LTRLSB)GO TO 14
GO TO 24
C
C *****************************************************
C * *
C * COMPARE PAIR OF NUMBERS BETWEEN SQUARE BRACKETS *
C * *
C *****************************************************
C
14 IPASS=1
15 IFIRST=IFIRST+1
IF(IFIRST.GT.LMTBFR)GO TO 5
LTRNOW=LTRBFR(IFIRST)
IF(LTRNOW.EQ.LTREXC)GO TO 5
IF(LTRNOW.EQ.LTRRSB)GO TO 5
IF(LTRNOW.EQ.LTRSPA)GO TO 15
IF(LTRNOW.EQ.LTRSTA)GO TO 19
IFINAL=IFIRST
16 IFINAL=IFINAL+1
IF(IFINAL.GT.LMTBFR)GO TO 17
LTRNOW=LTRBFR(IFINAL)
IF(LTRNOW.EQ.LTREXC)GO TO 17
IF(LTRNOW.EQ.LTRRSB)GO TO 17
IF(LTRNOW.EQ.LTRSPA)GO TO 17
IF(LTRNOW.EQ.LTRCOM)GO TO 17
IF(LTRNOW.EQ.LTRSTA)GO TO 17
GO TO 16
17 NUMBER=IPRJCT
IF(IPASS.EQ.2)NUMBER=IPRGRM
JFINAL=IFINAL
18 JFINAL=JFINAL-1
IF(JFINAL.LT.IFIRST)GO TO 20
MATCH=NUMBER
NUMBER=NUMBER/8
MATCH=MATCH-(8*NUMBER)
LTRNOW=LTRBFR(JFINAL)
IF(LTRNOW.EQ.LTRQUE)GO TO 18
IF(LTRNOW.EQ.LTRDGT(MATCH+1))GO TO 18
GO TO 5
19 IFINAL=IFIRST+1
GO TO 21
20 IF(NUMBER.NE.0)GO TO 5
21 IFINAL=IFINAL-1
IF(IPASS.EQ.2)GO TO 34
IPASS=2
22 IFINAL=IFINAL+1
IF(IFINAL.GT.LMTBFR)GO TO 5
LTRNOW=LTRBFR(IFINAL)
IF(LTRNOW.EQ.LTREXC)GO TO 5
IF(LTRNOW.EQ.LTRRSB)GO TO 5
IF(LTRNOW.EQ.LTRSPA)GO TO 22
IF(LTRNOW.EQ.LTRCOM)GO TO 23
IFIRST=IFINAL-1
GO TO 15
23 IFIRST=IFINAL
GO TO 15
C
C *****************************************************
C * *
C * ACCOUNT NAME BETWEEN LESS THAN AND GREATER THAN *
C * *
C *****************************************************
C
C GET NEXT CHARACTERS FROM LOCAL NAME AND FILE
24 IFIRST=IFIRST-1
25 IF(LMTWHO.LE.0)GO TO 5
JFIRST=0
IF(LTRWHO(1).EQ.LTRLTS)JFIRST=1
26 INODE=1
GO TO 28
27 INODE=0
28 IFIRST=IFIRST+1
JFIRST=JFIRST+1
IF(IFIRST.GT.LMTBFR)GO TO 30
LTRGBL=LTRBFR(IFIRST)
IF(LTRGBL.EQ.LTREXC)GO TO 30
IF(LTRGBL.EQ.LTRSPA)GO TO 30
IF(LTRGBL.EQ.LTRGTS)GO TO 30
IF(JFIRST.GT.LMTWHO)GO TO 5
LTRLCL=LTRWHO(JFIRST)
IF(LTRLCL.EQ.LTREXC)GO TO 5
IF(LTRLCL.EQ.LTRSPA)GO TO 5
IF(LTRLCL.EQ.LTRGTS)GO TO 5
IF(LTRGBL.EQ.LTRSTA)GO TO 31
IF(LTRGBL.EQ.LTRLCL)GO TO 29
IF(LTRGBL.EQ.LWRWHO(JFIRST))GO TO 29
GO TO 5
29 IF(LTRGBL.NE.LTRDOT)GO TO 27
GO TO 26
C
C END OF LINE REACHED IN FILE
30 IF(JFIRST.GT.LMTWHO)GO TO 34
LTRLCL=LTRWHO(JFIRST)
IF(LTRLCL.EQ.LTREXC)GO TO 34
IF(LTRLCL.EQ.LTRSPA)GO TO 34
IF(LTRLCL.EQ.LTRGTS)GO TO 34
GO TO 5
C
C ASTERISK FOUND IN FILE
31 IF(INODE.NE.0)GO TO 34
IF(LTRLCL.NE.LTRDOT)GO TO 5
GO TO 34
C
C RETURN TO CALLING PROGRAM
32 IYEAR=1000
GO TO 35
33 IYEAR=1000
34 CALL RSMCLS(1,NUMWHO,IYEAR,ITTY,IDISK,IFCLOS)
35 RETURN
END
SUBROUTINE PASWRD(LTRPSW,LMTPSW,ITTY,LNGPSW,NUMWHO,
1LTRBFR,LMTBFR)
C RENBR(/GET PASSWORD AND CONVERT TO NUMBER)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C LTRPSW = ARRAY RETURNED CONTAINING PASSWORD
C LMTPSW = DIMENSION OF LTRPSW
C ITTY = UNIT FROM WHICH MESSAGE IS READ
C LNGPSW = RETURNED WITH NUMBER OF CHARACTERS IN PASSWORD
C NUMWHO = RETURNED WITH NUMBER BASED ON PASSWORD
C = -1 RETURNED IF HELP MESSAGE NEEDED
C LTRBFR = ARRAY USED TO READ IN PASSWORD. SHOULD BE LONGER
C THAN LTRPSW SO OVERFLOW OF LTRPSW CAN BE SENSED.
C LMTBFR = DIMENSION OF LTRBFR
C
C UPPER CASE A-Z, LOWER CASE A-Z AND DIGITS 0-9
COMMON/RSMFIV/LTRABC(26),LWRABC(26),LTRDGT(10)
C
DIMENSION LTRPSW(LMTPSW),
1LTRBFR(LMTBFR)
DATA LTRSPA /1H /
C
C LMTVAL = 1 MORE THAN MAXIMUM VALUE OF NUMBER WHICH CAN
C BE RETURNED BASED UPON PASSWORD
DATA LMTVAL/1000000/
C
C ASK USER FOR PASSWORD
1 WRITE(ITTY,2)
2 FORMAT(' Password? ',$)
CALL GETLIN(ITTY,LTRBFR,LMTBFR,MAXBFR)
IF(MAXBFR.LT.0)GO TO 19
IF(MAXBFR.EQ.0)GO TO 17
C
C CONVERT THE PASSWORD INTO A 6 DIGIT DECIMAL NUMBER.
C THE WORD IS TREATED ESSENTIALLY AS A RADIX 37 NUMBER.
C THE SPACES BETWEEN WORDS HAVE THE VALUE ZERO.
C THE LETTERS A THROUGH Z HAVE VALUES 1 THROUGH 26.
C THE DIGITS 0 THROUGH 9 HAVE VALUES 27 THROUGH 36
C
C WORD VALUE WORD VALUE
C A 1 A A 1370
C
C 9 36 A 9 1405
C AA 38 AAA 1407
C
C A9 73 A99 2737
C BA 75 B A 2739
C
C B9 110 B 9 2774
C
C WORDS ARE ALSO SHIFTED TO LEFT AND CAPITALIZED
C
NUMWHO=0
LNGPSW=0
IBLANK=-1
DO 11 IOUTER=1,MAXBFR
LTRNOW=LTRBFR(IOUTER)
IF(LTRNOW.EQ.LTRSPA)GO TO 10
C
C CHECK FOR DIGITS
DO 3 INNER=1,10
IF(LTRNOW.NE.LTRDGT(INNER))GO TO 3
NEXT=INNER+26
GO TO 6
3 CONTINUE
C
C CHECK FOR UPPER CASE LETTERS
DO 4 INNER=1,26
IF(LTRNOW.NE.LTRABC(INNER))GO TO 4
NEXT=INNER
GO TO 6
4 CONTINUE
C
C CHECK FOR LOWER CASE LETTERS
DO 5 INNER=1,26
IF(LTRNOW.NE.LWRABC(INNER))GO TO 5
LTRNOW=LTRABC(INNER)
NEXT=INNER
GO TO 6
5 CONTINUE
C
C NO MATCH FOUND
GO TO 13
C
C INSERT THE VALUE OF CHARACTER INTO PASSWORD NUMBER
6 IF(IBLANK.LE.0)GO TO 7
NUMWHO=37*NUMWHO
GO TO 8
7 IBLANK=0
NUMWHO=(37*NUMWHO)+NEXT
8 IF(LNGPSW.GE.LMTPSW)GO TO 15
NUMWHO=NUMWHO-LMTVAL*(NUMWHO/LMTVAL)
IF(IBLANK.EQ.0)GO TO 9
LNGPSW=LNGPSW+1
LTRPSW(LNGPSW)=LTRSPA
GO TO 7
9 LNGPSW=LNGPSW+1
LTRPSW(LNGPSW)=LTRNOW
GO TO 11
C
C BLANK FOUND
10 IF(IBLANK.EQ.0)IBLANK=1
11 CONTINUE
C
C FILL REST OF ARRAY WITH SPACES
I=LNGPSW
12 I=I+1
IF(I.GT.LMTPSW)GO TO 20
LTRPSW(I)=LTRSPA
GO TO 12
C
C ERROR MESSAGE AND HELP MESSAGE
13 WRITE(ITTY,14)LTRNOW
14 FORMAT(' Password contains illegal character ',1A1/
1' Use only letters A through Z, digits 0 through 9 and spaces')
GO TO 1
15 WRITE(ITTY,16)LMTPSW
16 FORMAT(' Password cannot be longer than',1I3,' characters')
GO TO 1
17 WRITE(ITTY,18)
18 FORMAT(' Password must be supplied'/' Type ? for help')
GO TO 1
C
C MAIN PROGRAM MUST SUPPLY HELP MESSAGE
19 NUMWHO=-1
20 RETURN
END
SUBROUTINE PASLST(IVIDEO,JVIDEO,IYEAR,IDISK,ITTY,
1LMTPSW,LTRPSW,LTRCHK,LNGPSW,NUMWHO,LTRBFR,LMTBFR)
C RENBR(/GET PASSWORD FROM PREDEFINED LIST)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C INPUT ARGUMENTS
C JVIDEO = 0, DO NOT FORM FEED BEFORE HELP MESSAGES
C = 1, ISSUE FORM FEED BEFORE HELP MESSAGES
C IYEAR = CLASS NUMBER
C IDISK = UNIT FROM WHICH READ
C ITTY = UNIT ON WHICH MESSAGE ARE WRITTEN, PASSWORD READ
C LMTPSW = DIMENSION OF LTRPSW
C
C OUTPUT ARGUMENTS
C LTRPSW = ARRAY RETURNED WITH UPPER CASE PASSWORD
C LTRCHK = ARRAY RETURNED WITH LOWER CASE PASSWORD. THIS
C IS SCRATH ARRAY NOT NEEDED BY CALLING PROGRAM
C LNGPSW = RETURNED WITH NUMBER OF CHARACTERS IN PASSWORD
C NUMWHO = RETURNED WITH NUMBER READ AS START OF PASSWORD
C
C SCRATCH ARRAY
C LTRBFR = ARRAY USED TO READ IN PASSWORD. SHOULD BE LONGER
C THAN LTRPSW SO OVERFLOW OF LTRPSW CAN BE SENSED.
C LMTBFR = DIMENSION OF LTRBFR
C
C UPPER CASE A-Z, LOWER CASE A-Z AND DIGITS 0-9
COMMON/RSMFIV/LTRABC(26),LWRABC(26),LTRDGT(10)
C
DIMENSION LTRPSW(LMTPSW),
1LTRBFR(LMTBFR),LTRCHK(LMTPSW)
C
DATA LTRSPA,LTRZER,LTREQU,LTREXC /1H ,1H0,1H=,1H!/
C
C ASK USER FOR NUMBER
KNTPSW=0
1 WRITE(ITTY,2)
2 FORMAT(' Number and password? ',$)
CALL GETLIN(ITTY,LTRBFR,LMTBFR,MAXBFR)
IF(MAXBFR.LT.0)GO TO 43
IF(MAXBFR.EQ.0)GO TO 41
MINBFR=0
3 MINBFR=MINBFR+1
IF(LTRBFR(MINBFR).EQ.LTRSPA)GO TO 3
KOMPAR=-1
4 LTRNOW=LTRBFR(MINBFR)
IF(LTRNOW.EQ.LTRSPA)GO TO 9
DO 5 IDIGIT=1,10
IF(LTRNOW.NE.LTRDGT(IDIGIT))GO TO 5
IF(KOMPAR.LT.0)KOMPAR=0
KOMPAR=(10*KOMPAR)+IDIGIT-1
GO TO 6
5 CONTINUE
IF(KOMPAR.LT.0)GO TO 41
GO TO 9
6 MINBFR=MINBFR+1
IF(MINBFR.LE.MAXBFR)GO TO 4
C
C ASK USER FOR PASSWORD
7 WRITE(ITTY,8)
8 FORMAT(' Password? ',$)
CALL GETLIN(ITTY,LTRBFR,LMTBFR,MAXBFR)
IF(MAXBFR.LT.0)GO TO 46
IF(MAXBFR.EQ.0)GO TO 44
C
C CONVERT PASWORD TO UPPER CASE AND REMOVE EXTRA SPACES
MINBFR=1
9 LNGPSW=0
IBLANK=-1
DO 17 IOUTER=MINBFR,MAXBFR
LTRNOW=LTRBFR(IOUTER)
LWRNOW=LTRNOW
IF(LTRNOW.EQ.LTRSPA)GO TO 16
C
C CHECK FOR UPPER CASE LETTERS
DO 10 INNER=1,26
IF(LTRNOW.NE.LTRABC(INNER))GO TO 10
LWRNOW=LWRABC(INNER)
GO TO 12
10 CONTINUE
C
C CHECK FOR LOWER CASE LETTERS
DO 11 INNER=1,26
IF(LTRNOW.NE.LWRABC(INNER))GO TO 11
LTRNOW=LTRABC(INNER)
GO TO 12
11 CONTINUE
C
C PACK THE PRINTING CHARACTER INTO PASSWORD
12 IF(IBLANK.GT.0)GO TO 14
13 IBLANK=0
14 IF(LNGPSW.GE.LMTPSW)GO TO 38
IF(IBLANK.EQ.0)GO TO 15
LNGPSW=LNGPSW+1
LTRPSW(LNGPSW)=LTRSPA
GO TO 13
15 LNGPSW=LNGPSW+1
LTRPSW(LNGPSW)=LTRNOW
LTRCHK(LNGPSW)=LWRNOW
GO TO 17
C
C BLANK FOUND
16 IF(IBLANK.EQ.0)IBLANK=1
17 CONTINUE
C
C FILL REST OF ARRAY WITH SPACES
I=LNGPSW
18 I=I+1
IF(I.GT.LMTPSW)GO TO 19
LTRPSW(I)=LTRSPA
LTRCHK(I)=LTRSPA
GO TO 18
19 CONTINUE
C
C OPEN THE PASSWORD FILE
CALL RSMOPN(2,NUMWHO,IYEAR,ITTY,IDISK,IFOPEN)
IF(IFOPEN.EQ.0)GO TO 47
20 READ(IDISK,21,END=37)LTRBFR
21 FORMAT(80A1)
C
C SKIP OVER LEADING NUMBER ON LINE
MINNUM=0
22 MINNUM=MINNUM+1
IF(MINNUM.GT.LMTBFR)GO TO 20
IF(LTRBFR(MINNUM).EQ.LTRSPA)GO TO 22
MAXNUM=MINNUM
23 MAXNUM=MAXNUM+1
IF(MAXNUM.GT.LMTBFR)GO TO 20
IF(LTRBFR(MAXNUM).NE.LTRSPA)GO TO 23
IF(LTRBFR(MINNUM).EQ.LTREQU)GO TO 37
C
C EVALUATE NUMBER AT START OF LINE
NUMWHO=0
GO TO 25
24 MINNUM=MINNUM+1
IF(MINNUM.GE.MAXNUM)GO TO 27
25 LTRNOW=LTRBFR(MINNUM)
DO 26 IDIGIT=1,10
IF(LTRNOW.NE.LTRDGT(IDIGIT))GO TO 26
NUMWHO=(10*NUMWHO)+IDIGIT-1
GO TO 24
26 CONTINUE
GO TO 20
27 IF(NUMWHO.NE.KOMPAR)GO TO 20
C
C COMPARE PASSWORD TYPED BY USER AND READ FROM FILE
IFIRST=MAXNUM-1
JFIRST=0
C
C NOTE THAT THIS IS A GENERAL PROCEDURE FOR COMPARING
C ANY 2 STRINGS THAT CAN CONTAIN SPACES AND THAT CAN,
C BUT ARE NOT REQUIRED TO, BEGIN AND END WITH SPACES.
C BOTH STRINGS MUST HAVE THE PRINTING CHARACTERS SPLIT
C INTO THE SAME NUMBER OF WORDS, BUT THE ACTUAL NUMBER
C OF SPACES BETWEEN THE WORDS IS IGNORED IN BOTH ARRAYS.
C
C LTRBFR = ARRAY CONTAINING LINE READ FROM FILE
C LMTBFR = NUMBER OF CHARACTERS IN LTRBFR ARRAY
C IFIRST = LOCATION TO LEFT OF FIRST LOCATION TO TEST
C IN LTRBFR ARRAY.
C LTRPSW = UPPER CASE PASSWORD TYPED BY USER
C LTRCHK = LOWER CASE VERSION OF PASSWORD TYPED BY USER
C LMTPSW = NUMBER OF CHARACTERS IN LTRPSW ARRAY
C JFIRST = LOCATION TO LEFT OF FIRST LOCATION TO TEST
C IN LTRPSW ARRAY.
C
IBLANK=-1
GO TO 29
28 IBLANK=0
29 IFIRST=IFIRST+1
IF(IFIRST.GT.LMTBFR)GO TO 34
LTRNOW=LTRBFR(IFIRST)
IF(LTRNOW.EQ.LTRSPA)GO TO 31
IF(LTRNOW.EQ.LTREXC)GO TO 33
30 JFIRST=JFIRST+1
IF(JFIRST.GT.LMTPSW)GO TO 35
IF(LTRPSW(JFIRST).EQ.LTRSPA)GO TO 32
IF(IBLANK.GT.0)GO TO 36
IF(LTRNOW.EQ.LTRPSW(JFIRST))GO TO 28
IF(LTRNOW.EQ.LTRCHK(JFIRST))GO TO 28
GO TO 36
31 IF(IBLANK.EQ.0)IBLANK=1
GO TO 29
32 IF(IBLANK.EQ.0)GO TO 36
IBLANK=-1
GO TO 30
33 IFIRST=LMTBFR+1
34 IBLANK=1
GO TO 30
35 IF(IFIRST.LE.LMTBFR)GO TO 36
C
C MATCH
KNTPSW=-1
GO TO 37
C
C NO MATCH
36 GO TO 37
C
C ALL DONE READING FILE
37 CALL RSMCLS(2,NUMWHO,IYEAR,ITTY,IDISK,IFCLOS)
IF(KNTPSW.LT.0)GO TO 50
38 WRITE(ITTY,39)
39 FORMAT(' Unknown password')
KNTPSW=KNTPSW+1
IF(KNTPSW.LT.3)GO TO 1
WRITE(ITTY,40)
40 FORMAT(' Only 3 tries are allowed')
GO TO 49
C
C ERROR MESSAGE AND HELP MESSAGE
41 WRITE(ITTY,42)
42 FORMAT(' Number must be supplied. Type ? for help.')
GO TO 1
43 CALL RSMHLP(ITTY,44,LTRBFR,LMTBFR,MAXBFR,IVIDEO)
GO TO 1
44 WRITE(ITTY,45)
45 FORMAT(' Password must be supplied. Type ? for help.')
GO TO 7
46 CALL RSMHLP(ITTY,40,LTRBFR,LMTBFR,MAXBFR,IVIDEO)
GO TO 7
47 WRITE(ITTY,48)
48 FORMAT(' Cannot read password file')
GO TO 49
C
C RETURN TO CALLING PROGRAM
49 LNGPSW=0
50 RETURN
END
SUBROUTINE YESNO(IFORCE,KNDYES,ITTY)
C IFORCE = 0, RETURN KNDYES=1 FOR EMPTY RESPONSE.
C NO NOT GENERATE A WARNING.
C = 1, RETURN KNDYES=2 FOR EMPTY RESPONSE.
C THE USER IS TOLD TO RESPOND WITH YES OR NO.
C KNDYES = 1, NOTHING TYPED (AND IFORCE=0)
C = 2, ERROR, REISSUE PROMPT
C = 3, YES ANSWERED
C = 4, NO ANSWERED
C = 5, QUESTION MARK TYPED
DIMENSION LTRBFR(20),LTRYES(5),LNGYES(2)
DATA LMTBFR/20/
DATA LTRYES/1HY,1HE,1HS,1HN,1HO/
DATA LNGYES/3,2/
DATA LMTLYN,LMTKYN/5,2/
DATA LTRSPA/1H /
C
C READ LINE FO TEXT TYPED BY USER
CALL GETLIN(ITTY,LTRBFR,LMTBFR,MAXBFR)
IF(MAXBFR.LT.0)GO TO 6
C
C IDENITIFY RESPONSE
LOWBFR=1
CALL DAVERB(1,LMTLYN,LTRYES,1,LMTKYN,
1LNGYES,LTRBFR,MAXBFR,LOWBFR,KIND,MATCH,LCNWRD,
2LCNKNT,LCNBFR)
GO TO(2,4,1,1,4),KIND
C
C CHECK FOR TRAILING PRINTING CHARACTER
1 IF(LOWBFR.GT.MAXBFR)GO TO 7
IF(LTRBFR(LOWBFR).NE.LTRSPA)GO TO 4
LOWBFR=LOWBFR+1
GO TO 1
C
C RETURN TO CALLING PROGRAM
2 IF(IFORCE.NE.0)GO TO 4
3 KNDYES=1
GO TO 8
4 WRITE(ITTY,5)
5 FORMAT(' Answer either YES or NO')
KNDYES=2
GO TO 8
6 KNDYES=5
GO TO 8
7 KNDYES=MATCH+2
8 RETURN
END
SUBROUTINE DAHEFT(KONTRL,ITRAIL,IEXTRA,IBUFFR,MAXBFR,
1 LOWBFR,KIND ,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
2 VALUE )
C RENBR(/FREE FORMAT NUMERIC INPUT ROUTINE)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAHEFT INTERPRETS AN ARRAY READ BY THE CALLING
C PROGRAM WITH A MULTIPLE OF AN A1 FORMAT AND RETURNS
C THE VALUES CONTAINED IN THIS ARRAY.
C
C NUMBERS INTERPRETTED BY DAHEFT CAN CONTAIN LEADING
C SIGN, EMBEDDED DECIMAL POINT AND/OR TRAILING E WITH
C SIGNED EXPONENT. A PERCENT SIGN FOLLOWING THE NUMBER
C IMPLIES E-2, TRAILING LETTER K IMPLIES E3 AND
C TRAILING LETTER M IMPLIES E6.
C
C ARGUMENT LIST DEFINITIONS:
C
C KONTRL = 1 OR GREATER, ITEM IN IBUFFR ARRAY IS
C FLOATING POINT. IF POSSIBLE, THE FLOATING
C POINT NUMBER WILL BE ACCUMULATED AS AN
C INTEGER, THEN BE CONVERTED TO FLOATING POINT
C AND SHIFTED IF NECESSARY. KONTRL IS THEN
C THE MAXIMUM NUMBER OF DIGITS IN THE INTEGER.
C THE VALUE IS OUTPUT AS THE ARGUMENT VALUE.
C IF THE ITEM HAS MORE THAN KONTRL DIGITS,
C THEN THE ENTIRE EVALUATION IS DONE IN
C FLOATING POINT. THE ADVANTAGE OF
C CALCULATING THE FLOATING POINT VALUES IN
C INTEGER AS LONG AS THE PRECISION OF THE
C COMPUTER IS NOT OVERFLOWED IS THAT THE
C CALCULATION OF THE PORTION OF THE NUMBER
C RIGHT OF THE DECIMAL POINT IS MORE EXACT.
C AS AN EXAMPLE, IF KONTRL IS GREATER THAN OR
C EQUAL TO 4, THEN THE NUMBER 33.33 CAN BE
C STORED AS THE INTEGER 3333, THEN BE
C CONVERTED TO FLOATING POINT VALUE 3333.0 AND
C DIVIDED BY 100.0 TO OBTAIN THE FINAL
C ANSWER. IF IT MAKES NO DIFFERENCE WHETHER
C THE NUMBER TYPED AS 33.33 HAS VALUE 33.33 OR
C 33.32999... THEN KONTRL CAN BE GIVEN THE
C VALUE 1.
C = 0, ITEM IN IBUFFR ARRAY IS INTEGER DECIMAL.
C THE NUMBER CAN BE TYPED WITH A DECIMAL POINT
C (FOR EXAMPLE 1.23K OR 1.23E3 EQUALS 1230),
C BUT IS STORED AS AN INTEGER IN DAHEFT, AND
C IS OUTPUT AS ARGUMENT IVALUE. ANY DECIMAL
C INTEGER WHICH THE COMPUTER CAN REPRESENT CAN
C BE EVALUATED. THIS INCLUDES, ON TWOS
C COMPLEMENT COMPUTERS, THE LARGEST NEGATIVE
C NUMBER THE ABSOLUTE VALUE OF WHICH CANNOT BE
C STORED. ON THE PDP10, A 36 BIT COMPUTER
C WITH TWOS COMPLEMENT NOTATION, THE RANGE OF
C DECIMAL INTEGERS IS -34359738368 THROUGH
C 34359738367 (OCTAL NOTATION OF BIT PATTERNS
C BEING 400000000000 THROUGH 377777777777).
C = -1, ITEM IN IBUFFR ARRAY IS OCTAL. THE
C NUMBER CAN BE TYPED WITH A DECIMAL POINT
C AND/OR WITH AN EXPONENT. HOWEVER, THE
C NUMBER FOLLOWING THE LETTER E OF THE
C EXPONENT IS EVALUATED IN DECIMAL. THE VALUE
C OF THE OCTAL NUMBER IS RETURNED AS THE
C ARGUMENT IVALUE. IT MUST BE NOTED THAT
C NUMBERS EVALUATED AS NEGATIVE OCTAL INTEGERS
C HAVE THE NEGATIVE OCTAL INTEGER AS THEIR
C VALUE, NOT AS THEIR BIT REPRESENTATION IN
C COMPUTER STORAGE. FOR EXAMPLE, ON A 36 BIT
C TWOS COMPLEMENT COMPUTER, THE OCTAL NUMBER
C -400000000000 (WHICH COULD ALSO BE TYPED AS
C -4E11 OR -4E+11 WHERE THE 11 AFTER THE E IS
C IN DECIMAL) IS REPRESENTED AS BIT PATTERN
C HAVING OCTAL NOTATION 400000000000 AND THE
C OCTAL NUMBER -377777777777 IS REPRESENTED BY
C THE BIT PATTERN 400000000001.
C = -2, DO NOT EVALUATE NUMBERS. INSTEAD THE
C CHARACTERS FORMING NUMBER ARE TREATED LIKE
C ANY OTHER PRINTING CHARACTERS.
C ITRAIL = SPECIFIES WHETHER EXPONENTS ARE TO BE
C RECOGNIZED.
C = -1, ALLOW NUMBERS TO BE FOLLOWED BY E
C EXPONENT, BUT DO NOT RECOGNIZE PERCENT SIGN,
C K OR M AT END OF NUMBER. E IS NOT
C RECOGNIZED IF NOT PRECEDED BY SIGN, DECIMAL
C POINT OR DIGIT.
C = 0, DO NOT ALLOW TRAILING PERCENT SIGN, K M
C OR E EXPONENT.
C = 1, ALLOW NUMBERS TO BE FOLLOWED BY PERCENT
C SIGN, K M OR E EXPONENT. PERCENT SIGN, K M
C OR E IS NOT RECOGNIZED IF NOT PRECEDED BY
C SIGN, DECIMAL POINT OR DIGIT.
C
C FOLLOWING VALUES DO NOT REQUIRE THAT EXPONENT
C BE PRECEDED BY NUMBER. ALTHOUGH RETURNED
C VALUE WILL ALWAYS BE ZERO IF NO VALUE DIGITS
C ARE FOUND, CALLING PROGRAM COULD ADJUST THIS
C RETURNED VALUE.
C
C = -3, LEADING E EXPONENT IS RECOGNIZED.
C LEADING DIGITS, SIGNS AND DECIMAL POINTS ARE
C NOT ALLOWED.
C = -2, SAME AS ITRAIL=-1, EXCEPT THAT IN
C ADDITION E EXPONENT IS RECOGNIZED EVEN IF
C NOT PRECEDED BY DIGITS, SIGN OR DECIMAL
C POINT.
C = 2, SAME AS ITRAIL=1, EXCEPT THAT IN ADDITION
C LEADING PERCENT SIGN, OR LETTERS K M OR E
C EXPONENT ARE RECOGNIZED EVEN IF NOT PRECEDED
C BY DIGITS, SIGN OR DECIMAL POINT.
C = 3, ONLY LEADING PERCENT SIGN OR LETTERS K M
C OR E EXPONENT ARE RECOGNIZED. LEADING
C DIGITS, SIGNS OR DECIMAL POINTS ARE NOT
C ALLOWED.
C
C IF 10 IS SUBTRACTED FROM ITRAIL VALUES -3
C THROUGH 3, AND IF EITHER VALUE DIGITS OR
C DIGITS FOLLOWING LETTER E ARE MISSING, THEN
C ONE, RATHER THAN ZERO, IS ASSUMED TO BE THE
C DEFAULT FOR THE VALUE OR THE EXPONENT
C RESPECTIVELY. -E- WOULD BE EQUIVALENT TO
C -1E-1 AND -E OR -E+ WOULD BE EQUIVALENT TO
C -1E1
C
C IF 10 IS ADDED TO ITRAIL VALUES -3 THROUGH 3,
C THEN VALUE IS RETURNED AS THOUGH NEITHER
C EXPONENT NOR DECIMAL POINT HAD BEEN TYPED.
C VALUE INDICATED BY COMBINATION OF DIGITS,
C DECIMAL POINT AND/OR EXPONENT CAN BE OBTAINED
C AS VALUE*10**KSHIFT OR IVALUE*10**KSHIFT.
C VALUE INDICATED BY COMBINATION OF DIGITS AND
C DECIMAL POINT BUT IGNORING EXPONENT CAN BE
C OBTAINED AS VALUE*10**(KSHIFT-JSHIFT) OR
C IVALUE*10**(KSHIFT-JSHIFT).
C IEXTRA = EXTRA SHIFT TO BE APPLIED TO VALUE. SHIFT
C IS STATED AS POWER OF RADIX. THIS IS
C APPLIED IN ADDITION TO SHIFT REPORTED IN
C ISHIFT, JSHIFT AND KSHIFT AS SPECIFIED BY
C USER. FOR EXAMPLE, IF DOLLAR VALUE IS TO BE
C RETURNED AS INTEGER NUMBER OF CENTS, IEXTRA
C WOULD HAVE VALUE 2.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR WORDS
C AND NUMBERS. IBUFFR THEN CONTAINS 1 LETTER
C PER COMPUTER STORAGE LOCATION.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C LOWBFR = SUBSCRIPT WITHIN THE IBUFFR ARRAY OF THE
C FIRST (LEFTMOST) CHARACTER WHICH CAN BE
C SCANNED FOR NUMBERS. LOWBFR WILL BE RETURNED
C POINTING TO FIRST PRINTING CHARACTER WHICH
C CANNOT APPEAR IN A NUMBER, OR BEYOND THE END
C OF THE BUFFER IF THE BUFFER DOES NOT CONTAIN
C ANY PRINTING CHARACTERS.
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, NOTHING WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR.
C = 2, NUMBER WAS NOT FOUND, BUT A PRINTING
C CHARACTER WHICH CANNOT START A NUMBER WAS
C FOUND. LOWBFR IS RETURNED POINTING TO THIS
C PRINTING CHARACTER.
C = 3, A NUMBER WAS FOUND. LOWBFR IS RETURNED
C POINTING TO CHARACTER TO RIGHT OF NUMBER.
C ISHIFT = 0, RETURNED IF NONE OF CHARACTERS E, %, K OR
C M FOLLOW NUMBER
C = 1, PERCENT SIGN FOLLOWS NUMBER
C = 2, K FOLLOWS NUMBER
C = 3, M FOLLOWS NUMBER
C = LESS THAN ZERO, RETURNED IF E FOLLOWS
C NUMBER.
C = -1, E AND POSSIBLY SIGNED NUMBER FOLLOW
C NUMBER.
C = -2, E IS FOLLOWED BY PLUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -3, E IS FOLLOWED BY MINUS SIGN NOT IN TURN
C FOLLOWED BY DIGITS.
C = -4, E IS FOLLOWED BY NEITHER SIGN NOR DIGITS
C JSHIFT = EXPONENT INDICATED BY FOLLOWING PERCENT
C SIGN, K, M OR E FOLLOWED BY DIGITS. THIS
C WILL HAVE BEEN APPLIED TO RETURNED VALUE IF
C ITRAIL EQUALS EITHER -1 OR 1. 12.34K OR
C 12.34E3 WOULD GIVE JSHIFT OF 3. 12% OR
C 12E-2 WOULD GIVE JSHIFT -2.
C KSHIFT = EXPONENT WHICH WOULD BE NECESSARY TO OBTAIN
C DESIRED VALUE IF NUMBER HAD BEEN TYPED
C WITHOUT DECIMAL POINT. 12.34 STATED WITHOUT
C DECIMAL POINT WOULD BE 1234E-2 SO KSHIFT
C WOULD BE -2. 12.34K WOULD BE 1234E1 SO
C KSHIFT WOULD BE 1.
C LSHIFT = ZERO OR LESS, THE VALUE ZERO IS BEING
C RETURNED FOR EITHER VALUE OR IVALUE,
C WHICHEVER IS APPROPRIATE.
C = -4, NUMBER CONTAINED NEITHER VALUE DIGITS,
C NOR DECIMAL POINT, NOR LEADING PLUS SIGN,
C NOR LEADING MINUS SIGN. THIS VALUE OF
C LSHIFT IS ALWAYS RETURNED IF KIND IS
C RETURNED CONTAINING A VALUE OTHER THAN 3.
C IF KIND IS RETURNED CONTAINING THE VALUE 3,
C THEN ITRAIL MUST BE EITHER -3 OR 3, AND THE
C CONTENTS OF THE INPUT TEXT BUFFER MUST BEGIN
C WITH A REPRESENTATION OF AN EXPONENT.
C = -3, A LEADING MINUS SIGN BUT NO VALUE DIGITS
C WAS FOUND.
C = -2, A LEADING PLUS SIGN BUT NO VALUE DIGITS
C WAS FOUND.
C = -1, A LEADING PERIOD BUT NO VALUE DIGITS WAS
C FOUND.
C = 0, ONE OR MORE ZERO DIGITS WERE FOUND, BUT
C THE NUMBER CONTAINED NO DIGITS OTHER THAN
C ZERO. THE NUMBER REPRESENTATION MAY OR MAY
C NOT HAVE BEEN BEGUN BY A PLUS SIGN OR A
C MINUS SIGN AND MAY OR MAY NOT HAVE CONTAINED
C A DECIMAL POINT.
C = GREATER THAN ZERO, LSHIFT IS NUMBER OF
C DIGITS COUNTING LEFTMOST NON-ZERO DIGIT AND
C ALL WHICH WERE SPECIFIED TO ITS RIGHT. THIS
C IS INDEPENDENT OF ANY SHIFT IMPLIED BY A
C DECIMAL POINT OR EXPONENT
C IVALUE = RETURNED WITH VALUE IF KONTRL IS LESS THAN
C OR EQUAL TO ZERO. NOTE THAT IF KONTRL IS
C LESS THAN OR EQUAL TO ZERO, THEN ORIGINAL
C CONTENT OF IVALUE IS ALWAYS DESTROYED. IN
C PARTICULAR, IF KONTRL IS LESS THAN OR EQUAL
C TO ZERO AND IF KIND IS RETURNED CONTAINING
C EITHER 1 OR 2, THEN IVALUE WILL BE ZEROED.
C VALUE = RETURNED WITH VALUE IF KONTRL IS GREATER
C THAN ZERO. NOTE THAT IF KONTRL IS GREATER
C THAN ZERO, THEN THE ORIGINAL CONTENT OF
C VALUE IS ALWAYS DESTROYED. IN PARTICULAR,
C IF KONTRL IS GREATER THAN ZERO AND IF KIND
C IS RETURNED CONTAINING EITHER 1 OR 2, THEN
C VALUE WILL BE ZEROED.
C
DIMENSION IBUFFR(MAXBFR),IDIGIT(10),KAPLTR(3),
1LOWLTR(3),JPOWER(3)
C
C IDIGIT CONTAINS ALPHAMERIC FORM OF DIGITS 0 THRU 9
DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
C
C IBLANK CONTAINS SPACE CHARACTER AND ITAB CONTAINS
C TAB CHARACTER. IF TAB CHARACTER IS NOT AVAILABLE,
C ITAB SHOULD INSTEAD CONTAIN A SPACE ALSO.
C DATA IPLUS,IMINUS,IDOT,IBLANK,ITAB/
C 11H+,1H-,1H.,1H ,"045004020100/
DATA IPLUS,IMINUS,IDOT,IBLANK,ITAB/
11H+,1H-,1H.,1H ,1H /
C
C KAPLTR = LIST OF UPPER CASE LETTERS WHICH CAN FOLLOW
C A NUMBER TO INDICATE AN EXPONENT.
C LOWLTR = LIST OF LOWER CASE LETTERS CORRESPONDING TO
C UPPER CASE LETTERS IN KAPLTR ARRAY.
C JPOWER = VALUE OF THE EXPONENT ASSOCIATED WITH THE
C PARALLEL CHARACTERS IN THE KAPLTR AND LOWLTR
C ARRAYS. JPOWER CAN BE NEGATIVE, FOR EXAMPLE
C PERCENT SIGN WOULD CORRESPOND TO JPOWER=-2.
C MAXTST = NUMBER OF ITEMS IN EACH OF KAPLTR, LOWLTR
C AND JPOWER ARRAYS.
C KAPEXP = UPPER CASE LETTER E
C LOWEXP = LOWER CASE LETTER E
C
C UPPER CASE LETTERS CAN BE SUBSTITUTED FOR LOWER CASE
C IN FOLLOWING DATA STATEMENTS, IF COMPUTER UPON WHICH
C THIS ROUTINE IS USED DOES NOT SUPPORT LOWER CASE.
C
DATA KAPLTR/1H%,1HK,1HM/
DATA LOWLTR/1H%,1Hk,1Hm/
DATA JPOWER/-2,3,6/
DATA MAXTST/3/
DATA KAPEXP,LOWEXP/1HE,1He/
C
C INITIALIZE
ISIGN=0
IF(KONTRL.GT.0)VALUE=0.0
IF(KONTRL.LE.0)IVALUE=0
ISHIFT=0
JSHIFT=0
KSHIFT=0
LSHIFT=-4
IRADIX=10
IF(KONTRL.LT.0)IRADIX=8
IADD=IRADIX-2
IPOWER=0
NUMKNT=-4
NUMVAL=0
NMBEXP=-1
NUMPNT=-1
IDEFLT=0
IF(ITRAIL.LT.-5)IDEFLT=1
KTRAIL=ITRAIL
IF(KTRAIL.GT.5)KTRAIL=KTRAIL-10
IF(KTRAIL.LT.-5)KTRAIL=KTRAIL+10
LTRAIL=KTRAIL
IF(LTRAIL.LT.0)LTRAIL=-LTRAIL
GO TO 2
C
C *********************
C * SCAN FOR NUMBER *
C *********************
C
C LOOP LOOKING AT CHARACTERS IN IBUFFR ARRAY
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 25
NOWLTR=IBUFFR(LOWBFR)
IF(NMBEXP.GE.0)GO TO 20
IF(ISIGN.NE.0)GO TO 4
C
C SCAN OVER LEADING SPACES AND/OR TABS
IF(NOWLTR.EQ.IBLANK)GO TO 1
IF(NOWLTR.EQ.ITAB)GO TO 1
C
C LOOK FOR INITIAL SIGNS + OR -
IF(KONTRL.LE.-2)GO TO 40
IF(LTRAIL.GE.3)GO TO 4
IF(NOWLTR.EQ.IPLUS)GO TO 3
IF(NOWLTR.NE.IMINUS)GO TO 4
ISIGN=-1
NUMKNT=-3
GO TO 1
3 ISIGN=1
NUMKNT=-2
GO TO 1
C
C LOOK FOR % K OR M FOLLOWING NUMBER
C LOCK OUT THESE AND ALSO E IF NO PART OF NUMBER FOUND
4 IF(LTRAIL.GE.2)GO TO 5
IF(ISIGN.EQ.0)GO TO 10
IF(KTRAIL.EQ.0)GO TO 10
5 IF(KTRAIL.LT.0)GO TO 8
I=0
6 I=I+1
IF(I.GT.MAXTST)GO TO 8
IF(NOWLTR.EQ.KAPLTR(I))GO TO 7
IF(NOWLTR.NE.LOWLTR(I))GO TO 6
7 IPOWER=JPOWER(I)
JSIGN=1
NMBEXP=1
ISHIFT=I
LOWBFR=LOWBFR+1
GO TO 26
C
C LOOK FOR LETTER E
8 IF(NOWLTR.EQ.KAPEXP)GO TO 9
IF(NOWLTR.NE.LOWEXP)GO TO 10
9 JSIGN=0
NMBEXP=0
ISHIFT=-4
GO TO 19
C
C LOOK FOR LEADING OR EMBEDDED PERIOD
10 IF(LTRAIL.GE.3)GO TO 24
IF(NUMPNT.GE.0)GO TO 11
IF(NOWLTR.NE.IDOT)GO TO 11
DECML=0.1
IF(ISIGN.EQ.0)NUMKNT=-1
GO TO 18
C
C LOOK FOR DIGIT OTHER THAN IN EXPONENT FIELD
11 DO 16 I=1,IRADIX
IF(NOWLTR.NE.IDIGIT(I))GO TO 16
IF(NUMKNT.GT.0)GO TO 12
NUMKNT=0
IF(I.EQ.1)GO TO 13
12 NUMKNT=NUMKNT+1
13 IF(KONTRL.LE.0)GO TO 15
IF(NUMKNT.LE.KONTRL)NUMVAL=(10*NUMVAL)+I-1
IF(NUMPNT.GE.0)GO TO 14
VALUE=(10.0*VALUE)+FLOAT(I-1)
GO TO 19
14 VALUE=VALUE+(DECML*FLOAT(I-1))
DECML=DECML/10.0
GO TO 18
C FOLLOWING ALLOWS LARGEST NEGATIVE NUMBER FOR
C WHICH THERE IS NOT CORRESPONDING POSITIVE VALUE
15 IF(NUMKNT.EQ.1)IVALUE=I-2
IF(NUMKNT.GT.1)IVALUE=(IRADIX*IVALUE)+I+IADD
GO TO 17
16 CONTINUE
GO TO 24
C
C DIGIT, E OR . FOUND SO MARK AS BEING IN NUMBER
17 IF(NUMPNT.LT.0)GO TO 19
18 NUMPNT=NUMPNT+1
19 IF(ISIGN.EQ.0)ISIGN=1
GO TO 1
C
C LOOK FOR SIGN IN EXPONENT FIELD
20 IF(JSIGN.NE.0)GO TO 22
IF(NOWLTR.EQ.IPLUS)GO TO 21
IF(NOWLTR.NE.IMINUS)GO TO 22
JSIGN=-1
ISHIFT=-3
GO TO 1
21 JSIGN=1
ISHIFT=-2
GO TO 1
C
C LOOK FOR DIGITS IN EXPONENT FIELD
22 DO 23 I=1,10
IF(NOWLTR.NE.IDIGIT(I))GO TO 23
IPOWER=(10*IPOWER)+I-1
NMBEXP=1
ISHIFT=-1
IF(JSIGN.EQ.0)JSIGN=1
GO TO 1
23 CONTINUE
GO TO 26
C
C DECIDE WHAT TO DO IF NO MATCH FOUND
24 IF(ISIGN.NE.0)GO TO 26
GO TO 40
C
C *******************************
C * NUMBER HAS BEEN EVALUATED *
C *******************************
C
25 IF(ISIGN.EQ.0)GO TO 39
26 KIND=3
C
C ADJUST EXPONENT SIGN
IF(NMBEXP.LT.0)GO TO 27
IF(NMBEXP.EQ.0)IPOWER=IDEFLT
IF(JSIGN.LT.0)IPOWER=-IPOWER
C
C SHIFT FLOATING POINT NUMBER ACCORDING TO EXPONENT
27 JSHIFT=IPOWER
KSHIFT=IPOWER
IF(NUMPNT.GT.0)KSHIFT=KSHIFT-NUMPNT
LSHIFT=NUMKNT
IF(NUMPNT.LT.0)NUMPNT=0
IF(ITRAIL.GT.5)IPOWER=NUMPNT
IPOWER=IPOWER+IEXTRA
IF(KONTRL.LE.0)GO TO 31
IF(NUMKNT.GT.KONTRL)GO TO 28
IF(NUMKNT.LT.0)NUMVAL=IDEFLT
IF(ISIGN.LT.0)NUMVAL=-NUMVAL
VALUE=FLOAT(NUMVAL)
IPOWER=IPOWER-NUMPNT
GO TO 29
28 IF(NUMKNT.LT.0)VALUE=IDEFLT
IF(ISIGN.LT.0)VALUE=-VALUE
29 IF(IPOWER.EQ.0)GO TO 41
IF(IPOWER.GT.0)GO TO 30
IPOWER=-IPOWER
VALUE=VALUE/(10.0**IPOWER)
GO TO 41
30 VALUE=VALUE*(10.0**IPOWER)
GO TO 41
C
C SHIFT AN INTEGER ACCORDING TO EXPONENT
31 IF(NUMKNT.LT.0)IVALUE=IDEFLT
IPOWER=IPOWER-NUMPNT
IF(ISIGN.GE.0)GO TO 32
IVALUE=-IVALUE
C NOTE THAT NEGATIVE NUMBER AT THIS POINT HAS ABSOLUTE
C VALUE 1 TOO LOW TO ALLOW THE LARGEST NEGATIVE NUMBER
C WHICH HAS NO CORRESPONDING POSITIVE VALUE IN TWOS
C COMPLEMENT NOTATION
IF(NUMKNT.GT.0)IVALUE=IVALUE-1
GO TO 33
32 IF(NUMKNT.GT.0)IVALUE=IVALUE+1
33 IF(IPOWER.LE.0)GO TO 37
IPOWER=IPOWER-1
KVALUE=IVALUE
IVALUE=IRADIX*IVALUE
IF(ISIGN.GE.0)GO TO 34
IF(IVALUE.GE.KVALUE)GO TO 36
GO TO 35
34 IF(IVALUE.LE.KVALUE)GO TO 36
35 IF((IVALUE/IRADIX).EQ.KVALUE)GO TO 33
36 IVALUE=KVALUE
37 IF(IPOWER.GE.0)GO TO 41
IPOWER=IPOWER+1
KVALUE=IVALUE
IVALUE=IVALUE/IRADIX
IF(ISIGN.GE.0)GO TO 38
IF((IRADIX*IVALUE).LT.KVALUE)IVALUE=IVALUE+1
38 IF(IVALUE.NE.0)GO TO 37
GO TO 41
C
C NUMBER NOT FOUND
39 KIND=1
GO TO 41
40 KIND=2
C
C RETURN TO CALLING PROGRAM
41 RETURN
C
C IBLANK = THE BLANK OR SPACE CHARACTER
C JSIGN = 0, NEITHER SIGN NOR DIGITS AFTER E
C = 1, EITHER PLUS OR DIGITS AFTER E
C = -1, MINUS SIGN AFTER E
C ITAB = THE TAB CHARACTER
C ISIGN = 0, NO PART OF NUMBER ENCOUNTERED
C = -1, MINUS SIGN AT START OF NUMBER
C = 1, NUMBER DOES NOT START WITH MINUS SIGN
C NMBEXP = -1, NO EXPONENT FIELD YET FOUND
C = 0, EXPONENT FIELD FOUND BUT NUMBER NOT
C YET FOUND
C = 1, NUMBER FOUND IN EXPONENT FIELD
C NOWLTR = THE CHARACTER CURRENTLY BEING TESTED
C NUMKNT = NUMBER OF DIGITS IN VALUE FIELD
C = 0, LEFT HAND ZERO ONLY READ SO FAR
C = -1, NO DIGITS YET FOUND
C NUMPNT = -1, DECIMAL POINT NOT YET FOUND
C = 0, DECIMAL POINT ENCOUNTERED IN VALUE FIELD
C = .GT.0, VALUE IS NUMBER OF DIGITS ENCOUNTERED
C TO RIGHT OF DECIMAL POINT IN NUMBER.
C204733708764%KME
END
SUBROUTINE DAVERB(LOWWRD,MAXWRD,IWORD ,LOWKNT,MAXKNT,
1 KNTLTR,IBUFFR,MAXBFR,LOWBFR,KIND ,MATCH ,LCNWRD,
2 LCNKNT,LCNBFR)
C RENBR(/IDENTIFY WORDS OR ABBREVIATIONS)
C
C DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C DAVERB INTERPRETS AN ARRAY READ BY THE CALLING
C PROGRAM WITH A MULTIPLE OF AN A1 FORMAT AND
C IDENTIFIES THE WORDS AND WORD ABBREVIATIONS CONTAINED
C IN THIS ARRAY. THE WORDS ARE RECOGNIZED BY BEING
C MATCHED AGAINST A USER DEFINED DICTIONARY. IF THE
C ARRAY CONTAINS ABBREVIATIONS OF WORDS IN THE
C DICTIONARY, THEN DAVERB ALSO SPECIFIES WHETHER THESE
C ABBREVIATIONS ARE AMBIGUOUS.
C
C ARGUMENT LIST DEFINITIONS:
C
C LOWBFR IS USED FOR BOTH INPUT AND OUTPUT. KIND,
C MATCH, LCNWRD, LCNKNT AND LCNBFR ARE USED ONLY FOR
C OUTPUT. REMAINING ARGUMENTS ARE USED ONLY FOR INPUT.
C
C LOWWRD = SUBSCRIPT OF LOCATION IN IWORD ARRAY WHICH
C CONTAINS 1ST LETTER OF 1ST WORD. NOTE THAT
C IF KNTLTR(LOWKNT) IS NEGATIVE, THEN THE 1ST
C LETTER OF 1ST WORD WILL BE FOUND IN ARRAY
C LOCATION IWORD(LOWWRD-KNTLTR(LOWKNT)).
C MAXWRD = DIMENSION OF IWORD ARRAY.
C IWORD = DICTIONARY ARRAY CONTAINING CHARACTERS OF
C WORDS TO BE RECOGNIZED, 1 CHARACTER PER
C ARRAY LOCATION AS READ BY A1 FORMAT OR ELSE
C DEFINED BY 1H FIELD. SECTIONS OF A WORD CAN
C BE ABBREVIATED AND/OR SEPARATED BY SPACES OR
C TABS IF THE WORD IN IWORD CONTAINS A SINGLE
C SPACE BETWEEN EACH SUCH SECTION AND IF THE
C LENGTH STORED IN THE KNTLTR ARRAY IS 100
C MORE THAN THE ACTUAL LENGTH (INCLUDING THE
C SPACES). ALL LETTERS IN THE IWORD ARRAY
C MUST BE UPPER CASE.
C LOWKNT = SUBSCRIPT OF KNTLTR ARRAY LOCATION DEFINING
C LENGTH OF FIRST WORD WHICH CAN BE MATCHED IN
C THE IWORD ARRAY. THIS FIRST WORD WILL START
C AT IWORD(LOWWRD). IF NO WORDS ARE TO BE
C RECOGNIZED, THEN EITHER MAXKNT SHOULD BE
C LESS THAN LOWKNT, OR ELSE BOTH LOWKNT AND
C MAXKNT CAN POINT TO THE SAME ZERO ENTRY IN
C THE KNTLTR ARRAY.
C MAXKNT = SUBSCRIPT OF KNTLTR ARRAY LOCATION DEFINING
C LENGTH OF FINAL WORD WHICH CAN BE MATCHED IN
C THE IWORD ARRAY.
C KNTLTR = ARRAY CONTAINING THE NUMBERS OF CHARACTERS
C IN THE WORDS IN THE IWORD ARRAY. A ZERO OR
C NEGATIVE VALUE IN THE KNTLTR ARRAY OFFSETS
C THE NEXT POSSIBLE WORD WHICH CAN BE MATCHED
C IN THE IWORD ARRAY BY THE NUMBER OF LETTERS
C GIVEN BY THE ABSOLUTE VALUE OF THE NEGATIVE
C NUMBER IN THE KNTLTR ARRAY. DIMENSION OF
C KNTLTR MUST BE AT LEAST MAXKNT. FOR EXAMPLE
C TO RECOGNIZE THE WORDS
C
C YES, NO, MAYBE
C
C THE CONTENTS OF THE IWORD ARRAY WOULD BE
C
C 1HY,1HE,1HS,1HN,1HO,1HM,1HA,1HY,1HB,1HE
C
C AND CONTENTS OF THE KNTLTR ARRAY WOULD BE
C
C 3,2,5
C
C IF A WORD IN THE IWORD ARRAY CONTAINS
C EMBEDDED SPACES, THEN 100 MUST BE ADDED TO
C THE LENGTH STORED FOR THIS WORD IN THE
C KNTLTR ARRAY TO ALLOW THE PORTION OF THE
C WORD LEFT OF THE SPACE TO BE ABBREVIATED.
C VALUES 101 THROUGH 199 IN KNTLTR ARRAY THUS
C INDICATE WORDS CONTAINING SPACES WHICH HAVE
C LENGTHS OF 1 THROUGH 99 RESPECTIVELY. THE
C VALUE 100 IN THE KNTLTR ARRAY IS TREATED THE
C SAME AS A ZERO.
C IBUFFR = INPUT BUFFER ARRAY CONTAINING CHARACTERS
C TYPED BY USER, READ BY A MULTIPLE OF AN A1
C FORMAT, WHICH IS TO BE SEARCHED FOR WORDS.
C IBUFFR THEN CONTAINS 1 LETTER PER COMPUTER
C STORAGE LOCATION. LETTERS IN THE IBUFFR
C ARRAY CAN BE EITHER UPPER OR LOWER CASE.
C MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR ARRAY TO BE
C SEARCHED
C LOWBFR = SUBSCRIPT WITHIN THE IBUFFR ARRAY OF THE
C FIRST (LEFTMOST) CHARACTER WHICH CAN BE
C SCANNED FOR WORDS. LOWBFR WILL BE RETURNED
C POINTING TO THE NEXT CHARACTER BEYOND A
C MATCHED WORD IF A WORD IS FOUND. IF THERE
C IS NOTHING AT OR TO RIGHT OF LOWBFR, THEN
C LOWBFR WILL BE LEFT POINTING AT MAXBFR+1 AND
C KIND WILL BE RETURNED CONTAINING ONE.
C LOWBFR MUST BE SET BY CALLING PROGRAM BEFORE
C ANYTHING IS PROCESSED IN CURRENT CONTENTS
C OF THE IBUFFR ARRAY, BUT THEN SHOULD NOT BE
C MODIFIED BY CALLING PROGRAM UNTIL THE ENTIRE
C CONTENTS OF IBUFFR ARRAY HAS BEEN PROCESSED.
C KIND = RETURNED DESCRIBING THE KIND OF ITEM LOCATED
C IN THE IBUFFR ARRAY.
C = 1, NOTHING WAS FOUND AT OR TO THE RIGHT OF
C LOWBFR. THE CALLING PROGRAM SHOULD READ A
C NEW LINE INTO IBUFFR.
C = 2, ACCEPTABLE WORD OR ABBREVIATION THEREOF
C WAS NOT FOUND, BUT A PRINTING CHARACTER WAS
C FOUND WHICH DOES NOT BEGIN ANY WORD IN THE
C DICTIONARY. LOWBFR IS RETURNED POINTING TO
C THIS PRINTING CHARACTER.
C = RETURNED CONTAINING 3, 4 OR 5 IF A WORD IN
C THE DICTIONARY WAS MATCHED EVEN PARTIALLY.
C FOR EXAMPLE, IF DICTIONARY CONTAINED BOTH OF
C THE WORDS NO AND NONE, THEN
C A) INITIAL LETTER N IN THE BUFFER FOLLOWED
C BY SOME CHARACTER OTHER THAN THE LETTER O
C WOULD BE AMBIGUOUS ABBREVIATION AND THE
C POINTER NAMED MATCH WOULD BE RETURNED
C POINTING TO (CONTAINING SEQUENCE NUMBER
C WITHIN DICTIONARY OF) WHICHEVER WORD NO
C OR NONE APPEARED FIRST IN THE DICTIONARY.
C B) INITIAL LETTERS N AND O FOLLOWED BY SOME
C CHARACTER OTHER THAN THE LETTER N WOULD
C BE AN EXACT MATCH WITH THE WORD NO.
C C) INITIAL LETTERS N AND O AND N WOULD BE A
C PARTIAL BUT NONAMBIGUOUS MATCH WITH THE
C WORD NONE.
C LEADING SPACES AND/OR TABS ARE IGNORED. A
C STRING OF CHARACTERS CONTAINING EMBEDDED
C SPACES AND/OR TABS CAN MATCH A WORD IN THE
C DICTIONARY ONLY IF THE WORD IN DICTIONARY
C CONTAINS A SINGLE SPACE AT THE POSITION AT
C WHICH THE SPACES AND/OR TABS ARE ALLOWED
C (BUT NOT NECESSARY).
C = 3, A WORD IN THE IWORD ARRAY WAS MATCHED
C EXACTLY. MATCH IS RETURNED CONTAINING THE
C SEQUENCE NUMBER OF THE WORD MATCHED IN THE
C IWORD ARRAY.
C = 4, A NONAMBIGUOUS ABBREVIATION OF A WORD IN
C THE IWORD ARRAY WAS FOUND. MATCH IS
C RETURNED CONTAINING THE SEQUENCE NUMBER OF
C THE WORD IN THE IWORD ARRAY.
C = 5, AN AMBIGUOUS ABBREVIATION OF A WORD WAS
C FOUND. MATCH IS RETURNED CONTAINING THE
C SEQUENCE NUMBER OF THE FIRST WORD MATCHED IN
C THE IWORD ARRAY.
C MATCH = RETURNED CONTAINING THE SEQUENCE NUMBER OF A
C WORD MATCHED IN THE IWORD ARRAY IF KIND IS
C RETURNED CONTAINING 3, 4 OR 5. FOR EXAMPLE,
C IF THE SECOND WORD IS MATCHED, THEN MATCH
C WOULD BE RETURNED CONTAINING 2. THE
C SEQUENCE NUMBER OF THE WORD IN THE IWORD
C ARRAY DOES NOT INCLUDE THE LETTERS SKIPPED
C OVER BY THE VALUE OF LOWWRD, AND DOES NOT
C INCLUDE THE LETTERS SKIPPED OVER BY NEGATIVE
C VALUES ENCOUNTERED IN THE KNTLTR ARRAY.
C MATCH IS RETURNED CONTAINING KIND-2 IF KIND
C IS RETURNED .LE.2 INDICATING THAT NO WORD IN
C THE IWORD ARRAY COULD BE MATCHED EVEN
C PARTIALLY. THIS MEANS THAT IF THE CALLING
C PROGRAM TESTS FOR KIND=5 AFTER THE RETURN
C FROM DAVERB, AND IF KIND=4 IS TO BE TAKEN AS
C EQUIVALENT TO KIND=3, THEN CALLING PROGRAM
C CAN ADD 2 TO THE VALUE OF MATCH AND USE THIS
C SUM AS INDEX FOR A COMPUTED GO TO STATEMENT.
C LCNWRD = IF KIND IS RETURNED CONTAINING 3 OR GREATER,
C LOCWRD IS RETURNED WITH SUBSCRIPT OF IWORD
C LOCATION CONTAINING FIRST LETTER OF MATCHED
C WORD.
C LCNKNT = IF KIND IS RETURNED CONTAINING 3 OR GREATER,
C LCNKNT IS RETURNED WITH SUBSCRIPT OF KNTWRD
C LOCATION CONTAINING THE WORD LENGTH.
C LCNBFR = IF KIND IS RETURNED CONTAINING 3 OR GREATER,
C INDICATING THAT A WORD OR ITS ABBREVIATION
C WAS FOUND, THEN LCNBFR IS RETURNED
C CONTAINING THE SUBSCRIPT OF THE IBUFFR ARRAY
C LOCATION WHICH CONTAINS THE FIRST CHARACTER
C OF THE WORD OR ITS ABBREVIATION.
C
DIMENSION IBUFFR(MAXBFR),IWORD(MAXWRD),
1KNTLTR(MAXKNT),KONVRT(10),KAPITL(26),LOWER(26)
C
C CCCC AAA UU UU TTTTTTTT IIII OOOO NN NN
C CC AAAA UU UU TT II OO OO NNN NN
C CC AA AA UU UU TT II OO OO NNNN NN
C CC AA AA UU UU TT II OO OO NN NN NN
C CC AAAAAAA UU UU TT II OO OO NN NNNN
C CC AA AA UU UU TT II OO OO NN NNN
C CCCC AA AA UUU TT IIII OOOO NN NN
C
C TO CONVERT LOWER CASE LETTERS IN THE INPUT TEXT
C BUFFER INTO UPPER CASE LETTERS WHICH CAN BE MATCHED
C AGAINST THE DICTIONARY, THIS ROUTINE COMPARES THE
C CHARACTERS IN THE INPUT TEXT BUFFER AGAINST THE LOWER
C CASE LETTERS IN THE LOWER ARRAY. THE LETTERS IN THE
C LOWER ARRAY MUST BE ARRANGED IN INCREASING NUMERICAL
C ORDER. IF THE NUMERICAL ORDER IS NOT THE SAME AS THE
C ALPHABETICAL ORDER, THEN THE DATA STATEMENTS
C APPEARING BELOW MUST BE CHANGED OR ELSE SOME OR ALL
C LOWER CASE LETTERS IN THE INPUT TEXT BUFFER WILL NOT
C BE TREATED AS EQUIVALENT TO THE CORRESPONDING UPPER
C CASE LETTERS. ONCE THE LETTERS IN THE LOWER ARRAY
C ARE SORTED INTO INCREASING NUMERICAL ORDER, THE UPPER
C CASE LETTERS IN THE KAPITL ARRAY SHOULD BE REARRANGED
C SO THAT LOWER AND UPPER CASE VERSIONS OF EACH LETTER
C APPEAR IN LOCATIONS IN THE LOWER AND KAPITL ARRAYS
C HAVING THE SAME SUBSCRIPTS.
C
C IF THE COMPUTER UPON WHICH THIS ROUTINE IS USED DOES
C NOT SUPPORT LOWER CASE LETTERS, THEN BOTH THE LOWER
C AND KAPITL ARRAYS CAN CONTAIN THE LETTERS 1HA THROUGH
C 1HZ IN ALPHABETICAL ORDER (EVEN IF THIS IS NOT THE
C NUMERICALLY SORTED ORDER).
C
C KAPITL = UPPER CASE LETTERS A THROUGH Z SORTED ON
C LOWER ARRAY
DATA KAPITL/
11HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ,
21HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT,
31HU,1HV,1HW,1HX,1HY,1HZ/
C
C LOWER = LOWER CASE LETTERS A THROUGH Z SORTED INTO
C NUMERICALLY INCREASING ORDER
DATA LOWER/
11Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj,
21Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht,
31Hu,1Hv,1Hw,1Hx,1Hy,1Hz/
C
C IBLANK = THE BLANK OR SPACE CHARACTER
C ITAB = TABULATION CHARACTER, THIS CAN BE REPLACED
C BY SPACE IF TAB CHARACTER IS NOT AVAILABLE
C DATA IBLANK,ITAB/1H ,"045004020100/
DATA IBLANK,ITAB/1H ,1H /
C
C SEARCH FOR FIRST PRINTING CHARACTER
GO TO 2
1 LOWBFR=LOWBFR+1
2 IF(LOWBFR.GT.MAXBFR)GO TO 29
NOWLTR=IBUFFR(LOWBFR)
IF(NOWLTR.EQ.IBLANK)GO TO 1
IF(NOWLTR.EQ.ITAB)GO TO 1
C
C SET INITIAL CONSTANTS IF FIND PRINTING CHARACTER
LMTBFR=MAXBFR
LCNBFR=LOWBFR
IEND=LOWWRD
MSTSAM=1
KNTKNV=0
KNTWRD=LOWKNT-1
INDEX=0
3 IEXACT=1
4 KNTWRD=KNTWRD+1
IF(KNTWRD.GT.MAXKNT)GO TO 28
C
C GET NEXT WORD IN DICTIONARY
JEND=KNTLTR(KNTWRD)
KEND=JEND-100
IF(KEND.GE.0)JEND=KEND
IF(JEND.LE.0)GO TO 27
KEND=0
NXTCMP=IEND
IEND=IEND+JEND
JEXACT=-1
INDEX=INDEX+1
NXTBFR=LOWBFR
NOWSAM=1
C
C GET NEXT CHARACTERS TO BE COMPARED
5 IF(NXTBFR.GT.LMTBFR)GO TO 22
KOMPAR=IBUFFR(NXTBFR)
IF(KOMPAR.EQ.IBLANK)GO TO 15
IF(KOMPAR.EQ.ITAB)GO TO 15
IF(NOWSAM.LE.KNTKNV)GO TO 13
C
C DETERMINE UPPER CASE VERSION OF A LOWER CASE LETTER.
C THIS IS A TERNARY SEARCH TAKING ADVANTAGE OF THE SIZE
C OF ALPHABET BEING NEARLY 3**3. THE 3RD OF THE ARRAY
C CONTAINING THE DESIRED LETTER IS FIRST LOCATED, THEN
C THE 3RD OF THIS 3RD, AND FINALLY EACH OF THE
C REMAINING 3 LETTERS ARE TESTED INDIVIDUALLY. TO
C PREVENT TESTING AGAINST THE 27TH LETTER WHICH DOES
C NOT EXIST, UPPER 3RD IS TAKEN AS UPPER 9 SORTED
C LETTERS, RATHER THAN FROM 19TH THROUGH 27TH LETTERS,
C SO THAT LOWER(18) IS TESTED AGAINST IN UPPER 3RD EVEN
C THOUGH LETTER BEING MATCHED HAS ALREADY BEEN FOUND TO
C BE LARGER THAN THIS.
IF(KOMPAR.GT.LOWER(18))GO TO 7
IF(KOMPAR.GT.LOWER(9))GO TO 6
IF(KOMPAR.LT.LOWER(1))GO TO 11
KUT=3
GO TO 8
6 KUT=12
GO TO 8
7 IF(KOMPAR.GT.LOWER(26))GO TO 11
KUT=20
8 IF(KOMPAR.LE.LOWER(KUT))GO TO 9
KUT=KUT+3
IF(KOMPAR.GT.LOWER(KUT))KUT=KUT+3
9 IF(KOMPAR.EQ.LOWER(KUT))GO TO 10
KUT=KUT-1
IF(KOMPAR.EQ.LOWER(KUT))GO TO 10
KUT=KUT-1
IF(KOMPAR.NE.LOWER(KUT))GO TO 11
10 KOMPAR=KAPITL(KUT)
11 IF(KNTKNV.GE.10)GO TO 12
KNTKNV=KNTKNV+1
KONVRT(KNTKNV)=KOMPAR
C
C DETERMINE IF LETTER IN BUFFER MATCHES DICTIONARY.
12 IF(KOMPAR.EQ.IWORD(NXTCMP))GO TO 19
GO TO 14
13 IF(KONVRT(NOWSAM).EQ.IWORD(NXTCMP))GO TO 19
14 IF(KEND.LE.0)GO TO 23
GO TO 17
15 IF(KEND.LE.0)GO TO 23
16 NXTBFR=NXTBFR+1
IF(NXTBFR.GT.LMTBFR)GO TO 22
IF(IBUFFR(NXTBFR).EQ.IBLANK)GO TO 16
IF(IBUFFR(NXTBFR).EQ.ITAB)GO TO 16
17 KEND=0
18 IF(IWORD(NXTCMP).EQ.IBLANK)GO TO 20
JEXACT=0
NXTCMP=NXTCMP+1
IF(NXTCMP.LT.IEND)GO TO 18
GO TO 24
19 NOWSAM=NOWSAM+1
NEWBFR=NXTBFR
KEND=JEND
NXTBFR=NXTBFR+1
20 NXTCMP=NXTCMP+1
21 IF(NXTCMP.LT.IEND)GO TO 5
GO TO 24
C
C WORD CANNOT EXTEND FURTHER TO RIGHT
22 LMTBFR=NEWBFR
23 JEXACT=0
24 IF(NOWSAM.LT.MSTSAM)GO TO 4
IF(NOWSAM.GT.MSTSAM)GO TO 26
IF(IEXACT.GE.0)GO TO 25
IF(JEXACT.LT.0)GO TO 3
GO TO 4
25 IF(JEXACT.GE.0)GO TO 3
26 IEXACT=JEXACT
MSTSAM=NOWSAM
MATCH=INDEX
LSTBFR=NEWBFR+1
LCNKNT=KNTWRD
LCNWRD=IEND
GO TO 4
27 IEND=IEND-JEND
GO TO 4
C
C ENTIRE DICTIONARY HAS BEEN SEARCHED
28 IF(MSTSAM.LE.1)GO TO 30
LOWBFR=LSTBFR
KIND=4+IEXACT
JEND=KNTLTR(LCNKNT)
IF(JEND.GE.100)JEND=JEND-100
LCNWRD=LCNWRD-JEND
GO TO 31
C
C NO PRINTING CHARACTERS WERE FOUND TO BE IDENTIFIED
29 KIND=1
MATCH=-1
GO TO 31
C
C NOT EVEN A PARTIAL MATCH COULD BE MADE
30 KIND=2
MATCH=0
C
C RETURN TO CALLING PROGRAM
31 RETURN
C
C IEXACT = -1, EXACT MATCH FOUND BUT MUST CHECK THAT
C A LONGER MATCH CANNOT BE FOUND WITH ANOTHER
C WORD (FOR EXAMPLE, IF IWORD ARRAY CONTAINS
C BOTH OF THE WORDS NO AND NONE, THEN THE
C BUFFER CONTENTS "NON" WOULD MATCH WORD NO
C EXACTLY, BUT THE PARTIAL MATCH WITH WORD
C NONE WOULD BE BETTER)
C = 0, A PARTIAL MATCH HAS BEEN FOUND
C = 1, NO MATCH FOUND OR DUPLICATE PARTIAL
C MSTSAM = 1 + MAXIMUM NUMBER OF LETTERS MATCHED
C NOWSAM = 1 + NUMBER OF LETTERS MATCHING CURRENT WORD
C864241272470ABCDEFGHIJKLMNOPQRSTUVWXYZ
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 DAWHEN(ISMITH,IDAY,IMONTH,IYEAR,LTRBFR,
1LOWBFR,LMTBFR)
C RENBR(/REPRESENT A DATE AS CHARACTERS)
C
C ISMITH = 0, USE DATE INPUT IN IDAY, IMONTH, IYEAR
C = 1 OR GREATER, USE THIS SMITHSONIAN DATE
C IDAY = NUMERIC DAY OF MONTH
C IMONTH = NUMERIC MONTH OF YEAR
C IYEAR = NUMERIC YEAR, ONLY RIGHT 2 DIGITS ARE USED
C
DIMENSION LTRBFR(LMTBFR),LTRDGT(10),LTRMTH(36)
C
C THE SPACE CHARACTER
DATA LTRSPA/1H /
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/
C
DATA LTRMIN/1H-/
C
C CONVERT SMITHSONIAN DATE TO DAY, MONTH AND YEAR
IF((LOWBFR+9).GT.LMTBFR)GO TO 3
IF(ISMITH.LE.0)GO TO 1
CALL DAWEEK(-1,ISMITH,JDAY,JMONTH,JYEAR,JWEEK)
GO TO 2
1 JDAY=IDAY
JMONTH=IMONTH
JYEAR=IYEAR
C
C REPRESENT THE DAY OF THE MONTH
2 I=JDAY/10
J=JDAY-(10*I)
IF(I.EQ.0)LTRBFR(LOWBFR+1)=LTRSPA
IF(I.GT.0)LTRBFR(LOWBFR+1)=LTRDGT(I+1)
LTRBFR(LOWBFR+2)=LTRDGT(J+1)
LTRBFR(LOWBFR+3)=LTRMIN
C
C REPRESENT THE MONTH
I=3*JMONTH-2
LTRBFR(LOWBFR+4)=LTRMTH(I)
LTRBFR(LOWBFR+5)=LTRMTH(I+1)
LTRBFR(LOWBFR+6)=LTRMTH(I+2)
LTRBFR(LOWBFR+7)=LTRMIN
C
C REPRESENT RIGHT 2 DIGITS OF THE YEAR
I=JYEAR/100
J=JYEAR/10
I=J-(10*I)
J=JYEAR-(10*J)
LTRBFR(LOWBFR+8)=LTRDGT(I+1)
LTRBFR(LOWBFR+9)=LTRDGT(J+1)
LOWBFR=LOWBFR+9
3 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 DAHOUR(ITIME,IFBLNK,KASE,IFILL,LTRBFR,
1LMTBFR,LOWBFR,IERROR)
C RENBR(/DISPLAY TIME OF DAY)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C ITIME = TIME IN 24 HOUR SYSTEM
C = 0, MIDNIGHT AT START OF DAY
C = 1200, NOON
C = 2400, MIDNIGHT AT END OF DAY
C IFBLNK = 0, NO SPACE IS TO BE INSERTED BETWEEN MINUTES
C AND THE AM, M OR PM SUFFIX
C = 1, A SPACE IS TO BE INSERTED
C KASE = 0, AM, M OR PM ARE TO BE LOWER CASE
C = 1, AM, M OR PM ARE TO BE UPPER CASE
C IFILL = 0, HOURS LESS THAN 10 AND M EACH USE 1 COLUMN
C = 1, HOURS LESS THAN 10 AND M EACH USE 2 COLUMNS
C IERROR = 0, RETURNED IF NOT ERROR
C = 1, RETURNED IF INSUFFICIENT ROOM
C = 2, RETURNED IF TIME OUT OF PROPER RANGE
C
DIMENSION LTRBFR(LMTBFR),LTRDGT(10),LTRSFX(12)
DATA LTRSFX/1Ha,1Hm,1Hm,1H ,1Hp,1Hm,1HA,1HM,1HM,1H ,1HP,1HM/
DATA LTRDGT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
DATA LTRSPA,LTRCOL/1H ,1H:/
C
C CHECK FOR BAD TIME
IF(ITIME.LT.0)GO TO 14
IF(ITIME.GT.2400)GO TO 14
JTIME=ITIME
IF(JTIME.GE.1300)JTIME=JTIME-1200
C
C SPLIT TIME INTO DIGITS
IONE=JTIME/1000
ITWO=JTIME/100
ITHR=JTIME/10
IFOU=JTIME-(10*ITHR)
ITHR=ITHR-(10*ITWO)
ITWO=ITWO-(10*IONE)
C
C DON'T ALLOW MINUTES OVER 59
IF(ITHR.GT.5)GO TO 14
C
C CHECK FOR BUFFER OVERFLOW
C DIGITS AND COLON
I=4
IF(IFILL.NE.0)GO TO 1
IF(JTIME.LT.1000)GO TO 2
1 I=I+1
2 CONTINUE
C BLANK BETWEEN DIGITS AND SUFFIX
IF(IFBLNK.NE.0)I=I+1
C AM, M OR PM
I=I+1
IF(IFILL.NE.0)GO TO 3
IF(ITIME.EQ.1200)GO TO 4
3 I=I+1
4 CONTINUE
IF((LOWBFR+I).GT.LMTBFR)GO TO 13
C
C CONSTRUCT THE LETTER REPRESENTATION OF TIME
IERROR=0
IF(IONE.NE.0)GO TO 5
IF(IFILL.EQ.0)GO TO 6
LOWBFR=LOWBFR+1
LTRBFR(LOWBFR)=LTRSPA
GO TO 6
5 LOWBFR=LOWBFR+1
LTRBFR(LOWBFR)=LTRDGT(IONE+1)
6 LOWBFR=LOWBFR+4
LTRBFR(LOWBFR-3)=LTRDGT(ITWO+1)
LTRBFR(LOWBFR-2)=LTRCOL
LTRBFR(LOWBFR-1)=LTRDGT(ITHR+1)
LTRBFR(LOWBFR)=LTRDGT(IFOU+1)
C
C INSERT BLANK BETWEEN MINUTES AND SUFFIX
IF(IFBLNK.EQ.0)GO TO 7
LOWBFR=LOWBFR+1
LTRBFR(LOWBFR)=LTRSPA
C
C INSERT AM, M OR PM SUFFIX
7 IF(ITIME.GT.1200)GO TO 9
IF(ITIME.EQ.1200)GO TO 8
ILOWER=1
IUPPER=2
GO TO 10
8 ILOWER=3
IUPPER=3
IF(IFILL.NE.0)IUPPER=4
GO TO 10
9 ILOWER=5
IUPPER=6
10 IF(KASE.EQ.0)GO TO 11
ILOWER=ILOWER+6
IUPPER=IUPPER+6
11 DO 12 I=ILOWER,IUPPER
LOWBFR=LOWBFR+1
LTRBFR(LOWBFR)=LTRSFX(I)
12 CONTINUE
GO TO 15
13 IERROR=1
GO TO 15
14 IERROR=2
15 RETURN
END
SUBROUTINE GETLIN(ITTY,LTRBFR,LMTBFR,MAXBFR)
C GET NEXT LINE TYPED BY USER
C
C MAXBFR = -1 RETURNED IF ? ONLY WAS TYPED
C = 0 OR GREATER, RETURNED WITH NUMBER OF CHARACTERS
C TYPED BY THE USER
DIMENSION LTRBFR(LMTBFR)
DATA LTRSPA/1H /
MAXBFR=0
READ(ITTY,1,END=8)LTRBFR
1 FORMAT(3000A1)
INDEX0=0
INDEX1=0
2 IF(INDEX0.GE.LMTBFR)GO TO 9
INDEX0=INDEX0+1
LTRNOW=LTRBFR(INDEX0)
IF(LTRNOW.EQ.LTRSPA)GO TO 7
C NEXT 2 LINES DISCARD CONTROL CHARACTERS ON DECSYSTEM 20
IF(LTRNOW.LE.0)GO TO 3
IF(LTRNOW.GT.LTRSPA)GO TO 3
IF(INDEX1.GT.0)INDEX1=INDEX1-1
IF(MAXBFR.GT.INDEX1)MAXBFR=INDEX1
GO TO 2
3 IF(MAXBFR.NE.0)GO TO 6
IF(LTRNOW.NE.1H?)GO TO 6
I=INDEX1
4 IF(I.LE.0)GO TO 5
IF(LTRBFR(I).NE.LTRSPA)GO TO 6
I=I-1
GO TO 4
5 MAXBFR=-1
GO TO 7
6 MAXBFR=INDEX1+1
7 INDEX1=INDEX1+1
LTRBFR(INDEX1)=LTRNOW
GO TO 2
C ON DECSYSTEM20 THE TERMINAL MUST BE CLOSED AFTER AN
C END-OF-FILE TO PREVENT GETTING SAME END-OF-FILE AGAIN
8 CLOSE(UNIT=ITTY)
9 RETURN
END
SUBROUTINE RSMHLP(ITTY,KNDMSG,LTRBFR,LMTBFR,MAXBFR,IVIDEO)
C RENBR(/DUMMY FOR RESUME PASSWORD CHECKER)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
DIMENSION LTRBFR(LMTBFR)
NEWMSG=0
IF(KNDMSG.EQ.40)NEWMSG=27
IF(KNDMSG.EQ.44)NEWMSG=28
IF(NEWMSG.EQ.0)GO TO 1
CALL JOBHLP(ITTY,NEWMSG,LTRBFR,LMTBFR,MAXBFR,IVIDEO)
GO TO 3
C
C ERROR, MISSING MESSAGE NEEDED BY RESUME PROGRAM
1 WRITE(ITTY,2)
2 FORMAT(' **** MISSING ERROR MESSAGE ****')
C
C RETURN TO CALLING PROGRAM
3 RETURN
END
SUBROUTINE DASWAP(IARRAY,LOW,MID,MAX)
C RENBR(/SWAP ADJACENT SECTIONS OF ARRAY)
C
C DONALD BARTH, CHEMISTRY DEPT., HARVARD UNIVERSITY
C
C ROUTINE TO SWAP ADJACENT SECTIONS OF SINGLE ARRAY
C
C IARRAY = ARRAY CONTAINING SECTIONS TO BE SWAPPED
C LOW = SUBSCRIPT OF LOWEST LOCATION IN LOW SECTION
C MID = SUBSCRIPT OF HIGHEST LOCATION IN LOW SECTION
C MAX = SUBSCRIPT OF HIGHEST LOCATION IN HIGH
C SECTION
C
C SWAP IS PERFORMED BY MOVING VALUES DIRECTLY TO
C LOCATIONS THEY ARE TO OCCUPY IN THE RESULT.
C
C FOR EXAMPLE, TO SWAP ABCD AND 123 IN THE
C FOLLOWING EXAMPLE, 3 IS MOVED TO LOCATION HOLDING C
C WHICH IS MOVED TO LOCATION HOLDING 2 AND SO ON.
C
C A B C D 1 2 3
C . . I-----------I
C . . I--------I .
C . I-----------I .
C . I--------I . .
C I-----------I . .
C I--------I . . .
C . . . I--------I
C
C IARRAY ARRAY AND NEW AND KEEP VARIABLES SHOULD BE
C MADE FLOATING POINT TO SWAP A FLOATING POINT ARRAY.
C
DIMENSION IARRAY(MAX)
IF(LOW.GT.MID)GO TO 5
IF(MID.GE.MAX)GO TO 5
KOUNT=LOW-MAX-1
LAST=MAX
LONGLO=LOW-MID-1
LONGHI=MAX-MID
1 INDEX=LAST+LONGLO
KEEP=IARRAY(LAST)
2 KOUNT=KOUNT+1
NEW=IARRAY(INDEX)
IARRAY(INDEX)=KEEP
KEEP=NEW
IF(INDEX.GT.MID)GO TO 3
INDEX=INDEX+LONGHI
GO TO 2
3 IF(INDEX.EQ.LAST)GO TO 4
INDEX=INDEX+LONGLO
GO TO 2
4 IF(KOUNT.EQ.0)GO TO 5
LAST=LAST-1
GO TO 1
5 RETURN
END
SUBROUTINE RANK(KERNEL,IRANK,INIRNK,LMTRNK,IOFFST)
C RENBR(/INSERT RANDOM UNIQUE VALUES IN ARRAY)
C
C DONALD BARTH, YALE SCHOOL OF MANAGEMENT
C
C KERNEL = -1, SIMULATE RANDOM NUMBER GENERATOR RETURNING
C VALUE 0.5 ALWAYS. THIS MUST NOT BE USED FOR
C REAL RUNS. IT IS ONLY MEANT FOR CHECKING THE
C PROGRAMS WHEN MOVING FROM ONE MACHINE OR
C OPERATING SYSTEM TO ANOTHER
C = 0 OR GREATER, CALL RAN FUNCTION TO OBTAIN
C RANDOM NUMBERS. THIS SHOULD BE USED FOR
C REAL RUNS.
C IRANK = THE ARRAY INTO WHICH VALUES ARE TO BE INSERTED
C INIRNK = SUBSCRIPT OF LOWEST LOCATION IN IRANK ARRAY
C LMTRNK = SUBSCRIPT OF HIGHEST LOCATION IN IRANK ARRAY
C IOFFST = 1 LESS THAN MINIMUM VALUE TO BE INSERTED
C
DIMENSION IRANK(LMTRNK)
IF(INIRNK.GT.LMTRNK)GO TO 5
C
C CONSTRUCT POINTER LIST IN ARRAY LOCATIONS
DO 1 I=INIRNK,LMTRNK
IRANK(I)=I+1
1 CONTINUE
IRANK(LMTRNK)=INIRNK
C
C RANDOMIZE THE LIST
JOFFST=IOFFST
LFTOVR=LMTRNK-INIRNK+1
LSTLOC=INIRNK
C
C GET SERIAL LOCATION OF NEXT ITEM IN RAMDOMIZED LIST
2 NXTLOC=IRANK(LSTLOC)
KOUNT=0
RANDOM=0.5
IF(KERNEL.GE.0)RANDOM=RAN(DUMMY)
INTEGR=RANDOM*FLOAT(LFTOVR)
C
C SEARCH FOR NEXT ITEM IN RANDOMIZED LIST
3 IF(KOUNT.GE.INTEGR)GO TO 4
KOUNT=KOUNT+1
LSTLOC=NXTLOC
NXTLOC=IRANK(LSTLOC)
GO TO 3
C
C REMOVE THE ITEM FROM THE LIST
4 IRANK(LSTLOC)=IRANK(NXTLOC)
LFTOVR=LFTOVR-1
JOFFST=JOFFST+1
IRANK(NXTLOC)=JOFFST
IF(LFTOVR.GT.0)GO TO 2
C
C RETURN TO CALLING PROGRAM
5 RETURN
END