Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-12 - 43,50546/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