Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0141/darank.for
There are 2 other files named darank.for in the archive. Click here to see a list.
      SUBROUTINE DARANK(INCRES,IFTEST,MINMUM,MAXMUM,MINSTR,
     1    MAXSTR,IBUFFR,MAXBFR,LOWBFR,KIND  ,MAXUSD,ISTORE)
C     RENBR(/RETURNS SORTED INTEGERS)
C
C     DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C     DARANK RETURNS A GROUP OF INTEGERS SORTED INTO EITHER
C     INCREASING  OR  DECREASING ORDER.  DUPLICATES ARE NOT
C     RETURNED.   NUMBERS  CAN  BE   SPECIFIED   IN   SLASH
C     NOTATION.
C
C     INCRES = 1,  RETURN  VALUES  IN  ISTORE  SORTED  INTO
C              DECREASING  ORDER.  IF MORE VALUES ARE FOUND
C              THAN CAN BE RETURNED IN ISTORE  ARRAY,  THEN
C              SMALLER VALUES ARE DISCARDED.
C            = 2,  RETURN  VALUES  IN  ISTORE  SORTED  INTO
C              DECREASING  ORDER.  IF MORE VALUES ARE FOUND
C              THAN CAN BE RETURNED IN ISTORE  ARRAY,  THEN
C              LARGER VALUES ARE DISCARDED.
C            = 3,  RETURN  VALUES  IN  ISTORE  SORTED  INTO
C              INCREASING  ORDER.  IF MORE VALUES ARE FOUND
C              THAN CAN BE RETURNED IN ISTORE  ARRAY,  THEN
C              SMALLER VALUES ARE DISCARDED.
C            = 4,  RETURN  VALUES  IN  ISTORE  SORTED  INTO
C              INCREASING  ORDER.  IF MORE VALUES ARE FOUND
C              THAN CAN BE RETURNED IN ISTORE  ARRAY,  THEN
C              LARGER VALUES ARE DISCARDED.
C     IFTEST = -2 OR 2, THERE ARE NO  MINIMUM  AND  MAXIMUM
C              LIMITS TO RANGE OF LEGAL VALUES.
C            = -1, REJECT VALUES LESS THAN MINMUM.
C            = 0, REJECT VALUES LESS THAN MINMUM OR GREATER
C              THAN MAXMUM.
C            = 1, REJECT VALUES GREATER THAN MAXMUM.
C     MINMUM = LOWER LIMIT OF ALLOWED VALUES IF  IFTEST  IS
C              -1  OR  0.   VALUES LESS THAN MINMUM ARE NOT
C              RETURNED IN ISTORE IF IFTEST IS -1 OR 0.
C     MAXMUM = UPPER LIMIT OF ALLOWED VALUES IF IFTEST IS 0
C              OR  1.   VALUES  GREATER THAN MAXMUM ARE NOT
C              RETURNED IN ISTORE IF IFTEST IS 0 OR 1.
C     MINSTR = SUBSCRIPT OF LOWEST LOCATION IN ISTORE ARRAY
C              INTO WHICH VALUE CAN BE PLACED.
C     MAXSTR = SUBSCRIPT  OF  HIGHEST  LOCATION  IN  ISTORE
C              ARRAY INTO WHICH VALUE CAN BE PLACED.
C     IBUFFR = INPUT TEXT BUFFER CONTAINING 1 CHARACTER PER
C              ARRAY  LOCATION  AS  READ  BY MULTIPLE OF A1
C              FORMAT.
C     MAXBFR = MAXIMUM SUBSCRIPT OF IBUFFR  ARRAY  LOCATION
C              TO BE SEARCHED FOR CHARACTERS.
C     LOWBFR = INPUT CONTAINING SUBSCRIPT OF  IBUFFR  ARRAY
C              LOCATION  CONTAINING  FIRST  CHARACTER TO BE
C              TESTED.   LOWBFR  IS   RETURNED   CONTAINING
C              SUBSCRIPT    OF    IBUFFR   ARRAY   LOCATION
C              CONTAINING NEXT CHARACTER NOT YET EVALUATED.
C     KIND   = SHOULD BE INPUT  CONTAINING  ZERO  (OR  ONE)
C              WHENEVER  THIS ROUTINE IS CALLED TO GENERATE
C              NEW  GROUP  OF  SORTED  NUMBERS.   KIND   IS
C              RETURNED  DESCRIBING  REASON  FOR  RETURN TO
C              CALLING  PROGRAM.   IF  KIND   IS   RETURNED
C              CONTAINING  VALUE  OF  3  OR GREATER, AND IS
C              SENT  TO  SUBSEQUENT  CALL  UNCHANGED,  THEN
C              MAXUSD  IS  NOT  RESET  TO MINSTR-1, AND NEW
C              VALUES ARE APPENDED TO OLD CONTENTS, IF ANY,
C              OF ISTORE.
C            = 1, RETURNED EITHER IF NO PRINTING CHARACTERS
C              ARE  FOUND BEYOND NUMBERS, OR IF EXCLAMATION
C              POINT  IS  NEXT  CHARACTER  BEYOND  NUMBERS.
C              LOWBFR  IS  RETURNED  POINTING BEYOND END OF
C              BUFFER.
C            = 2, RETURNED IF SEMICOLON WAS FOUND  AS  NEXT
C              PRINTING  CHARACTER  BEYOND NUMBERS.  LOWBFR
C              IS  RETURNED  POINTING  TO  NEXT   CHARACTER
C              BEYOND SEMICOLON.
C            = 3, RETURNED IF AMPERSAND WAS FOUND  AS  NEXT
C              PRINTING  CHARACTER  BEYOND NUMBERS.  LOWBFR
C              IS RETURNED POINTING BEYOND END OF BUFFER.
C            = 4, RETURNED IF UNKNOWN CHARACTER  WAS  FOUND
C              AS  NEXT  PRINTING CHARACTER BEYOND NUMBERS.
C              LOWBFR IS RETURNED  POINTING TO THIS UNKNOWN
C              CHARACTER.   LOWBFR  MUST BE  INCREMENTED BY
C              CALLING PROGRAM BEFORE  THIS ROUTINE IS NEXT
C              CALLED.
C            = 5, ILLEGAL SERIES SPECIFICATION  WAS  FOUND.
C              LOWBFR   IS   RETURNED   POINTING   TO  NEXT
C              CHARACTER BEYOND SERIES SPECIFICATION.
C     MAXUSD = RETURNED  CONTAINING  SUBSCRIPT  OF  HIGHEST
C              LOCATION  IN  ISTORE  USED  TO RETURN SORTED
C              VALUES.
C     ISTORE = ARRAY  USED  TO  RETURN  SORTED  VALUES   IN
C              ISTORE(MINSTR)    THROUGH    AND   INCLUDING
C              ISTORE(MAXUSD).
C
      DIMENSION IBUFFR(MAXBFR),ISTORE(MAXSTR)
      JNCRES=INCRES-2
      MANY=0
      MINTST=IFTEST
      IF(MINTST.LT.-1)MINTST=1
      MAXTST=IFTEST
      IF(MAXTST.GT.1)MAXTST=-1
      IF(KIND.LT.3)MAXUSD=MINSTR-1
    1 KIND=0
    2 CALL DANEXT(0,0.0,IBUFFR,MAXBFR,LOWBFR,
     1MANY,KIND,NEWVAL,INCVAL,LMTVAL,VALNEW,VALINC,
     2VALLMT)
      GO TO(34,34,34,2,3,1,1,33,32),KIND
C
C     TEST IF NEW VALUE IS IN REGION BEING DISCARDED
    3 GO TO(5,4,5,4),INCRES
    4 IF(INCVAL.GE.0)GO TO 7
      LEFT=(NEWVAL-LMTVAL)/(-INCVAL)
      GO TO 6
    5 IF(INCVAL.LE.0)GO TO 7
      LEFT=(LMTVAL-NEWVAL)/INCVAL
    6 IF(LEFT.LE.0)GO TO 7
      LMTVAL=NEWVAL
      NEWVAL=NEWVAL+LEFT*INCVAL
      INCVAL=-INCVAL
    7 IF(MINTST.GT.0)GO TO 8
      IF(NEWVAL.GE.MINMUM)GO TO 8
      IF(INCVAL.LE.0)GO TO 1
      LEFT=(MINMUM-NEWVAL-1)/INCVAL
      GO TO 9
    8 IF(MAXTST.LT.0)GO TO 10
      IF(NEWVAL.LE.MAXMUM)GO TO 10
      IF(INCVAL.GE.0)GO TO 1
      LEFT=(NEWVAL-MAXMUM-1)/(-INCVAL)
    9 IF(LEFT.GT.0)NEWVAL=NEWVAL+(LEFT*INCVAL)
      GO TO 2
   10 IF(MAXUSD.LT.MAXSTR)GO TO 15
      IF(MAXSTR.LT.MINSTR)GO TO 1
      GO TO(11,12,13,14),INCRES
   11 IF(NEWVAL.LE.ISTORE(MAXUSD))GO TO 1
      GO TO 15
   12 IF(NEWVAL.GE.ISTORE(MINSTR))GO TO 1
      GO TO 15
   13 IF(NEWVAL.LE.ISTORE(MINSTR))GO TO 1
      GO TO 15
   14 IF(NEWVAL.GE.ISTORE(MAXUSD))GO TO 1
C
C     TEST IF NEW VALUE IS ALREADY KNOWN
   15 MIDDLE=MINSTR-1
      IF(MAXUSD.LT.MINSTR)GO TO 22
      IUPPER=MAXUSD
   16 ILOWER=MIDDLE+1
      GO TO 18
   17 IUPPER=MIDDLE-1
   18 IHALF=(IUPPER-ILOWER)/2
      MIDDLE=IUPPER-IHALF
      IF(NEWVAL.EQ.ISTORE(MIDDLE))GO TO 31
      IF(JNCRES.GT.0)GO TO 19
      IF(NEWVAL.LT.ISTORE(MIDDLE))GO TO 21
      GO TO 20
   19 IF(NEWVAL.GT.ISTORE(MIDDLE))GO TO 21
   20 IF(IHALF.GT.0)GO TO 17
      IF(IUPPER.LE.ILOWER)GO TO 23
      IUPPER=ILOWER
      GO TO 18
   21 IF(IHALF.GT.0)GO TO 16
C
C     SHIFT REST OF ARRAY AND INSERT NEW VALUE
   22 MIDDLE=MIDDLE+1
   23 IF(MAXUSD.LT.MAXSTR)GO TO 25
      GO TO(24,28,28,24),INCRES
   24 IF(MIDDLE.GT.MAXSTR)GO TO 31
      GO TO 26
   25 MAXUSD=MAXUSD+1
   26 I=MAXUSD
   27 IF(I.LE.MIDDLE)GO TO 30
      ISTORE(I)=ISTORE(I-1)
      I=I-1
      GO TO 27
   28 IF(MIDDLE.LE.MINSTR)GO TO 31
      MIDDLE=MIDDLE-1
      I=MINSTR
   29 IF(I.GE.MIDDLE)GO TO 30
      ISTORE(I)=ISTORE(I+1)
      I=I+1
      GO TO 29
   30 ISTORE(MIDDLE)=NEWVAL
   31 IF(INCVAL.EQ.0)GO TO 1
      GO TO 2
   32 KIND=4
      LOWBFR=LOWBFR-1
      GO TO 34
   33 KIND=5
   34 RETURN
C689599426999
      END