SUBROUTINE SORT(FILE1,RLEN1,TYPE1,KEYN1,CLEN1,TOP1)
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTS/ START,FILE,RLEN,TYPE,CLEN,KEYNUM
      COMMON /SORTM/ SLEN,LEN1,FPTR,FPTR1,SPTR,SPTR1,END,FEND,TOP2
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      FILE = FILE1
      RLEN = RLEN1
      TYPE = TYPE1
      KEYNUM = KEYN1
      CLEN = CLEN1
      TOP2 = TOP1
      LEN = 1000
      START = 1
10    CALL READB(START,LEN,1,RLEN,FILE,TOP1)
      DO 11, I=LEN/2, 1, -1
      CALL HEAPIFY(I, LEN)
11    CONTINUE
      DO 20 I=1, LEN - 1
      TOP = LEN - I + 1
      CALL SWAP(1, TOP)
      CALL HEAPIFY(1, TOP-1)
20    CONTINUE
      CALL WRITEB(START,LEN,1,RLEN,FILE)
      START = START + LEN
      IF (START .LT. TOP1) GOTO 10
      LEN = 1000
      TOP = TOP1
80    IF (LEN .GE. TOP) RETURN
      OPEN (UNIT=11, FILE='SCR.TMP', TYPE='SCRATCH', ACCESS='DIRECT',
     1      RECORDSIZE=RLEN/2+1, ASSOCIATEVARIABLE=I3,MAXREC=TOP)
      LEN1 = 1000
      START = 1
30    CALL READB(START,LEN1,1,RLEN,FILE,TOP)
      CALL WRITEB(START,LEN1,1,RLEN,11)
      START = START + LEN1
      IF (START .LT. TOP) GOTO 30
      START = 1
70    LEN1 = 500
      SLEN = 500
      FPTR = START
      SPTR = START + LEN
      END = SPTR + LEN
      IF (END .GT. TOP) END = TOP + 1
      FEND = SPTR
      IF (SPTR .GT. TOP) GOTO 40
      CALL READB(FPTR,LEN1,1,RLEN,11,TOP)
      CALL READB(SPTR,SLEN,501,RLEN,11,TOP)
      FPTR1 = 1
      SPTR1 = 501
50    IF (SPTR .GE. END) GOTO 35
      IF (FPTR .GE. FEND) GOTO 45
      IF (COMPARE(FPTR1,SPTR1,TYPE,KEYNUM,CLEN) .LT. 0) GOTO 32
      CALL OUT2
      GOTO 50
32    CALL OUT1
      GOTO 50
35    CALL OUT1
      IF (FPTR .LT. FEND) GOTO 35
      GOTO 60
45    CALL OUT2
      IF (SPTR .LT. END) GOTO 45
60    START = FEND + LEN
      IF (START .LE. TOP) GOTO 70
40    LEN = LEN * 2
      CLOSE(UNIT=11)
      GOTO 80
      RETURN
      END

      SUBROUTINE HEAPIFY(HEAD, TOP)
      IMPLICIT INTEGER (A-Z)
      COMMON /SORTS/ START,FILE,RLEN,TYPE,CLEN,KEYNUM
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      I = HEAD
2     IF (I .GT. TOP / 2) RETURN
      K = I
      DO 9, J = 2*I,MIN0(2*I+1,TOP)
      IF (COMPARE(K,J,TYPE,KEYNUM,CLEN) .LT. 0) K=J
9     CONTINUE
      IF (I .EQ. K) RETURN
      CALL SWAP(I, K)
      I = K
      GOTO 2
      END

      SUBROUTINE SWAP(I, K)
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTS/ START,FILE,RLEN,TYPE,CLEN,KEYNUM
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      DO 10, I1=1,14
      TEMP=SBUFF(I1,I)
      SBUFF(I1,I)=SBUFF(I1,K)
      SBUFF(I1,K)=TEMP
10    CONTINUE
      RETURN
      END

      SUBROUTINE READB(RSTART,LEN,BSTART,RLEN,FILE,TOP)
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      I1 = RSTART + LEN - 1
      IF (I1 .GT. TOP) I1 = TOP
      LEN = I1 - RSTART + 1
      I = BSTART
      DO 10, J = RSTART,I1
      READ (FILE'J) (SBUFF(I2,I),I2=1,RLEN)
      I = I + 1
10    CONTINUE
      RETURN
      END

      SUBROUTINE WRITEB(RSTART,LEN,BSTART,RLEN,FILE)
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      I = BSTART
      DO 10, J = RSTART,RSTART + LEN - 1
      WRITE (FILE'J,END=100,ERR=100) (SBUFF(I1,I),I1=1,RLEN)
      I = I + 1
10    CONTINUE
      RETURN
100   STOP 'Sort File Error'
      END

      FUNCTION COMPARE(I,J,TYPE,KEYNUM,LEN)
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      IF (TYPE .EQ. 0) GOTO 10
      IF (TYPE .EQ. -1) GOTO 40
      COMPARE = CEQUAL(SBUFF(1,I),SBUFF(1,J),12)
      RETURN
10    I2 = KEYNUM
      I1 = LEN
20    COMPARE = COMP1(I2,I,J)
      IF (COMPARE .NE. 0) RETURN
      I1 = I1 - 1
      I2 = I2 + 1
      IF (I1 .GT. 0) GOTO 20
      RETURN
40    COMPARE = CEQUAL(SBUFF(1,I),SBUFF(1,J),12)
      IF (COMPARE .NE. 0) RETURN
      COMPARE = CEQUAL(SBUFF(7,I),SBUFF(7,J),14)
      IF (COMPARE .NE. 0) RETURN
      COMPARE = COMP1(14,I,J)
      RETURN
      END

      FUNCTION COMP1(I2,I,J)
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      COMP1 = 0
      IF (IABS(SBUFF(I2,I)).LT.IABS(SBUFF(I2,J))) COMP1 = -1
      IF (IABS(SBUFF(I2,I)).GT.IABS(SBUFF(I2,J))) COMP1 = 1
      RETURN
      END

      SUBROUTINE OUT2
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      COMMON /SORTS/ START,FILE,RLEN,TYPE,CLEN,KEYNUM
      COMMON /SORTM/ SLEN,LEN1,FPTR,FPTR1,SPTR,SPTR1,END,FEND,TOP2
      WRITE (FILE'START) (SBUFF(I1,SPTR1),I1=1,RLEN)
      START = START + 1
      SPTR1 = SPTR1 + 1
      SPTR = SPTR + 1
      SLEN = SLEN - 1
      IF ((SLEN .GT. 0) .OR. (SPTR .GE. END)) RETURN
      SLEN = 500
      CALL READB(SPTR,SLEN,501,RLEN,11,TOP2)
      SPTR1 = 501
      RETURN
      END

      SUBROUTINE OUT1
      IMPLICIT INTEGER(A-Z)
      COMMON /SORTB/ SBUFF
      DIMENSION SBUFF(14,1000)
      COMMON /SORTS/ START,FILE,RLEN,TYPE,CLEN,KEYNUM
      COMMON /SORTM/ SLEN,LEN1,FPTR,FPTR1,SPTR,SPTR1,END,FEND,TOP2
      WRITE (FILE'START) (SBUFF(I1,FPTR1),I1=1,RLEN)
      START = START + 1
      FPTR1 = FPTR1 + 1
      FPTR = FPTR + 1
      LEN1 = LEN1 - 1
      IF ((LEN1 .GT. 0) .OR. (FPTR .GE. FEND)) RETURN
      LEN1 = 500
      CALL READB(FPTR,LEN1,1,RLEN,11,TOP2)
      FPTR1 = 1
      RETURN
      END