C
C	ROUTINE TO READ EBCDIC BLOCKED TAPES
C	READS ONE TAPE RECORD AND DIVIDES IT INTO 80 BYTE IMAGES
C
	PARAMETER ITIT=132
C
	DIMENSION IBUFL(2048),IBUFW(4096),IBUFB(8192),IOSB(4)
C
	INCLUDE  	'SYS$LIBRARY:FORSYSDEF($IODEF)/NOLIST'
	INCLUDE		'SYS$LIBRARY:FORSYSDEF($SSDEF)/NOLIST'
C
	EQUIVALENCE (IBUFW,IBUFB),(IBUFL,IBUFB)
	INTEGER SYS$ASSIGN,SYS$QIOW,SYS$TRNLOG
	BYTE IBUFB
	INTEGER*2 IOSB,IBUFW
	INTEGER*4 IBUFL
	LOGICAL LONG,NEOF,FOPEN
	CHARACTER DEV*(20),NAME*(13),LINE*(ITIT)
C
C	ASSIGN CHANNEL
C
	NCHAR=80			!SIZE OF LINE
C
	LUN=1				!SET UNIT
	NEOF=.FALSE.			!SET NONE SEEN
	FOPEN=.FALSE.			!NO FILE OPEN
	DEV='   '
	ISTAT=SYS$TRNLOG('TAPE',LENDEV,DEV,,,)
	IF(ISTAT.NE.SS$_NORMAL)CALL EXIT(ISTAT)
	ISTAT=SYS$ASSIGN(DEV,ICHAN,,)
	IF(ISTAT.NE.SS$_NORMAL)CALL EXIT(ISTAT)
C
C	GET THE FILE NAME
C
10	NAME=' '
	TYPE 1100,'$ ENTER FILE NAME '
	READ 1100,NAME
C
C	OPEN OUTPUT FILE
C
	OPEN(UNIT=2,CARRIAGECONTROL='LIST',DISPOSE='SAVE'
	1,FORM='FORMATTED',TYPE='NEW',FILE=NAME
	2,ORGANIZATION='SEQUENTIAL',RECORDTYPE='VARIABLE')
C
C	READ THE A BLOCK
C
20	ISTAT=SYS$QIOW(,%VAL(ICHAN),%VAL(IO$_READVBLK),IOSB,,,
	1IBUFB,%VAL(8192),,,,)
	IF(ISTAT.NE.SS$_NORMAL)CALL EXIT(ISTAT)
	IF(IOSB(1).EQ.SS$_ENDOFFILE)GO TO 50
	IF(IOSB(1).NE.SS$_NORMAL)THEN
		TYPE *,' TAPE READ ERROR',IOSB
		CALL EXIT
	ENDIF
	NEOF=.FALSE.
	NBYTES=IOSB(2)				!NUMBER OF BYTES
	NUMBER=1				!SET STARTING POSITION
	FOPEN=.TRUE.
	DO WHILE (NUMBER.LT.NBYTES)
		DO 40 I=1,NCHAR	
		LINE(I:I)=CHAR(IBUFB(NUMBER))	!MOVE EACH CHAR.
40		NUMBER=NUMBER+1			!UP POINTER
		ISTAT=LIB$TRA_EBC_ASC(LINE,LINE)
		WRITE(2,1100),LINE(1:NCHAR)	!OUTPUT IT
	END DO
	GO TO 20
C
C	NOW SAVE OUTPUT DATA
C
50	TYPE *,' END FILE READ'
	IF(FOPEN)CLOSE(UNIT=2,DISPOSE='SAVE')
	FOPEN=.FALSE.
	IF(NEOF)CALL EXIT
	NEOF=.TRUE.			!SET FLAG TRUE
	GO TO 10			!AGAIN
C
C	FORMAT
C
1100	FORMAT(A)
	END