Google
 

Trailing-Edge - PDP-10 Archives - KS10_APT_INSTALL_TAPE - uetp/lib/compar.for
There are 3 other files named compar.for in the archive. Click here to see a list.
C       UETCMP.FOR              9/19/77                                 MAIN0001
CTHIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED        MAIN0002
C  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.              MAIN0003
C                                                                       MAIN0004
CCOPYRIGHT (C) 1977 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.    MAIN0005
C                                                                       MAIN0006
C       WHEN LOADED, IT ASKS FOR A COMMAND, 'SEND' OR 'RECEIVE' OR      MAIN0007
C        'COMPARE'.                                                     MAIN0008
C                                                                       MAIN0009
C       AFTER THE COMMAND, ON THE NEXT LINE, IT TAKES ONE OR MORE       MAIN0010
C       INTEGER PARAMETERS, AS EXPLAINED HERE:                          MAIN0011
C                                                                       MAIN0012
C       COMMAND                 PARAMETER(S)                            MAIN0013
C       =======                 ============                            MAIN0014
C                                                                       MAIN0015
C       SEND                    AN INTEGER (N)                          MAIN0016
C                               (READS COMM.TXT AND WRITES IT TO        MAIN0017
C                               DEVICE N)                               MAIN0018
C                                                                       MAIN0019
C       RECEIVE                 TWO INTEGERS (N,M)                      MAIN0020
C                               (READS DEVICE N, LOGS THE DATA ONTO     MAIN0021
C                               DEVICE M)                               MAIN0022
C                                                                       MAIN0023
C       COMPARE                 COMPARES CONTENTS OF DEVICE N AND M.    MAIN0024
C                               PRINTS ERROR MESSAGES INTO COMM.ERR     MAIN0025
C                                                                       MAIN0026
C******RESTRICTION -- TRAILING BLANKS ARE DELETED FROM ALL LINES*****   MAIN0027
C                                                                       MAIN0028
C       EXIT                    EXITS                                   MAIN0029
C                                                                       MAIN0030
C                                                                       MAIN0031
      IMPLICIT INTEGER (A-Z)                                            MAIN0032
C       IN1WRD AND IN2WRD ARE FILE NAMES FOR COMPARED FILES             MAIN0033
      DOUBLE PRECISION IN1WRD,IN2WRD                                    MAIN0034
      DIMENSION SEND(4),RECEIV(7),COMPAR(7),WORK1(132)                  MAIN0035
      DIMENSION WORK2(132),WORK3(132),EXIT(4)                           MAIN0036
C                                                                       MAIN0037
      DATA (SEND(I),I=1,4)/'S','E','N','D'/                             MAIN0038
      DATA (RECEIV(I),I=1,7)/'R','E','C','E','I','V','E'/               MAIN0039
      DATA (COMPAR(I),I=1,7)/'C','O','M','P','A','R','E'/               MAIN0040
      DATA (EXIT(I),I=1,4)/'E','X','I','T'/                             MAIN0041
C                                                                       MAIN0042
C       READ COMMAND AND IDENTIFY IT                                    MAIN0043
   10 WRITE(5,310)                                                      MAIN0044
      READ(5,290,END=120) (WORK1(I),I=1,15)                             MAIN0045
      CALL SEARCH(SEND,4,WORK1,1,4,KSTART,KLAST,KFOUND)                 MAIN0046
      IF (KFOUND .EQ. 1)        GOTO 20                                 MAIN0047
      CALL SEARCH(RECEIV,7,WORK1,1,7,KSTART,KLAST,KFOUND)               MAIN0048
      IF (KFOUND .EQ. 1)        GOTO 80                                 MAIN0049
      CALL SEARCH(COMPAR,7,WORK1,1,7,KSTART,KLAST,KFOUND)               MAIN0050
      IF (KFOUND .EQ. 1)        GOTO 160                                MAIN0051
      CALL SEARCH(EXIT,4,WORK1,1,4,KSTART,KLAST,KFOUND)                 MAIN0052
      IF (KFOUND .EQ. 1)        STOP                                    MAIN0053
C                                                                       MAIN0054
C       IF NONE OF THESE, GIVE AN ERROR                                 MAIN0055
      WRITE (5,300)                                                     MAIN0056
      GOTO 10                                                           MAIN0057
C                                                                       MAIN0058
C       THE COMMAND WAS 'SEND'.  NOW PROMPT FOR AND ACCEPT              MAIN0059
C        AN INTEGER TO BE TAKEN AS THE DEVICE NUMBER TO                 MAIN0060
C        SEND TO.                                                       MAIN0061
   20 WRITE(5,320)                                                      MAIN0062
      READ(5,330,ERR=70) N                                              MAIN0063
      OPEN (UNIT=20,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',           MAIN0064
     1  FILE='COMM.TXT')                                                MAIN0065
      OPEN (UNIT=N,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')           MAIN0066
   30 READ(20,340,END=60) (WORK1(I),I=1,132)                            MAIN0067
C       LOCATE THE LAST NONBLANK READ IN.  WRITE OUT THE ARRAY          MAIN0068
C        FROM THE BEGINNING TO THAT POINT (MINUS ONE POSITION)          MAIN0069
      K=132                                                             MAIN0070
      DO 40 I=1,132                                                     MAIN0071
        IF (WORK1(K) .NE. ' ')        GOTO 50                           MAIN0072
        K=K-1                                                           MAIN0073
   40 CONTINUE                                                          MAIN0074
   50 WRITE(N,340) (WORK1(I1),I1=1,K)                                   MAIN0075
      GOTO 30                                                           MAIN0076
C                                                                       MAIN0077
   60 CLOSE (UNIT=N,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')          MAIN0078
      GOTO 10                                                           MAIN0079
C       USER TYPED IN SOMETHING OTHER THAN A 2 DIGIT INTEGER            MAIN0080
   70 READ(5,330)                                                       MAIN0081
      GOTO 20                                                           MAIN0082
C       COMMAND WAS 'RECEIVE' (FROM DEVICE N, LOGGING DATA RECEIVED     MAIN0083
C        ON DEVICE M)                                                   MAIN0084
C                                                                       MAIN0085
C       FIRST PROMPT FOR N AND M.                                       MAIN0086
C                                                                       MAIN0087
   80 WRITE (5,350)                                                     MAIN0088
      READ (5,330,ERR=150) N                                            MAIN0089
      WRITE (5,360)                                                     MAIN0090
      READ (5,330,ERR=150) M                                            MAIN0091
      OPEN (UNIT=N,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII')            MAIN0092
      OPEN (UNIT=M,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')           MAIN0093
   90 READ(N,340,END=140) (WORK1(I),I=1,132)                            MAIN0094
C       LOCATE THE LAST NONBLANK READ IN.  WRITE OUT THE ARRAY          MAIN0095
C        FROM THE BEGINNING TO THAT POINT (MINUS ONE POSITION)          MAIN0096
      K=132                                                             MAIN0097
      DO 100 I=1,132                                                    MAIN0098
        IF (WORK1(K) .NE. ' ')        GOTO 110                          MAIN0099
        K=K-1                                                           MAIN0100
  100 CONTINUE                                                          MAIN0101
  110 WRITE(M,340) (WORK1(I1),I1=1,K)                                   MAIN0102
      GOTO 90                                                           MAIN0103
  120 WRITE(5,130)                                                      MAIN0104
  130 FORMAT(' ?UNEXPECTED EOF IN COMMAND FILE')                        MAIN0105
      STOP                                                              MAIN0106
C                                                                       MAIN0107
C       END OF INPUT FILE ENCOUNTERED                                   MAIN0108
  140 CLOSE (UNIT=M,DEVICE='DSK',ACCESS='SEQOUT',MODE='ASCII')          MAIN0109
      GOTO 10                                                           MAIN0110
C                                                                       MAIN0111
C       ERROR IN INPUT OF INTEGER                                       MAIN0112
C       SKIP THIS TTY RECORD AND GO BACK AND PROMPT AGAIN               MAIN0113
  150 WRITE (5,370)                                                     MAIN0114
      READ (5,330)                                                      MAIN0115
      GOTO 80                                                           MAIN0116
C                                                                       MAIN0117
C       COMPARE FILES N AND M.  SEND DISCREPANCIES TO FILE P.           MAIN0118
  160 NOMTCH = .FALSE.                                                  MAIN0119
      N=30                                                              MAIN0120
      M=31                                                              MAIN0121
      P=5                                                               MAIN0122
      WRITE (5,480)                                                     MAIN0123
      READ (5,470) IN1WRD                                               MAIN0124
      WRITE (5,490)                                                     MAIN0125
      READ (5,470) IN2WRD                                               MAIN0126
      OPEN (UNIT=N,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',FILE=IN1WRD)MAIN0127
      OPEN (UNIT=M,DEVICE='DSK',ACCESS='SEQIN',MODE='ASCII',FILE=IN2WRD)MAIN0128
      WRITE (P,450)                                                     MAIN0129
      COUNT=1                                                           MAIN0130
C                                                                       MAIN0131
C       READ RECORD FROM FILE N AND LOCATE LAST NON-BLANK               MAIN0132
  170 READ(N,340,END=240) (WORK1(I),I=1,132)                            MAIN0133
C                                                                       MAIN0134
C       LOCATE THE LAST NONBLANK READ IN.                               MAIN0135
      K=132                                                             MAIN0136
      DO 180 I=1,132                                                    MAIN0137
        IF (WORK1(K) .NE. ' ')        GOTO 190                          MAIN0138
        K=K-1                                                           MAIN0139
  180 CONTINUE                                                          MAIN0140
  190 CONTINUE                                                          MAIN0141
C                                                                       MAIN0142
C                                                                       MAIN0143
C       READ RECORD FROM FILE M AND LOCATE LAST NON-BLANK               MAIN0144
  200 READ(M,340,END=260) (WORK2(I),I=1,132)                            MAIN0145
C       LOCATE THE LAST NONBLANK READ IN.                               MAIN0146
      K1=132                                                            MAIN0147
      DO 210 I=1,132                                                    MAIN0148
        IF (WORK2(K1) .NE. ' ')        GOTO 220                         MAIN0149
        K1=K1-1                                                         MAIN0150
  210 CONTINUE                                                          MAIN0151
  220 CONTINUE                                                          MAIN0152
C                                                                       MAIN0153
C       NOW SEE IF THE LINES ARE EQUAL. (UPDATE LINE COUNT).            MAIN0154
      COUNT=COUNT+1                                                     MAIN0155
      IF (K .NE. K1)        GOTO 230                                    MAIN0156
      CALL SEARCH(WORK1,K,WORK2,1,K,KSTART,KLAST,KFOUND)                MAIN0157
      IF (KFOUND .NE. 1)        GOTO 230                                MAIN0158
      GOTO 170                                                          MAIN0159
C                                                                       MAIN0160
C       DATA DOES NOT MATCH UP.  SEND MESSAGE TO ERROR FILE P           MAIN0161
C                                                                       MAIN0162
  230 WRITE (P,430) N,COUNT,M,COUNT,WORK1,WORK2                         MAIN0163
      NOMTCH = .TRUE.                                                   MAIN0164
      GOTO 170                                                          MAIN0165
C                                                                       MAIN0166
C       FILE N HAS ENDED. DO A READ ON FILE M TO SEE IF                 MAIN0167
C        IT ALSO ENDS.  OTHERWISE FILES DON'T MATCH                     MAIN0168
  240 READ (M,340,END=250) (WORK2(I),I=1,132)                           MAIN0169
C                                                                       MAIN0170
C       FALL-THROUGH MEANS FILE M IS LONGER                             MAIN0171
      WRITE (P,440) COUNT,M,N,(WORK2(I),I=1,132)                        MAIN0172
      NOMTCH = .TRUE.                                                   MAIN0173
      GOTO 280                                                          MAIN0174
C                                                                       MAIN0175
C       FILE ENDED, AS EXPECTED -- NO ERROR TO REPORT.                  MAIN0176
  250 GOTO 280                                                          MAIN0177
C                                                                       MAIN0178
C       FILE M ENDED BEFORE FILE N -- ERROR                             MAIN0179
  260 WRITE (P,440) COUNT,N,M,(WORK1(I),I=1,132)                        MAIN0180
      NOMTCH = .TRUE.                                                   MAIN0181
      GOTO 280                                                          MAIN0182
C                                                                       MAIN0183
C       INTEGER INPUT MISTYPED                                          MAIN0184
  270 WRITE (5,370)                                                     MAIN0185
      READ(5,390)                                                       MAIN0186
      GOTO 160                                                          MAIN0187
C                                                                       MAIN0188
C                                                                       MAIN0189
  280 IF (NOMTCH)        WRITE (5,410)                                  MAIN0190
      IF (.NOT. NOMTCH)        WRITE (5,400)                            MAIN0191
      WRITE (P,460)                                                     MAIN0192
      CLOSE (UNIT=P,DEVICE='DSK',MODE='ASCII')                          MAIN0193
      GOTO 10                                                           MAIN0194
C                                                                       MAIN0195
  290 FORMAT (15A1)                                                     MAIN0196
  300 FORMAT (1H ,'%ILLEGAL COMMAND.  COMMANDS ARE:',/,                 MAIN0197
     1 1H ,'SEND   RECEIVE   COMPARE   EXIT')                           MAIN0198
  310 FORMAT (1H 'COMM>',$)                                             MAIN0199
  320 FORMAT (1H ,' DEVICE NUMBER TO SEND TO (21-63): ',$)              MAIN0200
  330 FORMAT (I2)                                                       MAIN0201
  340 FORMAT (132A1)                                                    MAIN0202
  350 FORMAT (1H ,' DEVICE NUMBER TO RECEIVE FROM: ',$)                 MAIN0203
  360 FORMAT (1H ,' DEVICE NUMBER TO LOG DATA RECEIVED (21-63): ',$)    MAIN0204
  370 FORMAT (1H '?INPUT TYPED INCORRECTLY.  SHOULD BE A TWO DIGIT      MAIN0205
     1 INTEGER.')                                                       MAIN0206
  380 FORMAT(1H ,' DEVICE NUMBER OF FIRST FILE (21-63): ',$)            MAIN0207
  390 FORMAT (1H ,' DEVICE NUMBER OF SECOND FILE (21-63): ',$)          MAIN0208
  400 FORMAT (1H ,'FILES COMPARED -- EQUAL')                            MAIN0209
  410 FORMAT (1H ,'?FILES COMPARED -- NOT EQUAL')                       MAIN0210
  420 FORMAT (1H ,' DEVICE NUMBER OF ERROR LOG (21-63): '$)             MAIN0211
  430 FORMAT (' ++++ 1ST LINE FROM FILE: ',I2,',  RECORD # ',I4,        MAIN0212
     1';   2ND LINE FROM FILE: ',I2,',  RECORD # ',I4,T91,              MAIN0213
     2'++++',/,                                                         MAIN0214
     3  1H ,132A1,/,1H ,132A1)                                          MAIN0215
  440 FORMAT (' ++++    AFTER ',I4,' LINES,',T65,'++++',/,              MAIN0216
     1' ++++    FILE:',I2,' IS LONGER THAN',T65,'++++',                 MAIN0217
     2/,' ++++  FILE:',I2,'.  WHAT FOLLOWS IS THE                       MAIN0218
     3',T65,'++++                                                       MAIN0219
     4',/,' ++++        FIRST EXTRA LINE:',T65,'++++',                  MAIN0220
     5/,1H                                                              MAIN0221
     6,132A1)                                                           MAIN0222
  450 FORMAT(/,'         MESSAGE FROM PROGRAM UETCMP.FOR',T65)          MAIN0223
  460 FORMAT('  END UETCMP.FOR  MESSAGE',T65,/)                         MAIN0224
  470 FORMAT(A10)                                                       MAIN0225
  480 FORMAT(' FILE NAME FOR CREATED FILE : '$)                         MAIN0226
  490 FORMAT(' FILE NAME OF ORIGINAL FILE : '$)                         MAIN0227
      END                                                               MAIN0228
C MOVE                                                                  MOVE0001
C                                                                       MOVE0002
C                                                                       MOVE0003
C SUBROUTINE MOVES WORDS FROM FROM ONE ARRAY INTO ANOTHER.              MOVE0004
C MAXIMUM MOVE OF 72 WORDS.                                             MOVE0005
C                                                                       MOVE0006
C       CALL MOVE(SOURCE,DEST,NCHAR)                                    MOVE0007
C                                                                       MOVE0008
      SUBROUTINE MOVE(SOURCE,DEST,NCHAR)                                MOVE0009
C                                                                       MOVE0010
      INTEGER SOURCE(NCHAR),DEST(NCHAR),NCHAR                           MOVE0011
      DO 10 I=1,NCHAR,1                                                 MOVE0012
        DEST(I)=SOURCE(I)                                               MOVE0013
   10 CONTINUE                                                          MOVE0014
      RETURN                                                            MOVE0015
      END                                                               MOVE0016
C       SEARCH                                                          SRCH0001
C                                                                       SRCH0002
C A SUBPROGRAM WHICH SEARCHES A STRING FOR A SUBSTRING.                 SRCH0003
C  CALLED AS FOLLOWS:                                                   SRCH0004
C                                                                       SRCH0005
C CALL SEARCH (SUBSTR,LSUBST,AREA,ISTART,ILAST                          SRCH0006
C       ,KSTART,KLAST,KFOUND)                                           SRCH0007
C                                                                       SRCH0008
C INPUTS:                                                               SRCH0009
C                                                                       SRCH0010
C SUBSTR        AN ARRAY OF WORDS, WITH CHARACTERS                      SRCH0011
C               LEFT JUSTIFIED ONE PER WORD, CONTAINING                 SRCH0012
C               THE SUBSTRING TO SEARCH FOR                             SRCH0013
C                                                                       SRCH0014
C LSUBST        SIZE OF SUBSTR IN WORDS ( AND THEREFORE                 SRCH0015
C               CHARACTERS)                                             SRCH0016
C                                                                       SRCH0017
C AREA          AN ARRAY OF SIMILAR FORMAT TO SUBSTR,                   SRCH0018
C               CONTAINING THE STRING TO BE SEARCHED                    SRCH0019
C                                                                       SRCH0020
C ISTART        POINTER INTO AREA -- FIRST CHARACTER TO                 SRCH0021
C               SEARCH                                                  SRCH0022
C                                                                       SRCH0023
C ILAST         POINTER INTO AREA -- LAST CHARACTER TO                  SRCH0024
C               SEARCH                                                  SRCH0025
C                                                                       SRCH0026
C                                                                       SRCH0027
C OUTPUTS:                                                              SRCH0028
C                                                                       SRCH0029
C KSTART        POINTER INTO AREA -- START OF FOUND STRING              SRCH0030
C                                                                       SRCH0031
C KLAST         POINTER INTO AREA -- LAST CHARACTER OF                  SRCH0032
C               FOUND STRING                                            SRCH0033
C                                                                       SRCH0034
C KFOUND        =1      SEARCH WAS SUCCESSFUL                           SRCH0035
C               =0      SEARCH WAS UNSUCCESSFUL                         SRCH0036
C                                                                       SRCH0037
      SUBROUTINE SEARCH (SUBSTR,LSUBST,AREA,ISTART,ILAST                SRCH0038
     1,KSTART,KLAST,KFOUND)                                             SRCH0039
C                                                                       SRCH0040
      INTEGER AREA(132),SUBSTR(132),LSUBST,ISTART,ILAST,KSTART          SRCH0041
      INTEGER KLAST,KFOUND                                              SRCH0042
C                                                                       SRCH0043
      LFOUND=0                                                          SRCH0044
      KFOUND=0                                                          SRCH0045
      DO 10 I=ISTART,ILAST,1                                            SRCH0046
C               COMPARE THE FIRST CHARACTER IN THE SUBSTRING WITH       SRCH0047
C               THE CURRENT CHARACTER IN AREA.                          SRCH0048
C               IF SUCCESSFUL THIS IS A POSSIBLE PLACE TO               SRCH0049
C               COMPARE FOR ENTIRE MATCH, SO CALL COMPAR.               SRCH0050
        IX=I                                                            SRCH0051
        IF (SUBSTR(1).EQ.AREA(I))                                       SRCH0052
     1                                                                  SRCH0053
     2                                                                  SRCH0054
     3                                                                  SRCH0055
     4                                                                  SRCH0056
     5                                                          CALL COMSRCH0057
     6PAR(SUBSTR,LSUBST,AREA,                        IX,ILAST,KLAST,    SRCH0058
     7      LFOUND)                                                     SRCH0059
        IF (LFOUND.EQ.1)        GOTO 20                                 SRCH0060
C               IF NOT SUCCESSFUL, THE DO LOOP CYCLES AROUND TO DO      SRCH0061
C               A COMAPRISON OF THE FIRST CHAR. IN SUBSTR               SRCH0062
C               WITH ANOTHER IN "AREA".                                 SRCH0063
   10 CONTINUE                                                          SRCH0064
C       IF LOOP FALLS THROUGH THE SEARCH WAS UNSUCCESSFUL.              SRCH0065
      RETURN                                                            SRCH0066
C       SET UP A SUCCESSFUL RETURN                                      SRCH0067
   20 KSTART=I                                                          SRCH0068
      KFOUND=LFOUND                                                     SRCH0069
      RETURN                                                            SRCH0070
      END                                                               SRCH0071
C                                                                       CMPR0001
C COMPAR                                                                CMPR0002
C                                                                       CMPR0003
C A SUBPROGRAM WHICH COMPARES TWO STRINGS AND RETURNS                   CMPR0004
C SUCCESS IF THEY AR EQUAL.  CALLLED AS FOLLOWS:                        CMPR0005
C                                                                       CMPR0006
C CALL COMPAR (SUBSTR,LSUBST,AREA,I,ILAST,KLAST,LFOUND)                 CMPR0007
C                                                                       CMPR0008
C PARAMETERS ARE AS DEFINED FOR SEARCH (ABOVE), PLUS:                   CMPR0009
C                                                                       CMPR0010
C I             POINTER INTO AREA -- FIRST CHARACTER                    CMPR0011
C               TO SEARCH                                               CMPR0012
C                                                                       CMPR0013
C LFOUND        =1      COMPARISON WAS SUCCESSFUL                       CMPR0014
C               =0      COMPARISON WAS UNSUCCESSFUL                     CMPR0015
C                                                                       CMPR0016
C INPUTS: SUBSTR,LSUBST,AREA,I                                          CMPR0017
C OUTPUTS: KLAST, LFOUND                                                CMPR0018
      SUBROUTINE COMPAR (SUBSTR,LSUBST,AREA,I,ILAST,                    CMPR0019
     1KLAST,LFOUND)                                                     CMPR0020
      INTEGER AREA(132),SUBSTR(132),LSUBST,ILAST,KSTART                 CMPR0021
      INTEGER KLAST,LFOUND                                              CMPR0022
      J1=1                                                              CMPR0023
   10 DO 20 J=I,ILAST,1                                                 CMPR0024
        IF (SUBSTR(J1).NE.AREA(J))        GO TO 30                      CMPR0025
        J1=J1+1                                                         CMPR0026
        IF (J1.GT.LSUBST)        GO TO 40                               CMPR0027
   20 CONTINUE                                                          CMPR0028
C       IF LOOP FALLS THROUGH, ALL CHARACTERS IN AREA MATCHED           CMPR0029
C        THOSE IN SUBSTR, BUT AREA RAN OUT FIRST, SO IT'S               CMPR0030
C        NO MATCH.                                                      CMPR0031
   30 RETURN                                                            CMPR0032
C       SUCCESSFUL MATCH.  PREPARE FOR RETURN                           CMPR0033
   40 KLAST=J                                                           CMPR0034
      LFOUND=1                                                          CMPR0035
      RETURN                                                            CMPR0036
      END                                                               CMPR0037