C SORT USER PROFILE FILE FOR IAS V3.0 C C WRITTEN BY: JOHN HAYES C ALLEN-BRADLEY COMPANY C 747 ALPHA DRIVE C CLEVELAND, OHIO 44143 C 216-449-6700 C C SUMMARY- C C This program sorts the entries in the User Profile File(UPF) C from LB0:[1,100] and generates a new file in the current default C directory called PDSUPF.NEW . It sorts by UIC, and deletes C all holes in the file. The new file may be shorter than the C original for this reason. C C We are not aware of any bugs. The program has worked well for us. C The output file is a new file, so the old may be preserved if C desired. C IMPLICIT INTEGER*2 (A-Z) REAL RATIO BYTE IBUF(64,400),USRNAM(12),TEMP(4) BYTE FBUF(64) INTEGER*2 IBUF2(32,400),TEMP2(2),FBUF2(32) INTEGER*4 TEMP4 EQUIVALENCE(IBUF,IBUF2) EQUIVALENCE(FBUF,FBUF2) EQUIVALENCE(TEMP,TEMP2,TEMP4) C COMMON/USRDAT/IBUF C IX = 0 ! INTERNAL BUFFER INDEX C C OPEN USER PROFILE FILE OPEN(UNIT=1,NAME='LB0:[1,100]PDSUPF.DAT',TYPE='OLD',READONLY, 1 ACCESS='DIRECT') C C READ IN USER DATA. FIRST RECORD CONTAINS FIRST AND LAST C USER RECORDS READ(1'1)(FBUF(NN),NN=1,64) C IBEGIN=FBUF2(1) ! FIRST USER PROFILE IEND=FBUF2(2) ! LAST USER PROFILE C C READ IN DATA IX = 1 DO 1000 I=IBEGIN,IEND READ(1'I)(IBUF(NN,IX),NN=1,64) C C IF FIRST BYTE IS ZERO, THE RECORD IS EMPTY AND C SHOULD BE IGNORED IF (IBUF(1,IX) .NE. "000) IX = IX + 1 1000 CONTINUE IX = IX - 1 C C NOW CLOSE THE PROFILE FILE CLOSE(UNIT=1) C C SORT IBUF FILE CALL RSORT(1,IX,5) C C OUTPUT DATA C OPEN(UNIT=2,NAME='PDSUPF.NEW',TYPE='NEW',ACCESS='DIRECT', 1 RECORDSIZE=16) C C WRITE INITIAL RECORD IEND=IBEGIN+IX-1 ! FORMULATE A NEW END REC PTR FBUF2(2)=IEND WRITE(2'1)FBUF C C ZERO FBUF DO 2500 I=1,32 2500 FBUF2(I) = 0 C C OUTPUT USER RECORDS IX = 1 DO 2000 I=IBEGIN,IEND WRITE(2'I)(IBUF(NN,IX),NN=1,64) IX = IX + 1 2000 CONTINUE C C ZERO INDEX RECORDS DO 3000 I=2,IBEGIN-1 WRITE(2'I)FBUF 3000 CONTINUE C C NOW OUTPUT NEW INDEX IB=IBEGIN IREC=2 IX=1 C ZERO FBUF 3999 DO 3800 I=1,32 3800 FBUF2(I)=0 DO 4000 I=0,7 JJ=I*4+1 ! INDEX INTO FBUF DO 4444 KKK=1,4 FBUF2(JJ)=IBUF2(KKK,IX) JJ=JJ+1 4444 CONTINUE IX=IX+1 IB=IB+1 IF(IB .GT. IEND) GOTO 9000 ! DONE 4000 CONTINUE WRITE(2'IREC)(FBUF(NN),NN=1,64) IREC = IREC + 1 GOTO 3999 9000 WRITE(2'IREC)(FBUF(NN),NN=1,64) C C CLOSE NEW FILE CLOSE(UNIT=2) C C BYE Y'ALL CALL EXIT END SUBROUTINE RSORT(INDEX,NUMBER,FIELD) IMPLICIT INTEGER*2 (A-Z) BYTE IBUF(64,400) INTEGER*2 IBUF2(32,400) INTEGER*4 VALUE1,VALUE2 EQUIVALENCE(IBUF,IBUF2) C COMMON/USRDAT/IBUF C C RSORT PERFORMS A RIPPLE SORT ON THE PDSUPF.DAT RECORDS, C STARTING WITH RECORD # INDEX, SORTING FOR NUMBER C RECORDS. FIELD IS THE INTEGER*2 LOCATION IN BUF2 C ON WHICH THE SORT IS KEYED. C ITERS = 0 ! ZERO ITERATION COUNTER 10 CONTINUE SWAPS = 0 ! CLEAR NUMBER OF SWAPS DO 100 I=INDEX,INDEX+NUMBER-2 VALUE1 = IBUF2(FIELD,I) VALUE1 = IAND(VALUE1,"177777) VALUE2 = IBUF2(FIELD,I+1) VALUE2 = IAND(VALUE2,"177777) IF (VALUE1 .LE. VALUE2) GOTO 100 ! NO CHANGE - TRY NEXT PAIR C C SWAP RECORDS DO 50 J=1,32 ITEMP = IBUF2(J,I) IBUF2(J,I) = IBUF2(J,I+1) IBUF2(J,I+1) = ITEMP 50 CONTINUE SWAPS = SWAPS + 1 100 CONTINUE C C CHECK FOR SORT COMPLETED IF(SWAPS .EQ. 0) RETURN ITERS = ITERS + 1 C C CHECK FOR TOO MANY ITERATIONS IF(ITERS .LT. NUMBER) GOTO 10 STOP 'RSORT ERROR - TOO MANY ITERATIONS REQUIRED' END