Program GETFILE
c
c ...	This program retrieves files from the bad disk (WIPED)
c ...	 and stores them onto the current default device and directory.
c
c..  This version accepts a block number on the disk
C
	IMPLICIT INTEGER (A-Z)
c
	INTEGER * 4 PARSE, ACPOPEN
	INTEGER * 4 SYS$ASSIGN, SYS$DASSGN
C
	BYTE F_NAME(21)			! FILE NAME FROM HEADER
	BYTE DEV_ID(16)			! OUTPUT DEVICE ID (COUNTED STRING)
	BYTE RSS(180),ESS(180)		! RSS AND ESS FROM PARSE
	INTEGER * 2 DIR_ID(3)		! OUTPUT DIRECTORY ID FROM PARSE
	INTEGER * 4 IO_STATUS(2)	! OUTPUT I/O STATUS FROM ACPOPEN
C
C	A STRING DESCRIPTOR FOR THE DEVICE ID
C
	INTEGER * 4 DEV_ID_DESCR(2)
C
	Byte Header(512) , data(512)
	character val*1
	Integer*4 Fblock(100), Nblocks(100), Attr(7), Succ
	Integer*4 OCHAN,O_EFN
	DATA O_EFN / 2 /
c
c ........ open the log file to keep track of usage of this prog
C	Open(Unit=9, Name=']Files.log',
C	1 Form='Formatted', Type='New')
c ......... 
20	TYPE 2
2	Format(' Enter disk block number: '$)
	Read *,Nblock
	If(Nblock .eq. 0)Then
	 stop
	End if
c ....... Read the file header
	Call Rdblok(Nblock, Header)	
c ....... Determine the number of blocks on the file.
C
	Call Points(Header, Np, Fblock, Nblocks, Flag)
C
	If (Flag .NE. 0) Then
 	  TYPE *,' Cannot process file. Flag= ',flag
	  go to 20
	end if
C
	nsum = 0
	Do j=1,np
	nsum = nsum + nblocks(j)
	end do
C
	TYPE 3,nfile, nsum,(header(i),i=77,95)
3	format(i6,2x,i6,' Blocks. ',19a1)
c
	TYPE 4
4	Format(' Do you want this file? '$)
	Read 6,val
6	Format(a)
	If (Val .eq. 'N' .or. val .eq. 'n') GO TO 20
C
C	NOW GET THE ORIGINAL FILE NAME AND MAKE IT A BYTE ARRAY(ASCIZ)
C
	DO 110 I=1,20
	F_NAME(I) = HEADER(76+I)
	IF (F_NAME(I) .EQ. ' ') F_NAME(I) = 0
110	CONTINUE
C
C	NOW CALL PARSE TO GET THE OUTPUT DEVICE ID AND DIRECTORY ID
C
	CALL PARSE(F_NAME,DEV_ID,DIR_ID,RSS,ESS)
C
	TYPE 911,'FIL',(F_NAME(I), I=1,STRING_LEN(F_NAME))
C
	TYPE 911,'DVI',(DEV_ID(I),I=2,DEV_ID(1)+1)
	TYPE 912,'DID',DIR_ID
	TYPE 911,'RSS',(RSS(I), I=1,STRING_LEN(RSS))
	TYPE 911,'ESS',(ESS(I), I=1,STRING_LEN(ESS))
C
911	FORMAT (1X,A,1X,60A1)
912	FORMAT (1X,A,1X,3I8)
C
C	FILL IN THE DEV_ID STRING DESCRIPTOR
C
	DEV_ID_DESCR(1) = DEV_ID(1)		! LENGTH IN BYTES
	DEV_ID_DESCR(2) = %LOC( DEV_ID(2) )	! LOC
C
C	OPEN A CHANNEL TO THE DEVICE
C
	SUCC = SYS$ASSIGN(DEV_ID_DESCR,OCHAN,,)
	IF ( .NOT. SUCC) THEN
	  CALL FAILURE(SUCC,'Cant assign output channel')
	  TYPE *,(DEV_ID(I),I=2,DEV_ID(1))
	  STOP
	ENDIF
C
C	CREATE THE OUTPUT FILE AND WRITE ATTRIBUTES
C
	SUCC = ACPOPEN(OCHAN,O_EFN,NSUM,HEADER,DIR_ID,IO_STATUS)
	IF ( .NOT. SUCC ) THEN
	  TYPE *,'Cant open output file. I/O STATUS: ',IO_STATUS
	  CALL LIB$STOP(%VAL(SUCC))
	ENDIF
	IF (.NOT. IO_STATUS(1)) THEN
	  TYPE *,'Open status bad. I/O status: ',IO_STATUS
	  STOP
	ENDIF
C
	Nr_vblock = 1
c ....... loop thru the mapping pointers returned by POINTS
	Do jj = 1, np
	  Kblock = Fblock(jj)
C
	TYPE *, 'Count: ',NBLOCKS(JJ),'  LBN: ',KBLOCK
C
	  do jk = 1, nblocks(jj)
c ..........  read and write the blocks
	    Call Rdblok(Kblock, Data)
	    Kblock = Kblock + 1
	      Nbytes = 512
	    Call Wrblok(Nr_vblock, Data, Nbytes, OCHAN, O_EFN)
	    Nr_vblock = Nr_vblock + 1
	  end do
	end do
C
C	CLOSE THE OUTPUT FILE
C
	CALL ACPCLOSE(IO_STATUS)
	IF ( .NOT. SUCC ) THEN
	  TYPE *,'Cant close output file. I/O status: ',IO_STATUS
	  CALL LIB$STOP(%VAL(SUCC))
	ENDIF
	IF (.NOT. IO_STATUS(1)) THEN
	  TYPE *,'Close status bad. I/O status: ',IO_STATUS
	  STOP
	ENDIF
	SUCC = SYS$DASSGN(%VAL(OCHAN))
	IF (.NOT. SUCC) CALL LIB$STOP(%VAL(SUCC))
	GO TO 20
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	End

	Subroutine Points(Header, Npoints, Fblock, Nblocks, Flag)
c
c ...	This routine puts the map pointers in a file header into
c ...	more tractable form.  It returns, first of all, the number
c ... 	of pointers there are in Npoints.  Then, for each, it returns
c ...   the number of blocks there are in this pointer group (in
c ...   Nblocks) and the location of the first in Fblock.
c ...	  Flag is returned 0 if everything is fine
c ...	                   1 if an illegal pointer type is found (not <>0,1,2
c ...                      2 if the map pointer count is < 0 or > 100.
c
	Implicit Integer (A-Z)
	Integer*4 Fblock(100), Nblocks(100), Hd(8)
	Byte Header(512)
c
c
c	Nwords = # of Map words (2 bytes each) in header
	Nwords = Header(59)
	Nwords = Iand(Nwords, 'FF'x)
	If (Nwords .lt. 0 )Then
	  Flag = 2
	  Return
	End if
c ...	131 is byte address of first Map pointer
	Loc = 131
	Npoints = 0
10	Continue
	Do j = 1,8
	 Hd(j) = Header(Loc + j - 1) 
	 Hd(j) = Iand(Hd(j) , 'FF'x)
	End do
c ...  Upper 2 bits of 2nd byte have pointer type
	Type = Jishft(Hd(2), -6)
c ...  	Remove upper 2 bits from HD(2)
	Hd(2) = Jiand(Hd(2), '3F'x)
	If(Type .eq. 0)Then
	  Flag = 1
	  Return
	Else if(Type .eq. 1)Then  !  Format 1
	  Npoints = Npoints + 1
	  Nblocks(Npoints) = Hd(1) + 1
	  Fblock(Npoints) = Jishft(Hd(2),16) + Jishft(Hd(4),8) +
	1   Hd(3)
	  Nbyts = 4
	Else if (Type .eq. 2)Then   !  Format 2
	  Npoints = Npoints + 1
	  Nblocks(Npoints) = Hd(2) * 256 + Hd(1) + 1
	  Fblock(Npoints) = ((Hd(6) * 256 + Hd(5)) * 256 + Hd(4))
	1  * 256 + Hd(3)
	  Nbyts = 6
	Else if(Type .eq. 3)Then
	  Npoints = Npoints + 1
	  Nblocks(Npoints) = ((Hd(2)* 256 + Hd(1)) * 256 + Hd(4)) * 256
	1  + Hd(3) + 1
	  Fblock(Npoints) = ((Hd(8)*256 + Hd(7)) * 256 + Hd(6)) * 256
	1  + Hd(5)
	  Nbyts = 8
	End if
	Nwords = Nwords - Nbyts / 2
	Loc = Loc + Nbyts
	If(Nwords .gt. 0)Then
	  Go to 10
	End if
	Flag = 0
	Return
	End

	Subroutine Rdblok(Block,Data)
      IMPLICIT INTEGER*4 (A-Z)
	Byte Data(512)
	Logical Failure
      INTEGER*2 STATUS(4)
      INTEGER*4 DEVDEPINF
      INTEGER*2 NUMBYTES, QIOSTAT
      EQUIVALENCE (STATUS(1),QIOSTAT)
      EQUIVALENCE (STATUS(2),NUMBYTES)
      EQUIVALENCE (STATUS(3),DEVDEPINF)
	Data First /0/
	If(First .eq. 0)Then
      SUCC = SYS$ASSIGN('WIPED',CHAN,,)
      IF(FAILURE(SUCC,'ASSIGN FAILURE'))TYPE*,CHAN
	First = 1
	End if
C
C	33 IS IO$_READLBLK - READ LOGICAL
C
      SUCC = SYS$QIOW(%VAL(1),%VAL(CHAN),%VAL(33),STATUS,,,
     +Data,%VAL(512),%VAL(Block),,,)
      IF(FAILURE(SUCC,'QIO FAILURE'))TYPE*,CHAN
	Succ = Iand(Qiostat, 'FFFF'x)
	If(Failure(Succ, 'Qio failure in Rdblok.'))Stop
C     WRITE(6,10001)QIOSTAT, NUMBYTES, DEVDEPINF
C0001 FORMAT(1X,'QIOSTAT IS',Z4,'NUMBYTES IS ',I4,
C    +'DEVDEPINF IS',Z8)
	Return
      END

      LOGICAL FUNCTION FAILURE(SUCC, ERRMSG)
      IMPLICIT INTEGER*4 (A-Z)
      CHARACTER* (*) ERRMSG
      CHARACTER*60  MSG
      FAILURE = .FALSE.
      IF(SUCC .EQ. 0 .OR. SUCC .EQ. 1)RETURN
      FAILURE = .TRUE.
      IF(LEN(ERRMSG) .GT. 1)TYPE 1,ERRMSG(1:LEN(ERRMSG)),SUCC
      STAT=SYS$GETMSG(%VAL(SUCC), LENGTH, MSG, %VAL(15), )
      IF(STAT .NE. 1)RETURN
      TYPE 2, MSG(1:LENGTH)
1     FORMAT(1X,A,'.  (CODE=',Z')')
2     FORMAT(1X,A)
      RETURN
      END

	Subroutine Wrblok(Block,Data, Nbytes,OCHAN,O_EFN)
      IMPLICIT INTEGER*4 (A-Z)
	Integer*4 Chan, Block, OCHAN, O_EFN
	Logical Failure
	Byte Data(512)
      INTEGER*2 STATUS(4)
      INTEGER*4 DEVDEPINF
      INTEGER*2 NUMBYTES, QIOSTAT
      EQUIVALENCE (STATUS(1),QIOSTAT)
      EQUIVALENCE (STATUS(2),NUMBYTES)
      EQUIVALENCE (STATUS(3),DEVDEPINF)
c ...		'30'x is Io$_Writevblk
      SUCC = SYS$QIOW(%VAL(O_EFN),%VAL(OCHAN),%VAL('30'x),STATUS,,,
     +Data,%VAL(Nbytes),%VAL(Block),,,)
      IF(FAILURE(SUCC,'QIO FAILURE IN Wrblok'))TYPE*,OCHAN
	Succ = Iand(Qiostat, 'FFFF'x)
	If(Failure(Succ,' Qio failure in Wrblok.'))Stop
	Return
	End