FTN4,L,C,T        
      PROGRAM DSFC(3,99), SEARCHING FILE COMPARISON 6633  4-02-79 
C           --------------  U S E R   I N F O R M A T I O N  ---------- 
C                 
C    CALLING SEQUENCE:
C       RU,DSFC,WAS:SC:CT,IS:SC:CT,MESSAGES,COMPARES OUTPUT 
C    EXAMPLES:    
C       RU,DSFC,JVDWAS:1111:105,JVDIS:1111:105,12,6 
C       RU,DSFC,JVDA,JVDB,0G,0G 
C       RU,DSFC,JVDA,JVXX,12,12 
C                 
C  NOTE ---- PROGRAM MAY BE TERMINATED BY 'BREAK' 
C                 
C     ----------   UPDATING INFORMATION   ------------- 
C     INITIALS   DATE             ITEM
C       JVD      11/10/78    INPUT PARAMETERS ON 'TIME STAMP' LINE
C        "           "       REMOVE BIAS FROM COMPARE 
C        "           "       GIVE RECORD NUMBER ON EACH LINE
C       JVD       12/7/78    FIX E-O-F ROUTINES 
C        "       12/13/78    SCREEN PROMPTS WHILE RUNNING 
C        "           "       WRAP 'FILES USED' MESSAGE
C        "        2/23/79    READJUST PROMPT COUNT
C        "           "       ALLOW TYPE -2- FILES 
C        "       04/02/79    FIX END-OF-FILE BUG
C        "           "       SPEEDUP BY USING CB & MB 
C        "           "       CLARIFY DOCUMENTATION
C                 
C           ---- P R O G R A M M E R   I N F O R M A T I O N ---------
C                 
C    THE ARRAY SIZES CAN BE CHANGED BY SETTING THE VARIABLES 'C' & 'Y'
C         TO SOME VALUE 20 OR MORE.  AT THE SAME TIME, THE ARRAYS 
C         ARRAYA & ARRAYZ MUST BE SET TO (40*C) IN SIZE E.G. 40 X 20
C         WORDS LONG EACH IF ARRAY IS 20 LONG.
C         THE ARRAYS MUST BE THE SAME SIZE. 
C                 
C           ------   V A R I A B L E S   -------
C                 
C    VALUES ARE USUALLY INTEGERS REPRESENTING LINE NUMBERS. 
C    VARIABLES MUST USUALLY BE MULTIPLIED BY LINE LENGTH TO 
C        COMPUTE ARRAY ADDRESS. 
C                 
C  EOFA      END-OF-FILE SWITCH FOR FILEA 
C  EOFZ        "    "     "      "  FILEZ 
C  B         FLOATING POINTER RUNNING IN ARRAYA 
C  X            "        "      "     "  ARRAYZ 
C  C         END POINTER OF ARRAYA
C  Y          "      "   "  ARRAYZ
C  LA,LZ     LENGTH OF EACH ARRAY 
C  IA        CURRENT POINTER INTO ARRAYA
C  IZ          "       "      "   ARRAYZ
C  CRT       OUTPUT FILE (FROM RMPAR) 
C  NBEGA     POINTER TO FIRST POSITION OF SPECIFIC ARRAY LINE 
C  NBEGZ       "     "   "        "    "     "       "    " 
C  NENDA       "     "  LAST      "    "     "       "    " 
C  NENDZ       "     "   "        "    "     "       "    " 
C  I,J,K,L,M,N  ARE ALL AVAILABLE AT ALL TIMES FOR LOCAL MANIPULATION 
C  IGOOD     GOOD COMPARE POSITIONS IN A LINE.
C  IRET      DEBUGGING RETURN FROM ARRAY PRINTER
C  NRECA     RECORD COUNT OF 'A' FILE 
C  NRECZ       "      "   "  'Z' FILE 
C                 
C                 --------   S T O P S      ------- 
C  0000      END OF PROGRAM  NORMAL TERMINATION 
C  1234      LESS THAN AN ARRAY-FULL OF DATA ON SOURCE FILE.
C  2222      NO RETURN PROVIDED IN ARRAY PRINTOUT.
C   713      BUG - ATTEMPTING TO WRITE OUT MORE THAN A LINE 
C   770      SECOND ATTEMPT TO READ E-O-F 
C   772      READ ERROR 
C   773      OPEN FAILURE ON FILES
C   774      LENGTH OF INPUT RECORD GREATER THAN ALLOWED
C                 
C                 
      DIMENSION ARRAYA(2800),ARRAYZ(2800) 
      DIMENSION BUFA(81),BUFZ(81) 
      DIMENSION ITIME(5),IYEAR(1) 
      INTEGER CRT (5) 
      INTEGER A,B,C,X,Y,Z,ARRAYA,ARRAYZ,BUFA,BUFZ 
      INTEGER EOFA,EOFZ 
      INTEGER FILEA,FILEZ 
      INTEGER IDCBA(144)
      INTEGER IDCBZ(144)
      INTEGER NAMEAA(3) 
      INTEGER NAMEBB(3) 
      INTEGER SIZEAA(2) 
      INTEGER SIZEBB(2) 
      INTEGER CRNAA 
      INTEGER CRNBB 
      INTEGER SCODAA
      INTEGER SCODBB
      INTEGER LENAA 
      INTEGER LENBB 
      INTEGER CMPRAA(128) 
      INTEGER CMPRBB(128) 
      INTEGER PRSBUF(33)
      INTEGER IREG(2) 
      INTEGER HCOPY 
      INTEGER COUNT 
      INTEGER COMMA 
      INTEGER COLON 
      INTEGER PARAM(5)
      INTEGER NRECA 
      INTEGER NRECZ 
      INTEGER KNT 
      LOGICAL CB  
C                 
C     EQUIVALENCES
C                 
      EQUIVALENCE (IREG(1),REG) 
      EQUIVALENCE (IAREG,IREG(1)) 
      EQUIVALENCE (IBREG,IREG(2)) 
C                 
C     DATA        
C                 
      DATA COMMA /2H, / 
      DATA COLON /2H: / 
C     CRT = CRT YOU ARE ON AT THIS POINT
C                 
C  GET OUTPUT FILE DESIGNATION
C                 
C                 
C     GET STRING OF PARAMETERS
C                 
      CALL GETST(CMPRAA,-70,ILOG) 
C     WRITE (CRT,7005) ILOG, ILOG, (CMPRAA(I),I=1,40) 
 7005 FORMAT (" 7005(DSFC): ",K6,I8,5(/,8A2)) 
      IF (ILOG .GT. 0) GOTO 7010
C                 
      IERR=-1     
      GO TO 9999  
C                 
C     PARSE PARAMETER STRING
C                 
 7010 CALL PARSE(CMPRAA,ILOG,PRSBUF)
      IMESG=PRSBUF(10)
      CRT  =PRSBUF(14)
      CALL LURQ (1,CRT,1) 
C     WRITE (CRT,7006) (CMPRAA(I),I=1,40),ILOG,(PRSBUF(I),I=1,32) 
C    -,(PRSBUF(I),I=1,32),IMESG,CRT 
 7006 FORMAT (" 7006(DSFC): ",5(/,8A2),I6," PRSBUF",4(/,8A2),4(//,8K7), 
     -/," IMESG: ",I6,/," CRT  :  ",I6) 
C                 
C     PREPARE STRING FOR 2ND PARSE
C                 
      CALL CODE   
      READ (CMPRAA,7001)(CMPRBB(I),I=1,35)
 7001 FORMAT(A1)  
C                 
      COUNT=0     
C                 
      DO 7002 I=1,70
      IF(CMPRBB(I).EQ.COMMA) COUNT=COUNT+1
      IF(CMPRBB(I).EQ.COLON) CMPRBB(I)=COMMA
      IF(COUNT.EQ.2) GO TO 7003 
 7002 IAREG=I     
C                 
 7003 CALL CODE   
      WRITE(CMPRAA,7004)(CMPRBB(I),I=1,70)
 7004 FORMAT(A1)  
C                 
C                 
C     PARSE PARAMETER STRING AGAIN
C                 
      CALL PARSE (CMPRAA,IAREG,PRSBUF)
C     WRITE (CRT,7015) (CMPRAA(I),I=1,40),IAREG,(PRSBUF(I),I=1,32)
 7015 FORMAT (" 7015(DSFC): ",5(/,8A2)," IAREG: ", ,I6," PRSBUF: ",4(/,8A2))
     -8K7) )      
      IF(PRSBUF(1).EQ.2) GO TO 7020 
C                 
      IERR=-1     
      GO TO 9999  
C                 
 7020 IF(PRSBUF(5).NE.2) GO TO 7050 
C     IF BOTH THE SECURITY CODE & CARTRIDGE NUMBER FIELDS 
C     ARE MISSING FROMTHE 1ST. NAMR MOVE THE REMAINING
C     FIELDS IN PRSBUF TWO FIELDS BACK TO COMPENSATEING 
C                 
      DO 7030 I=24,13,-1
C                 
 7030 PRSBUF(I)=PRSBUF(I-8) 
      DO 7040 I=5,12
 7040 PRSBUF(I)=0 
C                 
 7050 IF(PRSBUF(9).NE.2) GO TO 7080 
C     IF CARTRIDGE NUMBER IS MISSING FROM THE 1ST. NAMR 
C     MOVE THE REMAINGING FIELDS ONE FIELD BACK TO COMPENSATE 
C                 
      DO 7060 I=24,13,-1
C                 
 7060 PRSBUF(I)=PRSBUF(I-4) 
C                 
      DO 7070 I=9,12
 7070 PRSBUF(I)=0 
C                 
C     SET FMG INFORMATION 
 7080 NAMEAA(1)=PRSBUF(2) 
      NAMEAA(2)=PRSBUF(3) 
      NAMEAA(3)=PRSBUF(4) 
         SCODAA=PRSBUF(6) 
          CRNAA=PRSBUF(10)
C                 
      IF(PRSBUF(13).EQ.2) GO TO 7090
C                 
      IERR=-1     
      GO TO 9999  
C                 
 7090 NAMEBB(1)=PRSBUF(14)
      NAMEBB(2)=PRSBUF(15)
      NAMEBB(3)=PRSBUF(16)
         SCODBB=PRSBUF(18)
          CRNBB=PRSBUF(22)
C     WRITE (CRT,7095) NAMEAA(1),NAMEAA(2),NAMEAA(3),SCODAA,CRNAA 
C     WRITE (CRT,7095) NAMEBB(1),NAMEBB(2),NAMEBB(3),SCODBB,CRNBB 
 7095 FORMAT (" 7095(DSFC): ",3A2,I6,I6)
C                 
C     OPEN FILES TO BE VERFIED FOR FMG OPERATIONS 
C                 
C                 
 7099 CALL EXEC (11,ITIME,IYEAR)
      WRITE (CRT,8) ITIME(5),ITIME(4),ITIME(3), 
     -NAMEAA(1),NAMEAA(2),NAMEAA(3),SCODAA,CRNAA, 
     -NAMEBB(1),NAMEBB(2),NAMEBB(3),SCODBB,CRNBB
    8 FORMAT ("1TIME STAMP ( DAY & HOUR ):   ",I3,3X,I3,":",I2, 
     -2(/,1X,3A2,I6,I6))
      WRITE (CRT,10)
   10 FORMAT (" DINKEY SEARCHING FILE COMPARE") 
      IA=1        
      IB=1        
      C=70        
      Y=70        
      KNT=1       
      IZ=1        
      CALL OPEN (IDCBA,IERR,NAMEAA,1,SCODAA,CRNAA,128)
      IF (IERR.EQ.4) GOTO 11
      IF (IERR.EQ.3) GOTO 11
      IF (IERR.EQ.2) GOTO 11
      GOTO 15     
   11 CALL OPEN (IDCBZ,IERR,NAMEBB,1,SCODBB,CRNBB,128)
      IF (IERR.EQ.4) GOTO 13
      IF (IERR.EQ.3) GOTO 13
      IF (IERR.EQ.2) GOTO 13
      GOTO 15     
   13 WRITE (IMESG,12)
   12 FORMAT (" FILES HAVE BEEN OPENED")
      GOTO 20     
   15 WRITE (IMESG,16) IERR,JVDA,JVDZ,FILEA,FILEZ 
   16 FORMAT (/," OPEN FAILURE ON FILES",7I6) 
      WRITE (IMESG,18)
   18 FORMAT (" STOP 773")
      GOTO 9000   
C---------------------------------------------------------- 
C  FILL AND PRINT INITIAL ARRAY VALUES FOR IDENTIFICATION PURPOSES. 
C                 
   20 IF (EOFA.GT.0) GOTO 38
      CALL READ (BUFA,EOFA,IDCBA,CRT) 
C     WRITE (CRT,22)
   22 FORMAT (" READ RETURNED @ 22 - ") 
      IF (EOFA.EQ.1) GOTO 30
      L=((IA*40)-40)
      DO 25 M = 1,40
      ARRAYA(L+M) = BUFA(M) 
   25 CONTINUE    
C     WRITE (CRT,27) L, EOFA, IA
C  27 FORMAT (" 27 (DSFC): L, EOFA, IA : ",3I6) 
C     WRITE (CRT,29)
C  29 FORMAT (" 29 (DSFC): PRINT RETURNED") 
C     WRITE (CRT,28)
C  28 FORMAT (" 28 (DSFC): CALL PRINT ARRAYA")
      IA=IA+1     
      IF (IA.GT.C) GOTO 26
      IF (IA.GT.21) GOTO 20 
      IB=IA-1     
      CALL PRINT (ARRAYA,IB,CRT)
      GOTO 20     
   26 WRITE (CRT,29)
   29 FORMAT (//," ^^^^^^^ 20 RECORDS FROM 'WAS' FILE ^^^^^^^^^^",/)
   30 IF (EOFZ.GT.0) GOTO 38
      CALL READ (BUFZ,EOFZ,IDCBZ,CRT) 
      IF (EOFZ.EQ.1) GOTO 40
      L = ((IZ*40)-40)
      DO 35 M= 1,40 
      ARRAYZ(L+M) = BUFZ(M) 
   35 CONTINUE    
C     WRITE (CRT,37)
C  37 FORMAT (" 37 (DSFC): CALL PRINT ARRAYZ")
      IZ=IZ+1     
      IF (IZ.GT.Y) GOTO 34
      IF (IZ.GT.21) GOTO 30 
      IY=IZ-1     
      CALL PRINT (ARRAYZ,IY,CRT)
      GOTO 30     
   34 WRITE (CRT,36)
   36 FORMAT (//," ^^^^^^^ 20 RECORDS FROM  'IS' FILE ^^^^^^^^^^",/)
      WRITE (CRT,41)
   41 FORMAT ("1")
      NRECA=1     
      NRECZ=1     
      GOTO 50     
   38 WRITE (IMESG,39)
   39 FORMAT ("  39 (DSFC): ATTEMPTING 2ND E-O-F ON FILE")
      GOTO 9000   
C                 
C   THERE IS LESS THAN ONE 'ARRAY-FULL' OF RECORDS - TERMINATE RUN
C                 
   40 WRITE (IMESG,45)
   45 FORMAT (/," LESS THAN AN 'ARRAY FULL' BEFORE EOF - RUN ABORTED")
      WRITE (IMESG,47)
   47 FORMAT (" STOP 1234") 
      GOTO 9000   
C                 
C   SEE IF THE FIRST REC IN EACH ARRAY IS EQUAL 
C      (WILL BE MOST OF THE TIME) 
C                 
C  50 WRITE (CRT,115) 
   50 CONTINUE    
  115 FORMAT (" 115 (DSFC): (1) TO (1) COMPARE")
      IF (IFBRK(IDMY)) 9050,117 
  117 IRET=116    
C     GOTO 9500   
  116 CONTINUE    
C   PRINT SCREEN PROMPTS TO TELL USER STILL WORKING 
      KNT=KNT+1   
      IF (KNT.NE.100*(KNT/100)) GOTO 119
      WRITE (IMESG,118) KNT 
  118 FORMAT (" WORKING ON REC: ",I5) 
  119 CONTINUE    
      IF (.NOT. CB (ARRAYA,ARRAYZ,40)) GOTO 200 
C                 
C   COMPARISON OF (1) TO (1) IS EQUAL.
C   MOVE CONTENTS OF EACH ARRAY DOWN 1 LINE FOR (C-1) 
C      LINES.  TERMINATE IF THESE WERE LAST RECORDS.
C                 
C 125 WRITE (CRT,126) 
  125 CONTINUE    
  126 FORMAT (" 126 (DSFC): (1) TO (1) EQUAL - MOVE DOWN")
      IF ((C+Y).EQ.2) GOTO 9000 
      CALL MB (ARRAYA(41),ARRAYA(1),(C-1)*40) 
      CALL MB (ARRAYZ(41),ARRAYZ(1),(Y-1)*40) 
C                 
C    NOW FILL IN THE LAST POSITION IN EACH ARRAY IF NOT E-O-F.
C                 
C     WRITE (CRT,135) 
  135 FORMAT (" 135 (DSFC): FILL IN LAST POSITION OF EACH ARRAY") 
      IRET=136    
C     GOTO 9500   
  136 CONTINUE    
      IF (EOFA.GT.0) GOTO 150 
      CALL READ (BUFA,EOFA,IDCBA,CRT) 
      IF (EOFA.GT.0) GOTO 150 
      NRECA=NRECA+1 
      CALL MB (BUFA(1),ARRAYA((C*40)-39),40)
      GOTO 160    
  150 C = C-1     
      IF (C.LT.1) GOTO 1000 
  160 IF (EOFZ.GT.0) GOTO 180 
      CALL READ (BUFZ,EOFZ,IDCBZ,CRT) 
      IF (EOFZ.GT.0) GOTO 180 
      NRECZ=NRECZ+1 
      CALL MB (BUFZ(1),ARRAYZ((Y*40)-39),40)
      GOTO 50     
  180 Y=Y-1       
      IF (Y.LT.1) GOTO 2000 
      GOTO 50     
C                 
C   COMPARISON FAILURE IN (1) VS (1). 
C       SEARCH EACH ARRAY FOR A MATCH IN EACH DIRECTION TO
C          AVOID MAKING A 'BIAS' TOWARDS EITHER ARRAY.  THEN
C          RESOLVE THE DIFFERENCE TOWARDS THE PAIR CLOSEST TO 
C          THE TOP OF THE ARRAY.
C                 
  200 DO 240 J = 1,C
      DO 230 K = 1,Y
      NBEGA = ((J*40)-39) 
      NENDA = (NBEGA +39) 
      NBEGZ = ((K*40) -39)
      NENDZ = (NBEGZ +39) 
      IF(CB(ARRAYA(NBEGA),ARRAYZ(NBEGZ),40)) GOTO 700 
  230 CONTINUE    
  240 CONTINUE    
      GOTO 244    
  700 DO 740 N=1,Y
      DO 730 M=1,C
      NBEGA = ((M*40)-39) 
      NENDA = (NBEGA +39) 
      NBEGZ = ((N*40) -39)
      NENDZ = (NBEGZ +39) 
      IF (CB(ARRAYA(NBEGA),ARRAYZ(NBEGZ),40)) GOTO 750
  730 CONTINUE    
  740 CONTINUE    
      STOP 22     
  750 IF ((IABS(J-K)).GT.(IABS(M-N))) GOTO 770
      GOTO 250    
  770 J=M         
      K=N         
      GOTO 250    
  244 IRET=245    
C     GOTO 9500   
  245 CONTINUE    
C     WRITE (CRT,248) 
  248 FORMAT (" 248 (DSFC): COMPLETE COMPARISON FAILURE") 
      IF ((C-1).LT.1) GOTO 1000 
      IF ((Y-1).LT.1) GOTO 2000 
      GOTO 250    
C                 
C   COMPARISON HAS BEEN FOUND (AT J,K)  - ARE INCREMENTS IDENTICAL? 
C                 
  250 IF (J.NE.K) GOTO 300
C                 
C  EVEN COMPARISON MATCH (BUT KNOWN BY PREVIOUS TEST
C    NOT TO BE (1) VS (1)).  OUTPUT EVEN RECORDS UNTIL THE
C    COMPARISONS ARE REACHED, MOVE DOWN AND REFILL THE ARRAYS.
C       (J HAS LINE NUMBER OF MATCHED COMPARISON IN IT.)
C                 
C 255 WRITE (CRT,259) 
C 255 CONTINUE    
  259 FORMAT (" 259 (DSTC): ENTERED EVEN COMPARISON") 
      DO 280 I=1,(J-1)
      NBEGA=((I*40)-39) 
      NENDA=NBEGA +39 
      IF ((NENDA-NBEGA).NE.39) GOTO 295 
      WRITE (CRT,260) NRECA,(ARRAYA(L),L=NBEGA,NENDA) 
      WRITE (CRT,270) NRECZ,(ARRAYZ(L),L=NBEGA,NENDA) 
  260 FORMAT (1X,I5,"  W A S ===   ",40A2)
  270 FORMAT (1X,I5,"    I S ===   ",40A2,//) 
      NRECA = NRECA +1
      NRECZ = NRECZ +1
  280 CONTINUE    
C     WRITE (CRT,290) 
  290 FORMAT (" 290 (DSFC): LEAVING EVEN COMPARISON FOR REFILL")
      GOTO 400    
  295 WRITE (IMESG,296) 
  296 FORMAT (" STOP 713")
      GOTO 9000   
C                 
C   UNEVEN COMPARISON.
C      EMPTY BUFFERS IN PARALLEL UNTIL NO CORRESPONDING RECORD
C      AT WHICH TIME START GENERATING 'NO CORRESPONDING RECORD' 
C      MESSAGES UNTIL SATISFIED. (J= ARRAYA, K=ARRAYZ COMPARISON POINTERS)
C                 
C 300 WRITE (CRT,310) 
  300 CONTINUE    
  310 FORMAT (" 310 (DSFC): ENTERING UNEVEN COMPARISON")
C    I= HIGHER COUNT OF J & K (-1 FOR LAST UNEQUAL) 
      IRET=314    
C     GOTO 9500   
  314 CONTINUE    
      I=J         
      IF (K.GT.J) I=K 
      M=I-1       
      DO 390 L=1,M
      IF (L.LE.(J-1)) GOTO 320
      WRITE (CRT,1020) NRECA
C1020 IS 'NO CORRESPONDING RECORD'
      GOTO 350    
  320 NBEGA = ((L*40)-39) 
      NENDA = NBEGA+39
      WRITE (CRT,340) NRECA,(ARRAYA(N),N=NBEGA,NENDA) 
  340 FORMAT (1X,I5,"  W A S ===   ",40A2)
      NRECA = NRECA +1
  350 IF (L.LE.(K-1)) GOTO 360
      WRITE (CRT,2020) NRECZ
      GOTO 390    
  360 NBEGZ = ((L*40)-39) 
      NENDZ = NBEGZ+39
      WRITE (CRT,380) NRECZ,(ARRAYZ(N),N=NBEGZ,NENDZ) 
  380 FORMAT (1X,I5,"    I S ===   ",40A2,//) 
      NRECZ = NRECZ +1
  390 CONTINUE    
C                 
C   THE UNEVEN COMPARISONS HAVE BEEN WRITTEN OUT. NOW 
C      THE EXISTING BUFFERS MUST BE MOVED DOWN AND
C      THE BALANCE OF THE ARRAYS REFILLED.
C           (J & K ARE ARRAY CURRENT EQUAL LINE POINTERS) 
C                 
C 400 WRITE (CRT,401) 
  400 CONTINUE    
  401 FORMAT (" 401 (DSFC): UNEVEN COMPARISON PUSH-DOWN.")
      IRET=410    
C     GOTO 9500   
  410 CONTINUE    
      IF (J.NE.1) CALL MB (ARRAYA(40*J-39),ARRAYA(1),(C-J+1)*40)
      IF (K.NE.1) CALL MB (ARRAYZ(40*K-39),ARRAYZ(1),(Y-K+1)*40)
      IRET=505    
C     GOTO 9500   
  505 CONTINUE    
C                 
C    FILL IN THE HOLES (UNEVEN) AT THE TOP OF THE ARRAY IN
C         EACH CASE.  J & K ARE STILL OLD COMPARE POSITIONS.
C                 
C 500 WRITE (CRT,501) 
  500 CONTINUE    
  501 FORMAT (" 501 (DSFC): BEGIN TO FILL IN UNEVEN HOLES") 
      IRET=508    
C     GOTO 9500   
  508 CONTINUE    
      IF ((J-1).EQ.0) GOTO 530
      DO 520  I=1, (J-1)
      IF (EOFA.GT.0) C=C-1
      IF (EOFA.GT.0) GOTO 520 
      CALL READ (BUFA,EOFA,IDCBA,CRT) 
      IF (EOFA.NE.0) C= C-1 
      IF (EOFA.NE.0) GOTO 520 
      CALL MB (BUFA(1),ARRAYA(((C-J+I+1)*40)-39),40)
  520 CONTINUE    
  530 CONTINUE    
  550 IF ((K-1).EQ.0) GOTO 580
      DO 570 I= 1, (K-1)
      IF (EOFZ.GT.0) Y=Y-1
      IF (EOFZ.GT.0) GOTO 570 
      CALL READ (BUFZ,EOFZ,IDCBZ,CRT) 
      IF (EOFZ.NE.0) Y= Y-1 
      IF (EOFZ.NE.0) GOTO 570 
      CALL MB (BUFZ(1),ARRAYZ(((Y-K+I+1)*40)-39),40)
  570 CONTINUE    
  580 CONTINUE    
      IF(C.LT.1) GOTO 1000
      IF(Y.LT.1) GOTO 2000
      IRET=595    
C     GOTO 9500   
  595 CONTINUE    
      GOTO 50     
C                 
C    END OF FILE ON FILEA 
C         (POSSIBLE EOF ON FILEZ ALSO)
C                 
C1000 WRITE (CRT,1002)
 1000 CONTINUE    
 1002 FORMAT (" 1002(DSFC):  EOF ON FILEA") 
      IRET=1004   
C     GOTO 9500   
 1004 CONTINUE    
C                 
C   CHECK THAT OTHER FILE IS EOF, IF SO END PROGRAM 
C                 
      IF (Y.LT.1) GOTO 9000 
C                 
C   WRITE OUT CONTENTS OF ARRAYZ (WITH NO 'CORRES' MESSAGE) 
C      FOLLOWED BY THE BALANCE OF THE FILEZ RECORDS THAT HAVE 
C      NOT YET BEEN READ IN.
C   TERMINATE PROGRAM AT END OF EITHER THE ARRAY DUMPING (IF NO 
C      MORE RECORDS) OR WHEN EOF IS ENCOUNTERED ON FILEZ. 
C                 
      DO 1040 I=1,Y 
      NBEGZ = ((I*40)-39) 
      NENDZ = NBEGZ +39 
      WRITE (CRT,1020) NRECA
      WRITE (CRT,1030) NRECZ,(ARRAYZ(K), K=NBEGZ,NENDZ) 
 1020 FORMAT (1X,I5,"  W A S ===   "," N O   C O R R E S P O N D I N G   R E C O R D ") 
     - R E C O R D ") 
 1030 FORMAT (1X,I5,"    I S ===   ",40A2,//) 
      NRECZ = NRECZ +1
 1040 CONTINUE    
C     END THE TAPE
      WRITE (CRT,1070)
 1070 FORMAT (1X,//," ----- THE FOLLOWING EXCEEDS THE LENGTH OF THE 'WAS
     -' FILE ----- ",//)
 1050 IF (EOFZ.GT.0) GOTO 9000
      CALL READ (BUFZ,EOFZ,IDCBZ,CRT) 
      IF (EOFZ.GT.0) GOTO 9000
      WRITE (CRT,1030) NRECZ,(BUFZ(K),K=1,40) 
      NRECZ = NRECZ +1
      IF (IFBRK(IDMY)) 9050,1050
C                 
C    END OF FILE ON FILEZ 
C       (POSSIBLE  EOF ON FILEA ALSO) 
C                 
C2000 WRITE (CRT,2001)
 2000 CONTINUE    
 2001 FORMAT (" 2001(DSFC): EOF ON FILEZ")
C                 
C    CHECK THAT FILE IS NOT ALSO EOF  IF SO END PROGRAM 
C                 
      IF (C.LT.1) GOTO 9000 
C                 
C   WRITE OUT CONTENTS OF ARRAYA (WITH NO CORRES MESSAGE) 
C     FOLLOWED BY THE BALANCE OF THE FILEA RECORDS THAT HAVE
C     NOT YET BEEN READ IN.  TERMINATE PROGRAM AT END OF EITHER 
C     THE ARRAY DUMPING (IF NO MORE RECORDS) OR WHEN EOF
C     IS ENCOUNTERED ON FILEA.
C                 
      DO 2040 I=1,C 
      NBEGA = ((I*40)-39) 
      NENDA = NBEGA + 39
      WRITE (CRT,2030) NRECA,(ARRAYA(K),K=1,40) 
      WRITE (CRT,2020) NRECZ
 2020 FORMAT (1X,I5,"    I S ===   "," N O    C O R R E S P O N D I N G    R E C O R D ",//)
     -   R E C O R D "//) 
 2030 FORMAT (1X,I5,"  W A S ===   ",40A2)
      NRECA = NRECA +1
 2040 CONTINUE    
C   END THE TAPE  
      WRITE (CRT,2070)
 2070 FORMAT (1X,//," ----- THE FOLLOWING EXCEEDS THE LENGTH OF THE 'IS'
     - FILE ----- ",//) 
 2050 IF (EOFA.GT.0) GOTO 9000
      CALL READ (BUFA,EOFA,IDCBA,CRT) 
      IF (EOFA.GT.0) GOTO 9000
      WRITE (CRT,2030) NRECA,(BUFA(K),K=NBEGA,NENDA)
      NRECA = NRECA +1
      IF (IFBRK(IDMY)) 9050,2050
 9000 WRITE (CRT,9010)
      WRITE (IMESG,9010)
 9010 FORMAT (" 9000(DSFC):  - - -  E N D    O F   P R O G R A M - - - "
     -,/,1H1,/,1H1) 
      CALL LURQ(0,CRT,1)
      IRET=9020   
C     GOTO 9500   
 9020 CONTINUE    
      CALL CLOSE (IDCBA)
      CALL CLOSE (IDCBZ)
      STOP 0000   
C                 
C     HANDLE 'BREAK' FROM CONSOLE 
C                 
 9050 WRITE (CRT,9060)
 9060 FORMAT (" 9060(DSFC) PROGRAM TERMINATED BY CONSOLE 'BREAK'")
      GOTO 9000   
C                 
C  ARRAY DUMP ROUTINE FOR DEBUGGING 
C                 
C9500 GOTO 9560   
 9500 CONTINUE    
 9502 WRITE (CRT,9542)
      WRITE (CRT,9510) I,J,K,L,M,N
 9510 FORMAT (//," I=",I4," J=",I4," K=",I4," L=",I4," M=",I4," N=",I4) 
 9514 WRITE (CRT,9516) X,Y,Z
 9516 FORMAT (" X=",I3," Y=",I3," Z=",I3) 
      WRITE (CRT,9520) NBEGA,NENDA,ICNTA,IA,EOFA
 9520 FORMAT (" NBEGA=",I4," NENDA=",I4," ICNTA=",I4," IA=",I4," EOFA=",I3) 
     -I3)         
      WRITE (CRT,9522) NBEGZ,NENDZ,ICNTZ,IZ,EOFZ
 9522 FORMAT (" NBEGZ=",I4," NENDZ=",I4," ICNTZ=",I4," IZ=",I4," EOFZ=",I3) 
     -I3)         
      WRITE (CRT,9524) ICOUNT,C,IRET,NRECA,NRECZ
 9524 FORMAT (" ICOUNT=",I3," C=",I3," IRET=",I3,"  NRECA=",I6,"  NRECZ=",I6) 
     -",I6)       
      WRITE (CRT,9530)
 9530 FORMAT ("0 =======    ARRAY A  ==================    ARRAY Z ==",//)
     -/)          
      NM=C        
      IF (NM.LT.Y) NM=Y 
      NM=5        
      DO 9550 NI=1,NM 
      NJ=(NI*40) -39
      NL=NJ+19    
      WRITE (CRT,9540) NI, (ARRAYA(NK),NK=NJ,NL),(ARRAYZ(NK),NK=NJ,NL)
 9540 FORMAT (1X,I2,5X,20A2,5X,20A2)
 9550 CONTINUE    
      WRITE (CRT,9542)
 9542 FORMAT (//," ============================================",//)
 9560 IF (IRET.EQ.116) GOTO 116 
      IF (IRET.EQ.9020) GOTO 9020 
      IF (IRET.EQ. 136) GOTO  136 
      IF (IRET.EQ. 245) GOTO  245 
      IF (IRET.EQ. 314) GOTO  314 
      IF (IRET.EQ. 410) GOTO  410 
      IF (IRET.EQ. 505) GOTO  505 
      IF (IRET.EQ. 508) GOTO  508 
      IF (IRET.EQ. 595) GOTO  595 
      IF (IRET.EQ.1004) GOTO 1004 
      WRITE (IMESG,9552)
 9552 FORMAT (" STOP 2222") 
      GOTO 9000   
 9999 WRITE (IMESG,9998)
 9998 FORMAT (" 9998(DSFC): FORMAT MUST BE:") 
      WRITE (IMESG,9997)
 9997 FORMAT (" RU,DSFC,FILE:SC:C,FILE:SC:C,MESSAGES,OUTPUT") 
      WRITE (IMESG,9996)
 9996 FORMAT (" RU,DSFC,JVDA:1111:105,JVDZ:1111:105,12,6")
      END         
C---------------------------------------------------------- 
C                 
C    READS A FILE AND MAKES THE 'EOF' = 1 IF EOF HAS BEEN ENCOUNTERED.
C        PROHIBITS A SECOND READ REQUEST FROM READING AFTER 'EOF'.
C                 
      SUBROUTINE READ (BUF,EOF,IDCB,CRT)
      DIMENSION BUF (81), IDCB (144)
      INTEGER BUF,EOF,CRT 
C     WRITE (CRT,2) EOF 
    2 FORMAT ("  2 (READ): READ ENTRY 'EOF' : ",I6) 
      IF (EOF.EQ.0) GOTO 10 
      CALL CLOSE (IDCB) 
      WRITE (CRT,5) 
    5 FORMAT (" SECOND ATTEMPT AT EOF") 
      STOP 770    
   10 DO 11 K = 1,81
      BUF (K) = 2H
   11 CONTINUE    
      CALL READF (IDCB,IERR,BUF,81,LEN) 
C     WRITE (CRT,50) IERR,LEN,(BUF(J), J=1,20)
   50 FORMAT ("  50 (READ):IERR, LEN, BUF : ",2I6,5X, 20A2) 
      IF (LEN.EQ.-1) EOF=1
      IF (IERR.NE.0) GOTO 100 
      IF (LEN.GT.80) GOTO 102 
      RETURN      
  100 WRITE (CRT,101) IERR
  101 FORMAT (/," READ ERROR - DID NOT RETURN '0'  ",I6)
      STOP 772    
  102 WRITE (CRT,103) 
  103 FORMAT (/," LENTH OF REC > 80 IN FILE") 
      STOP 774    
      END         
C---------------------------------------------------------
C     PRINT THE ARRAY ELEMENT NAMED FROM ARRAY A
C                 
      SUBROUTINE PRINT (ARRAYA,IA,CRT)
      INTEGER ARRAYA,CRT
      DIMENSION ARRAYA (800)
C     WRITE (CRT,1) IA
    1 FORMAT (" 1 (PRINT): ARRIVED IN 'PRINT' ROUTINE - IA = ",I6)
      IF (IA.LE.0) STOP 776 
      IB= ((IA*40)-39)
      IBB = IB+39 
      WRITE (CRT,20) (ARRAYA(I),I=IB,IBB) 
   20 FORMAT (2X,80A2)
C     WRITE (CRT, 30) 
   30 FORMAT (" 30 (PRINT): EXITING 'PRINT'") 
      RETURN      
      END         
      END$        
