Program READTAR		! Version 1.0 July 1984
c
c
c*****************************************************************************
c
c	This program will read and DEformat UNIX 'tar' tapes.
c	It is assumed that the TAR container file is blocked at
c	10240 bytes/block. Any other format and this program will
c	have to be modified. 
c	If file is on tape the mount command is:
c		$ Mount/foreign/block=10240 Mxyz:
c
c	The name of the input file should be the Tapedrive for TAR
c	container files on tape.
c	
c
c
	implicit integer*4 (a-z)
	integer*4 tape_channel,max_bytes,max_pos

	character*80 command_line,file_to_get
	character*1024 buffer
	character*1 total_buffer(10240),answer
	character*1 readbuf(1024)
	character*50 unix_filename,file_name

	logical*1 last_file,skip_file,query_file,single_file,list_only
	logical*1 Log_on

	external tar_table

	equivalence (buffer,readbuf)

	common /buffers/total_buffer,position,Tape_Channel,max_bytes,Max_Pos

	call lib$get_foreign(command_line,,ilen)
	if(.not.(cli$dcl_parse('readtar '//command_line(:ilen),tar_table)))
     &	 call exit
	if (cli$present('LOG')) log_on = .true.
	if (cli$present('LIST')) then
	   list_only = .true.
	   log_on = .false.
	   goto 50
	end if
	if (cli$present('QUERY')) query_file = .true.
	if(cli$present('FILE')) then
	   call cli$get_value('FILE',file_to_get)
	   ilen_file = charlen(file_to_get)
	   single_file = .true.
	end if
50	open(unit=1,name='tape:',form='unformatted',err=650,
	1	type='old',readonly,recl=2560,recordtype='variable')
	rewind 1
200	call read_buffer (readbuf,1,512)
	last_file = .true.
	do i=1,512
	   if(ichar(readbuf(i)).ne.0) last_file = .false.
	end do
	if(last_file) then
	   write(6,*) ' End of files on tape.'
	   call exit
	end if
	last = 0
	ifirst = 0
	do 250 i=100,1,-1
	if(last.eq.0.and.ichar(readbuf(i)).ne.0) last = i
	if(ifirst.eq.0.and.readbuf(i).eq.'/') ifirst=i+1
250	continue
	if(ifirst.eq.0) ifirst = 1
	istatus = ots$cvt_to_l(buffer(125:135),isize)
	if(.not.istatus) isize = 0
	if(list_only) write(6,*) buffer(:last), ' Size: ',isize
	unix_filename=buffer(ifirst:last)

	if(buffer(157:157).eq.'1') then
		write(6,*) 'Link. ',unix_filename
		go to 200
		endif

	skip_file = .false.
	if(list_only) skip_file = .true.
	ilen_unix_file = charlen(unix_filename)
	if(ilen_unix_file.eq.0) skip_file = .true.
	if(single_file) then
	   call str$upcase(unix_filename,unix_filename)
	   if(unix_filename(:ilen_unix_file).ne.
	1	 file_to_get(:ilen_file)) skip_file = .true.
	end if
	if(query_file) then
	   write(6,260) Buffer(:last)
260	   format(' ',a,' ? ',$)
	   read(5,270,end=600) answer
270	   format(a1)
	   if((answer.ne.'Y').and.(answer.ne.'y')) skip_file = .true.
	end if
	if( .not.skip_file ) then

c 	-- Create a compatible VMS filename --

	   call vms_file( file_name, unix_filename, file_name_len)

300	end if
	if(.not.skip_file) then
	   if(log_on) write(6,*) 
	1     '"',unix_filename(:ilen_unix_file),
	2     '" is being created as "',file_name(:file_name_len),'"'
	   open(unit=2,name=file_name(:file_name_len),defaultfile='_._',
	1	type='new',carriagecontrol='list')
	end if
	istart = 0
	if(isize.eq.0) then
	   close(unit=2)
	   go to 200
	end if
350	call read_buffer(readbuf,istart+1,istart+512)
	istart = istart + min(512,isize)
	isize = isize - min(512,isize)
	if(skip_file) then
		istart = 0
		if(isize.gt.0) go to 350
		go to 200
		endif
400	do 450 i=1,istart
	if(ichar(readbuf(i)).eq.10) go to 500
	if(i.gt.132) then
c  must be bad file, lines too long
		skip_file = .true.
		write(6,*) '%E, Binary file, ',file_name(:file_name_len),
	1		', cannot copy.'
		close(unit=2,dispose='delete')
		if(isize.gt.0) go to 350
		goto 200
		endif
450	continue
	if(isize.gt.0) go to 350
500	write(2,550) buffer(1:i-1)
550 	format(a)
	buffer=buffer(i+1:)
	istart = istart - i
	if(istart.gt.0) go to 400
	if(isize.gt.0) go to 350
	close(unit=2)
	go to 200
600	close(unit=1)
	call exit
650	write(6,*) ' Did your mount the tape correctly?'
	write(6,*) ' The correct command is:'
	write(6,*) ' $ Mount/foreign <tape-device> TAPE TAPE'
	call exit
	end
c
c------------------------------------------------------------
c	This subroutine will attempt to convert a UNIX filename
c	to a compatible VMS filespec.
c
c
c
	subroutine VMS_FILE(VMS_filename,UNIX_filename,j)
	logical*1 Found_dpoint
	integer j,charlen,last_char
	character*(*) VMS_filename,UNIX_filename

c 	-- Create a compatible VMS filename --

	j = 0
	found_dpoint = .false.
	last_char = charlen(UNIX_filename)
	do i=1,last_char,1
	   i_char = ichar(UNIX_filename(i:i))

			if(j.lt.75) then  !keep under the limit

	   if( (i_char.ge.48).and.(i_char.le.57) ) then  ! 0-9
		j = j + 1
		VMS_filename(j:j) = UNIX_filename(i:i)

	   else if( (i_char.ge.65).and.(i_char.le.90) ) then  ! a-z
		j = j + 1
		VMS_filename(j:j) = UNIX_filename(i:i)

	   else if( (i_char.ge.97).and.(i_char.le.122) ) then ! A-Z
		j = j + 1
		VMS_filename(j:j) = UNIX_filename(i:i)

	   else if( (i_char.eq.36).or.(i_char.eq.95) ) then  ! '_' or '$'
		j = j + 1
		VMS_filename(j:j) = UNIX_filename(i:i)

	   else if( i_char.eq.46 ) then		! The magic '.'
		j = j + 1
		if(.not.(found_dpoint) ) VMS_filename(j:j) = '.'
		if( found_dpoint ) VMS_filename(j:j) = '_'
		found_dpoint = .true.

	   end if

	   if(j.eq.38) then
		j = j + 1
		VMS_filename(j:j) = '.'
		found_dpoint = .true.
	   end if

			end if	 !if we go over we do nothing!

	end do
	if( .not.(found_dpoint) ) then 
	   j = j + 1
	   VMS_Filename(j:j) = '.'
	end if
	return
	end
c
c--------------------------------------------------------
c
	subroutine read_buffer(the_buffer,start,finish)

	implicit integer*4 (a-z)
	integer*2 iosb(4)
	integer*4 max_bytes,max_pos,position,service_status,Tape_Channel

	character*1024 the_buffer
	character*1 total_buffer(10240)
	character*512 parts_of_buffer(20)

	include '($ssdef)'
	include '($iodef)'

	equivalence (parts_of_buffer,total_buffer)

	common /buffers/total_buffer,position,Tape_Channel,max_bytes,Max_Pos

	if( position.eq.0 ) then
c			- - Assign the tape channel - -
	   Service_Status = Sys$Assign('TAPE:', Tape_Channel, , )

	   if( .not.(Service_Status) ) 
	1	call Lib$Stop( %val(Service_Status) )

c			- - Rewind the tape to start at the beginning - -
	   Service_Status = Sys$Qiow(, %Val(Tape_Channel), 
	1     %Val(Io$_Rewind), iosb, , , , , , , , )

	   if( .not.(Service_Status) )
	1	call Lib$Stop( %val(Service_Status) )

c			- - Get the first block and setup max_pos and block
	   Service_Status = Sys$Qiow(, %Val(Tape_Channel), 
	1     %Val(Io$_ReadlBlk), iosb, , , %ref(total_buffer), 
	2     %val(10240), , , , )

	   if( .not.(Service_Status) ) 
	1	call Lib$Stop( %val(Service_Status) )

	   position = 1
	   max_bytes = iosb(2)
	   max_pos = max_bytes / 512
	   write(6,10) max_pos
10	   format(' Tape blocksize: ',i3)

	else if(position.gt.max_pos) then
c			- - Read the next block
	   Service_Status = Sys$Qiow(, %Val(Tape_Channel), %Val(Io$_ReadlBlk), 
	1  iosb, , , %ref(total_buffer), %val(Max_Bytes), , , , )

	   if( .not.(Service_Status) ) 
	1	call Lib$Stop( %val(Service_Status) )

	   position = 1
	end if

	the_buffer(start:finish) = parts_of_buffer(position)
	position = position + 1
	return
	end
c
c-----------------------------------------------------------
c		this function will return the actual length of the 
c		string and not the length of the variable as returned by
c		the FORTRAN call "LEN" this will check for the last
c		ascii character that is not a " " or a "^@"

	integer*4 function charlen(string)
	implicit integer*4 (a-z)
	character*(*) string

	size = len(string)
	do location = size , 1 , -1
	   value = ichar(string(location:location))
	   if((value.ne.0).and.(value.ne.32)) goto 10
	end do
10	charlen = location
	return
	end