Google
 

Trailing-Edge - PDP-10 Archives - BB-H137B-BM - uetp/lib/uetcmp.for
There are 17 other files named uetcmp.for in the archive. Click here to see a list.
C	UETCMP.FOR		9/19/77
CTHIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
C  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
C
CCOPYRIGHT (C) 1977 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
C
C	WHEN LOADED, IT ASKS FOR A COMMAND, 'SEND' OR 'RECEIVE' OR
C	 'COMPARE'.
C
C	AFTER THE COMMAND, ON THE NEXT LINE, IT TAKES ONE OR MORE
C	INTEGER PARAMETERS, AS EXPLAINED HERE:
C
C	COMMAND			PARAMETER(S)
C	=======			============
C
C	SEND			AN INTEGER (N)
C				(READS COMM.TXT AND WRITES IT TO
C				DEVICE N)
C
C	RECEIVE			TWO INTEGERS (N,M)
C				(READS DEVICE N, LOGS THE DATA ONTO
C				DEVICE M)
C
C	COMPARE			COMPARES CONTENTS OF DEVICE N AND M.
C				PRINTS ERROR MESSAGES INTO COMM.ERR
C
C******RESTRICTION -- TRAILING BLANKS ARE DELETED FROM ALL LINES*****
C
C	EXIT			EXITS
C
C
	IMPLICIT INTEGER (A-Z)
C	IN1WRD AND IN2WRD ARE FILE NAMES FOR COMPARED FILES
	DOUBLE PRECISION IN1WRD,IN2WRD
	DIMENSION SEND(4),RECEIV(7),COMPAR(7),WORK1(132)
	DIMENSION WORK2(132),WORK3(132),EXIT(4)
C
	DATA (SEND(I),I=1,4)/'S','E','N','D'/
	DATA (RECEIV(I),I=1,7)/'R','E','C','E','I','V','E'/
	DATA (COMPAR(I),I=1,7)/'C','O','M','P','A','R','E'/
	DATA (EXIT(I),I=1,4)/'E','X','I','T'/
C
C	READ COMMAND AND IDENTIFY IT
90	WRITE(5,9002)
	READ(5,9000,END=12345) (WORK1(I),I=1,15)
	CALL SEARCH(SEND,4,WORK1,1,4,KSTART,KLAST,KFOUND)
	IF (KFOUND .EQ. 1) GOTO 100
	CALL SEARCH(RECEIV,7,WORK1,1,7,KSTART,KLAST,KFOUND)
	IF (KFOUND .EQ. 1) GOTO 200
	CALL SEARCH(COMPAR,7,WORK1,1,7,KSTART,KLAST,KFOUND)
	IF (KFOUND .EQ. 1) GOTO 300
	CALL SEARCH(EXIT,4,WORK1,1,4,KSTART,KLAST,KFOUND)
	IF (KFOUND .EQ. 1) STOP
C
C	IF NONE OF THESE, GIVE AN ERROR
	WRITE (5,9001)
	GOTO 90
C
C	THE COMMAND WAS 'SEND'.  NOW PROMPT FOR AND ACCEPT
C	 AN INTEGER TO BE TAKEN AS THE DEVICE NUMBER TO
C	 SEND TO.
100	WRITE(5,9003)
	READ(5,9004,ERR=19001) N
	OPEN (UNIT=20,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',
	1 	FILE='COMM.TXT')
	OPEN (UNIT=N,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')
101	READ(20,9005,END=19002) (WORK1(I),I=1,132)
C	LOCATE THE LAST NONBLANK READ IN.  WRITE OUT THE ARRAY
C	 FROM THE BEGINNING TO THAT POINT (MINUS ONE POSITION)
	K=132
	DO 102 I=1,132
		IF (WORK1(K) .NE. ' ') GOTO 103
		K=K-1
102	CONTINUE
103	WRITE(N,9005) (WORK1(I1),I1=1,K)
	GOTO 101
C
19002	CLOSE (UNIT=N,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')
	GOTO 90
C	USER TYPED IN SOMETHING OTHER THAN A 2 DIGIT INTEGER
19001	READ(5,9004)
	GOTO 100
C	COMMAND WAS 'RECEIVE' (FROM DEVICE N, LOGGING DATA RECEIVED
C	 ON DEVICE M)
C
C	FIRST PROMPT FOR N AND M.
C
200	WRITE (5,9006)
	READ (5,9004,ERR=29001) N
	WRITE (5,9007)
	READ (5,9004,ERR=29001) M
	OPEN (UNIT=N,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII')
	OPEN (UNIT=M,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')
201	READ(N,9005,END=29002) (WORK1(I),I=1,132)
C	LOCATE THE LAST NONBLANK READ IN.  WRITE OUT THE ARRAY
C	 FROM THE BEGINNING TO THAT POINT (MINUS ONE POSITION)
	K=132
	DO 202 I=1,132
		IF (WORK1(K) .NE. ' ') GOTO 203
		K=K-1
202	CONTINUE
203	WRITE(M,9005) (WORK1(I1),I1=1,K)
	GOTO 201
12345	WRITE(5,12346)
12346	FORMAT(' ?UNEXPECTED EOF IN COMMAND FILE')
	STOP
C
C	END OF INPUT FILE ENCOUNTERED
29002	CLOSE (UNIT=M,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')
	GOTO 90
C
C	ERROR IN INPUT OF INTEGER
C	SKIP THIS TTY RECORD AND GO BACK AND PROMPT AGAIN
29001	WRITE (5,9008)
	READ (5,9004)
	GOTO 200
C
C	COMPARE FILES N AND M.  SEND DISCREPANCIES TO FILE P.
300	NOMTCH = .FALSE.
	N=30
	M=31
	P=5
	WRITE (5,9020)
	READ (5,9019) IN1WRD
	WRITE (5,9021)
	READ (5,9019) IN2WRD
	OPEN (UNIT=N,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',FILE=IN1WRD)
	OPEN (UNIT=M,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',FILE=IN2WRD)
	WRITE (P,9017)
	COUNT=1
C
C	READ RECORD FROM FILE N AND LOCATE LAST NON-BLANK
301	READ(N,9005,END=39002) (WORK1(I),I=1,132)
C
C	LOCATE THE LAST NONBLANK READ IN.
	K=132
	DO 302 I=1,132
		IF (WORK1(K) .NE. ' ') GOTO 303
		K=K-1
302	CONTINUE
303	CONTINUE
C
C
C	READ RECORD FROM FILE M AND LOCATE LAST NON-BLANK
3010	READ(M,9005,END=39003) (WORK2(I),I=1,132)
C	LOCATE THE LAST NONBLANK READ IN.
	K1=132
	DO 3020 I=1,132
		IF (WORK2(K1) .NE. ' ') GOTO 3030
		K1=K1-1
3020	CONTINUE
3030	CONTINUE
C
C	NOW SEE IF THE LINES ARE EQUAL. (UPDATE LINE COUNT).
	COUNT=COUNT+1
	IF (K .NE. K1) GOTO 305
	CALL SEARCH(WORK1,K,WORK2,1,K,KSTART,KLAST,KFOUND)
	IF (KFOUND .NE. 1) GOTO 305
	GOTO 301
C
C	DATA DOES NOT MATCH UP.  SEND MESSAGE TO ERROR FILE P
C
305	WRITE (P,9015) N,COUNT,M,COUNT,WORK1,WORK2
	NOMTCH = .TRUE.
	GOTO 301
C
C	FILE N HAS ENDED. DO A READ ON FILE M TO SEE IF
C	 IT ALSO ENDS.  OTHERWISE FILES DON'T MATCH
39002	READ (M,9005,END=39005) (WORK2(I),I=1,132)
C
C	FALL-THROUGH MEANS FILE M IS LONGER
	WRITE (P,9016) COUNT,M,N,(WORK2(I),I=1,132)	
	NOMTCH = .TRUE.
	GOTO 310
C
C	FILE ENDED, AS EXPECTED -- NO ERROR TO REPORT.
39005	GOTO 310
C
C	FILE M ENDED BEFORE FILE N -- ERROR
39003	WRITE (P,9016) COUNT,N,M,(WORK1(I),I=1,132)
	NOMTCH = .TRUE.
	GOTO 310
C
C	INTEGER INPUT MISTYPED
39001	WRITE (5,9008)
	READ(5,9010)
	GOTO 300
C
C
310	IF (NOMTCH) WRITE (5,9012)
	IF (.NOT. NOMTCH) WRITE (5,9011)
	WRITE (P,9018)
	CLOSE (UNIT=P,DEVICE='DSK',MODE='ASCII')
	GOTO 90
C
9000	FORMAT (15A1)
9001	FORMAT (1H ,'%ILLEGAL COMMAND.  COMMANDS ARE:',/,
	1 1H ,'SEND   RECEIVE   COMPARE   EXIT')
9002	FORMAT (1H 'COMM>',$)
9003	FORMAT (1H ,' DEVICE NUMBER TO SEND TO (21-63): ',$)
9004	FORMAT (I2)	
9005	FORMAT (132A1)
9006	FORMAT (1H ,' DEVICE NUMBER TO RECEIVE FROM: ',$)
9007	FORMAT (1H ,' DEVICE NUMBER TO LOG DATA RECEIVED (21-63): ',$)
9008	FORMAT (1H '?INPUT TYPED INCORRECTLY.  SHOULD BE A TWO DIGIT
	1 INTEGER.')
9009	FORMAT(1H ,' DEVICE NUMBER OF FIRST FILE (21-63): ',$)
9010	FORMAT (1H ,' DEVICE NUMBER OF SECOND FILE (21-63): ',$)
9011	FORMAT (1H ,'FILES COMPARED -- EQUAL')
9012	FORMAT (1H ,'?FILES COMPARED -- NOT EQUAL')
9014	FORMAT (1H ,' DEVICE NUMBER OF ERROR LOG (21-63): '$)
9015	FORMAT (' ++++ 1ST LINE FROM FILE: ',I2,',  RECORD # ',I4,
	1';   2ND LINE FROM FILE: ',I2,',  RECORD # ',I4,T91,
	2'++++',/,
	2  1H ,132A1,/,1H ,132A1)
9016	FORMAT (' ++++	AFTER ',I4,' LINES,',T65,'++++',/,
	1' ++++	FILE:',I2,' IS LONGER THAN',T65,'++++',
	4/,' ++++	FILE:',I2,'.  WHAT FOLLOWS IS THE
	5',T65,'++++
	6',/,' ++++	FIRST EXTRA LINE:',T65,'++++',
	7/,1H 
	8,132A1)
9017	FORMAT(/,' 	 MESSAGE FROM PROGRAM UETCMP.FOR',T65)
9018	FORMAT(' 	END UETCMP.FOR  MESSAGE',T65,/)
9019	FORMAT(A10)
9020	FORMAT(' FILE NAME FOR CREATED FILE : '$)
9021	FORMAT(' FILE NAME OF ORIGINAL FILE : '$)
	END
C MOVE
C
C
C SUBROUTINE MOVES WORDS FROM FROM ONE ARRAY INTO ANOTHER.
C MAXIMUM MOVE OF 72 WORDS.
C
C	CALL MOVE(SOURCE,DEST,NCHAR)
C
	SUBROUTINE MOVE(SOURCE,DEST,NCHAR)
C
	INTEGER SOURCE(NCHAR),DEST(NCHAR),NCHAR

	DO 100 I=1,NCHAR,1
		DEST(I)=SOURCE(I)
100	CONTINUE
	RETURN
	END
C	SEARCH
C
C A SUBPROGRAM WHICH SEARCHES A STRING FOR A SUBSTRING.
C  CALLED AS FOLLOWS:
C
C CALL SEARCH (SUBSTR,LSUBST,AREA,ISTART,ILAST
C	,KSTART,KLAST,KFOUND)
C
C INPUTS:
C
C SUBSTR	AN ARRAY OF WORDS, WITH CHARACTERS
C		LEFT JUSTIFIED ONE PER WORD, CONTAINING
C		THE SUBSTRING TO SEARCH FOR
C
C LSUBST	SIZE OF SUBSTR IN WORDS ( AND THEREFORE
C		CHARACTERS)
C
C AREA		AN ARRAY OF SIMILAR FORMAT TO SUBSTR, 
C		CONTAINING THE STRING TO BE SEARCHED
C
C ISTART	POINTER INTO AREA -- FIRST CHARACTER TO
C		SEARCH
C
C ILAST		POINTER INTO AREA -- LAST CHARACTER TO 
C		SEARCH
C
C
C OUTPUTS:
C
C KSTART	POINTER INTO AREA -- START OF FOUND STRING
C
C KLAST		POINTER INTO AREA -- LAST CHARACTER OF
C		FOUND STRING
C
C KFOUND	=1	SEARCH WAS SUCCESSFUL
C		=0	SEARCH WAS UNSUCCESSFUL
C

	SUBROUTINE SEARCH (SUBSTR,LSUBST,AREA,ISTART,ILAST
	1,KSTART,KLAST,KFOUND)
C
	INTEGER AREA(132),SUBSTR(132),LSUBST,ISTART,ILAST,KSTART
	INTEGER KLAST,KFOUND
C
	LFOUND=0
	KFOUND=0
	DO 2000 I=ISTART,ILAST,1

C		COMPARE THE FIRST CHARACTER IN THE SUBSTRING WITH
C		THE CURRENT CHARACTER IN AREA.
C		IF SUCCESSFUL THIS IS A POSSIBLE PLACE TO
C		COMPARE FOR ENTIRE MATCH, SO CALL COMPAR.
		IX=I
		IF (SUBSTR(1).EQ.AREA(I)) 
	1		CALL COMPAR(SUBSTR,LSUBST,AREA,
	2		 IX,ILAST,KLAST,LFOUND)
		IF (LFOUND.EQ.1) GOTO 1000

C		IF NOT SUCCESSFUL, THE DO LOOP CYCLES AROUND TO DO
C		A COMAPRISON OF THE FIRST CHAR. IN SUBSTR
C		WITH ANOTHER IN "AREA".

2000	CONTINUE

C	IF LOOP FALLS THROUGH THE SEARCH WAS UNSUCCESSFUL.

	RETURN

C	SET UP A SUCCESSFUL RETURN

1000	KSTART=I
	KFOUND=LFOUND
	RETURN
	END
C
C COMPAR
C
C A SUBPROGRAM WHICH COMPARES TWO STRINGS AND RETURNS
C SUCCESS IF THEY AR EQUAL.  CALLLED AS FOLLOWS:
C
C CALL COMPAR (SUBSTR,LSUBST,AREA,I,ILAST,KLAST,LFOUND)
C
C PARAMETERS ARE AS DEFINED FOR SEARCH (ABOVE), PLUS:
C
C I		POINTER INTO AREA -- FIRST CHARACTER
C		TO SEARCH
C
C LFOUND	=1	COMPARISON WAS SUCCESSFUL
C		=0	COMPARISON WAS UNSUCCESSFUL
C
C INPUTS: SUBSTR,LSUBST,AREA,I
C OUTPUTS: KLAST, LFOUND

	SUBROUTINE COMPAR 	(SUBSTR,LSUBST,AREA,I,ILAST
	1			,KLAST,LFOUND)

	INTEGER AREA(132),SUBSTR(132),LSUBST,ILAST,KSTART
	INTEGER KLAST,LFOUND

	J1=1
4000	DO 1000 J=I,ILAST,1
		IF (SUBSTR(J1).NE.AREA(J)) GO TO 2000
		J1=J1+1
		IF (J1.GT.LSUBST) GO TO 3000
1000	CONTINUE

C	IF LOOP FALLS THROUGH, ALL CHARACTERS IN AREA MATCHED
C	 THOSE IN SUBSTR, BUT AREA RAN OUT FIRST, SO IT'S 
C	 NO MATCH.

2000	RETURN

C	SUCCESSFUL MATCH.  PREPARE FOR RETURN

3000	KLAST=J
	LFOUND=1
	RETURN

	END