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