INCLUDE '($FABDEF)'
      INCLUDE '($RMEDEF)'
      RECORD /FABDEF/ MYFAB
      INTEGER*4 LENGTH, STATUS, SYS$OPEN, SYS$CLOSE, SYS$MODIFY, BLKSIZ
      BYTE FILENAME(80)
      MYFAB.FAB$B_BID = FAB$C_BID
      MYFAB.FAB$B_BLN = FAB$C_BLN
      MYFAB.FAB$L_FNA = %LOC(FILENAME)
      MYFAB.FAB$B_FAC = FAB$M_PUT
      MYFAB.FAB$L_FOP = IOR(FAB$M_ESC,MYFAB.FAB$L_FOP)
      MYFAB.FAB$L_CTX = IOR(RME$C_SETRFM,MYFAB.FAB$L_CTX)
      MYFAB.FAB$W_IFI = 0
      TYPE *,'REBLOCK -- change block size of VMS binary files'
1     TYPE 5, 'New blocksize: '
5     FORMAT(1X,A,$)
      ACCEPT *, BLKSIZ
      IF(BLKSIZ .LT. 1 .OR.BLKSIZ .GT. 32767) THEN
        TYPE *,' Blocksize must be between 1 and 32767 inclusive.'
        GOTO 1
      ENDIF
      TYPE *, 'Enter filename(s) with Ctl-Z or blank line to terminate'
10    TYPE 5, 'Filename: '
      READ(5,20,END=999) LENGTH, (FILENAME(I), I = 1, LENGTH)
20    FORMAT(Q, 80A1)
      IF (LENGTH .EQ. 0) GO TO 999
      MYFAB.FAB$B_FNS = LENGTH
      STATUS = SYS$OPEN(MYFAB, %VAL(0),%VAL(0))
      IF (IAND(STATUS, 7) .NE. 1) TYPE *, ' OPEN ERROR. STATUS = ', status
      MYFAB.FAB$W_MRS = BLKSIZ
      STATUS = SYS$MODIFY(MYFAB, %VAL(0), %VAL(0))
      IF (IAND(STATUS, 7) .NE. 1) TYPE *, ' MODIFY ERROR. STATUS = ', status
      STATUS = SYS$CLOSE(MYFAB, %VAL(0), %VAL(0))
      IF (IAND(STATUS, 7) .NE. 1) TYPE *, ' CLOSE ERROR. STATUS = ', status
      GOTO 10
999   END