C This file: http://ftp.aset.psu.edu/pub/ger/fortran/hdk/compare.for C C Fileid of this file: COMPARE.FOR C C Purpose: Compare two (Binary) files for being identical/different. C C Compiler/Platform: Fortran 90 (Multiplatform)/Windows 9x/ME/NT/2000. C Source code for Digital Visual Fortran with commented code for Salford C FTN95 and Lahey LF90/LF95. Code is basically Fortran 77. C C Use: Issue the DOS command: COMPARE and respond to the C input fileid prompts with full DOS filespecs (Fileids). C or C Issue: COMPARE InFilespec1 InFilespec2 C or C Drag/Drop input files from Windows Explorer C or Issue: COMPARE ? for brief on-line help. C See the file COMPARE.TXT for more documentation; it's on the Web at: C http://ftp.cac.psu.edu/pub/ger/fortran/hdk/compare.txt C C ---------------------------------------------------------------------- C Author: hdkLESS at SPAM psu dot edu C 10 Feb. 1997, 26 May 1998, 10 Nov. 1998, C 21 June 1999, 19 July 1999, 2 Feb. 2000, C 20 October 2000, 29 November 2000, C 18 January 2001. C Penn State Center for Academic Computing C ---------------------------------------------------------------------- PARAMETER (NBUF=256000) CHARACTER*256000 LINE1, LINE2 CHARACTER*120 FID1,FID2 CHARACTER*2 TH INTEGER I, J, L, LL, UU, LAST, MORE, N, NJ INTEGER NRECS, SIZE1,SIZE2, UNIT1, UNIT2, STAT1, STAT2 LOGICAL FSET, SAME, QUIET DATA UNIT1/50/, UNIT2/60/ C---Define Files, do some checking on them; then open them. CALL GETFID(FID1,FID2,FSET,SIZE1,SIZE2,UNIT1,UNIT2,SAME,QUIET) IF (.NOT.FSET) THEN WRITE(*,*) 'No COMPARE action taken.' GOTO 99 ENDIF C---Opens: Lah=Lahey F90/F95, Sal=Salford FTN95; W77=Watcom Fortran 77 C Dig=Ditigal Visual Fortran. OPEN(UNIT=UNIT1,FILE=FID1,STATUS='OLD',IOSTAT=IOERR, * FORM='UNFORMATTED',RECORDTYPE='STREAM') CDig * FORM='UNFORMATTED',RECORDTYPE='STREAM') CLah * ACCESS='TRANSPARENT',FORM='UNFORMATTED') CSal * ACCESS='TRANSPARENT',FORM='UNFORMATTED') CW77 * ACCESS='SEQUENTIAL',FORM='UNFORMATTED',RECORDTYPE='FIXED') IF (IOERR.NE.0) THEN WRITE(*,*) '?? Invalid Fileid:',FID1 WRITE(*,*) 'No COMPARE action taken.' GoTo 99 ENDIF OPEN(UNIT=UNIT2,FILE=FID2,STATUS='OLD',IOSTAT=IOERR, * FORM='UNFORMATTED',RECORDTYPE='STREAM') CDig * FORM='UNFORMATTED',RECORDTYPE='STREAM') CLah * ACCESS='TRANSPARENT',FORM='UNFORMATTED') CSal * ACCESS='TRANSPARENT',FORM='UNFORMATTED') CW77 * ACCESS='SEQUENTIAL',FORM='UNFORMATTED',RECORDTYPE='FIXED') IF (IOERR.NE.0) THEN WRITE(*,*) '?? Invalid Fileid:',FID2 WRITE(*,*) 'No COMPARE action taken.' GoTo 99 ENDIF IF(.NOT.QUIET) THEN WRITE(*,*) ' ' WRITE(*,*) 'Penn State University Center for Academic Computing' WRITE(*,*) ' ** Comparing two (Binary) Files...' WRITE(*,*) ' ' WRITE(*,*) '1st File: SIZE=',SIZE1,' Id=',TRIM(FID1) WRITE(*,*) '2nd File: SIZE=',SIZE2,' Id=',TRIM(FID2) ENDIF L=MIN(SIZE1,SIZE2) NRECS = L/NBUF LAST = MOD(L,NBUF) IF (LAST.EQ.0) THEN MORE = 0 ELSE MORE = 1 ENDIF C---Read a record at a time and compare. L = NBUF N = 0 DO 100 I=1,NRECS+MORE IF(I.GT.NRECS) L = LAST READ(UNIT=UNIT1,IOSTAT=STAT1) LINE1(:L) IF (STAT1 .GT.0) GOTO 33 IF (STAT1 .LT.0) GOTO 35 READ(UNIT=UNIT2,IOSTAT=STAT2) LINE2(:L) IF (STAT2 .GT.0) GOTO 34 IF (STAT2 .LT.0) GOTO 36 IF (LINE1(:L).NE.LINE2(:L)) THEN C---Search to find where within this file segment matching quits. SAME=.FALSE. DO J=1,L IF(LINE1(J:J).NE.LINE2(J:J)) THEN N=N+J-1 NJ=J GOTO 150 ENDIF END DO ELSE N=N+L ENDIF 100 CONTINUE GOTO 150 33 WRITE(*,*) '?? Premature End-of-File: Record#' ,I WRITE(*,*) ' Fileid=',FID1 GOTO 88 34 WRITE(*,*) '?? Premature End-of-File: Record#' ,I WRITE(*,*) ' Fileid=',FID2 GOTO 88 35 WRITE(*,*) '?? Error reading fileid: Record#',I WRITE(*,*) ' Fileid=',FID1 GOTO 99 36 WRITE(*,*) '?? Error reading fileid: Record#',I WRITE(*,*) ' Fileid=',FID2 GOTO 99 C---Display results of compare. 150 IF(SIZE1.NE.SIZE2) THEN IF (.NOT. QUIET) THEN WRITE(*,*) '$$ File are different sizes.' ENDIF SAME = .FALSE. ENDIF IF (SAME) THEN IF (.NOT.QUIET) THEN WRITE(*,*) '** Files ARE identical.' ENDIF ELSE IF (.NOT.QUIET) THEN WRITE(*,*) '$$ Files are NOT identical.' ENDIF ENDIF C---Wrap up and display summary count. 88 CLOSE(UNIT=UNIT1) CLOSE(UNIT=UNIT2) IF (.NOT.SAME .AND. .NOT. QUIET) THEN NP1=N+1 TH='th' IF(NP1.EQ.1) TH='st' IF(NP1.EQ.2) TH='nd' IF(NP1.EQ.3) TH='rd' WRITE(*,*) ' ' WRITE(*,*) 'The first character pair in these two files that' WRITE(*,*) 'differs is the ',NP1,TH,' pair (counting from 1);' WRITE(*,200) 'this is at Hexadecimal file location: ',NP1 200 FORMAT(1X,A,Z8) WRITE(*,250) 'Hexadecimal representations of this pair are: ', * LINE1(NJ:NJ),LINE2(NJ:NJ) 250 FORMAT(1X,A,Z2,1X,Z2) ENDIF 99 IF(.NOT.QUIET) THEN WRITE(*,*) ' ' C---PAUSE in case input/output files were dragged/dropped C from Windows Explorer pause so DOS screen doesn't close. PAUSE ENDIF IF (SAME) THEN STOP ELSE C---Set DOS ERRORLEVEL to 1 (if possible). CALL EXIT(1) ENDIF END SUBROUTINE GETFID (FID1,FID2,FSET,SIZE1,SIZE2,UNIT1,UNIT2,SAME, * QUIET) C===Get Input Fileids either from command line parms or via C screen prompt. Return File sizes, SIZE1 and SIZE2, and C FSET=.TRUE. IFF FID1 and FID2 were specified; .FALSE. otherwise. CHARACTER*(*) FID1, FID2 C---To run this in WATCOM Fortran 77, Activate lines beginning CW77. C When using other compilers, let the CW77 lines commented. C "INTEGER PARM" and "L=PARM(CH)". CHARACTER*128 CH CHARACTER*19 HELP CHARACTER*28 OPTS INTEGER FGETCMD, SIZE1,SIZE2,UNIT1,UNIT2 CW77 INTEGER PARM INTEGER L,I,J, IOPT LOGICAL FSET, FOUND, SLASH, SAME, QUIET HELP = '? /? /h /H -? -h -H' OPTS = '/QUIET /quiet -QUIET -quiet' FID1 = ' ' FID2 = ' ' FSET = .FALSE. SAME = .TRUE. QUIET = .FALSE. C---PARM or FGETCMD are WATFOR77 library system functions that return C the options or parameters passed (to .EXE) at run-time. L = FGETCMD(CH) CW77 L = PARM(CH) C---If the option is a Help signal, then display brief Help. IF(L.LE.2) THEN IF (L.EQ.0 ) GOTO 2 IF (CH(1:L).EQ.' ') GOTO 2 IF (INDEX(HELP,CH(1:L)).NE.0) THEN CALL COMPHLP RETURN ENDIF ENDIF C---Kludgy Scan for the QUIET option. I=0 DO WHILE(IOPT.EQ.0.AND.I.LE.3) IOPT = INDEX(CH(1:L),OPTS(I*7+1:I*7+6)) IF (IOPT.NE.0) THEN QUIET=.TRUE. CH(IOPT:IOPT+5)=' ' IF(CH(1:1).EQ.' ') CH=CH(8:) L=L-7 ENDIF I=I+1 END DO C---Scan out the fileids. DO 1 I=1,L IF(CH(I:I).EQ.' ') THEN FID1 = CH(1:I-1) FID2 = CH(I+1:L) GOTO 2 ENDIF 1 CONTINUE FID1 = CH(1:L) C---Prompt for Input Filespecs. 2 IF (FID1 .EQ. ' ') THEN WRITE(*,*) 'Please enter FileId of 1st Input file:' READ(*,'(A)') FID1 IF (FID1.EQ.' ') RETURN L=INDEX(FID1,' ')-1 IF (L.LE.2) THEN IF (INDEX(HELP,FID1(1:L)).NE.0) THEN CALL COMPHLP RETURN ENDIF ENDIF ENDIF C---Insure Input files exist and get their file sizes. INQUIRE(FILE=FID1,EXIST=FOUND) IF(.NOT.FOUND) THEN SAME=.FALSE. WRITE(*,*) '$$COMPARE Error:' WRITE(*,*) '1st Input file not found: ',TRIM(FID1) WRITE(*,*) ' ' RETURN ENDIF CALL GETFSIZ(FID1,SIZE1,UNIT1) C---Special symbol (=) means set filename.ext of Fileid2 equal to C the same filename.ext of Fileid1. C E.g., COMPARE C:\aa\my.dat E:\aa\= sets Fileid2 to E:\aa\my.dat. 111 J=INDEX(FID2,'=') IF (J.NE.0) THEN C---Isolate filename.ext from FID1 and replace = sign with that. SLASH=.FALSE. DO I=LEN(FID1),1,-1 IF (FID1(I:I).EQ. '\') THEN FID2(J:)=FID1(I+1:) SLASH=.TRUE. EXIT ENDIF END DO IF (.NOT.SLASH) FID2(J:)=FID1(1:) ENDIF C---Continue regular checks on Fileid2. IF (FID2 .EQ. ' ') THEN FID2 = ' ' WRITE(*,*) 'Please enter FileId of 2nd Input file:' READ(*,'(A)') FID2 IF (FID2.EQ. ' ') THEN RETURN ELSE GOTO 111 ENDIF ENDIF INQUIRE(FILE=FID2,EXIST=FOUND) IF(.NOT.FOUND) THEN SAME=.FALSE. WRITE(*,*) '$$COMPARE Error:' WRITE(*,*) '2nd Input file not found: ',TRIM(FID2) WRITE(*,*) ' ' RETURN ENDIF CALL GETFSIZ(FID2,SIZE2,UNIT2) FSET = .TRUE. RETURN END SUBROUTINE COMPHLP C====Display brief on-line HELP. WRITE(*,*) ' ' WRITE(*,*)'Penn State University Center for Academic Computing' WRITE(*,*)' ' WRITE(*,*)'Purpose: COMPARE two (Binary) files.' WRITE(*,*)' ' WRITE(*,*)'Syntax: COMPARE Filespec1 Filespec2 [/QUIET]' WRITE(*,*)' or: COMPARE (no args) will prompt for filepecs.' WRITE(*,*)' or: drag/drop file(s) to COMPARE prompt or Icon.' WRITE(*,*)' ' WRITE(*,*)'Results: A message is displayed indicating whether' WRITE(*,*)' files differ or are identical. If files' WRITE(*,*)' differ, a character count indicating where' WRITE(*,*)' first difference occurs is also displayed.' WRITE(*,*)' DOS ERRORLEVEL is returned 0 for identical' WRITE(*,*)' files; 1 otherwise. /QUIET suppresses output.' WRITE(*,*)' ' WRITE(*,*)' For more details and options see: COMPARE.TXT at:' WRITE(*,*)'http://ftp.cac.psu.edu/pub/ger/fortran/hdk/compare.txt' WRITE(*,*) ' ' PAUSE STOP END INTEGER FUNCTION FGETCMD(CH) C===FGETCMD returns CH, the options string of the system C command used to invoke this program, and it's length, FGETCMD. C The system command itself is NOT returned as part of CH. C In this case there must be none, one or two options or C an error message is generated to the console. C C---Following USE is for CVF. USE DFLIB INTEGER*2 I,STATUS,NEXT CHARACTER*128 ARGSTR CHARACTER*(*) CH C---Digital Fortran and Microsoft Fortran F(X) have subprogram GETARG C which returns the command line with command name as first token. C To be compatible with the others this first token has to be removed C from the string CH before returning here. C---begin CVF/MFX code NEXT=0 STATUS=0 DO I=1,NARGS()-1 IF(I.GT.3) THEN WRITE(*,*) '$$COMPARE Error: To many Arguments.' FGETCMD=1 CH(1:1)='?' RETURN ENDIF CALL GETARG(I,ARGSTR,STATUS) CH(NEXT+1:NEXT+STATUS+1) = ARGSTR(1:STATUS)//' ' C WRITE(*,*)'I=',I,' STATUS=',STATUS C WRITE(*,*) ' ARGSTRING=>',ARGSTR(1:STATUS),'<' NEXT=NEXT+STATUS+1 END DO FGETCMD=NEXT-1 RETURN C----end CVF/MFX code C CDig no further action required. CLah CALL GETCL(CH) CSal CALL COMMAND_LINE(CH) CW77---WATCOM WATFOR77 FGETCMD works without code in this function. C Using Lah and Sal uncomment the following code and remove C above USE DFLIB and comment code between C---begin and C---end above. C C---Compute the command string length assuming C that the command itself is not part of CH. C DO I=LEN(CH),1,-1 C IF(CH(I:I) .NE. ' ') THEN C FGETCMD=I C RETURN C ENDIF C END DO C FGETCMD=0 C RETURN END SUBROUTINE GETFSIZ(FID,SIZE,UNITNO) C===Get file size of file with FILE=FID or Unit=UNITNO. C Code is set up for Compaq CVF C Lah - Lahey/Fujitsu LF95 C MSF - Microsoft Fortran F(X) C Sal - Salford FTN95 C INT - Intel Fortran For Linux C CVF USE DFLIB C INT USE IFPORT C MSF USE MSFLIB USE DFLIB CHARACTER*(*) FID INTEGER UNITNO, SIZE C---Compaq Fortran; same as Intel, same as MS Fortran requires following C 10 lines. USE xxLIB (must be just after SUBROUTINE statement). INTEGER*4 iresult, handle TYPE (FILE$INFO) info handle = FILE$FIRST iresult = GETFILEINFOQQ(FID,info,handle) if( iresult.NE.0 ) THEN SIZE=info.length ELSE SIZE=0 END IF CLah INQUIRE(FILE=FID,FLEN=SIZE) C CMSF Same as CVF code above with exceptions: C USE MSFLIB C iresult=GETFILEINFOQQ(FID,buffer,handle) C where buffer is a derived type file$info defined in C MSFLIB.F90 and handle is a status indicator. CSal Salford Fortran requires the following three lines. C INTEGER (KIND=3) SIZE C INTEGER (KIND=2) ERRCODE C CALL FILE_SIZE@(FID,SIZE,ERRCODE) RETURN END