PROGRAM EDRBLOCK
C
C EDR RECORD REBLOCKER
C
C     INCLUDE '($IODEF)'
      PARAMETER (LREC=512)
      LOGICAL*1 REC(LREC),TREC(20000)
      CHARACTER PROJID*3,RECLEN*4,TIM(2)*8,RUNDATE*9,DSN*50
      INTEGER*2 BLEN
C
C OPEN BINARY IBM BIT MAPPED EDR .  512 BYTE LENGTH RECORD EXPECTED.
C READ AS SPANNED RECORD WITH EBCIDC STRING 'MJS' DENOTING THE START
C OF RECORD.  WRITE REBLOCKED RECORDS.
C
      CALL DATE(RUNDATE)
      CALL TIME(TIM(1))
C
      WRITE(6,*) 
      WRITE(6,*) 'ENTER INPUT DSN'
      READ(5,'(A)') DSN
      OPEN(50,FILE=DSN,STATUS='OLD',FORM='UNFORMATTED',READONLY)
C
      WRITE(6,*) 
      WRITE(6,*) 'ENTER OUTPUT DSN'
      READ(5,'(A)') DSN
      OPEN(51,FILE=DSN,STATUS='NEW',FORM='UNFORMATTED',
     &     RECORDTYPE='VARIABLE',RECL=8191)
C
      WRITE(RECLEN,'(I4)') LREC
      WRITE(6,*) 
      IBYTE = 0
      NREC = 0
   10 CONTINUE
       READ(50,END=100,ERR=10) (REC(I),I=1,LREC)
C
C SEARCH INPUT RECORD FOR 'MJS' PROJECT ID STRING
C
       DO J = 1,LREC
C
C BUILD HOLDING ARRAY TREC
C
        TREC(IBYTE+J) = REC(J)   
        IF (IBYTE+J.GE.3) THEN
C        WRITE(PROJID,'(3A1)') (TREC(K),K=IBYTE+J-2,IBYTE+J)
C        ISTAT = LIB$TRA_EBC_ASC(PROJID,PROJID)
C
C WHEN STRING MJS IS ENCOUNTERED WRITE PRECEDING BYTES AS ONE RECORD
C AND REINITIALIZE BYTE COUNTER FOR TREC
C 
C        IF (PROJID.EQ.'MJS') THEN
C
C SEARCH FOR DECIMAL EQUIVALENT OF EBCDIC 'MJS'
C
         IF (ZEXT(TREC(IBYTE+J-2)).EQ.212.AND.
     &       ZEXT(TREC(IBYTE+J-1)).EQ.209.AND.
     &       ZEXT(TREC(IBYTE+J)).EQ.226) THEN
          BLEN = IBYTE + J - 3
          IF (BLEN.GT.3) THEN
           WRITE(51) (TREC(L),L=1,BLEN)
           NREC = NREC + 1
C          WRITE(6,*) NREC,BLEN
           IF (MOD(NREC,100).EQ.0) 
     &      WRITE(6,'(1X,I5.5,'' RECORDS WRITTEN'')') NREC
           TREC(1) = TREC(IBYTE+J-2)
           TREC(2) = TREC(IBYTE+J-1)
           TREC(3) = TREC(IBYTE+J)
           IBYTE = 3 - J
          END IF
         END IF
        END IF
       END DO
       IBYTE = IBYTE + LREC
      GOTO 10
  100 CONTINUE
C
C WRITE FINAL RECORD
C
      BLEN = IBYTE 
      IF (BLEN.GT.3) THEN
       WRITE(51) (TREC(L),L=1,BLEN)
       NREC = NREC + 1
C      WRITE(6,*) NREC,BLEN
      END IF
      WRITE(6,*)
      WRITE(6,'(1X,I5.5,'' TOTAL RECORDS WRITTEN'')') NREC
C
      CLOSE(50)
      CLOSE(51)
      CALL TIME(TIM(2))
      WRITE(6,*)
      WRITE(6,'(1X,''RUN DATE: '',A9)') RUNDATE
      WRITE(6,'(1X,''START CLOCK TIME:  '',A8)') TIM(1)
      WRITE(6,'(1X,''END CLOCK TIME:  '',A8)') TIM(2)
      WRITE(6,*)
      STOP
C
  800 FORMAT('RECLEN'A1)
C
      END