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