PROGRAM MAG * 12 Dec 83 - COMMAND_IS_MOUNT - Check new status 4 from TAPE_MOUNT * 27 Jan 84 - COMMAND_IS_SHOW - Completely rewrite * COMMAND_IS_SET - Remove SET FORMATTED, SET UNFORMATTED * MAG (main prog) - Make default tape name a qualifier * 28 Jan 84 - (various) - Implement SET RECORDSIZE VARYING option * 30 Jan 84 - CONVERT_TABS - Check for records too large to process * COMMAND_IS_HELP - Make help library location a qualifier * 15 Apr 84 - BYTE_SWAP - Simplify coding * WRITE_THE_FILE - Use library function DETAB to delete tabs * WRITE_THE_FILE - If line truncated, decrement its length * WRITE_THE_FILE - Allow BYTESWAP on writes * 2 Jan 85 - COMMAND_IS_MOUNT - Correct syntax checking; check new * status 6 from TAPE_MOUNT * OPEN_THE_TAPE - Check new status 6 from TAPE_OPEN, use * tape error recovery * WRITE_THE_FILE, READ_THE_FILE - Make these functions, set * up a condition handler * WRITE_LOCKED, CONDITION_HANDLER, CREATE_BUFFER, * TAPE_ERROR_RECOVERY, SYSTEM_MESSAGE - New routines * COMMAND_IS_WRITE - See if the tape is write locked * ERROR - Add new function codes 6, 7, and 8. * MAG (main prog), SET BLOCKSIZE, COMMAND_IS_READ, * READ_THE_FILE, COMMAND_IS_WRITE, WRITE_THE_FILE - * make buffer dynamically allocated (/BUFFER qualifier) * COMMAND_GET, CHECK_FOR_INDIRECT, COMMAND_IS_READ, * UNPACK_BUFFER, OPEN_FILE_READ, WRITE_THE_FILE, * ERROR - improve error type 2 diagnostics--print the VMS * message for the error. * UNPACK_BUFFER - Handle zero-length lines correctly. * 13 Jan 86 - Use CLI facility to parse directives; this caused changes * throughout the program. * WRITE_THE_FILE, READ_THE_FILE, CONTROL_Y_HANDLER, * COMMAND_PROCESS - add control-y handling. * COMMAND_IS_MOUNT - add /NOWRITE option. * COMMAND_IS_DISMOUNT - add /NOUNLOAD option. * TAPE_END_OF_REEL, TAPE_READ - VMS V4 does not signal end- * of-reels on reads, so check device status on end-of- * files to see if past end-of-reel. Also write an end- * of-file when end-of-reel hit on write. * TAPE_END_OF_REEL - do not handle CTRL\Y during reel switch. * IMPLICIT INTEGER (A-Z) CHARACTER*64 INPUT_FILE,OUTPUT_FILE CHARACTER*128 HELP_LOC CHARACTER*8 VERSION,SGS_VERSION LOGICAL BATCH_MODE,INTERACTIVE_INPUT LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 EXTERNAL CONTROL_B COMMON /HELP/ HELP_LOC,HL_LEN,VERSION COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN DATA INPUT_FILE / 'SYS$INPUT:' / DATA EXIT_STAT,ECHO6,WRITE6,WRITE7 1 / 1,.FALSE.,.TRUE.,.FALSE. / sgs_version = '3.0' VERSION = 'MAG V' // SGS_VERSION INTERACT = INTERACTIVE_INPUT() IF (INTERACT) CALL CONTROL('B',CONTROL_B) IF (CLI$PRESENT('LISTING')) THEN CALL CLI$GET_VALUE('LISTING',OUTPUT_FILE) WRITE7 = .TRUE. OPEN (7,FILE=OUTPUT_FILE,STATUS='NEW',DEFAULTFILE='.LIS') CALL DATE(OUTPUT_FILE(1:11)) CALL TIME(OUTPUT_FILE(12:20)) WRITE (7,1001) OUTPUT_FILE(1:20) CALL DISPLAY_NAME(7,'LISTING IS TO') WRITE (7,1000) ENDIF WRITE (6,1000) IF (CLI$PRESENT('INPUT')) THEN CALL CLI$GET_VALUE('INPUT',INPUT_FILE) INTERACT = .FALSE. ECHO6 = .TRUE. OPEN (5,FILE=INPUT_FILE,STATUS='OLD',DEFAULTFILE='.INP', 1 READONLY) CALL DISPLAY_NAME(5,'INPUT IS FROM') ENDIF IF (BATCH_MODE()) THEN ECHO6 = .TRUE. WRITE6 = .FALSE. ENDIF IF (.NOT.INTERACTIVE_INPUT()) ECHO6 = .TRUE. CALL CLI$GET_VALUE('TAPE',TAPE_NAME) TN_LEN = STR_LEN(TAPE_NAME) CALL CREATE_BUFFER CALL CLI$GET_VALUE('HELP',HELP_LOC,HL_LEN) CALL COMMAND_PROCESS 1000 FORMAT (' ') 1001 FORMAT ('1NSWC MAG TAPE UTILITY ',A) END SUBROUTINE DISPLAY_NAME(UNIT,TEXT) IMPLICIT INTEGER (A-Z) CHARACTER*(*) TEXT CHARACTER*128 NAME LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 INQUIRE (UNIT,NAME=NAME) NAMELEN = STR_LEN(NAME) WRITE (6,1000) TEXT,NAME(1:NAMELEN) IF (WRITE7) WRITE (7,1000) TEXT,NAME(1:NAMELEN) 1000 FORMAT ('0',A,' ',A) END SUBROUTINE CREATE_BUFFER * We let VMS allocate space for our tape block buffer, then we * create a dummy Character String Descriptor DESCR pointing to * the allocated space. When DESCR is used as an actual argument * to a subprogram, and the corresponding formal parameter is of * type CHARACTER, this works great. IMPLICIT INTEGER (A-Z) COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) STATUS = CLI_INT( 'BUFFER' , BUFFER_SIZE ) IF (.NOT.STATUS .OR. 1 BUFFER_SIZE.LT.1024 .OR. BUFFER_SIZE.GT.65535) 2 CALL ERROR(0,'INVALID /BUFFER QUALIFIER') STATUS = LIB$GET_VM( BUFFER_SIZE , DESCR(2) ) IF (.NOT.STATUS) 1 CALL ERROR(0,'COULD NOT ALLOCATE MEMORY FOR BUFFER') DESCR(1) = BUFFER_SIZE END SUBROUTINE COMMAND_PROCESS IMPLICIT INTEGER (A-Z) CHARACTER*128 COMMAND_LINE LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /COMMAND1/ LINE_LEN,COMMAND_LINE EXTERNAL MAG_DIRECTIVES 10 IF (INTERACT) CALL CONTROL_Y() CALL COMMAND_GET STATUS = CLI$DCL_PARSE(COMMAND_LINE(1:LINE_LEN),MAG_DIRECTIVES) IF (.NOT.STATUS) THEN IF (INTERACT) GO TO 10 EXIT_STAT = '10000004'X CALL COMMAND_IS_EXIT ENDIF CALL CLI$DISPATCH GO TO 10 END SUBROUTINE COMMAND_GET IMPLICIT INTEGER (A-Z) CHARACTER*128 COMMAND_LINE LOGICAL INDIRECT_FILE LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /COMMAND1/ LINE_LEN,COMMAND_LINE COMMON /INDIRECT/ INDIRECT_FILE IF (INDIRECT_FILE) THEN CALL GET_NEXT_INDIRECT(&10,&100) RETURN ENDIF 10 WRITE (6,1000) READ (5,1001,END=200,ERR=100) LINE_LEN,COMMAND_LINE IF (ECHO6) WRITE (6,1002) COMMAND_LINE(1:LINE_LEN) IF (WRITE7) WRITE (7,1003) COMMAND_LINE(1:LINE_LEN) CALL COMMAND_COMPRESS(*10,*100) RETURN 100 CALL ERROR(2,'ERROR READING COMMAND LINE') 200 CALL COMMAND_IS_EXIT 1000 FORMAT ('$MAG> ') 1001 FORMAT (Q,A) 1002 FORMAT ('+ ',A) 1003 FORMAT (' MAG> ',A) END SUBROUTINE COMMAND_COMPRESS(*,*) IMPLICIT INTEGER (A-Z) CHARACTER*128 COMMAND_LINE CHARACTER*1 CCHAR CHARACTER*2 CCHAR2 COMMON /COMMAND1/ LINE_LEN,COMMAND_LINE IF (LINE_LEN.EQ.0) RETURN 1 * Strip off comment field, if any. COMMENT_COL = INDEX(COMMAND_LINE(1:LINE_LEN),'!') IF (COMMENT_COL.NE.0) THEN LINE_LEN = COMMENT_COL-1 IF (LINE_LEN.EQ.0) RETURN 1 ENDIF * Check to see if the line actually contains a command. DO I=1,LINE_LEN CCHAR = COMMAND_LINE(I:I) IF (CCHAR.NE.' ' .AND. CCHAR.NE.CHAR(9)) GO TO 10 ENDDO RETURN 1 * Translate any DCL symbols in single quotes. 10 COMMAND_LINE(LINE_LEN+1:) = ' ' STATUS = SYMBOL_SUBSTITUTE(COMMAND_LINE,LINE_LEN) IF (.NOT.STATUS) RETURN 2 CCHAR2 = COMMAND_LINE(I:I+1) * Allow READ directive to be abbreviated to one character by * using the synonymous GET directive. IF (CCHAR2.EQ.'R ' .OR. CCHAR2.EQ.'r ') COMMAND_LINE(I:I) = 'G' END SUBROUTINE CHECK_FOR_INDIRECT(*) IMPLICIT INTEGER (A-Z) CHARACTER*128 COMMAND_LINE CHARACTER*64 INDIRECT_FILE_NAME CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL INDIRECT_FILE,EXISTS LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /INDIRECT/ INDIRECT_FILE COMMON /COMMAND1/ LINE_LEN,COMMAND_LINE COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME DATA INDIRECT_FILE / .FALSE. / OPEN (19,FILE=FILE_NAME(2:),STATUS='OLD',READONLY, 1 DEFAULTFILE=DEFAULT_NAME,ERR=100) WRITE (6,1002) IF (WRITE7) WRITE (7,1002) CALL CLI$GET_VALUE('$VERB',COMMAND_LINE) COMMAND_LINE(2:2) = ' ' INDIRECT_FILE = .TRUE. RETURN 100 CALL ERROR(2,'ERROR OPENING INDIRECT FILE') RETURN 1 ENTRY GET_NEXT_INDIRECT(*,*) 10 READ (19,1000,END=200,ERR=300) LINE_LEN,COMMAND_LINE(3:128) WRITE (6,1001) COMMAND_LINE(3:LINE_LEN+2) IF (WRITE7) WRITE (7,1001) COMMAND_LINE(3:LINE_LEN+2) IF (COMMAND_LINE(3:3).EQ.'!') GO TO 10 NAME_END = INDEX(COMMAND_LINE(3:128),' ') IF (NAME_END.GT.0) LINE_LEN = NAME_END - 1 LINE_LEN = LINE_LEN + 2 CALL COMMAND_COMPRESS INDIRECT_FILE = .TRUE. RETURN 200 CLOSE (19) INDIRECT_FILE = .FALSE. RETURN 1 300 CLOSE (19,ERR=310) INDIRECT_FILE = .FALSE. 310 RETURN 2 1000 FORMAT (Q,A) 1001 FORMAT (' indirect> ',A) 1002 FORMAT (' ') END INTEGER FUNCTION NUMERIC_VALUE(STRING) IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING STATUS = OTS$CVT_TI_L(STRING,NUMERIC_VALUE) IF ((.NOT.STATUS) .OR. (NUMERIC_VALUE.LT.0)) THEN NUMERIC_VALUE = 0 ENDIF END SUBROUTINE COMMAND_IS_EXIT IMPLICIT INTEGER (A-Z) LOGICAL TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /MAG_2/ TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN EXTERNAL CONDITION_HANDLER DATA TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN / 3*.FALSE. / CALL LIB$ESTABLISH(CONDITION_HANDLER) IF (TAPE_WAS_WRITTEN) THEN CALL TAPE_WRITE_TRAILER ELSE IF (TAPE_IS_OPEN) THEN CALL TAPE_REWIND ENDIF WRITE (6,1000) CALL EXIT(EXIT_STAT) ENTRY COMMAND_IS_REWIND CALL LIB$ESTABLISH(CONDITION_HANDLER) IF (TAPE_WAS_WRITTEN) THEN CALL TAPE_WRITE_TRAILER TAPE_WAS_WRITTEN = .FALSE. ELSE IF (.NOT.TAPE_IS_OPEN) CALL OPEN_THE_TAPE(&300) CALL TAPE_REWIND TAPE_WAS_READ = .FALSE. ENDIF TAPE_IS_OPEN = .FALSE. 300 RETURN 1000 FORMAT (' ') END SUBROUTINE COMMAND_IS_HELP IMPLICIT INTEGER (A-Z) CHARACTER*128 COMMAND_LINE,HELP_LOC CHARACTER*128 OPTIONS,WORK CHARACTER*8 VERSION LOGICAL INTERACT,ECHO6,WRITE6,WRITE7,CLI$PRESENT REAL*8 DESC1,DESC2 COMMON /COMMAND1/ LINE_LEN,COMMAND_LINE COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /HELP/ HELP_LOC,HL_LEN,VERSION COMMON /WORK/ OPT,IOPT,WORK INTEGER*4 ARGLIST(7) / 6,6*0 / LOGICAL FIRST_CALL / .TRUE. / EXTERNAL LIB$PUT_OUTPUT,LIB$GET_INPUT IF (.NOT.INTERACT) RETURN IF (FIRST_CALL) THEN FIRST_CALL = .FALSE. STATUS = LIB$FIND_IMAGE_SYMBOL('LBRSHR','LBR$OUTPUT_HELP', 1 LBR$OUTPUT_HELP) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) ARGLIST(2) = %LOC(LIB$PUT_OUTPUT) ARGLIST(5) = DESCRIPTOR(HELP_LOC(1:HL_LEN),DESC1) ARGLIST(7) = %LOC(LIB$GET_INPUT) ENDIF IF (.NOT.CLI$PRESENT('P1')) THEN ARGLIST(4) = DESCRIPTOR('MAG',DESC2) ELSE CALL CLI$GET_VALUE('P1',COMMAND_LINE,LINE_LEN) WORK(1:LINE_LEN+4) = 'MAG ' // COMMAND_LINE(1:LINE_LEN) ARGLIST(4) = DESCRIPTOR(WORK(1:LINE_LEN+4),DESC2) ENDIF STATUS = LIB$CALLG(ARGLIST,%VAL(LBR$OUTPUT_HELP)) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) WRITE (6,1000) 1000 FORMAT (' ') END SUBROUTINE SET_MISC IMPLICIT INTEGER (A-Z) CHARACTER*16 VALUE CHARACTER*10 NOTR / 'NOTRUNCATE' / CHARACTER*8 NOSP / 'NOSPACES' / CHARACTER*10 NOBY / 'NOBYTESWAP' / CHARACTER*5 ASCI / 'ASCII' / CHARACTER*6 EBCD / 'EBCDIC' / LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE DATA TRUNCATE,BYTESWAP,ASCII,COLUMNS,MAXLINE 1 / .TRUE.,.FALSE.,.TRUE.,0,0,9999999 / CALL CLI$GET_VALUE('P1',VALUE,VLEN) IF (VALUE(1:VLEN).EQ.NOTR(3:VLEN+2)) THEN TRUNCATE = .TRUE. ELSE IF (VALUE(1:VLEN).EQ.NOTR(1:VLEN)) THEN TRUNCATE = .FALSE. ELSE IF (VALUE(1:VLEN).EQ.ASCI(1:VLEN)) THEN ASCII = .TRUE. ELSE IF (VALUE(1:VLEN).EQ.EBCD(1:VLEN)) THEN ASCII = .FALSE. ELSE IF (VALUE(1:VLEN).EQ.NOBY(3:VLEN+2)) THEN BYTESWAP = .TRUE. ELSE IF (VALUE(1:VLEN).EQ.NOBY(1:VLEN)) THEN BYTESWAP = .FALSE. ELSE IF (VALUE(1:VLEN).EQ.NOSP(3:VLEN+2)) THEN TABCVT = .TRUE. ELSE IF (VALUE(1:VLEN).EQ.NOSP(1:VLEN)) THEN TABCVT = .FALSE. ENDIF END SUBROUTINE SET_BLOCKSIZE IMPLICIT INTEGER (A-Z) PARAMETER (default_block = 1280) CHARACTER*16 VALUE COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) DATA BLOCK_SIZE / default_block / CALL CLI$GET_VALUE('P2',VALUE,VLEN) BLOCK_SIZE = NUMERIC_VALUE(VALUE(1:VLEN)) IF (BLOCK_SIZE.LE.0) THEN BLOCK_SIZE = default_block CALL ERROR(1,'BLOCKSIZE CANNOT BE ZERO, SET TO ', 1 default_block,WARN) ELSEIF (BLOCK_SIZE.GT.BUFFER_SIZE) THEN BLOCK_SIZE = default_block CALL ERROR(1,'BLOCKSIZE TOO LARGE, SET TO ',default_block, 1 WARN) ENDIF END SUBROUTINE SET_RECORDSIZE IMPLICIT INTEGER (A-Z) PARAMETER (default_record = 80) CHARACTER*16 VALUE CHARACTER*8 VARYING / 'VARYING ' / COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE DATA RECORD_SIZE / default_record / CALL CLI$GET_VALUE('P2',VALUE,VLEN) IF (VALUE(1:VLEN).EQ.VARYING(1:VLEN)) THEN RECORD_SIZE = 0 RETURN ! SET RECORDSIZE VARYING ENDIF RECORD_SIZE = NUMERIC_VALUE(VALUE(1:VLEN)) IF (RECORD_SIZE.LE.0) THEN RECORD_SIZE = default_record CALL ERROR(1,'RECORDSIZE CANNOT BE ZERO, SET TO ', 1 default_block,WARN) ENDIF END SUBROUTINE SET_COLUMNS IMPLICIT INTEGER (A-Z) CHARACTER*16 VALUE LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT,CLI$PRESENT COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE IF (.NOT.CLI$PRESENT('P2')) GO TO 300 IF (.NOT.CLI$PRESENT('P3')) THEN CALL ERROR(0,'INVALID COLUMNS SPECIFICATION') GO TO 300 ENDIF CALL CLI$GET_VALUE('P2',VALUE,VLEN) COLUMNS(1) = NUMERIC_VALUE(VALUE(1:VLEN)) CALL CLI$GET_VALUE('P3',VALUE,VLEN) COLUMNS(2) = NUMERIC_VALUE(VALUE(1:VLEN)) RETURN 300 COLUMNS(1) = 0 COLUMNS(2) = 0 END SUBROUTINE SET_LINES IMPLICIT INTEGER (A-Z) CHARACTER*16 VALUE LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT,CLI$PRESENT COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE IF (CLI$PRESENT('P2')) THEN CALL CLI$GET_VALUE('P2',VALUE,VLEN) MAXLINE = NUMERIC_VALUE(VALUE(1:VLEN)) IF (MAXLINE.GT.0) RETURN ENDIF 300 MAXLINE = 9999999 END SUBROUTINE SET_DEFAULT IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL CLI$PRESENT COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN DATA DEFAULT_NAME,DN_LEN / ' ',0 / IF (.NOT.CLI$PRESENT('P2')) THEN DN_LEN = 0 ELSE CALL CLI$GET_VALUE('P2',DEFAULT_NAME,DN_LEN) ENDIF END SUBROUTINE SET_MAGTAPE IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN CALL CLI$GET_VALUE('P2',TAPE_NAME,TN_LEN) END SUBROUTINE COMMAND_IS_SHOW IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME CHARACTER*16 OPT(8) CHARACTER*128 OPTIONS,WORK,HELP_LOC CHARACTER*8 VERSION LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 EQUIVALENCE (OPT,OPTIONS) COMMON /HELP/ HELP_LOC,HL_LEN,VERSION COMMON /WORK/ OPT,IOPT,WORK COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /TAPE_IO/ LINES,BLOCKS,FILES,BUF_SIZE COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE OPTIONS = 'Ascii Truncate' NOPT = 2 IF (.NOT.ASCII) OPT(1) = 'Ebcdic' IF (.NOT.TRUNCATE) OPT(2) = 'Notruncate' IF (BYTESWAP) THEN NOPT = NOPT + 1 OPT(NOPT) = 'Byteswap' ENDIF IF (TABCVT) THEN NOPT = NOPT + 1 OPT(NOPT) = 'Spaces' ENDIF WRITE (6,1000) BLOCK_SIZE,TAPE_NAME(1:TN_LEN), 1 OPT(1),VERSION IF (WRITE7) WRITE (6,1000) BLOCK_SIZE,TAPE_NAME(1:TN_LEN), 1 OPT(1),VERSION WRITE (WORK(1:5),1002) RECORD_SIZE IF (RECORD_SIZE.EQ.0) WORK(1:5) = ' VAR' WRITE (6,1001) WORK(1:5),FILES+1,OPT(2) IF (WRITE7) WRITE (7,1001) WORK(1:5),FILES+1,OPT(2) IOPT = 2 IF (COLUMNS(1).NE.0.OR.DN_LEN.NE.0.OR.MAXLINE.LT.9999999 1 .OR.NOPT.GT.2) CALL SHOW_FAO(' ',0,0) IF (COLUMNS(1).NE.0) CALL SHOW_FAO( 1 'Active Columns are !UL to !UL.',COLUMNS(1),COLUMNS(2)) IF (MAXLINE.LT.9999999) CALL SHOW_FAO( 1 'Reads will stop after !UL lines.',MAXLINE,0) IF (DN_LEN.NE.0) CALL SHOW_FAO( 1 'The default file name is ''!AD''',DN_LEN,%LOC(DEFAULT_NAME)) 10 IF (IOPT.LT.NOPT) THEN CALL SHOW_FAO(' ',0,0) GO TO 10 ENDIF PRINT 1001 1000 FORMAT ('0',T34,'Blocksize', I6,T4,'Tape Drive ',A,T58,A,T72,A) 1001 FORMAT (' ',:,T34,'Recordsize',A5,T4,'Next File',I4, T58,A) 1002 FORMAT (I5) END SUBROUTINE SHOW_FAO(FORMAT,VAL1,VAL2) IMPLICIT INTEGER (A-Z) CHARACTER*(*) FORMAT CHARACTER*16 OPT(8) CHARACTER*128 WORK LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /WORK/ OPT,IOPT,WORK CALL SYS$FAO(FORMAT,LEN,WORK,%VAL(VAL1),%VAL(VAL2)) IF (LEN.LT.54) THEN IOPT = IOPT + 1 WRITE (6,1000) WORK(1:LEN),OPT(IOPT) IF (WRITE7) WRITE (7,1000) WORK(1:LEN),OPT(IOPT) ELSE WRITE (6,1000) WORK(1:LEN) IF (WRITE7) WRITE (7,1000) WORK(1:LEN) ENDIF 1000 FORMAT (T4,A,T58,A) END SUBROUTINE COMMAND_IS_SKIP IMPLICIT INTEGER (A-Z) CHARACTER*16 VALUE LOGICAL TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN COMMON /MAG_2/ TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN EXTERNAL CONDITION_HANDLER CALL LIB$ESTABLISH(CONDITION_HANDLER) CALL CLI$GET_VALUE('P1',VALUE,VLEN) FILES_TO_SKIP = NUMERIC_VALUE(VALUE(1:VLEN)) IF (FILES_TO_SKIP.LE.0) THEN CALL ERROR(0,'INVALID SKIP COUNT') RETURN ELSE IF (TAPE_WAS_WRITTEN) THEN CALL ERROR(0,'CANNOT SKIP AFTER WRITE') RETURN ENDIF IF (.NOT.TAPE_IS_OPEN) CALL OPEN_THE_TAPE(&300) CALL TAPE_SKIP(FILES_TO_SKIP) 300 RETURN END SUBROUTINE COMMAND_IS_READ IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE COMMON /MAG_2/ TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE IF (TAPE_WAS_WRITTEN) THEN CALL ERROR(0,'CANNOT READ AFTER WRITE') RETURN ENDIF CALL CLI$GET_VALUE('P1',FILE_NAME) IF (FILE_NAME(1:1).EQ.'@') THEN CALL CHECK_FOR_INDIRECT(*300) RETURN ENDIF CALL CHECK_THE_PARAMETERS('READ',&300) REC_SIZE = RECORD_SIZE IF (REC_SIZE.EQ.0) REC_SIZE = BUFFER_SIZE OPEN (10,FILE=FILE_NAME,STATUS='NEW',CARRIAGECONTROL='LIST', 1 RECL=REC_SIZE,DEFAULTFILE=DEFAULT_NAME,ERR=400) CALL GET_TRUE_FILE_NAME IF (.NOT.TAPE_IS_OPEN) CALL OPEN_THE_TAPE(&200) TAPE_WAS_READ = .TRUE. CALL READ_THE_FILE(DESCR) 200 CLOSE(10) 300 RETURN 400 CALL ERROR(2,'ERROR OPENING DISK FILE') END LOGICAL FUNCTION READ_THE_FILE(BUFFER) IMPLICIT INTEGER (A-Z) CHARACTER*(*) BUFFER CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT LOGICAL INTERACT,ECHO6,WRITE6,WRITE7,HALTED COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) COMMON /TAPE_IO/ LINES,BLOCKS,FILES,BUF_SIZE COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE COMMON /BLOCK/ LARGEST_BLOCK,SIZE_OF_BLOCK COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE COMMON /CTRL_Y/ HALTED VOLATILE HALTED EXTERNAL CONDITION_HANDLER,CONTROL_Y_HANDLER CALL LIB$ESTABLISH(CONDITION_HANDLER) IF (INTERACT) CALL CONTROL_Y(CONTROL_Y_HANDLER) BUF_SIZE = BUFFER_SIZE READ_THE_FILE = .TRUE. FILES = FILES+1 LINES = 0 BLOCKS = 0 HALTED = .FALSE. REC_SIZE = RECORD_SIZE ! Used unless SET REC VAR specified LARGEST_BLOCK = 0 WRITE (6,1002) IF (WRITE7) WRITE (7,1002) 10 CALL TAPE_READ(BUFFER,SIZE_OF_BLOCK) IF (SIZE_OF_BLOCK.LE.0) THEN 20 WRITE (6,1000) '+',FILES,LINES,BLOCKS, 1 TAPE_NAME(1:TN_LEN),FILE_NAME(1:FN_LEN) IF (WRITE7) WRITE (7,1000) ' ',FILES,LINES,BLOCKS, 1 TAPE_NAME(1:TN_LEN),FILE_NAME(1:FN_LEN) IF (LARGEST_BLOCK.GT.0) THEN WRITE (6,1001) LARGEST_BLOCK IF (WRITE7) WRITE (7,1001) LARGEST_BLOCK ENDIF IF (BLOCKS.EQ.0) THEN CALL ERROR(0,'FILE WAS EMPTY ON TAPE',,WARN) EXIT_STAT = '10000000'X ! WARNING ENDIF LARGEST_BLOCK = 0 ! For Control_B RETURN ENDIF LARGEST_BLOCK = MAX(LARGEST_BLOCK,SIZE_OF_BLOCK) IF (BYTESWAP) CALL BYTE_SWAP(BUFFER,SIZE_OF_BLOCK) IF (RECORD_SIZE.EQ.0) REC_SIZE = SIZE_OF_BLOCK ! If SET REC VAR in use CALL UNPACK_BUFFER(BUFFER(1:SIZE_OF_BLOCK),REC_SIZE,&300,&20) IF (.NOT.HALTED) GO TO 10 CALL ERROR(0, 1 'TAPE POSITION UNCERTAIN; SAFEST THING TO DO IS REWIND') GO TO 20 300 RETURN 1000 FORMAT (A,' FILE',I3,I6,' LINES',I7,' BLOCKS READ FROM ',A/ 1 '0 WRITTEN TO ',A/) 1001 FORMAT (10X,'LARGEST BLOCK WAS',I5,' BYTES'/) 1002 FORMAT ('0') END SUBROUTINE CONTROL_Y_HANDLER IMPLICIT INTEGER (A-Z) LOGICAL HALTED COMMON /CTRL_Y/ HALTED VOLATILE HALTED HALTED = .TRUE. END SUBROUTINE CONTROL_B * * If READ operation is in progress, and the user enters CTRL/B, * we print out the size of the largest block read and the last * block read. This is done with an Out-of-band AST (see routine * CONTROL in AZLIBRARY). * IMPLICIT INTEGER (A-Z) CHARACTER*40 LINE / 'Largest block nnnnn, Current block nnnnn' / COMMON /BLOCK/ LARGEST_BLOCK,SIZE_OF_BLOCK DATA LARGEST_BLOCK / 0 / IF (LARGEST_BLOCK.EQ.0) RETURN ! Probably not doing READ CALL OTS$CVT_L_TI(LARGEST_BLOCK,LINE(15:19)) CALL OTS$CVT_L_TI(SIZE_OF_BLOCK,LINE(36:40)) CALL LIB$PUT_LINE(' ',2) CALL LIB$PUT_LINE(LINE,2) END SUBROUTINE UNPACK_BUFFER(BUFFER,RECORD_SIZE,*,*) IMPLICIT INTEGER (A-Z) CHARACTER*(*) BUFFER INTEGER*2 LEN LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /TAPE_IO/ LINES,BLOCKS,FILES,BUF_SIZE COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE SIZE_OF_BLOCK = LEN(BUFFER) LINE_START = 1 IF (.NOT.ASCII) CALL LIB$TRA_EBC_ASC( BUFFER , BUFFER ) DOWHILE (LINE_START.LE.SIZE_OF_BLOCK) LAST_COL = LINE_START + RECORD_SIZE - 1 IF (LAST_COL.GT.SIZE_OF_BLOCK) THEN LAST_COL = SIZE_OF_BLOCK CALL ERROR(1,'SHORT RECORD READ, LENGTH', 1 LAST_COL-LINE_START+1,WARN) ENDIF IF (COLUMNS(1).NE.0) THEN FIRST_COL = MIN( LINE_START+COLUMNS(1)-1 , LAST_COL ) LAST_COL = MIN( LINE_START+COLUMNS(2)-1 , LAST_COL ) ELSE FIRST_COL = LINE_START ENDIF IF (TRUNCATE) THEN LAST_COL = STR_LEN(BUFFER(FIRST_COL:LAST_COL)) 1 + FIRST_COL - 1 IF (LAST_COL.LT.FIRST_COL) THEN WRITE (10,1000,ERR=200,IOSTAT=OUTPUT_ERR) GO TO 10 ENDIF ENDIF WRITE (10,1000,ERR=200,IOSTAT=OUTPUT_ERR) 1 BUFFER(FIRST_COL:LAST_COL) 10 LINES = LINES + 1 IF (LINES.EQ.MAXLINE) THEN CALL MAX_LINE_REACHED RETURN 2 ENDIF IF (MOD(LINES,100).EQ.0) THEN IF (WRITE6) WRITE (6,1001) FILES,LINES,BLOCKS ENDIF LINE_START = LINE_START + RECORD_SIZE ENDDO RETURN 200 CALL ERROR(2,'ERROR WRITING DISK FILE') RETURN 1 1000 FORMAT (A) 1001 FORMAT ('+ FILE',I3,I6,' LINES',I7,' BLOCKS') END SUBROUTINE MAX_LINE_REACHED IMPLICIT INTEGER (A-Z) LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 CALL TAPE_SKIP(1) CALL ERROR(0,'COPY STOPPED AFTER REQUESTED LINE',,WARN) END SUBROUTINE BYTE_SWAP(BUFFER,SIZE_OF_BLOCK) IMPLICIT INTEGER (A-Z) CHARACTER*(*) BUFFER DO I=1,SIZE_OF_BLOCK,2 BUFFER(I:I+1) = BUFFER(I+1:I+1) // BUFFER(I:I) ENDDO END SUBROUTINE COMMAND_IS_WRITE IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN LOGICAL WRITE_LOCKED,WRITE_THE_FILE COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) COMMON /MAG_2/ TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN IF (TAPE_WAS_READ) THEN CALL ERROR(0,'CANNOT WRITE AFTER READ') RETURN ENDIF IF (.NOT.TAPE_IS_OPEN) CALL OPEN_THE_TAPE(&300) IF (WRITE_LOCKED()) GO TO 400 CALL CLI$GET_VALUE('P1',FILE_NAME) IF (FILE_NAME(1:1).EQ.'@') THEN CALL CHECK_FOR_INDIRECT(*300) RETURN ENDIF CALL CHECK_THE_PARAMETERS('WRITE',&300) CALL OPEN_FILE_READ(&300) TAPE_WAS_WRITTEN = .TRUE. IF (.NOT.WRITE_THE_FILE(DESCR)) GO TO 500 200 CLOSE(10) 300 RETURN 400 CALL ERROR(6,'TAPE IS WRITE-LOCKED; CANNOT BE WRITTEN TO') CALL ERROR(8,'Do: MAG> HELP ERRORS WRITELOCK for info') RETURN 500 CLOSE (10) TAPE_WAS_WRITTEN = .FALSE. END SUBROUTINE CHECK_THE_PARAMETERS(OPERATION,*) IMPLICIT INTEGER (A-Z) CHARACTER*(*) OPERATION LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE IF (OPERATION.EQ.'WRITE') THEN IF (RECORD_SIZE.EQ.0) THEN CALL ERROR(0, 1 '''VARYING'' RECORDSIZE NOT ALLOWED ON WRITE') RETURN 1 ENDIF IF (BLOCK_SIZE.LT.RECORD_SIZE .OR. 1 MOD(BLOCK_SIZE,RECORD_SIZE).NE.0) THEN CALL ERROR(0,'RECORD/BLOCK SIZES INCOMPATIBLE') RETURN 1 ENDIF ELSE IF (COLUMNS(2).GT.RECORD_SIZE) THEN CALL ERROR(0,'COLUMNS AND RECORDSIZE INCOMPATIBLE') RETURN 1 ENDIF ENDIF END SUBROUTINE OPEN_THE_TAPE(*) IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN COMMON /MAG_2/ TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN EXTERNAL TAPE_ERROR_RECOVERY STATUS = TAPE_OPEN(TAPE_NAME(1:TN_LEN),TAPE_ERROR_RECOVERY) IF (.NOT.STATUS) THEN IF (STATUS.EQ.0) THEN CALL ERROR(5,' IS NOT MOUNTED') ELSE IF (STATUS.EQ.6) THEN CALL ERROR(5,' IS NOT A MAGNETIC TAPE DEVICE') ELSE CALL ERROR(5,' IS NOT MOUNTED FOREIGN') ENDIF RETURN 1 ENDIF TAPE_IS_OPEN = .TRUE. END SUBROUTINE OPEN_FILE_READ(*) IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN OPEN (10,FILE=FILE_NAME,STATUS='OLD',DEFAULTFILE=DEFAULT_NAME, 1 READONLY,ERR=100) CALL GET_TRUE_FILE_NAME RETURN 100 CALL ERROR(2,'ERROR OPENING DISK FILE') RETURN 1 END LOGICAL FUNCTION WRITE_THE_FILE(BUFFER) IMPLICIT INTEGER (A-Z) CHARACTER*(*) BUFFER CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL TRUNCATE,ASCII,BYTESWAP,TABCVT LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 LOGICAL DETAB,HALTED COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN COMMON /MAG_1/ RECORD_SIZE,BLOCK_SIZE COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) COMMON /TAPE_IO/ LINES,BLOCKS,FILES,BUF_SIZE COMMON /OPTIONS/ TRUNCATE,ASCII,BYTESWAP,COLUMNS(2), 1 TABCVT,MAXLINE COMMON /CTRL_Y/ HALTED VOLATILE HALTED EXTERNAL CONDITION_HANDLER,CONTROL_Y_HANDLER BUF_SIZE = BUFFER_SIZE CALL LIB$ESTABLISH(CONDITION_HANDLER) IF (INTERACT) CALL CONTROL_Y(CONTROL_Y_HANDLER) LINES = 0 BLOCKS = 0 LINE_START = 1 HALTED = .FALSE. TRUNCATED_LINES = 0 WRITE_THE_FILE = .TRUE. WRITE (6,1003) IF (WRITE7) WRITE (7,1003) 10 LINE_END = LINE_START + RECORD_SIZE - 1 READ (10,1000,END=100,ERR=200,IOSTAT=INPUT_ERR) LINE_SIZE, 1 BUFFER(LINE_START:LINE_END) LINES = LINES + 1 IF (MOD(LINES,100).EQ.0) THEN IF (WRITE6) WRITE (6,1002) FILES+1,LINES,BLOCKS+1 ENDIF IF (LINE_SIZE.GT.RECORD_SIZE) THEN LINE_SIZE = RECORD_SIZE TRUNCATED_LINES = TRUNCATED_LINES + 1 ENDIF IF (TABCVT) THEN IF (.NOT.DETAB(BUFFER(LINE_START:LINE_START+LINE_SIZE-1), 1 BUFFER(LINE_START:LINE_END))) 2 TRUNCATED_LINES=TRUNCATED_LINES+1 ENDIF IF (LINE_END.EQ.BLOCK_SIZE) THEN IF (.NOT.ASCII) CALL LIB$TRA_ASC_EBC(BUFFER,BUFFER) IF (BYTESWAP) CALL BYTE_SWAP(BUFFER,BLOCK_SIZE) CALL TAPE_WRITE(BUFFER,BLOCK_SIZE) LINE_START = 1 ELSE LINE_START = LINE_START + RECORD_SIZE ENDIF IF (.NOT.HALTED) GO TO 10 CALL ERROR(0, 1 'TAPE POSITION UNCERTAIN; SAFEST THING TO DO IS REWIND') 100 IF (LINE_START.GT.1) THEN IF (.NOT.ASCII) CALL LIB$TRA_ASC_EBC(BUFFER,BUFFER) IF (BYTESWAP) CALL BYTE_SWAP(BUFFER,LINE_START-1) CALL TAPE_WRITE(BUFFER,LINE_START-1) ENDIF CALL TAPE_WRITE_ENDFILE WRITE (6,1001) '+',FILES,LINES,BLOCKS, 1 TAPE_NAME(1:TN_LEN),FILE_NAME(1:FN_LEN) IF (WRITE7) WRITE (7,1001) ' ',FILES,LINES,BLOCKS, 1 TAPE_NAME(1:TN_LEN),FILE_NAME(1:FN_LEN) IF (TRUNCATED_LINES.GT.0) 1 CALL ERROR(4,'LINE(S) WERE TRUNCATED',TRUNCATED_LINES,WARN) RETURN 200 CALL ERROR(2,'ERROR READING INPUT FILE') 1000 FORMAT (Q,A) 1001 FORMAT (A,' FILE',I3,I6,' LINES',I7,' BLOCKS WRITTEN TO ',A/ 1 '0 READ FROM ',A/) 1002 FORMAT ('+ FILE',I3,I6,' LINES',I7,' BLOCKS') 1003 FORMAT ('0') END SUBROUTINE GET_TRUE_FILE_NAME IMPLICIT INTEGER (A-Z) CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN INQUIRE (10,NAME=FILE_NAME) FN_LEN = STR_LEN(FILE_NAME) END SUBROUTINE ERROR(ERROR_FORMAT,MESSAGE,VALUE,WARNING) IMPLICIT INTEGER (A-Z) CHARACTER*(*) MESSAGE CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 LOGICAL NON_FATAL,ARG_EXIST COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 NON_FATAL = ARG_EXIST(4) ! Non-fatal if optional 4th arg used. FILE = 6 10 GO TO (11,12,13,14,15,16,17,18),ERROR_FORMAT WRITE (FILE,1000) MESSAGE GO TO 20 11 WRITE (FILE,1001) MESSAGE,VALUE GO TO 20 12 CALL FILE_ERROR(FILE) GO TO 20 13 WRITE (FILE,1003) VALUE,MESSAGE GO TO 20 14 WRITE (FILE,1004) VALUE,MESSAGE GO TO 20 15 WRITE (FILE,1005) TAPE_NAME(1:TN_LEN),MESSAGE GO TO 20 16 WRITE (FILE,1006) MESSAGE ! Message types 6, 7, and 8 must NON_FATAL = .TRUE. ! appear together in the order: GO TO 20 ! 1. Exactly one type 6 ! 2. Zero or more type 7 17 WRITE (FILE,1007) MESSAGE ! 3. Exactly one type 8 NON_FATAL = .TRUE. GO TO 20 18 WRITE (FILE,1008) MESSAGE 20 IF (FILE.EQ.7) THEN CONTINUE ELSE IF (.NOT.WRITE7) THEN WRITE (FILE,1011) ELSE FILE = 7 GO TO 10 ENDIF IF (INTERACT.OR.NON_FATAL) RETURN EXIT_STAT = '10000004'X ! SEVERE ERROR CALL COMMAND_IS_EXIT 1000 FORMAT ('0 ***** ',A,' *****'/) 1001 FORMAT ('0 ***** ',A,I5,' *****'/) 1002 FORMAT ('0 ***** ',A,' (see following messages) *****'/) 1003 FORMAT ('0 ***** ERROR ',I3,' ',A,' *****'/) 1004 FORMAT ('0 ***** ',I5,' ',A,' *****'/) 1005 FORMAT ('0 ***** `',A,'`',A,' *****'/) 1006 FORMAT ('0 ***** ',A,' *****') 1007 FORMAT (' ***** ',A,' *****') 1008 FORMAT (' ***** ',A,' *****'/) 1011 FORMAT (' ') END SUBROUTINE COMMAND_IS_MOUNT IMPLICIT INTEGER (A-Z) PARAMETER ( default_density = 1600 ) CHARACTER*128 COMMAND_LINE CHARACTER*64 FILE_NAME,TAPE_NAME,DEFAULT_NAME CHARACTER*1 CCHAR CHARACTER*80 VALUE LOGICAL TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN,CLI$PRESENT COMMON /COMMAND1/ LINE_LEN,COMMAND_LINE COMMON /MAG_2/ TAPE_IS_OPEN,TAPE_WAS_READ,TAPE_WAS_WRITTEN COMMON /NAMES1/ FILE_NAME,TAPE_NAME,DEFAULT_NAME COMMON /NAMES2/ FN_LEN, TN_LEN, DN_LEN EXTERNAL CONDITION_HANDLER DENSITY = 0 IF (CLI$PRESENT('P1')) THEN CALL CLI$GET_VALUE('P1',VALUE,VLEN) DENSITY = NUMERIC_VALUE(VALUE(1:VLEN)) IF (DENSITY.NE.0) THEN IF (DENSITY.NE.800 .AND. DENSITY.NE.1600 .AND. 1 DENSITY.NE.6250) GO TO 310 IF (CLI$PRESENT('P2')) THEN CALL CLI$GET_VALUE('P2',TAPE_NAME,TN_LEN) ENDIF ELSE TAPE_NAME = VALUE(1:VLEN) TN_LEN = VLEN IF (CLI$PRESENT('P2')) THEN CALL CLI$GET_VALUE('P2',VALUE,VLEN) DENSITY = NUMERIC_VALUE(VALUE(1:VLEN)) IF (DENSITY.NE.800 .AND. DENSITY.NE.1600 .AND. 1 DENSITY.NE.6250) GO TO 310 ENDIF ENDIF ENDIF IF (DENSITY.EQ.0) DENSITY = default_density WRITE (6,1000) IF (CLI$PRESENT('WRITE')) THEN STATUS = TAPE_MOUNT(TAPE_NAME(1:TN_LEN),DENSITY) ELSE STATUS = TAPE_MOUNT(TAPE_NAME(1:TN_LEN),DENSITY,,NOWRITE) ENDIF WRITE (6,1000) IF (.NOT.STATUS) THEN IF (STATUS.EQ.0) THEN CALL ERROR(5,' IS ALREADY MOUNTED') ELSE IF (STATUS.EQ.2) THEN CALL ERROR(5,' IS OFFLINE') ELSE IF (STATUS.EQ.6) THEN CALL ERROR(5,' IS NOT A MAGNETIC TAPE DEVICE') ELSE CALL ERROR(5,' IS IN USE BY ANOTHER USER') ENDIF ENDIF RETURN 300 CALL ERROR(0,'SYNTAX ERROR') RETURN 310 CALL ERROR(0,'`'//VALUE(1:VLEN)//'` IS NOT A VALID DENSITY') RETURN ENTRY COMMAND_IS_DISMOUNT CALL LIB$ESTABLISH(CONDITION_HANDLER) IF (TAPE_WAS_WRITTEN) THEN CALL TAPE_WRITE_TRAILER TAPE_WAS_WRITTEN = .FALSE. ELSE IF (TAPE_IS_OPEN) THEN CALL TAPE_REWIND TAPE_WAS_READ = .FALSE. ENDIF TAPE_IS_OPEN = .FALSE. IF (CLI$PRESENT('UNLOAD')) THEN STATUS = TAPE_DISMOUNT(TAPE_NAME(1:TN_LEN)) ELSE STATUS = TAPE_DISMOUNT(TAPE_NAME(1:TN_LEN),'NOUNLOAD') ENDIF IF (.NOT.STATUS) THEN CALL ERROR(5,' IS NOT MOUNTED',,WARN) ENDIF 1000 FORMAT (' ') END LOGICAL FUNCTION WRITE_LOCKED() IMPLICIT INTEGER (A-Z) CHARACTER*16 DEVICE_ INTEGER*4 DEVLEN_,DEVCHAR,DEVDEPEND COMMON /TAPE_/ DEVICE_,DEVLEN_,DEVCHAR,DEVDEPEND WRITE_LOCKED = IAND(DEVCHAR,'02000000'X) .NE. 0 END INTEGER*4 FUNCTION CONDITION_HANDLER(SIGARGS,MECHARGS) IMPLICIT INTEGER (A-Z) INTEGER*4 SIGARGS(*),MECHARGS(*) EXTERNAL SS$_ENDOFTAPE,SS$_PARITY,SS$_MEDOFL,SS$_OPINCOMPL EXTERNAL SS$_RESIGNAL,SS$_ENDOFVOLUME N = LIB$MATCH_COND( SIGARGS(2) , %LOC(SS$_PARITY), 2 %LOC(SS$_ENDOFTAPE), 3 %LOC(SS$_MEDOFL), 4 %LOC(SS$_OPINCOMPL), 4 %LOC(SS$_ENDOFVOLUME) ) IF (N.GT.0) THEN CALL LIB$SIG_TO_RET(SIGARGS,MECHARGS) ENDIF CONDITION_HANDLER = %LOC( SS$_RESIGNAL ) END LOGICAL FUNCTION TAPE_ERROR_RECOVERY(ERRCODE,WHEN) ** * LOGICAL FUNCTION TAPE_ERROR_RECOVERY( errcode , when ) * * * (Part of the NSWC N41 Basic Tape I/O package.) * * This is an example of an Error Handler for the NSWC N41 Basic Tape * I/O package. By default (if you do not use such an error handler) * Any I/O errors during magnetic tape operations cause the program * to abort; the text of the error message and a traceback are dis- * played (no traceback is displayed if the program is linked using * the /NOTRACE qualifier). * * If, however, when you call TAPE_OPEN, you provide the name of an * error-handling routine as the second argument, then this routine * will be called when a tape I/O error occurs, and can analyze the * error and make a more sophisticated response to it, such as: * * * Re-trying the failed operation * * Mounting a continuation reel * * "Unwinding" (see below) * * Printing a user-specified message and terminating the * program * * Prompting the user, letting him/her choose from a menu * of responses * * Taking the default response (aborting with a traceback) * * Etc. * * "Unwinding" means returning control directly to a subprogram sev- * eral levels higher in the hierarchy of CALLs which eventually * reached the Error Handler. This requires knowledge of VAX/VMS * Condition Handling; see the appropriate VAX/VMS manual for this * information. * * Error Handlers must be defined as logical functions with two argu- * ments. The first argument is the VMS status code for the error * which occurred; this is INTEGER*4. The second argument is an * INTEGER*2 value describing where the error occurred; see below for * the possible values. The function result must be set .TRUE. if the * failed operation should be re-tried. Returning a .FALSE. result * causes the default error action (displaying the VMS error message * and aborting the program with a traceback) to occur. The Error * Handler can also call LIB$SIGNAL, LIB$STOP, EXIT, etc. Unwinding * requires setting up a VMS Condition Handler and signalling the er- * ror. * * Examine the coding to see how this is all implemented. * * .INDEX TAPE I/O>> * * * Alan L. Zirkle Naval Surface Weapons Center * Code N41 * 2 Jan 1985 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) INCLUDE '($SSDEF)/NOLIST' INTEGER*4 STATUS,HANDLER INTEGER*2 IOSB(4),CHANNEL,DEVLEN CHARACTER*16 DEVICE EQUIVALENCE (IOSB(1),STATUS2) COMMON /STATUS_/ STATUS,IOSB,CHANNEL,DEVLEN,DEVICE,HANDLER COMMON /BUFFER_/ BUFFER_SIZE,DESCR(2) * WHEN = 1 TAPE_WRITE * WHEN = 2 TAPE_WRITE_ENDFILE * WHEN = 3 TAPE_READ * WHEN = 4 TAPE_REWIND * WHEN = 5 TAPE_SKIP CHARACTER*8 WHEN_(5) / 'WRITE','ENDFILE','READ','REWIND','SKIP'/ CHARACTER*10 PROBLEM LOGICAL PROMPT_YES TAPE_ERROR_RECOVERY = .FALSE. ! Assume no recovery N = LIB$MATCH_COND( ERRCODE , SS$_ABORT , ! Hardware or $CANCEL 2 SS$_CTRLERR , ! Hardware 3 SS$_DATAOVERUN , ! Buffer too small 4 SS$_DEVOFFLINE , ! Hardware 5 SS$_DRVERR , ! Hardware 6 SS$_ENDOFTAPE , ! End of reel hit 7 SS$_ENDOFVOLUME , ! EOF-EOF hit on skip 8 SS$_MEDOFL , ! Tape is not on line 9 SS$_NONEXDRV , ! Unit switch changed? O SS$_OPINCOMPL , ! Hardware 1 SS$_PARITY , ! Bad tape or Hardware 2 SS$_TIMEOUT , ! Hardware 3 SS$_UNSAFE) ! Hardware * Other known errors are: SS$_CANCEL * SS$_DATACHECK * SS$_ENDOFFILE (checked elsewhere) * SS$_FORMAT * SS$_ILLIOFUNC * SS$_VOLINV * SS$_WRITLCK * We do not handle these errors. GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13),N * Unhandled errors go through the following code. CALL ERROR(0, 1 'Notify the System Manager of the following error:' 2 ,,NON_FATAL) RETURN 1 PROBLEM = 'ABORT' ! Hardware problem. GO TO 90 2 PROBLEM = 'CTRLERR' ! Hardware problem. GO TO 90 3 CALL ERROR(6, 1 'MAG''S BUFFER IS TOO SMALL FOR THIS TAPE''S BLOCKSIZE;') CALL ERROR(7, 1 ' RE-RUN MAG WITH /BUFFER QUALIFIER LARGER THAN ITS') WRITE (PROBLEM,1000) BUFFER_SIZE CALL ERROR(8,' CURRENT VALUE OF' // PROBLEM(1:7) ) CALL EXIT 4 PROBLEM = 'DEVOFFLINE' ! Hardware problem (since we checked online GO TO 90 ! status when we opened the tape). 5 PROBLEM = 'DRVERR' ! Hardware problem GO TO 90 * End of Tape -- Our condition handler handles this (if routine * TAPE_END_OF_REEL decides not to). 6 TAPE_ERROR_RECOVERY = TAPE_END_OF_REEL(WHEN) ! See TAPE_END_OF_REEL RETURN ! for more information 7 CALL ERROR(0, 1 'DOUBLE EOF FOUND WHILE SKIPPING, OPERATION TERMINATED' 2 ,,NON_FATAL) RETURN * Medium Offline -- Our condition handler handles this. 8 CALL ERROR(0,'TAPE DRIVE WENT OFFLINE; OPERATION ABANDONED' 1 ,,NON_FATAL) RETURN 9 PROBLEM = 'NONEXDRV' ! Hardware problem (since we checked online GO TO 90 ! status when we opened the tape). * Operation Incomplete -- Our condition handler handles this. 10 CALL ERROR(6,'THE TAPE GOT "OPERATION INCOMPLETE" ERROR') CALL ERROR(8,'Do: MAG> HELP ERRORS OPINCOMPL for info' 1 ,,NON_FATAL) RETURN * Parity Error -- Our condition handler handles this. 11 CALL ERROR(0, 1 'PARITY ERROR ENCOUNTERED ON TAPE; DATA PROBABLY LOST' 2 ,,NON_FATAL) TAPE_ERROR_RECOVERY = PROMPT_YES('Do you want to continue') IF (.NOT.TAPE_ERROR_RECOVERY) CALL COMMAND_IS_EXIT RETURN 12 PROBLEM = 'TIMEOUT' ! Hardware problem. GO TO 90 13 PROBLEM = 'UNSAFE' ! Hardware problem. GO TO 90 90 CALL ERROR(6,'Hardware error (SS$_' // 1 PROBLEM(1:STR_LEN(PROBLEM)) // ') during ' // 2 WHEN_(WHEN)(1:STR_LEN(WHEN_(WHEN))) // ' operation.') CALL ERROR(8,'Please notify the System Manager.') 1000 FORMAT (I7) END LOGICAL FUNCTION TAPE_END_OF_REEL(WHEN) ** * LOGICAL FUNCTION TAPE_END_OF_REEL( ) * * * (Part of the NSWC K53 Basic Tape I/O package.) * * This is an example of part of an error handler; it handles the VMS * error SS$_ENDOFTAPE, which is returned from an I/O operation when * the end-of-reel marker is hit; according to tests I made, no data * will have been read or written when this error occurs; i.e. if re- * covery is to be done, the last I/O must be reattempted. * * If this is a batch process, recovery is not done; the program will * exit after printing a message. For interactive processes, we ask * the user if he/she wants to proceed to the next reel; if a NO re- * sponse is received, we rewind the tape and tell the user that we * did the rewind. In this case, we return a .FALSE. function result. * * If the user responds that he/she DOES want to go to the next reel, * we dismount the current reel (after determining its density and * write/nowrite status) and mount the next. In this case, we return * a .TRUE. result. * * This routine itself can be used (usually called by a main error * handler activated on a call to routine TAPE_OPEN), or its source * can be used as a template to write a customized routine for your * specific application; this may, for example, need to be done if * you want to write messages to a file other than SYS$OUTPUT, which * is what this routine uses. * * .INDEX TAPE I/O>> * * 22 Jan 86 If end-of-tape hit while writing, write an end-of- * file at the end of the current reel before switch- * ing reels. Require 'YES' responses to prompts, * instead of just . * * Alan L. Zirkle Naval Surface Weapons Center * Code K53 * 2 Jan 1985 Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) * WHEN = 1 TAPE_WRITE * WHEN = 2 TAPE_WRITE_ENDFILE * WHEN = 3 TAPE_READ * WHEN = 4 TAPE_REWIND * WHEN = 5 TAPE_SKIP INTEGER*4 STATUS,HANDLER INTEGER*2 IOSB(4),CHANNEL,DEVLEN CHARACTER*16 DEVICE EQUIVALENCE (IOSB(1),STATUS2) COMMON /STATUS_/ STATUS,IOSB,CHANNEL,DEVLEN,DEVICE,HANDLER CHARACTER*16 DEVICE_ INTEGER*4 DEVLEN_,DEVCHAR,DEVDEPEND COMMON /TAPE_/ DEVICE_,DEVLEN_,DEVCHAR,DEVDEPEND COMMON /TAPE_IO/ LINES,BLOCKS,FILES,BUF_SIZE LOGICAL INTERACT,ECHO6,WRITE6,WRITE7 COMMON /ENVIRON/ INTERACT,EXIT_STAT,ECHO6,WRITE6,WRITE7 CHARACTER*16 RESPONSE INTEGER*4 DENS(3:5) / 800,1600,6250 / LOGICAL PROMPT_YES,BATCH_MODE EXTERNAL CONTROL_Y_HANDLER IF (INTERACT) CALL CONTROL_Y() SAVE_BLOCKS = BLOCKS IF (WRITE6) THEN IF (WHEN.EQ.1) THEN WRITE (6,1002) FILES+1,LINES,BLOCKS+1 ELSE IF (WHEN.EQ.3) THEN WRITE (6,1002) FILES,LINES,BLOCKS ENDIF ENDIF IF (BATCH_MODE()) THEN PRINT 1001,'End-of-tape reached; program exited.' CALL EXIT ENDIF SAVE_HANDLER = HANDLER ! Prevent recursive calls HANDLER = 0 IF (.NOT.PROMPT_YES('End-of-tape reached. Do you want ' // 1 'to go to another reel')) THEN TAPE_END_OF_REEL = .FALSE. PRINT 1001,'The tape will be rewound' CALL TAPE_REWIND HANDLER = SAVE_HANDLER RETURN ENDIF IF (WHEN.EQ.1) CALL TAPE_WRITE_ENDFILE CALL TAPE_DEVICE(DEVICE(1:DEVLEN)) WRITE_LOCK = IAND(DEVCHAR,'02000000'X) DENSITY = DENS(IAND(DEVDEPEND,'1F00'X)/'100'X) CALL TAPE_DISMOUNT(DEVICE(1:DEVLEN)) 10 CALL PROMPT('Mount next reel, enter YES when ready',RESPONSE,RL) IF (RL.EQ.0) GO TO 10 IF (RESPONSE(1:1).NE.'Y' .AND. RESPONSE(1:1).NE.'y') GO TO 10 PRINT 1003 CALL TAPE_MOUNT(DEVICE(1:DEVLEN),DENSITY,,WRITE_LOCK) CALL TAPE_OPEN(DEVICE(1:DEVLEN)) HANDLER = SAVE_HANDLER TAPE_END_OF_REEL = .TRUE. IF (INTERACT .AND. WHEN.NE.5) CALL CONTROL_Y(CONTROL_Y_HANDLER) BLOCKS = SAVE_BLOCKS ! Adjust IF (WHEN.EQ.1) BLOCKS = BLOCKS + 1 ! tape position IF (WHEN.EQ.3) FILES = 1 ! indicators PRINT 1000 1000 FORMAT (' '/' ') 1001 FORMAT ('0',A/) 1002 FORMAT ('+ FILE',I3,I6,' LINES',I7,' BLOCKS') 1003 FORMAT (' ') END