From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX" 17-AUG-1989 17:07
To:	MRGATE::"ARISIA::EVERHART"
Subj:	RE:EBCDIC blocked tapes

Message-Id:  <8908172054.AA13208@crdgw1.ge.com>
Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Thu, 17 AUG 89 13:12:06 PDT
Received: from nwc.navy.mil by KL.SRI.COM with TCP; Thu, 17 Aug 89 13:06:15 PDT
Date: 17 Aug 89 12:20:00 PDT
From: "FIDLER::LEVINE" <levine%fidler.decnet@nwc.navy.mil>
Subject: RE:EBCDIC blocked tapes
To: "info-vax" <info-vax@kl.sri.com>

>    I need to send files to someone who can oly read unlabeled EBCDIC
>    tapes, and they currently exist on a VMS 4.5 system.  Can anyone
>    suggest the right way to do this?

	The following Fortran program will read/write blocked tapes
and do an optional translate ASCII/EBCDIC

Michael N. LeVine                     Naval Weapons Center
LEVINE%FIDLER.DECNET@NWC.NAVY.MIL     China Lake
(619) 939-2614                        Ca 93555
 avn  437-2614                        USA
******************************************************************************
	PROGRAM TAPE_COPY
C
C	PROGRAM TO COPY FILES TO/FROM A FOREIGN TAPE BLOCKED 
C
C	Michael N. LeVine
C	Code 3514
C	Naval Weapons Center
C	China Lake,Ca 93555
C
	PARAMETER MAX_BUFFER_SIZE=10000
	PARAMETER MAX_RECORD_SIZE=132

	CHARACTER ANSWER*1,TAPE*24,FILE_NAME*80,LIST_FILE*80,BLANK*10
	BYTE BUFFER(MAX_BUFFER_SIZE)
	INTEGER*4 EOF_COUNT,SYS$QIOW,SYS$QIO,SYS$WAITFR
	INTEGER*2 IOSB(4)
	LOGICAL*1 LOG,VERIFY
	BYTE LINE(MAX_RECORD_SIZE)
	LOGICAL*1 WRITE_TAPE,EOF,EBCDIC
	CHARACTER*(MAX_RECORD_SIZE) LINE_1,LINE_2

	DATA BLANK/'          '/

	INCLUDE '($IODEF)/NOLIST'
	INCLUDE '($SSDEF)/NOLIST'
C
C	GET DATA FOR TAPE AND LIST FILE
C
	WRITE(6,150)
150	FORMAT('$Tape drive ? ')
	TAPE='                        '
	READ(5,151)TAPE
151	FORMAT(A24)
3	WRITE(6,152)
152	FORMAT('$Tape density ? ')
	READ(5,153)IDENSITY
153	FORMAT(I5)
	IF(	     (IDENSITY.NE.800)
	1	.AND.(IDENSITY.NE.1600)
	1	.AND.(IDENSITY.NE.6250))GOTO 3
1	WRITE(6,156)MAX_RECORD_SIZE
156	FORMAT('$Bytes per record (',I4,' Max) ? ')
	READ(5,153)IRECORD_SIZE
	IF((IRECORD_SIZE.LT.1).OR.(IRECORD_SIZE.GT.MAX_RECORD_SIZE))GOTO 1
	MAX_RECORDS=MAX_BUFFER_SIZE/IRECORD_SIZE
2	WRITE(6,157)MAX_RECORDS
157	FORMAT('$Records per block (',I4,' Max) ? ')
	READ(5,153)IRECORDS
	IF((IRECORDS.LT.1).OR.(IRECORDS.GT.MAX_RECORDS))GOTO 2
	IBUFFER_SIZE=IRECORDS*IRECORD_SIZE
	WRITE(6,154)
154	FORMAT(' Name of file containing list of files to be copied ',/,
	1 '$(can be terminal) ? ')
	LIST_FILE=BLANK//BLANK//BLANK//BLANK//BLANK//BLANK//BLANK//BLANK
	READ(5,155)LIST_FILE
155	FORMAT(A80)
163	WRITE(6,160)
160	FORMAT('$Read or Write tape (R,W) ? ')
	READ(6,161)ANSWER
161	FORMAT(A1)
	IF(ANSWER.EQ.'R')THEN
		WRITE_TAPE=.FALSE.
	ELSEIF(ANSWER.EQ.'W')THEN
		WRITE_TAPE=.TRUE.
	ELSE
		GOTO 163
	ENDIF
164	WRITE(6,162)
162	FORMAT('$Is the tape in EBCDIC (T/F) ? ')
	READ(5,165,ERR=164)EBCDIC
165	FORMAT(L2)
C
C	OPEN TAPE CHANNEL
C
	CALL MOUNT_TAPE(TAPE,IBUFFER_SIZE,IRECORD_SIZE,IDENSITY,ICHAN)
C
C	OPEN FILE CONTAINING LIST OF FILES TO BE COPIED
C
	OPEN(UNIT=1,NAME=LIST_FILE,TYPE='OLD',ERR=500)
	EOF=.FALSE.
	DO WHILE(.TRUE.)
		FILE_NAME=BLANK//BLANK//BLANK//BLANK//BLANK//BLANK//BLANK//BLANK
		READ(1,100,END=400)LEN_FILE_NAME,FILE_NAME(1:LEN_FILE_NAME)
100		FORMAT(Q,A<LEN_FILE_NAME>)
		WRITE(6,170)FILE_NAME(1:LEN_FILE_NAME)
170		FORMAT(' Opening/createing file:',A<LEN_FILE_NAME>)
		IF(WRITE_TAPE)THEN
			OPEN(UNIT=2,NAME=FILE_NAME(1:LEN_FILE_NAME),
	1			TYPE='OLD',ERR=501)
		ELSE
			OPEN(UNIT=2,NAME=FILE_NAME(1:LEN_FILE_NAME),
	1			TYPE='NEW',ERR=501,CARRIAGECONTROL='LIST')
		ENDIF
		DO WHILE(.TRUE.)
		  INDEX=1
		  DO I=1,IBUFFER_SIZE
		    BUFFER(I)=' '
		  ENDDO
C
C		READ A LINE/BUFFER FROM FILE/TAPE
C
		  IF(WRITE_TAPE)THEN
		    DO I=1,IRECORDS
		      READ(2,101,END=200)ILEN,(BUFFER(M),M=INDEX,INDEX+ILEN-1)
101		      FORMAT(Q,<ILEN>A1)
		      IF(EBCDIC)THEN
			DO II=1,MAX_RECORD_SIZE
				IF(II.LE.ILEN)THEN
					LINE_1(II:II)=CHAR(BUFFER(INDEX-1+II))
				ELSE
					LINE_1(II:II)=' '
				ENDIF
			ENDDO
			CALL LIB$TRA_ASC_EBC(LINE_1,LINE_2)
			DO II=1,IRECORD_SIZE
				BUFFER(INDEX-1+II)=ICHAR(LINE_2(II:II))
			ENDDO
		      ENDIF
		      INDEX=INDEX+IRECORD_SIZE
		    ENDDO
		  ELSE
		    ISTAT=SYS$QIOW(%VAL(1),%VAL(ICHAN),%VAL(IO$_READLBLK),
	1	    IOSB,,,BUFFER,%VAL(IBUFFER_SIZE),,,,)
		    IF(IAND(1,ISTAT).EQ.0)THEN
			CALL SYS$EXIT(%VAL(ISTAT))
		    ELSEIF(IOSB(1).EQ.SS$_ENDOFFILE)THEN
		        IF(EOF)GOTO 499
			EOF=.TRUE.
			GOTO 200
		    ELSEIF(IAND(1,IOSB(1)).EQ.0)THEN
			CALL SYS$EXIT(%VAL(IOSB(1)))
		    ENDIF
		    EOF=.FALSE.
		  ENDIF
C
C	Now write line/buffer to disk/tape
C
		  IF(WRITE_TAPE)THEN
		    ISTAT=SYS$QIOW(%VAL(1),%VAL(ICHAN),%VAL(IO$_WRITELBLK),
	1	    IOSB,,,BUFFER,%VAL(IBUFFER_SIZE),,,,)
		    IF(IAND(1,ISTAT).EQ.0)CALL SYS$EXIT(%VAL(ISTAT))
		    IF(IAND(1,IOSB(1)).EQ.0)CALL SYS$EXIT(%VAL(IOSB(1)))
		  ELSE
		    DO I=1,IRECORDS
		      IF(EBCDIC)THEN
			DO II=1,MAX_RECORD_SIZE
				IF(II.LE.IRECORD_SIZE)THEN
					LINE_1(II:II)=CHAR(BUFFER(INDEX-1+II))
				ELSE
					LINE_1(II:II)=CHAR('40'X)
				ENDIF
			ENDDO
			CALL LIB$TRA_EBC_ASC(LINE_1,LINE_2)
			DO II=1,IRECORD_SIZE
				BUFFER(INDEX-1+II)=ICHAR(LINE_2(II:II))
			ENDDO
		      ENDIF
		      WRITE(2,121)(BUFFER(M),M=INDEX,INDEX+IRECORD_SIZE-1)
121		      FORMAT(<IRECORD_SIZE>A1)
		      INDEX=INDEX+IRECORD_SIZE
		    ENDDO
		  ENDIF		    
		ENDDO
200		CONTINUE
		IF((INDEX.GT.1).AND.WRITE_TAPE)THEN
		  ISTAT=SYS$QIOW(%VAL(1),%VAL(ICHAN),%VAL(IO$_WRITELBLK),
	1	  IOSB,,,BUFFER,%VAL(IBUFFER_SIZE),,,,)
		  IF(IAND(1,ISTAT).EQ.0)CALL SYS$EXIT(%VAL(ISTAT))
		  IF(IAND(1,IOSB(1)).EQ.0)CALL SYS$EXIT(%VAL(IOSB(1)))
		ENDIF
		CLOSE(UNIT=2)
		IF(WRITE_TAPE)THEN
		  ISTAT=SYS$QIOW(%VAL(1),%VAL(ICHAN),%VAL(IO$_WRITEOF),
	1		IOSB,,,,,,,,)	!WRITE EOF TO TAPE
		  IF(IAND(1,ISTAT).EQ.0)CALL SYS$EXIT(%VAL(ISTAT))
		  IF(IAND(1,IOSB(1)).EQ.0)CALL SYS$EXIT(%VAL(IOSB(1)))
		ENDIF
		WRITE(6,171)
171		FORMAT(' File completed')
	ENDDO
400	CONTINUE
	IF(WRITE_TAPE)THEN
		ISTAT=SYS$QIOW(%VAL(1),%VAL(ICHAN),%VAL(IO$_WRITEOF),
	1		IOSB,,,,,,,,)	!WRITE EOF TO TAPE
		IF(IAND(1,ISTAT).EQ.0)CALL SYS$EXIT(%VAL(ISTAT))
		IF(IAND(1,IOSB(1)).EQ.0)CALL SYS$EXIT(%VAL(IOSB(1)))
	ENDIF
499	CLOSE(UNIT=1)
	WRITE(6,172)
172	FORMAT(' All files transfered')
	GOTO 510
500	WRITE(6,550)
550	FORMAT(' Error opening file containing list of files')
	GOTO 510
501	WRITE(6,551)
551	FORMAT(' Error opening/createing disk file')
	GOTO 510
510	CALL DISMOUNT_TAPE(TAPE,ICHAN)	!DISMOUNT,DEASSIGN AND DEALLOCATE TAPE
	STOP			!DONE
	END
	SUBROUTINE MOUNT_TAPE(TAPE,BLOCKSIZE,RECORDSIZE,DENSITY,ICHAN)
C
C	ALLOCATE,ASSIGN AND MOUNT TAPE
C	RETURN VMS CHANNEL ASSIGNED
C
	CHARACTER*(*) TAPE

	INCLUDE	'($MNTDEF)/NOLIST'
	INCLUDE	'($SSDEF)/NOLIST'
C
C	SET UP LOCAL STORAGE
C
	INTEGER*4 SYS$ASSIGN,SYS$ALLOC,SYS$MOUNT,SYS$QIOW,FLAGS,BLOCKSIZE
	INTEGER*4 ITEMLIST(16),RECORDSIZE
C
C	ALLOCATE THE DEVICE
C
	LEN_TAPE=LEN(TAPE)
	ISTAT=SYS$ALLOC(TAPE,,,)
C
C	CHECK FOR ANY ERRORS DURING ALLOCATE
C
	IF(ISTAT.EQ.SS$_NORMAL)THEN
C
C		NO ERROR
C
		WRITE(6,103)TAPE
103		FORMAT(1X,A<LEN_TAPE>,' allocated')
	ELSEIF(ISTAT.EQ.SS$_DEVALRALLOC)THEN
C
C		DEVICE ALREADY ALLOCATED-NO ERROR
C
		WRITE(6,104)TAPE
104		FORMAT(1X,A<LEN_TAPE>,'  already allocated to task')
	ELSE
C
C		ANYTHING ELSE IS FATAL
C
		CALL SYS$EXIT(%VAL(ISTAT))
	ENDIF
C
C	ASSIGN LUN
C
	ISTAT=SYS$ASSIGN(TAPE,ICHAN,,)
C
C	CHECK FOR ERROR DURING ASSIGN
C
	IF(ISTAT.EQ.SS$_NORMAL)THEN
C
C		NO ERROR
C
		WRITE(6,201)
201		FORMAT(' Unit number assigned')
	ELSE
C
C		ANY ERROR IS FATAL
C
		CALL SYS$EXIT(%VAL(ISTAT))
	ENDIF
C
C	MOUNT
C
C	INIT THE ITEM LIST FOR THE MOUNT
C
	ITEMLIST(1)=LEN_TAPE+MNT$_DEVNAM*'10000'X
	ITEMLIST(2)=%LOC(TAPE)
	ITEMLIST(3)=0
	ITEMLIST(4)=4+MNT$_FLAGS*'10000'X
	ITEMLIST(5)=%LOC(FLAGS)
	ITEMLIST(6)=0
	ITEMLIST(7)=4+MNT$_BLOCKSIZE*'10000'X
	ITEMLIST(8)=%LOC(BLOCKSIZE)
	ITEMLIST(9)=0
	ITEMLIST(10)=4+MNT$_RECORDSIZ*'10000'X
	ITEMLIST(11)=%LOC(RECORDSIZE)
	ITEMLIST(12)=0
	ITEMLIST(13)=4+MNT$_DENSITY
	ITEMLIST(14)=%LOC(DENSITY)
	ITEMLIST(15)=0
	ITEMLIST(16)=0

	FLAGS=MNT$M_FOREIGN	!MOUNT AS FOREIGN

	ISTAT=SYS$MOUNT(ITEMLIST)
C
C	CHECK FOR ERROR DURING MOUNT
C
	IF(ISTAT.EQ.SS$_NORMAL)THEN
C
C		NO ERROR
C
		WRITE(6,301)
301		FORMAT(' Mount completed')
	ELSE
C
C		ANY ERROR IS FATAL
C
		CALL SYS$EXIT(%VAL(ISTAT))
	ENDIF
	RETURN
	END
	SUBROUTINE DISMOUNT_TAPE(TAPE,ICHAN)
C
C	DISMOUNT,DEASSIGN AND DEALLOCATE TAPE
C
	CHARACTER*(*) TAPE

	INCLUDE '($DMTDEF)/NOLIST'
	INCLUDE	'($SSDEF)/NOLIST'

	INTEGER*4 SYS$DISMOU,SYS$DALLOC,SYS$DASSGN,TAPE_SIZE
	INTEGER*4 MESSAGE_VECTOR(2)
	DATA MESSAGE_VECTOR/'F0002'X,0/
C
C	DISMOUNT
C
	ISTAT=SYS$DISMOU(TAPE,%VAL(DMT$M_UNIT))
C
C	CHECK FOR ANY ERRORS
C
	IF(ISTAT.EQ.SS$_NORMAL)THEN
C
C		NO ERROR
C
		WRITE(6,502)
502		FORMAT(' Dismount complete')
	ELSE
C
C		LOG ERROR
C
		MESSAGE_VECTOR(2)=ISTAT
		CALL SYS$PUTMSG(MESSAGE_VECTOR)
	ENDIF
C
C	DEASSIGN TAPE
C
	ISTAT=SYS$DASSGN(%VAL(ICHAN))
C
C	CHECK FOR ERROR
C
	IF(ISTAT.EQ.SS$_NORMAL)THEN
C
C		NO ERROR
C
		WRITE(6,505)
505		FORMAT(' Deassign complete')
	ELSE
C
C		LOG ERROR
C
		MESSAGE_VECTOR(2)=ISTAT
		CALL SYS$PUTMSG(MESSAGE_VECTOR)
	ENDIF
C
C	DEALLOCATE TAPE
C
	ISTAT=SYS$DALLOC(TAPE,)
C
C	CHEK FOR ERROR
C
	IF(ISTAT.EQ.SS$_NORMAL)THEN
C
C		NO ERROR
C
		WRITE(6,508)
508		FORMAT(' Deallocate complete')
	ELSE
C
C		LOG  ERROR
C
		MESSAGE_VECTOR(2)=ISTAT
		CALL SYS$PUTMSG(MESSAGE_VECTOR)
	ENDIF
	RETURN
	END


