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