program tape_erase C+ C Version: X1-002 C C Facility: Diagnostic Utilities. C C Abstract: This program will erase a tape by writing zeros all over it. C C Environment: VMS V5.2 and later. C C Link with option "PSECT_ATTR=BUFFER_PSECT,PAGE" C C History: C C 27-Mar-1991, DBS; Version X1-001 C 001 - Original version. (Taken from tape_exer.) C 05-Dec-1991, DBS; Version X1-002 C 002 - Include error counts in commencing and complete messages. C- implicit none C External references (and includes) include '($DCDEF)/nolist' include '($DVIDEF)/nolist' include '($IODEF)/nolist' include '($RMSDEF)/nolist' include '($SSDEF)/nolist' integer*4 lib$get_foreign external lib$get_foreign integer*4 lib$put_output external lib$put_output integer*4 lib$stop external lib$stop external report_error integer*4 sys$assign external sys$assign integer*4 sys$fao external sys$fao integer*4 sys$getdviw external sys$getdviw integer*4 sys$qio external sys$qio integer*4 sys$qiow external sys$qiow integer*4 sys$waitfr external sys$waitfr C Structures structure /iosb/ integer*2 sts /0/ integer*4 count /0/ integer*2 %fill end structure volatile /iosb/ structure /item_list_3/ integer*2 buffer_length /0/ integer*2 item_code /0/ integer*4 buffer_address /0/ integer*4 return_length_address /0/ end structure volatile /item_list_3/ C Type declarations for parameters and PARAMETER statements character device_prompt*(*) character exit_msg*(*) character fao_starting*(*) character fao_written*(*) character intro_msg*(*) integer*4 max_index integer*4 byte_count integer*4 pattern_1 parameter (device_prompt = '_tape unit: ') parameter (exit_msg = '!%D Erasing of !AS complete' 1 //', rewinding (ErrCnt=!UL)') parameter (fao_starting = '!%D Starting to write ' 1 //'!UL byte blocks (ErrCnt=!UL)') parameter (fao_written = '!%D !UL blocks written to tape') parameter (intro_msg = '!%D Erasing tape on unit !AS (!AS)') parameter (max_index = 16383) parameter (byte_count = max_index*4) parameter (pattern_1 = '00000000'X) C Type declarations for variables integer*4 blocks_written /0/ character date_time_buffer*23 /' '/ character device_name*32 /' '/ integer*4 device_name_len /0/ integer*4 dvi_devclass /0/ integer*4 dvi_errcnt /0/ character dvi_fulldevnam*64 /' '/ integer*4 dvi_s_fulldevnam /0/ character dvi_media_name*64 /' '/ integer*4 dvi_s_media_name /0/ integer*4 dvi_mnt /0/ integer*4 event_flag /0/ integer*4 index /0/ integer*4 iochannel /0/ character line*132 integer*4 line_len /0/ integer*4 loop integer*4 status /0/ integer*4 write_buffer(max_index) record /iosb/ iostat(2) record /item_list_3/ itmlst(6) C Commons common /buffer_psect/ write_buffer C+ C Mainline - Tape_Erase C- status = lib$get_foreign (device_name, device_prompt, device_name_len) if ((status .eq. rms$_eof) .or. (device_name_len .eq. 0)) 1 call lib$stop (%val('10000001'X)) status = sys$assign (device_name(1:device_name_len), iochannel,,) if (status .ne. ss$_normal) call lib$stop (%val(status)) itmlst(1).buffer_length = 4 itmlst(1).item_code = dvi$_devclass itmlst(1).buffer_address = %loc(dvi_devclass) itmlst(1).return_length_address = 0 itmlst(2).buffer_length = 4 itmlst(2).item_code = dvi$_mnt itmlst(2).buffer_address = %loc(dvi_mnt) itmlst(2).return_length_address = 0 itmlst(3).buffer_length = len(dvi_fulldevnam) itmlst(3).item_code = dvi$_fulldevnam itmlst(3).buffer_address = %loc(dvi_fulldevnam) itmlst(3).return_length_address = %loc(dvi_s_fulldevnam) itmlst(4).buffer_length = len(dvi_media_name) itmlst(4).item_code = dvi$_media_name itmlst(4).buffer_address = %loc(dvi_media_name) itmlst(4).return_length_address = %loc(dvi_s_media_name) itmlst(5).buffer_length = 4 itmlst(5).item_code = dvi$_errcnt itmlst(5).buffer_address = %loc(dvi_errcnt) itmlst(5).return_length_address = 0 status = sys$getdviw (,%val(iochannel),,%ref(itmlst),%ref(iostat),,,) if (status .ne. ss$_normal) call lib$stop (%val(status)) status = iostat(1).sts if (status .ne. ss$_normal) call lib$stop (%val(status)) if (dvi_devclass .ne. dc$_tape) call lib$stop (%val(ss$_ivdevnam)) if (.not. dvi_mnt) call lib$stop (%val(ss$_devnotmount)) call sys$fao (%descr(intro_msg) 1 ,%ref(line_len) 1 ,%descr(line) 1 ,%val(0) 1 ,%descr(dvi_fulldevnam(1:dvi_s_fulldevnam)) 1 ,%descr(dvi_media_name(1:dvi_s_media_name))) call lib$put_output (line(1:line_len)) do loop = max_index, 1, -1 write_buffer(loop) = pattern_1 enddo !loop = max_index, 1, -1 blocks_written = 0 status = sys$qiow (,%val(iochannel),%val(io$_rewind),,,,,,,,,) if (.not. status) call lib$stop (%val(status)) call sys$fao (%descr(fao_starting) 1 ,%ref(line_len) 1 ,%descr(line) 1 ,%val(0) 1 ,%val(byte_count) 1 ,%val(dvi_errcnt)) call lib$put_output (line(1:line_len)) event_flag = 0 status = sys$qio (%val(event_flag) 1 ,%val(iochannel) 1 ,%val(io$_writelblk) 1 ,%ref(iostat(event_flag + 1)),, 1 ,%val(%loc(write_buffer)) 1 ,%val(byte_count),,,,) event_flag = 1 do while (status .eq. ss$_normal) status = sys$qio (%val(event_flag) 1 ,%val(iochannel) 1 ,%val(io$_writelblk) 1 ,%ref(iostat(event_flag + 1)),, 1 ,%val(%loc(write_buffer)) 1 ,%val(byte_count),,,,) blocks_written = blocks_written + 1 event_flag = mod(event_flag + 1, 2) call sys$waitfr (%val(event_flag)) status = iostat(event_flag + 1).sts enddo !while (status .eq. ss$_normal) event_flag = mod(event_flag + 1, 2) call sys$waitfr (%val(event_flag)) call sys$fao (%descr(fao_written) 1 ,%ref(line_len) 1 ,%descr(line) 1 ,%val(0) 1 ,%val(blocks_written)) call lib$put_output (line(1:line_len)) if (status .ne. ss$_endoftape) 1 call report_error (status, blocks_written, iochannel) status = sys$qiow (,%val(iochannel),%val(io$_rewind),,,,,,,,,) if (.not. status) call lib$stop (%val(status)) status = sys$getdviw (,%val(iochannel),,%ref(itmlst),%ref(iostat),,,) call sys$fao (%descr(exit_msg) 1 ,%ref(line_len) 1 ,%descr(line) 1 ,%val(0) 1 ,%descr(dvi_fulldevnam(1:dvi_s_fulldevnam)) 1 ,%val(dvi_errcnt)) call lib$put_output (line(1:line_len)) status = sys$qiow (,%val(iochannel),%val(io$_rewind),,,,,,,,,) if (.not. status) call lib$stop (%val(status)) end subroutine report_error (status, block_number, iochannel) C++ C Functional Description: C This routine will report the block number that generated the error, C issue a rewind command to the tape drive then use lib$stop to C report the status. C C Calling Sequence: C call report_status (...) C C Formal Argument(s): C status.rl.r The status value to report. C block_number.rl.r The number of the block we were processing when C we got the error. C iochannel.rl.r The channel assigned to the tape drive, so we can do C a rewind before we exit. C C Implicit Inputs: C None C C Implicit Outputs: C None C C Completion Codes: C None C C Side Effects: C None C-- implicit none C External references (and includes) include '($IODEF)/nolist' external lib$put_output external lib$stop external sys$fao external sys$qiow C Structures C Type declarations for parameters and PARAMETER statements character error_msg*(*) parameter (error_msg = '!%D Error detected at block !UL' 1 //', rewinding') C Type declarations for variables integer*4 status integer*4 block_number integer*4 iochannel character line*132 /' '/ integer*4 line_len /0/ C Commons C+ C Mainline - report_error C- call sys$fao (%descr(error_msg) 1 ,%ref(line_len) 1 ,%descr(line) 1 ,%val(0) 1 ,%val(block_number)) call lib$put_output (line(1:line_len)) call sys$qiow (,%val(iochannel),%val(io$_rewind),,,,,,,,,) call lib$stop (%val(status)) return end