program extract
 
C Extract all the files from a RT-11 logical disk.
C When a logical disk is found in a logical disk volume,
C create a new subdirectory and spawn a copy of extract
C to handle the files/LD's in that LD.
 
C It checks the first block
C of a file for the string DECRT11A to determine if it is a LD or not,
C and just may be fooled by a non-LD file with this string in the same
C place.  The output files are exact copies of the RT-11 files, 
C done block-by-block;
C you may find text files unreadable/uneditable on some systems that use a
C different end-of-line terminator than RT11.
 
C Copyright 1994 by Tim Shoppa (shoppa@altair.krl.caltech.edu)
C Redistribution and modification for non-commercial purposes
C is encouraged; just be sure to keep the original Copright/attribution
C in the code.
 
	implicit integer*2 (i-n)
	character*12 fcheck
	byte fcheckb(12)
	equivalence(fcheck,fcheckb)
	character*10 fname
	byte fnameb(10)
	equivalence (fname,fnameb)
	integer*2 itemp(2)
	integer*4 iat,i,j,k,idir,isd0
	character*6 type
	character*80 infile,dirname,outfile
	character*80 line
	integer infilelen,infiledot,dirlen,outfilelen,fnamesp
	integer*2 buffer(0:255)
 
	read(5,666) infile
666	format(a)
 
	type *,infile
 
	open(unit=1,form='unformatted',file=infile,
     1		recordtype='fixed',recl=128,access='direct',
     2		status='old')
 
	infilelen=index(infile,' ')-1
	infiledot=index(infile,'.')
	dirname='[.'//infile(1:infiledot-1)//']'
c	dirname(infiledot+2:infiledot+2)='_'
	dirlen=index(dirname,' ')-1
 
	call lib$spawn('create/dir '//dirname(1:dirlen))
 
	call read1(1,496,fcheckb,12)
 
	if (fcheck.ne.'DECRT11A    ') then
	  type *,'Does not appear to be a RT-11 device'
	  go to 9990
	end if
 
	call read2(1,234,idir0,1)
 
	idir=idir0
 
110	call read2(idir,3,iextra,1)
	iextra=iextra/2
	call read2(idir,4,isd0,1)
	isd=isd0
	iat=5
150	call read2(idir,iat,istat,1)
	if (istat.eq.2048) then
	  call read2(idir,1,idirn,1)
	  if (idirn.eq.0) go to 200
	  idir=idir0+(idirn-1)*2
	  go to 110
	end if
	if (istat.ne.1024.and.istat.ne.-31744) go to 190
	call read2(idir,iat+1,itemp2,2)
	call r50asc(6,itemp2,fnameb(1))
	fname(7:7)='.'
	call read2(idir,iat+3,itemp2,1)
	call r50asc(3,itemp2,fnameb(8))
	call read2(idir,iat+4,ilen,2)
	call read2(idir,iat+6,idat,2)
	idatm=idat/1024
	idatd=(idat-idatm*1024)/32
	idaty=(idat-idatm*1024-idatd*32)+72
 
	fnamesp=index(fname,' ')
	if (fnamesp.eq.0 .or. fnamesp.ge.7) fnamesp=7
	
185	outfile=dirname(1:dirlen)//fname(1:fnamesp-1)//'.'
     1		//fname(8:10)//';2'
 
	open(unit=2,form='unformatted',file=outfile,
     1		recordtype='fixed',recl=128,access='direct',
     2		status='new')
	do i=0,ilen-1
	  call read2(isd+i,0,buffer,256)
	  write(2,rec=i+1) buffer
	end do
	close(2)
 
	type='FILE'
	if (ilen.ge.2) then
	  call read1(isd+1,496,fcheckb,12)
	  if (fcheck.eq.'DECRT11A    ') type='DIR'
	end if
 
189	type *,fname,ilen,isd,idatm,idatd,idaty,'  ',type
 
	if (type(1:3).eq.'DIR') then
	  open(unit=13,file='xxx_xxx.com',status='new',
     1		carriagecontrol='list')
	  write(13,666) '$set def '//dirname
	  write(13,666) '$run disk$data:[shoppa.pdp11.rt]extract'
	  outfile=fname(1:fnamesp-1)//'.'//fname(8:10)
	  outfilelen=index(outfile,' ')-1
	  write(13,666) outfile
	  write(13,666) '$delete '//outfile(1:outfilelen)//';*'
	  close(13)
	  call lib$spawn('@xxx_xxx.com')
	  call lib$spawn('delete xxx_xxx.com;*')
	end if
 
	isd=isd+ilen
190	iat=iat+iextra+7
	go to 150
 
200	continue
 
9990	continue
	end
 
	subroutine read1(iblock,iword,outbuf,n)
	byte outbuf(0:n-1)
	do i=0,n-1
	  outbuf(i)=ipeek(iblock,iword+i,1)
	end do
	return
	end
 
	subroutine read2(iblock,iword,outbuf,n)
	integer*2 outbuf(0:n-1)
	do i=0,n-1
	  outbuf(i)=ipeek(iblock,iword+i,2)
	end do
	return
	end
 
	function ipeek(iblock,iword,iws)
	logical first
	byte buffer1(0:511)
	integer*2 buffer2(0:255)
	integer*4 buffer4(0:127),i4
	equivalence (buffer1,buffer2)
	equivalence (buffer1,buffer4)
	data first/.true./
 
	if (first) then
	  first=.false.
	  ipblockb=-1
	end if
	
	ipblock=iblock+iword*iws/512
	ipword=mod(iword,512/iws)
 
	if (ipblockb.ne.ipblock) then
	  read(1,rec=ipblock+1) buffer1
	  ipblockb=ipblock
	end if
 
	if (iws.eq.1) then
	  ipeek=buffer1(ipword)
	else if (iws.eq.2) then
	  ipeek=buffer2(ipword)
	else if (iws.eq.4) then
	  ipeek=buffer4(ipword)
	else
	  stop ' illegal word size.'
	end if
 
	return
	end