C
C   PROGRAM TO READ NORT RECORDS   TPC 6/85
C   TAPE INPUT- TPC 12/85
C   verified for generic 3480 EDR tape read  SBK 01/10/2000
C
C   called by DCL command procedure that defines TNAME as tape drive
C   device name and mounts the volume foreign (ex. MOUNT/FOR LEPVOY$MKA100:).
C
	INCLUDE '($IODEF)'
	INCLUDE 'UNPACK.INC'
	BYTE BUFF(7500),PD,PAD(2)
	CHARACTER*5 TNAME/'TNAME'/
	DIMENSION F48(32)
	INTEGER*4 SYS$ASSIGN,SYS$QIO,SYS$QIOW,MASK(2),ISTAT(2),JSTAT(2)
	INTEGER*4 TCHAN,PLSREC,BADFLAG,AVREC
	INTEGER*2 IOSB(4)/4*0/
	EQUIVALENCE (IOSB(1),ISTAT(1))
	DATA LBUF/7456/
C
	COMMON /DAT/PAD,BUFF,N
	COMMON/FLAGS/PLSREC,MAGREC,ISWTCH(10),BADFLAG,AVREC
	DATA PLSREC/0/,MAGREC/1/,ISWTCH/10*0/,BADFLAG/0/,AVREC/1/
C
	IRET=SYS$ASSIGN(TNAME,TCHAN,,)
	CALL SYSSTAT('TAPE ERROR ASSIGN',IRET,0)
	TYPE *,IRET,TCHAN
C
	DO 10 I=1,20000
	IRET=SYS$QIOW(,%VAL(TCHAN),%VAL(IO$_READLBLK),ISTAT,,,BUFF,
     *  %VAL(LBUF),,,,)
	CALL SYSSTAT('ERROR QIOW',IRET,0)
	IF (IRET.NE.1) TYPE *,'TAPE READ ERROR'
	N=IOSB(2)
	CALL UNPACK(BUFF,IUST)
	PD=BUFF(4)/16
c	IF (BUFF(7).EQ.10.AND.PD.EQ.4) THEN
c	  CALL PLS1
c	  CALL MAG1
c	  END IF
    9	CALL DISPLAY
   10	CONTINUE
   98	TYPE *,'File 32 read error',IOS
	STOP
	END
C---------------------------------------------------------------------
C
C	DISPLAY SUBROUTINE FOR VOYAGER EDR'S
C	10/17/80   TPC
C
C---------------------------------------------------------------------
	SUBROUTINE DISPLAY
	INCLUDE 'UNPACK.INC'
	BYTE BUF(7500),IB(50),PAD(2)
	INTEGER*2 IN(25),INT,ISTAT(4),JSTAT(4)
	INTEGER*4 PLSREC,MAGREC
	EQUIVALENCE(BUF,INT),(IB,IN)
	COMMON /DAT/PAD,BUF,N
	COMMON/FLAGS/PLSREC,MAGREC,ISWTCH(10)
	DIMENSION SC(6),EX(16),DM(32),IO(6)
	DATA SC/'S/C2','S/C1','PTM ','UNKN','SIM1','SIM2'/
	DATA EX/'----','CRS','IRIS','LECP','MAG','PLS','PPS','PRA','PWS',
     1	'UVS','RSS','ENG','UN*','IMAG','MON','DCOM'/
	DATA DM/'ENG','CR2','CR3','CR4','CR5','CR6','***','CR1','***',
     1	'IM7','GS3','IM9','PB3','PB2','PB1','GS4','***','GS2','IM14',
     2	'***','IM12','IM11','IM10','OC1','IM8','***','IM6','IM5','IM4',
     3	'IM3','IM2','IM13'/
	IF (N.EQ.0) THEN
c	  TYPE *,' *** ZERO LENGTH RECORD RETURNED ***'
	  RETURN
	  END IF
	IF (PROJID.EQ.'EOT') THEN
	  TYPE *,' *** END OF TRANSMISSION ***'
	  RETURN
	  END IF
	IF (PROJID.NE.'MJS') THEN
	  TYPE 99,(BUF(I),I=1,14)
   99	  FORMAT(' *** BAD RECORD ***',14(2XZ2))
	  RETURN
	  END IF
	DO 11 I=2,50,2
	IB(I-1)=BUF(I)
   11	IB(I)=BUF(I-1)
	IB(4)=0
	I1=IN(2)/16+1
	I2=IN(2)-16*I1+17
	I3=BUF(7)+1
	IO(1)=IN(13)/24
	IO(2)=IN(13)-24*IO(1)
	IO(3)=IN(14)/60
	IO(4)=IN(14)-60*IO(3)
	IO(5)=IN(15)
	IO(6)=IN(3)
	IMG=MAGREC-1
	IPLS=PLSREC-1
	WRITE(6,100),SC(I2),EX(I1),DM(I3),IO,N,IMG,IPLS
  100 	FORMAT(' MJS',3(1XA4),'  DAY',I4,I3,2(':',I2),'.',I3,
     *	' EDR ',I4,' LEN =',I5,' MAG ',I4,' PLS ',I4)
	RETURN
	END