PROGRAM ISIS
	LOGICAL*1 END
	BYTE FILE(6), EXT(3), LINE(10), BLOCK(128)
	INTEGER*2 ATTRIB, STRSCT, STRTRK, LINK(2,62)
	INTEGER*2 TRACK, SECTR, BYTES
	LUNFIL=2
	LUNFLP=4
	TYPE *,'FLOPPY DRIVE'
	ACCEPT *,IDRV
	CALL ASNLUN(LUNFLP,'DX',IDRV)
	TYPE *,'ENTER FILE NAME'
	READ(5,1000)N,(LINE(I),I=1,N)
	DO 5,I=1,N
	IF(LINE(I).EQ.'.')GO TO 6
	FILE(I)=LINE(I)
5	CONTINUE
6	CONTINUE
	DO 7,J=I+1,N
	EXT(J-I)=LINE(J)
7	CONTINUE
	OPEN(UNIT=LUNFIL,FILE=LINE,STATUS='NEW'
	1,CARRIAGECONTROL='LIST',DISPOSE='DELETE')
	CALL GTFDAT(FILE,EXT,STRSCT,STRTRK,LASBYT,NUMBLK,ATTRIB,IERR)
	ITOTBL=NUMBLK
	IF(IERR.NE.1)THEN
		WRITE(5,*)'FILE NOT FOUND'
		CLOSE(UNIT=2,DISPOSE='DELETE')
		CALL EXIT
	END IF
	LNKSEC=STRSCT-1
	LNKTRK=STRTRK
	IF(LNKSEC.LT.0)THEN
		LNKSEC=26
		LNKTRK=STRTRK-1
	END IF
50	CONTINUE
D	TYPE *,'LNKSEC,LNKTRK,NUMBLK',LNKSEC,LNKTRK,NUMBLK
	CALL GETLNK(LINK,LNKSEC,LNKTRK,NUMBLK,IERR)
	IF(NUMBLK.LT.0)IFIN=-NUMBLK
	IF(NUMBLK.GE.0)IFIN=62
D	TYPE *,'NUMBLK',NUMBLK
	DO 10,I=1,IFIN
	TRACK=LINK(2,I)
	SECTR=LINK(1,I)
D	TYPE *,'TRACK/SECTR=',TRACK,SECTR
	CALL RDBLK(BLOCK,SECTR,TRACK,IERR)
D	TYPE *,'BEFORE RECOUT',IERR
	BYTES=128
	IF(I.EQ.-NUMBLK)BYTES=LASBYT
10	CALL RECOUT(BLOCK,BYTES,LUNFIL,END)
	IF(.NOT.END)GOTO 50
	WRITE(5,*)'FILE COPIED'
	CLOSE(UNIT=2,DISPOSE='SAVE')
	CALL EXIT
1000	FORMAT(Q,80A1)
	END
	SUBROUTINE GTFDAT(FILE, EXT, STRSCT, STRTRK, LASBYT,
	1NUMBLK, ATTRIB, IERR)
C
C	THIS SUBROUTINE WILL SEARCH THE ISIS DIRECTORY FOR THE
C	GIVEN FILE AS STORED IN FILE AND EXT. IF FOUND THE STARTING
C	SECTOR AND STARTING TRACK ARE RETURNED AS WELL AS THE
C	LAST BYTE IN LAST BLOCK AND NUMBER OF BLOCKS FOR THIS FILE
C	THE ATTRIBUTES ARE ALSO RETURNED.  IF THE FILE IS NOT FOUND
C	THE IERR CODE IS -1
C
	PARAMETER (MAXBLK=2001)
	PARAMETER (MAXBYT=128)
C 
	BYTE DIRBLK(MAXBYT), DIRENT(16,8), FILE(6), EXT(3)
	INTEGER*2 DIRUSG, DIRNAM, DIREXT, DIRATR, DIRNBY, DIRNBL
	INTEGER*2 DIRTRK, STRSCT, STRTRK, ATTRIB, DIRSEC, NUMBLK
	INTEGER*2 LASBYT, DIRSCT
	LOGICAL*1 FOUNDF
	EQUIVALENCE (DIRBLK(1),DIRENT(1,1))
	DATA DIRUSG/1/DIRNAM/2/DIREXT/8/DIRATR/11/DIRNBY/12/DIRNBL/13/
	DATA DIRSCT/15/DIRTRK/16/
	IERR=1
	STRSCT=0
	STRTRK=0
	LASBYT=0
	NUMBLK=0
	MAXDIR=25
	DIRSEC=1
5	IF(DIRSEC.GT.MAXDIR)GO TO 900
	CALL RDBLK(DIRBLK,DIRSEC,1,IERR)
D	TYPE *,'READING DIRECTORY',IERR
	IF(DIRENT(DIRUSG,1).EQ.'177'O)GO TO 900
	DO 10,I=1,8
	  IF(DIRENT(DIRUSG,I).EQ.0)THEN
		DO 11,J=1,6
		  IF(DIRENT(DIRNAM+J-1,I).NE.FILE(J))GO TO 10
11		CONTINUE
		DO 12,J=1,3
		  IF(DIRENT(DIREXT+J-1,I).NE.EXT(J))GO TO 10
12		CONTINUE
		LASBYT=DIRENT(DIRNBY,I)
		NUMBLK=DIRENT(DIRNBL,I)
		STRSCT=DIRENT(DIRSCT,I)
		STRTRK=DIRENT(DIRTRK,I)
		ATTRIB=DIRENT(DIRATR,I)
		IF(LASBYT.LT.0)LASBYT=LASBYT+256
		IF(NUMBLK.LT.0)NUMBLK=NUMBLK+256
		IF(STRSCT.LT.0)STRSCT=STRSCT+256
		IF(STRTRK.LT.0)STRTRK=STRTRK+256
		IF(ATTRIB.LT.0)ATTRIB=ATTRIB+256
D	TYPE *,'#LB,NB,S,T,A',LASBYT,NUMBLK,STRSCT,STRTRK,ATTRIB
		RETURN
	  END IF
	  IF(DIRENT(DIRUSG,I).EQ.'177'O)GO TO 900
10	CONTINUE
	DIRSEC=DIRSEC+1
	GO TO 5
900	IERR=-1
	RETURN
	END
	SUBROUTINE GETLNK(LINK,LNKSEC,LNKTRK,NUMBLK,IERR)
C
C	SUBROUTINE LINK WILL USE THE SECTOR GIVEN AS THE 
C	SECTOR AND TRACK WHERE THE POINTERS ARE STORED FOR THIS
C	62 OR LESS SECTION OF THE FILE.  LNKTRK AND LNKSEC ARE
C	UPDATED FOR THE NEXT BLOCK OF POINTERS.  NUMBLK IS
C	ALSO UPDATED FOR THE NUMBER OF BLOCKS LEFT TO SEEK.
C	IERR IS RETURNED FOR ERROR CODES.
C	LINK IS RETURNED AS A ARRAY OF FILE SECTOR/TRACK PAIRS.
C
	DIMENSION LINK(2,62)
	BYTE BLOCK(128)
	IERR=0
	CALL RDBLK(BLOCK,LNKSEC,LNKTRK,IERR)
D	TYPE *,'IN LINK',IERR
	IEND=126
	IF(NUMBLK.LT.62)IEND=NUMBLK * 2 + 2
	IF(IERR.NE.1)GO TO 900
	LINK(1,1)=LNKSEC+1
	LINK(2,1)=LNKTRK
	IF(LNKSEC.GT.26)THEN
		LINK(1,1)=0
		LINK(2,1)=LNKTRK+1
	END IF
	DO 10,J=5,IEND,2
	LINK(1,(J/2))=BLOCK(J)
	LINK(2,(J/2))=BLOCK(J+1)
10	CONTINUE
	IF(BLOCK(3).NE.0.AND.BLOCK(4).NE.0)THEN
		LNKTRK=BLOCK(4)
		LNKSEC=BLOCK(3)-1
	END IF
	IF(NUMBLK.GT.62)THEN
		NUMBLK=NUMBLK-62
	ELSE
		NUMBLK=-NUMBLK
	END IF
	RETURN
900	IERR=-2
	RETURN
	END
	SUBROUTINE RDBLK(ARRAY,SCTR,TRK,IERR)
C
C	THIS SUBROUTINE WILL READ THE GIVEN TRACK AND SECTOR
C	AND FILL THE BYTE ARRAY WITH THE CONTENTS.
C
	PARAMETER (MAXBYT=128)
	INTEGER*2 TRK, SCTR, BLOCK
	BYTE ARRAY(MAXBYT), AARRAY(MAXBYT), IOCODE(2), ISSUC
	DIMENSION ISB(2), IPRM(6)
	EQUIVALENCE (IARRAY,AARRAY(1))
	EQUIVALENCE (IOCODE(1),ISB(1))
	IERR=1
	IORPB='1040'O			!read physical block for RX01 floppies
	ISSUC=1				!sucess error code
	IOWPB='0440'O			!write physical block for RX01 floppies
	LUN=4				!logical unit number for floppies QIO
	IEFN=4				!event flag number for floppies QIO
	IPRM(2)=MAXBYT			!block size on floppies
	CALL GETADR(IPRM(1),IARRAY)	!find address of array for QIO
	IF(SCTR.GT.26)GO TO 20
	IF(TRK.GT.77)GO TO 20
	IF(SCTR.LT.0.OR.TRK.LT.0)GO TO 20
	BLOCK = SCTR + 26 * TRK		!get physical block
	IPRM(5)=BLOCK					!block for QIO
	CALL WTQIO(IORPB,LUN,IEFN,,ISB,IPRM,IDS)	!issue QIO
	IF(IDS.NE.ISSUC)GO TO 30			!QIO issued ok?
	IF(IOCODE(1).NE.ISSUC)GO TO 40			!QIO compleated ok?
	DO 10,I=1,128
	ARRAY(I)=AARRAY(I)
10	CONTINUE
	RETURN
20	IERR=-1					!INVALID TRK AND/OR SECTR
	RETURN
30	IERR=-2					!DIRECTIVE FAILURE
	RETURN
40	IERR=-3					!QIO FAILURE
	RETURN
	END
	SUBROUTINE RECOUT(ARRAY,BYTES,LUN,END)
C
C	SUBROUTINE RECOUT TAKES THE GIVEN 128 BYTE ARRAY AND TRANSLATES IT
C	TO INDIVIDUAL RECORDS TO BE WRITEN TO LUN 2.  IF END IS FOUND
C	(NULL FOLLOWS CARRIAGE RETURN LINE FEED) THEN END IS SET TO
C	BE TRUE.
C	ISIS BLOCKS THEIR BLOCKS WITH THE RECORDS DELIMITED BY ^M ^I
C	THUS THE NORMAL VARIABLE RECORD LENGTH IS NOT USED (NUMBER
C	OF BYTES TO FOLLOW WRITTEN IN THE FIRST BYTE).
C
	LOGICAL*1 END
	BYTE ARRAY(128), RECORD(132)
	INTEGER*2 BLOCK, BYTES
	END = .FALSE.
	DO 400,I=1,BYTES
	IF(ARRAY(I).EQ.'12'O)GO TO 400	!ignore line feeds
	IF(ARRAY(I).EQ.'15'O)THEN	!return means end of record
		WRITE(LUN,1390)(RECORD(J),J=1,RECL)
		RECL=0
		GO TO 400
	END IF
	RECL=RECL+1
	RECORD(RECL)=ARRAY(I)
400	CONTINUE
	IF(BYTES.NE.128)END = .TRUE.
	RETURN
1390	FORMAT(132A1)
	END