C			SORTL.FTN
C
C  A PROGRAM TO SORT LABELS BY EITHER NAME OR BY ZIP CODE
C
C
	INTEGER	STYPE		! 1 IF SORTING NAMES, 2 FOR ZIP CODES
	INTEGER	ECOUNT		! NO OF NAMES HAVING AN ERROR
	INTEGER	ENDS		! END OF SORTED NAMES
	BYTE	NAME(84)
	BYTE	ZSAV(10)
	BYTE	ZIPDIR(10,1000)
	BYTE	HINAM(10),LOWNAM(10)
	INTEGER	RECDIR(1000)		! DIRECTORY OF RECORD NO.
	INTEGER	REC,RECSAV	! RECORD NUMBER TO WRITE TO
	INTEGER	LASREC		! LAST RECORD
	INTEGER	COUNT,ROW,DROW,MEMROW
	INTEGER	COMPAR		! COMPARE SUBROUTINE
C	INTEGER	COMPF		! SUBSTITUTE COMPARE SUBROUTINE
	BYTE	SPA,SCOLON
	DATA	SPA,SCOLON/' ','!'/
	CALL ASSIGN(2,'LABEL.DAT;1')
	DEFINE FILE 2(32000,42,U,NXT)
	CALL FDBSET(2,'OLD','SHARE')
	CALL ASSIGN(3,'SORTL.DAT;1')
	DEFINE FILE 3(32000,42,U,NXT)
	CALL FDBSET(3,'NEW','SHARE')
	READ(2'1)LASREC,ENDS, NLIST
	LASREC=LASREC-1		! CHANGE TO LAST REC
100	FORMAT(I5)
	ECOUNT=1
	WRITE(5,105)LASREC
105	FORMAT(' LAST REC',I7)
	WRITE(5,110)
110	FORMAT(' ENTER',/,'  1 If sorting names alphabetically',/,
     2 '$2 If sorting names by zip code  ')
	READ(5,100)STYPE
      WRITE(5,112)
112   FORMAT(' Warning!!  It takes a considerable amount of time to
     1 sort all the names.',/,
     1 ' On a PDP 11-34 with RK05 disk drives it
     2 takes about 14 minutes',/,' per 1000 names.  So please be
     3 patient.')
C
C  PLACE ALL NAMES IN MEMORY
C
115	CALL LOA(LOWNAM,10,0)	! AT THE BEGINNING LOW NAME IS ZEROES
	CALL LOA(HINAM,10,"140)	! FILL HIGH NAME WITH MAX CHARACTER
C	COUNT=1
	COUNT=0
	MEMROW=0
	DROW=3		! FIRST ROW IN DESTINATION FILE
120	DO 195 ROW=3,LASREC	!
	READ(2'ROW)NAME
	IF(NAME(1).EQ."40)GO TO 130	! FIRST CHAR IS SPACE, REJECT
	IF(NAME(1).EQ."71)GO TO 195	! FIRST CHAR IS "9", WANTED IT DELETED
	DO 125 I=1,75
	IF(NAME(I).LE.0)GO TO 125
	IF(NAME(I).GE."40)GO TO 125
	GO TO 150			! THIS MUST BE ILLEGAL CHAR
125	CONTINUE
	GO TO 160
130	WRITE(5,135)ECOUNT,ROW,(NAME(J),J=1,40)
135	FORMAT(' ERROR ',I5,' ROW',I5,' FIRST CHAR IS A SPACE',/,
	1' NAME: ',40A1,/)
	ECOUNT=ECOUNT+1
	GO TO 195
140	WRITE(5,145)ECOUNT,ROW,(NAME(J),J=1,40)
145	FORMAT(' ERROR',I5,' ROW',I5,' NAME WAS DELETED',/,
	1' NAME: ',40A1,/)
	ECOUNT=ECOUNT+1
	GO TO 195
150	K=NAME(I)
	WRITE(5,155)ECOUNT,ROW,K,(NAME(J),J=1,40)
155	FORMAT(' ERROR',I5,' ROW',I5,' DEC VALUE OF ERROR',I5,/,
	1' NAME: ',40A1,/)
	ECOUNT=ECOUNT+1
	GO TO 195
160	IF(STYPE.EQ.2)GO TO 170			! DOING ZIPCODES
C	DO 165 I=1,10
C	ZSAV(I)=NAME(I)
C165	CONTINUE
      CALL SCOPY(NAME,ZSAV,10)
	GO TO 180
C
C  PLACE ZIP CODE INTO ARRAY
C
C170	DO 175 I=1,5
C	ZSAV(I)=NAME(70+I)	! PLACE ZIPCODE IN FIRST 5 CHAR
C	ZSAV(I+5)=NAME(I)	! 1ST 5 CHAR OF NAME IN LAST 5 CHAR OF ZSAV
C175	CONTINUE
170   CALL SCOPY(NAME,ZSAV,5,71)
      CALL SCOPY(NAME,ZSAV,5,1,6)
180   IF(COMPAR(ZSAV, LOWNAM, 10). NE. 1) GO TO 195 ! ALREADY USED
C180	IF(COMPF(ZSAV,LOWNAM,10,ROW).NE.1)GO TO 195 ! ALREADY USED
	MEMROW=MEMROW+1			! IF ZIPDIR FULL, THIS IS DESTROYED
	IF(COUNT.LE.999)GO TO 190	! TAKE THIS IRREGARDLESS
      IF(COMPAR(ZSAV, HINAM, 10).EQ.1) GO TO 195  ! ABOVE HIGH
C	IF(COMPF(ZSAV,HINAM,10,ROW).EQ.1)GO TO 195 ! ABOVE HIGH
C
C FIND THE HIGHEST CODE IN MEMORY
C
C	CALL STRMOV(LOWNAM,HINAM,10)
      CALL SCOPY(LOWNAM,HINAM,10)
	DO 185 I=1,1000		!
C	IF(COMPF(ZIPDIR(1,I),HINAM,10).EQ.2)GO TO 185 ! THIS NOT HIGHEST
      IF(COMPAR(ZIPDIR(1,I), HINAM, 10).EQ.2) GO TO 185 ! THIS IS NOT HIGHEST
C	CALL STRMOV(ZIPDIR(1,I),HINAM,10)	! SO FAR, THIS IS HIGHEST
      CALL SCOPY(ZIPDIR(1,I),HINAM,10)
	MEMROW=I			! REMEMBER WHICH ONE THIS WAS
185	CONTINUE
C
C  FOUND THE HIGHEST NAME IN MEMORY
C
C	IF(COMPF(ZSAV,HINAM,10,ROW).EQ.1)GO TO 195
      IF(COMPAR(ZSAV,HINAM,10).EQ.1) GO TO 195
C  SHOULD NOT REPLACE THIS NAME
190	COUNT=COUNT+1
C	CALL STRMOV(ZSAV,ZIPDIR(1,MEMROW),10)
      CALL SCOPY(ZSAV,ZIPDIR(1,MEMROW),10)
	RECDIR(MEMROW)=ROW
C	IF(COMPF(ZSAV,HINAM,10,ROW).EQ.2)GO TO 195
      IF(COMPAR(ZSAV, HINAM, 10).EQ.2) GO TO 195
C	CALL STRMOV(ZSAV,HINAM,10)		! HAVE A NEW HIGH NAME
      CALL SCOPY(ZSAV,HINAM,10)
C
195	CONTINUE
C
C
C  WORK YOUR WAY FROM BOTTOM TO TOP AND MAKE SURE EACH IS GREATER THAN
C  ONE BEFORE
C
	IF(COUNT.GT.1000)COUNT=1000	!
	DO 220 I=1,COUNT-1
C	IF(COMPF(ZIPDIR(1,I),ZIPDIR(1,I+1),10,I).NE.1)GO TO 220
      IF(COMPAR(ZIPDIR(1,I),ZIPDIR(1,I+1),10) .NE. 1) GO TO 220
C  IF 2ND REC IS BIGGER OR EQUAL TO 1ST GO ON TO NEXT SET
C  ELSE; DO THE FOLLOWING
200	RECSAV=RECDIR(I+1)
C
C  SAVE THE NEXT ONE UP
C	CALL STRMOV(ZIPDIR(1,I+1),ZSAV,10)
      CALL SCOPY(ZIPDIR(1,I+1),ZSAV,10)
C
C  NOW MOVE EACH UP ONE, GOING FROM CURRENT NAME TO FIRST NAME LESS
	DO 210 K=I+1,2,-1
C	IF(COMPF(ZIPDIR(1,K-1),ZSAV,10,K).EQ.2)GO TO 215
      IF(COMPAR(ZIPDIR(1,K-1), ZSAV, 10).EQ.2) GO TO 215
205	RECDIR(K)=RECDIR(K-1)
C	CALL STRMOV(ZIPDIR(1,K-1),ZIPDIR(1,K),10)
      CALL SCOPY(ZIPDIR(1,K-1),ZIPDIR(1,K),10)
210	CONTINUE
215	RECDIR(K)=RECSAV
C	CALL STRMOV(ZSAV,ZIPDIR(1,K),10)
      CALL SCOPY(ZSAV,ZIPDIR(1,K),10)
220	CONTINUE
C
C  NAMES ARE SORTED, WRITE TO DESTINATION FILE
C
	DO 225 I=1,COUNT
C	IF(RECDIR(I).LT.1)WRITE(5,486)RECDIR(I)
C486	FORMAT(' ROW NO',I5)
	IF(RECDIR(I).LT.1)GO TO 225
	READ(2'RECDIR(I))NAME
	WRITE(3'DROW)NAME
	DROW=DROW+1
225	CONTINUE
	IF(COUNT.LT.1000)GO TO 260	! ASSUME WE ARE FINNISHED
	IF(DROW.GE.LASREC)GO TO 260	! ALSO INDICATES FINNISHED
	IF(STYPE.EQ.2)GO TO 235
C	DO 230 I=1,10
C	HINAM(I)=NAME(I)
C230	CONTINUE
      CALL SCOPY(NAME,HINAM,10)
	GO TO 245
C235	DO 240 I=1,5
C	HINAM(I)=NAME(70+I)
C	HINAM(I+5)=NAME(I)
C240	CONTINUE
235   CALL SCOPY(NAME,HINAM,5,71,1)
      CALL SCOPY(NAME,HINAM,5,1,6)
C245	DO 250 I=1,10
C	LOWNAM(I)=HINAM(I)
C250	CONTINUE
245   CALL SCOPY(HINAM,LOWNAM,10)
	COUNT=0
	MEMROW=0
	GO TO 120			! GO BACK AND GET NEXT SET OF NAMES
260	LASREC=DROW		! THIS IS REALLY NEXT AVAIL REC
	IF(STYPE.EQ.1)ENDS=LASREC-1
	WRITE(3'1)LASREC,ENDS, NLIST	! 2ND NO. IS THE LAST SORTED NAME
	READ(2'2)NAME
	WRITE(3'2)NAME
      WRITE(5,265)
  265 FORMAT(' SORTING IS NOW FINISHED.  IF YOU ARE SORTING
     1 ALPHABETICALLY,',/,' GIVE THE COMMAND: "@ALPHA"  IF YOU ARE
     2 SORTING BY ZIPCODE,',/,' YOU ARE FINISHED.')
C
270	CALL EXIT
	END