Trailing-Edge
-
PDP-10 Archives
-
BB-D867D-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