C This file: http://ftp.aset.psu.edu/pub/ger/fortran/hdk/tree.for
C
C====SAMPLE DRIVER FOR BINARY TREE ROUTINES ADSRCH & TRPOST.
C    H. D. Knoble, S. P. Pennypacker - 1973
C    See file EXHASH.FOR for PA COUNTIES
      CHARACTER*1 KEY(20,68),K(20)
      INTEGER*2 LLINK(68),RLINK(68),P,Q,STACKA(26)
      LOGICAL OVERFL,ADD
C---READ IN SOME PENNSYLVANIA COUNTY NAMES IN RANDOM ORDER AND
C   ADD THEM TO THE BINARY TREE: KEY-LLINK-RLINK.
      OVERFL=.TRUE.
      IDIMA=3.14159*SQRT(68.)+0.5
      WRITE(6,*) 'Press only Enter to terminate input requests.'
      DO 1 I=1,999999
        WRITE(6,*) 'Please enter a Pennsylvania County name:'
        READ(5,2,END=99) K
2       FORMAT(20A1)
        CALL ADSRCH(KEY,LLINK,RLINK,68,20,K,P,Q,OVERFL,.TRUE.)
        IF(OVERFL) THEN
          WRITE(6,*) 'Pennsylvania has only 68 counties!!'
          STOP 16
        ENDIF
1     CONTINUE
C---Now traverse the tree in post order to print the county names
C   in lexicographic order.
C
99    P=0
      DO 3 I=1,99999
        CALL TRPOST(LLINK,RLINK,68,STACKA,IDIMA,P)
        IF(P.EQ.0) GOTO 100
3     WRITE(6,4) (KEY(J,P),J=1,20)
4     FORMAT(20A1)
100   STOP
      END
      SUBROUTINE ADSRCH(KEY,LLINK,RLINK,ISIZE,LEN,K,P,Q,OVERFL,ADD)
C---------------ADSRCH ADDS TO OR SEARCHES FOR ELEMENT K IN BINARY TREE
C             KEY.  IF ADD IS .TRUE. K IS ADDED AT POSITION Q IF K DOES
C             NOT ALREADY APPEAR IN KEY; IN EITHER CASE P IS RETURNED AS
C             A POINTER TO KEY SUCH THAT KEY(P)=K.  IF ADD IS .FALSE.
C             AND K IS NOT IN KEY, THEN P IS RETURNED ZERO AND Q
C             IS A DUMMY VARIABLE.  IF Q  BECOMES LARGER THAN ISIZE
C             THEN OVERFL IS RETURNED .TRUE., OTHERWISE ARGUMENT
C             VARIABLE CORRESPONDING TO OVERFL MUST BE SET .TRUE. ON
C             THE FIRST CALL, AND NOT CHANGED BETWEEN CALLS, TO ADSRCH.
C
C             BEFORE FIRST CALL OVERFL MUST BE SET TO .TRUE. .
C
C--------------SEE KNUTH, ART OF COMPUTER PROGRAMMING, VOL 3,
C                  ALGORIGHM 6.2.2T, PAGE 424.      HDK - MAY, 1978.
C                  WILL RUN IN FORTRAN IV OR FORTRAN 77 DEPENDING ON
C                  ANCILLARY ROUTINES KOMP AND CHMOVE.
C
      INTEGER LEN,ISIZE
      CHARACTER*1 K(LEN),KEY(LEN,ISIZE)
      LOGICAL OVERFL, ADD
C
      INTEGER*2 LLINK(ISIZE),RLINK(ISIZE),P,Q, LAMBDA,L
C---NOTE THAT INTEGER*2 VALUES ON IBM COMPUTERS ARE LIMITED TO THE RANGE
C   -2**15 <= X <= 2**15-1.  INTEGER*2 IS USED HERE ONLY TO CONSERVE
C   STORAGE.
      DATA LAMBDA/0/
C
      P=1
      IF(.NOT.OVERFL) GO TO 2
      LR=0
      Q=1
      DO 1 I=1,ISIZE
      LLINK(I)=LAMBDA
1     RLINK(I)=LAMBDA
      OVERFL=.FALSE.
      GO TO 6
C---KOMP=0, IF K=KEY(P); KOMP=1 IF K>KEY(P); KOMP=-1 IF K<KEY(P).
2     LR=KOMP(K,KEY(1,P),LEN)
      IF(LR) 3,999,4
3     L=LLINK(P)
      IF(L.EQ.LAMBDA) GO TO 5
      P=L
      GO TO 2
4     L=RLINK(P)
      IF(L.EQ.LAMBDA) GO TO 5
      P=L
C----------------SEARCH ONLY IF ADD=FALSE.
      GO TO 2
5     IF(ADD) GO TO 51
      P=0
      RETURN
51    Q=Q+1
      IF(Q.LE.ISIZE) GO TO 6
      OVERFL=.TRUE.
      RETURN
C---MOVE CHARACTERS FROM KEY TO K SUCH THAT KEY(Q)=K
6     CALL CHMOVE(K,KEY(1,Q),LEN)
      LLINK(Q)=LAMBDA
      RLINK(Q)=LAMBDA
      IF(LR.LT.0) LLINK(P)=Q
      IF(LR.GT.0) RLINK(P)=Q
      P=Q
999   RETURN
      END
      SUBROUTINE TRPOST(LLINK,RLINK,ISIZE,STACKA,IDIMA,P)
C----------------TRAPOST TRAVERSES BINARY TREE KEY-LINK (LLINK,RLINK)
C                IN POSTORDER.
C
C                P IS RETURNED AS LOCATION IN KEY CORRESPONDING
C                TO LINK TO BE "VISITED".  WHEN A CALL RETURNS
C                WITH P=0 THE BINARY TREE HAS BEEN COMPLETELY
C                TRAVERSED.  THE EXPECTED LARGEST DIMENSION NECESSARY
C                TO ACCOMODATE STACKA IS SQRT(PI*ISIZE).
C
C     ON FIRST CALL P MUST BE GIVEN AS EQUAL TO LAMBDA'S INITIAL VALUE.
C
C----------------SEE KNUTH, ART OF COMPUTER PROGRAMMING, VOL 1
C                    ALGORITHM 2.3.1T, P 317.       HDK - MAY, 1978.
C
      INTEGER ISIZE,IDIMA
      INTEGER*2 LLINK(ISIZE),RLINK(ISIZE),STACKA(IDIMA),P, LAMBDA
C---NOTE THAT INTEGER*2 VALUES ON IBM COMPUTERS ARE LIMITED TO THE RANGE
C   -2**15 <= X <= 2**15-1.  INTEGER*2 IS USED HERE ONLY TO CONSERVE
C   STORAGE.
      DATA LAMBDA/0/
C
      IF(P.NE.LAMBDA) GO TO 1
      P=1
      IPTA=0
      GO TO 2
1     P=RLINK(P)
2     IF(P.EQ.LAMBDA) GO TO 4
      IPTA=IPTA+1
      STACKA(IPTA)=P
      P=LLINK(P)
      GO TO 2
4     IF(IPTA.EQ.0) RETURN
      P=STACKA(IPTA)
      IPTA=IPTA-1
      RETURN
      END
      INTEGER FUNCTION KOMP(A,B,LEN)
C===KOMP=0, IF A=B; KOMP=1 IF A>B; KOMP=-1 IF A<B.
      CHARACTER*1 A(LEN),B(LEN)
      DO 1 I=1,LEN
        IF(A(I).NE.B(I)) GOTO 2
1     CONTINUE
      KOMP=0
      RETURN
2     IF(LGT(A(I),B(I))) THEN
        KOMP=+1
      ELSE
        KOMP=-1
      ENDIF
      RETURN
      END
      SUBROUTINE CHMOVE(A,B,LEN)
C===SET CHARACTER STRING B=A ASSUMING LENGTH(A)=LENGTH(B)=LEN.
      CHARACTER*1 A(LEN),B(LEN)
      DO 1 I=1,LEN
1     B(I)=A(I)
      RETURN
      END