FTN4,L,C
      PROGRAM MFGET(3,90),24999-16301 REV.2024 11-20-79 
C 
C 
C     THIS PROGRAM ALLOWS ALL OR PART OF THE FILES SAVED
C     IN "JSAVE" FORMAT TO BE ADDED TO AN EXISTING FMP DISC,
C     WITHOUT AFFECTING THE OTHER FILES ON THAT DISC. 
C     IT IS INTENDED FOR USE IN THOSE INSTANCES WHERE A HALF-DOZEN OR 
C     MORE FILES ARE REQUIRED(CASES FOR WHICH USE OF 'FGETR' IS 
C     INCONVENIENT OR TOO TIME-CONSUMING).
C 
C 
C     THE DIRECTORY TRACK(S) ON THE MAG TAPE ARE READ AND STORED
C     ON "SCRATCH" DISC TRACKS.  THE USER IS GIVEN AN OPPORTUNITY TO
C     DELETE THE ENTRIES FOR FILES HE DOES NOT WANT TO ADD TO 
C     THE DISC.  ENTRIES MAY BE DELETED INDIVIDUALLY, OR "DELETE ALL
C     ENTRIES UP TO BUT NOT INCLUDING" A GIVEN FILE NAME.  AN INDIVIDUAL
C     ENTRY MAY BE RENAMED. 
C 
C     COMMANDS ARE: 
C 
C     DL[,LU]       DIRECTORY LISTING(DEFAULT LU = TERMINAL)
C     PU,NAME       DELETE FILE NAME FROM DIRECTORY 
C     DELETE,NAME[,EXT#]   MARK ALL FILES IN DIRECTORY UP THRU BUT
C                          NOT INCLUDING 'NAME', SO THAT THE PASSED-OVER
C                          FILES WILL NOT BE ADDED TO THE FILE SYSTEM 
C                          WHEN THE 'ADD' COMMAND IS USED.
C                          A FILE EXTENT NUMBER MAY OPTIONALLY BE SPECIFIED.
C                          THE DEFAULT IS ZERO. 
C 
C     RN,OLDNAM,NEWNAM  CHANGE THE NAME OF A FILE, SO THAT WHEN IT
C                   IS ADDED TO THE EXISTING DISC, IT WILL HAVE A NEW 
C                   NAME. 
C     ADD[,SC[,CR]]    ALL FILES NOT EXPLICITLY EITHER PURGED OR
C                   REMOVED VIA THE "MARK" COMMAND WILL 
C                   BE ADDED TO THE EXISTING FILE SYSTEM. 
C                   <SC> SPECIFIES THE FILE SECURITY CODE. IF 
C                   DEFAULTED, THEN THE ORIGINAL SECURITY CODE OF 
C                   THE FILE AS SAVED ON TAPE WILL BE USED. 
C                   IF ZERO IS SPECIFIED, THEN NO SECURITY CODE 
C                   WILL BE USED. 
C                   <CR> SPECIFIES THE CARTRIDGE REFERENCE NUMBER.  DEFAULTING
C                   THIS PARAMETER ALLOWS THE FILES TO BE ADDED ANYWHERE
C                   THERE IS ENOUGH ROOM. 
C 
C     MA,NAME       SET A FLAG SO 'NAME' WON'T BE 
C                   TAKEN WHEN 'ADD' COMMAND IS ISSUED. 
C                   NOTE: THIS IS NOT THE SAME AS A 'PURGE' 
C                   BECAUSE THE FLAG CAN BE CLEARED LATER.
C                   USE MA,------ TO MARK ALL FILES, THEN CLEAR THE FLAGS ON
C                   SPECIFIC FILES BY NAME. 
C     CL,NAME       CLEAR THE "DON'T TAKE" FLAG FROM FILE.
C 
C     EX            END 
C     END           END 
C     /E            END 
C 
C                   NOTE: THE MINUS SIGN (-) MAY BE USED AS A 
C                   "MATCH ANYTHING" CHARACTER IN A FILE NAME, A LA FMGR
C                   'DL' COMMAND, EXCEPT THAT IT ALSO MATCHES BLANKS. 
C 
C 
C 
C                   REQUIRES TWO SUBROUTINES: 
C                   IFENT & ASCII.  IFENT SEARCHES THE
C                   CURRENT COPY OF THE 'DIRECTORY', STORED ON
C                   "SCRATCH" DISC TRACKS, FOR A MATCH
C                   TO A GIVEN FILE <NAMR>, RETURNING THE 
C                   POSITION IF FOUND, OR ZERO.  FOR A DESCRIPTION
C                   OF ARGUMENTS, SEE ITS LISTING.
C                   ASCII DOES A BINARY-TO-ASCII CONVERSION 
C                   WITH LEADING ZEROS LEFT. THE ROUTINE IS CODED IN
C                   ASSEMBLY.  THE CALLING SEQUNCE IS 
C                   CALL ASCII(I,J,K) 
C 
C                   I IS THE BINARY NUMBER
C                   J IS THE ADDRESS OF THE RESULT (3 WORDS)
C                   K IS THE BASE WE WANT THE RESULT IN 
C 
C 
C     7-2-79 LAW MODIFIED TO ADJUST FOR SHORT (<96 SECTOR) TRACKS 
C 
C     11-20-79 LAW MODIFIED TO HANDLE DISCS WHERE THE DIRECTORY 
C              TRACKS HAVE MORE SECTORS ON THEM THAN THE
C              SCRATCH TRACKS.
      DIMENSION ID(144),LT(40)
      DIMENSION LU(5),IREG(2),MBUF(30),IPBUF(33),IMBUF(33)
      DIMENSION IBUF(8193),JBUF(14000B),IANS(2) 
      DIMENSION MESS1(9),MESS2(9),MESS3(26),MESS4(12) 
      DIMENSION MESS5(13) 
      DIMENSION MESS6(11) 
      DIMENSION MES10(10),MES11(10) 
      DIMENSION MES12(6),LIN(25),LIN1(5)
      DIMENSION LIN2(35)
      LOGICAL IFEXI 
      INTEGER FILE,DELTF
      INTEGER SCRT1,SCRL1,TTRK,SCRLU,SCRTRK 
      INTEGER SCODE 
      INTEGER ITYPE(2)
      INTEGER CRN 
      INTEGER SECBUF(128) 
      INTEGER SECTOR
C                   NOTE: THE DIMENSION OF ARRAYS 
C                   'LUDISC', 'TRACKS', 'TRAK2' AND 'LU2TK' DEFINE
C                   LIMITS ON THE NUMBER OF DIRECTORY TRACKS WHICH
C                   CAN BE HANDLED.  TO ALLOW MORE, 
C                   INCREASE THE DIMENSIONS OF THESE ARRAYS 
C                   AND CHANGE THE INITIALIZATION VALUE OF
C                   'MAXDIR'. 
C 
      INTEGER LUDISC(5),LU2TK(5)
      INTEGER TRACKS(5),TRAK2(5)
C 
      EQUIVALENCE (IPBUF(2),IPBUF2), (IPBUF(6),IPBUF6)
      EQUIVALENCE (IPBUF(5),IPBUF5) 
      EQUIVALENCE (IPBUF(10),IPBF10)
      EQUIVALENCE (IA,IREG),(IB,IREG(2)),(X,IREG) 
      EQUIVALENCE (JBUF,IBUF(2))
      EQUIVALENCE (MBUF,IMBUF(2)) 
C 
C                   DEFINE MAXIMUM # DIRECTORY TRACKS ALLOWED.
      DATA MAXDIR/5/
C                   DEFINE SECTOR-SKIPPING VALUE
      DATA NSKIP/14/
C                   DEFINE TRACK LENGTH 
      DATA JLNTH/8192/
      DATA IMBUF/6412B/,IMBUF(32)/2H ?/,IMBUF(33)/2H _/ 
      DATA MESS1/6412B,2H  ,2HMA,2HG ,2HTA,2HPE,2H L,2HU:,2H _/ 
      DATA MESS2/2HFM,2HGR,2H E,2HRR,2H  /
      DATA MESS3/2HFI,2HLE,2H: ,0,0,0,2H :,0,0,0,2H :,0,0,0,0,2H :/ 
      DATA MESS4/2H  ,2HTH,2HAT,2H'S,2H N,2HOT,2H A,2H M,2HAG,2H T, 
     *2HAP,2HE!/
      DATA MESS5/2HTO,2HO ,2HMA,2HNY,2H D,2HIR,2HEC,2HTO,2HRY 
     &,2H T,2HRA,2HCK,2HS!/ 
      DATA MESS6/2H  ,2HMA,2HX ,2H= ,2H50,2H, ,2HMI,2HN ,2H= ,2H1!/ 
      DATA MES10/6412B,2H  ,2HMA,2HG ,2HTA,2HPE,2H F,2HIL,2HE:,2H _/
      DATA MES11/2H F,2HIL,2HE ,2HCR,2HEA,2HTI,2HON,2H E,2HRR,2HOR/ 
      DATA MES12/6412B,2H  ,2HCO,2HMM,2HAN,2HD?/
      DATA LIN/2H  ,2HNA,2HME,2H  ,2H T,2HYP,2HE ,
     *2H#B,2HLK,2HS/,2HLU,2H S,2HCO,2HDE,2H T,2HRA, 
     *2HCK,2H S,2HEC,2H  ,2HOP,2HEN,2H T,2HO /
      DATA LIN1/2H  ,2HCR,2H,3*2H  /
      DATA LIN2/2H  ,2H I,2HLA,2HB=,3*2H  ,2H N,2HXT,2HR=,
     *2*2H  ,2H N,2HXS,2HEC,2*2H  ,2H #,2HSE,2HC/,2HTR,2*2H  ,
     *2H L,2HAS,2HT ,2HTR,2H= ,2*2H  ,2H #,2HDR,2H T,2HR=,2H  / 
C 
      DATA ICLS/0/
C 
      CALL RMPAR(LU)
      IF(LU.LT.1)LU=1 
      LUTTY=LU+400B 
C 
C   GET  MAG TAPE LU
C 
10    CALL REIO(2,LUTTY,MESS1,9)
      X=REIO(1,LUTTY,MBUF,10) 
      CALL PARSE(MBUF,IB*2,IPBUF) 
      MTLU=IPBUF(2) 
C 
      CALL EXEC(13,MTLU,ISTAT)
C                   CHECK DEVICE TYPE 
      IF(IAND(ISTAT,37400B)*2.EQ.23000B)GO TO 14
C                   THAT'S NOT A MAG TAPE!
      CALL REIO(2,LUTTY,MESS4,12) 
      GO TO 10
C 
14    REWIND MTLU 
      FILE=1
C 
C                   FIND OUT THE FILE NUMBER TO USE.
C 
21    CALL REIO(2,LUTTY,MES10,10) 
      X=REIO(1,LUTTY,MBUF,10) 
      CALL PARSE(MBUF,IB*2,IPBUF) 
      NFILE=IPBUF(2)
      IF((NFILE.GT.0).AND.(NFILE.LE.50))GO TO 22
      CALL REIO(2,LUTTY,MESS6,11) 
      GOTO 21 
C 
C   POSITION THE TAPE 
C 
22    DELTF=NFILE-FILE
      IF(DELTF.EQ.0)GO TO 30
C 
      ICON=MTLU+1300B 
      IF(DELTF.GT.0)GO TO 23
      DELTF=-DELTF
      ICON=MTLU+1400B 
C 
23    DO 24 I=1,DELTF 
      CALL EXEC(19,ICON,II,ICLS)
      CALL EXEC(21,ICLS,II,JJ,KK,LL)
24    CONTINUE
C 
      IF(ICON.LT.1400B)GO TO 30 
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,MTLU+1300B) 
C 
C   GET HEADER AND CHECK IF THAT'S WHAT HE WANTS
C 
30    FILE=NFILE+1
      CALL REIO(1,MTLU,MBUF,30) 
31    CALL EXEC(2,LUTTY,IMBUF,33) 
      CALL REIO(1,LUTTY,IANS,2) 
      IF(IANS.EQ.2HYE)GO TO 40
      IF(IFEXI(IANS)) GOTO 100
      IF(IANS.NE.2HNO)GO TO 31
      FILE=FILE-1 
      CALL EXEC(3,MTLU+1400B) 
      CALL EXEC(3,MTLU+1300B) 
      GO TO 21
C 
C 
C 
C 
C                   THE TAPE IS POSITIONED SO THAT THE
C                   FIRST RECORD CONTAINS THE FIRST DIRECTORY 
C                   TRACK.
C                   READ THEM IN AND STORED THEM ON 
C                   "SCRATCH" TRACKS. 
C 
40    CONTINUE
C                   NOTE: JTRACK = INDEX INTO ARRAY OF SCRATCH TRACKS 
C                   WHERE THE DIRECTORY TRACKS READ FROM THE TAPE ARE 
C                   STORED. 
C                   TTRK = FLAG INDICATING WHEN THESE 
C                   DIRECTORY RECORDS ARE SO LARGE THAT 
C                   TWO TRACKS ARE REQUIRED (-1 WHEN SET, 
C                   ELSE 0) 
C                   JLS = LENGTH OF FIRST PORTION OF TRACK
C                          TO WRITE (LESSER OF: TAPE DIRECTORY RECORD LNTH, 
C                          OR SCRATCH TRACK SIZE, IN WORDS).
C                   JJX = SUBSCRIPT OF DIRECTORY TRACK ARRAY FOR WRITING
C                          2ND PORTION
C                   JLX  = LENGTH OF 2ND PORTION
C                   JSECT = NUMBER OF THE SECTOR IN THE TAPE RECORD 
C                           AT WHICH WE SWITCH OVER TO THE
C                           2ND PORTION OF THE SCRATCH AREA.
C 
      JTRACK = 1
      MR=0
42    M=1 
      ISEC=0
      JSEC=0
      JLS = JLNTH 
      TTRK = 0
C 
C 
C                   OBTAIN A DISC TRACK FOR "SCRATCH" USE 
C 
      CALL EXEC(4,1,SCRTRK,SCRLU,JSECT) 
415   CONTINUE
      CALL EXEC(1,MTLU,IBUF,JLNTH+1)
C                   CHECK THAT SCRATCH TRACK IS AT LEAST AS LARGE 
C                   AS THE DIRECTORY TRACK FROM THE TAPE. 
C                   IF NOT, GET ANOTHER TRACK.
      CALL ABREG(IA,IB) 
      JJ = JSECT * 64 
      IF ( JJ .GE. IB) GOTO 420 
C                   SCRATCH TRACK IS SHORTER.  GET ANOTHER ONE. 
      CALL EXEC(4,1,SCRT1,SCRL1,ISEC1)
      TTRK = -1 
      JLS = JJ
      JJX = JJ + 1
      JLX = IB - JJ 
C 
C 
420   CONTINUE
C                   IF MAG TAPE RECORD IS SMALLER THAN THE SIZE OF THE
C                   BUFFER WE HAVE ALLOCATED, ADJUST ACCORDINGLY. 
C 
      IB = IB -1
      IF(IB .LT. JLNTH) JLNTH = IB
C                   OBTAIN A DISC TRACK, AND COPY DIRECTORY THERE.
C                   AGAIN, IF TRACKS ARE TWO SHORT, GET ANOTHER.
      CALL EXEC(4,1,TRACKS(JTRACK),LUDISC(JTRACK),ISECT)
      CALL EXEC(2,LUDISC(JTRACK),JBUF,JLS,TRACKS(JTRACK),0) 
      IF(TTRK) 423, 424 
423   CONTINUE
      CALL EXEC(4,1,TRAK2(JTRACK),LU2TK(JTRACK),ISECT)
      CALL EXEC(2,LU2TK(JTRACK),JBUF(JJX),JLX,TRAK2(JTRACK),0)
C 
424   CONTINUE
C                   IF THIS IS THE FIRST DIRECTORY TRACK, 
C                   THEN THE FIRST 16 WORDS ARE THE 
C                   PACK LABEL INFORMATION. 
      IF(JTRACK .NE. 1) GOTO 425
      NDIREC = -JBUF(9) 
C                   PROTECT AGAINST TOO MANY DIRECTORY TRACKS 
      IF(NDIREC .GT. MAXDIR) GOTO 979 
      NDSPT = JBUF(7) 
      NDBPT = NDSPT/2 
      LTRK = JBUF(5)
425   CONTINUE
      JTRACK = JTRACK + 1 
      IF(JTRACK .LT. (NDIREC+1)) GOTO 415 
      LTRACK = LTRK -1
C 
C 
C 
C 
C     ********************************************************************
C 
15    CONTINUE
      ISEC = 0
      JSEC = 0
      CALL REIO(2,LUTTY,MES12,6)
      CALL REIO(1,LUTTY,IBUF,-80) 
      CALL ABREG(IA,IB) 
      CALL PARSE(IBUF,IB,IPBUF) 
C 
C                   GOTO COMMAND PROCESSOR
C 
      IF(IPBUF2 .EQ. 2HDL) GOTO 2000
      IF(IPBUF2 .EQ. 2HAD) GOTO 3000
      IF(IPBUF2 .EQ. 2HPU) GOTO 4500
      IF(IPBUF2 .EQ. 2HDE) GOTO 5000
      IF(IPBUF2 .EQ. 2HSK) GOTO 5500
      IF(IPBUF2 .EQ. 2HCL) GOTO 5700
      IF(IPBUF2 .EQ. 2HMA) GOTO 5800
      IF(IPBUF2 .EQ. 2HMK) GOTO 5800
      IF(IPBUF2 .EQ. 2HRN) GOTO 4000
      IF(IPBUF2 .EQ. 2H??) GOTO 9000
C                   CHECK FOR END 
      IF(IFEXI(IPBUF2)) GOTO 100
      ASSIGN 989 TO IFRMT 
      CALL MSGFR(IFRMT,LUTTY) 
      GOTO 15 
C                   TOO MANY DIRECTORY TRACKS 
979   CONTINUE
      CALL EXEC(2,LUTTY,MESS5,13) 
      GOTO 100
989   FORMAT("ILLEGAL COMMAND. USE ?? TO GET HELP") 
C 
C 
C     *********  DIRECTORY LISTING
C 
2000  CONTINUE
      ISEC = 0
C 
      LIST = IPBUF6 
      IF(LIST .LT. 1) LIST = LUTTY
C 
C                   READ DIRECTORY FROM "SCRATCH" TRACKS
C 
      DO 2113 JJ = 1,NDIREC 
      M = 1 
      CALL RDIRC(LUDISC,LU2TK,TRACKS,TRAK2,JJ,JBUF,TTRK,JJX,JLS,JLX)
      IF(JJ .NE. 1) GOTO 2045 
C 
C                   LIST CARTRIDGE INFORMATION FIRST
C 
      M = 17
      CALL ASCII(JBUF(4),LIN1(3),10)
      LIN1(3)=IAND(LIN1(3),177B)+36400B 
      CALL EXEC(3,1100B+LIST,-1)
      CALL EXEC(2,LIST,LIN1,5)
      LIN2(5)=IAND(JBUF(1),77777B)
      LIN2(6)=JBUF(2) 
      LIN2(7)=JBUF(3) 
      CALL ASCII(JBUF(10),MBUF,10)
      LIN2(11)=MBUF(2)
      LIN2(12)=MBUF(3)
      CALL ASCII(JBUF(6),MBUF,10) 
      LIN2(16)=IAND(MBUF(2),177B)+36400B
      LIN2(17)=MBUF(3)
      CALL ASCII(JBUF(7),MBUF,10) 
      LIN2(22)=IAND(MBUF(2),177B)+36400B
      LIN2(23)=MBUF(3)
      IA=JBUF(8)-JBUF(9)-1
      CALL ASCII(IA,MBUF,10)
      LIN2(29)=MBUF(2)
      LIN2(30)=MBUF(3)
      CALL ASCII(NDIREC,MBUF,10)
      LIN2(35)=MBUF(3)
      CALL REIO(2,LIST,LIN2,35) 
      CALL EXEC(3,1100B+LIST,1) 
      CALL EXEC(3,1100B+LIST,1) 
C 
C                   LIST INFORMATION FOR EACH FILE. 
C 
2045  DO 2103 N=M,128,16
C 
C                   COMPUTE THE FILE INFO OFFSET
C 
      MR=N+ISEC*64
C 
C                   IF ELEMENT = -1 FILE WAS PURGED IGNORE
C 
      IF(JBUF(MR).EQ.-1)GO TO 2103
C 
C                   IF = 0 END OF DIRECTORY GET OUT 
C 
      IF(JBUF(MR).EQ.0)GO TO 15 
C 
C                   DO DL FORMATTING STUFF
C 
      DO 193 IA=1,25
  193 LIN(IA)=2H
      LIN(2)=JBUF(MR) 
      LIN(3)=JBUF(MR+1) 
      LIN(4)=JBUF(MR+2) 
      CALL ASCII(JBUF(MR+3),LIN(5),10)
      IF(IAND(LIN(5),77400B).EQ.30000B)LIN(5)=IAND(LIN(5),177B) 
     1+20000B 
      IF(JBUF(MR+3).EQ.0)GO TO 236
      IA=JBUF(MR+6)/2 
      CALL ASCII(IA,LIN(8),10)
      IF(IAND(LIN(8),77400B).EQ.30000B)LIN(8)=IAND(LIN(8),177B) 
     1+20000B 
      CALL ASCII(JBUF(MR+4),LIN(15),10) 
      LIN(15)=20040B
      IA=IAND(JBUF(MR+5),377B)
      CALL ASCII(IA,MBUF,10)
      LIN(18)=MBUF(2) 
      IF(IAND(LIN(18),77400B).EQ.30000B)LIN(18)=IAND(LIN(18)
     1,177B)+20000B 
      LIN(19)=MBUF(3) 
      IA=0
      IF(JBUF(MR+5).LT.0)IA=200B
      IA=IA+IAND(77400B,JBUF(MR+5))/256 
      IF(IA.EQ.0)GO TO 237
      CALL ASCII(IA,MBUF,10)
      LIN(21)=IAND(MBUF(2),177B)+25400B 
      LIN(22)=MBUF(3) 
      GO TO 237 
  236 CALL ASCII(JBUF(MR+4),MBUF,10)
      LIN(10)=MBUF(3) 
  237 CALL ASCII(JBUF(MR+8),LIN(12),10) 
      IF(IAND(LIN(12),77400B).EQ.30000B)LIN(12)=IAND(LIN(12)
     1,177B)+20000B 
      IF(JBUF(MR+9) .LT. 0) LIN(25) = 2HDT
      CALL REIO(2,LIST,LIN,25)
C                   CHECK FOR 'BREAK' 
      IF(IFBRK(IA)) 15,2103 
C 
C 
C 
2103  CONTINUE
      M = 1 
C 
C 
      ISEC=MOD(ISEC+NSKIP,NDSPT)
      IF(ISEC .NE. 0) GOTO 2045 
2113  CONTINUE
      GOTO 15 
C 
C     ********************************************************************
C 
C     ADD ALL FILES NOT OTHERWISE REMOVED FROM THE 'DIRECTORY'
C     TO EXISTING FILE SYSTEM.
C 
C     ********************************************************************
3000  CONTINUE
      JOFF = 17 
      SCODE = IPBUF6
      CRN = IPBF10
C 
      DO 3390 I= 1, NDIREC
      SECTOR = 0
3005  CONTINUE
      JT = TRACKS(I)
      JLU = LUDISC(I) 
      JSCT = SECTOR 
C                   DO WE HAVE TO GO TO 2ND PORTION?
      IF(SECTOR .LT. JSECT) GOTO 3010 
C                   YES, WWITCH TO OTHER SCRATCH TRACKS,
C                   WHERE 2ND PORTION OF TAPE RECORD IS STORED. 
      JT = TRAK2(I) 
      JLU = LU2TK(I)
      JSCT = SECTOR - JSECT 
C 
3010  CONTINUE
      CALL EXEC(1,JLU,SECBUF,128,JT,JSCT) 
      DO 3300 K=JOFF,128,16 
C                   IGNORE NON-PURGED ENTRIES, TYPE-0 FILES,
C                   ENTRIES FOR EXTENTS, AND CHECK FOR END OF DIRECTORY.
C 
      IF(SECBUF(K) .EQ.  0) GOTO 15 
      IF(SECBUF(K+3) .LT. 1) GOTO 3300
      IF(IAND(SECBUF(K+5),177400B) .NE. 0) GOTO 3300
      IF(SECBUF(K) .EQ. -1) GOTO 3300 
      IF(SECBUF(K+9) .LT. 0) GOTO 3300
3020  CONTINUE
      IEXTNT = 0
      NSECS = SECBUF(K+6) 
      ITYPE=SECBUF(K + 3 )
      ITYPE(2)=SECBUF(K+7)
C 
C                   FIND ALL EXTENTS TO THIS FILE, SO 
C                   IT CAN BE CREATED WITH THE CORRECT SIZE.
C 
3030  CONTINUE
      IFLAG = 0 
      JFLAG = 0 
      IEXTNT = IEXTNT + 1 
      JK = IFENT(JBUF,SECBUF(K),TRACKS,LUDISC,NDIREC,IFLAG, 
     &NDSPT,IEXTNT,NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX)
      IF(JK .GT. 0) GOTO 3030 
C                   NOW, CALCULATE CORRECT FILE SIZE, 
C                   AND OBTAIN OTHER FILE INFORMATION 
      JBASE = ((NSECS+1)/2) 
      ISIZE = JBASE * IEXTNT
      KFTRAK = SECBUF(K+4)
      KFSEC = IAND(SECBUF(K+5),377B)
C 
C                   PRINT FILE NAME,SECURITY CODE, CR, TYPE, SIZE 
C 
      DO 3033 JJ = 0,2
3033  MESS3(JJ+4) = SECBUF(K+JJ)
      ISCODE = SCODE
      IF(IPBUF5 .EQ. 0) ISCODE = SECBUF(K+8)
      CALL ASCII(ISCODE,MESS3(8),10)
      CALL ASCII(CRN        ,MESS3(12),10)
      CALL ASCII(ITYPE      ,MESS3(17),10)
      MESS3(21) = 2H :
      CALL ASCII(ISIZE      ,MESS3(22),10)
      CALL EXEC(2,LUTTY,MESS3,26) 
C 
C                   CREATE THE FILE 
C 
C                   FILE TYPE & RECORD SIZE AS
C                   SPECIFIED IN PSEUDO-DIRECTORY 
C                   FILE SIZE AS DETERMINED BY SUM OF 
C                   # BLOCKS IN BASE FILE + ALL EXTENTS 
C 
C                   SECURITY CODE AS DETERMINED BY: 
C                     1) COMMAND, IF SPECIFIED
C                     2) OTHERWISE, FILE ENTRY IN PSEUDO-DIRECTORY
C 
      CALL CREAT(ID,IRE,SECBUF(K),ISIZE,ITYPE,ISCODE,CRN) 
      IF(IRE.GE.0)GO TO 3040
C 
C     THERE WAS A FILE CREATION ERROR.
C 
      CALL ASCII(IRE,MESS2(6),10) 
      CALL EXEC(2,LUTTY,MESS2,9)
      GOTO 3300 
C 
C                   CLOSE THE FILE SO WE CAN OPEN IT FOR UPDATE.
C 
3040  CONTINUE
      CALL CLOSE(ID)
      IEXTNT = 0
C 
C                   OPEN THE FILE AS TYPE ONE SO WE MAY JUST
C                   TRANSFER WHOLE RECORDS
C 
      CALL OPEN(ID,IRE,SECBUF(K),4,ISCODE,CRN)
C 
C 
C     DO WE WANT THIS RECORD? 
C 
3060  CONTINUE
      IF ( LTRACK .EQ. KFTRAK)  GO TO 3200
C                   IS PROPER RECORD FARTHER AHEAD ON TAPE? 
      IF(LTRACK .LT. KFTRAK) GOTO 3070
C                   MUST HAVE HAD TO READ AHEAD ON
C                   TAPE IN ORDER TO PICK UP EXTENTS. 
C                   BACKSPACE TAPE. 
3065  CONTINUE
      CALL EXEC(3,MTLU+200B)
3066  CONTINUE
      LTRACK = LTRACK - 1 
      CALL EXEC(3,MTLU+200B)
      IF(LTRACK .LT. KFTRAK) GOTO 3066
      GOTO 3071 
3070  CONTINUE
      LTRACK = LTRACK + 1 
3071  CONTINUE
      CALL EXEC(1,MTLU,IBUF,JLNTH+1)
      CALL WDIRC(SCRLU,SCRL1,SCRTRK,SCRT1,1,JBUF,TTRK,JJX,JLS,JLX)
      CALL EXEC(13,MTLU,ISTAT)
      IF(IAND(ISTAT,200B) .NE. 0) GOTO 3294 
      GOTO 3060 
C 
C 
C                   HAVE READ TRACK CONTAINING THE
C                   FIRST BLOCK OF FILE.
C                   CALCULTE OFFSET INTO FILE.
C 
3200  CONTINUE
      CALL RDIRC( SCRLU,SCRL1,SCRTRK,SCRT1,1,JBUF,TTRK,JJX,JLS,JLX) 
      IA=64*KFSEC+1 
C 
C                   TRANSFER THE CORRECT NUMBER OF SECTORS
      DO 3280 N=1,JBASE 
C                   CHECK FOR 'BREAK' 
      IF(IFBRK(JK)) 3294,3202 
3202  CONTINUE
      CALL WRITF(ID,IRE,JBUF(IA),128) 
      IA=IA+128 
C 
C                   END OF TRACK? 
C 
      IF(IA.LT.JLNTH)GO TO 3280 
C                   YES, READ NEXT TRACK
      LTRACK = LTRACK + 1 
      CALL EXEC(1,MTLU,IBUF,JLNTH+1)
      CALL WDIRC (SCRLU,SCRL1,SCRTRK,SCRT1,1,JBUF,TTRK,JJX,JLS,JLX) 
      CALL EXEC(13,MTLU,ISTAT)
      IF(IAND(ISTAT,200B).NE.0)GO TO 3294 
      IA=1
3280  CONTINUE
C                   SAVE CURRENT TRACK CONTENTS 
C                   SO DIRECTORY CAN BE SEARCHED FOR EXTENTS
      CALL WDIRC(SCRLU,SCRL1,SCRTRK,SCRT1,1,JBUF,TTRK,JJX,JLS,JLX)
3282  CONTINUE
      IEXTNT = IEXTNT + 1 
C                   IF THERE ARE ANY MORE EXTENTS, ADD THEM TO FILE.
      IFLAG = 0 
      JFLAG = 0 
      JK = IFENT(JBUF,SECBUF(K),TRACKS,LUDISC,NDIREC,IFLAG,NDSPT
     &,IEXTNT,NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX) 
      KFTRAK = JBUF(JK+4) 
      KFSEC = IAND(JBUF(JK+5),377B) 
C 
C                   NOW, RESTORE CURRENT TRACK BUFFER CONTENTS
C 
      CALL RDIRC (SCRLU,SCRL1,SCRTRK,SCRT1,1,JBUF,TTRK,JJX,JLS,JLX) 
      IF(JK .NE. 0) GOTO 3060 
3294  CALL CLOSE(ID)
3300  CONTINUE
      JOFF = 1
      SECTOR = MOD(SECTOR+NSKIP,NDSPT)
      IF(SECTOR .NE. 0) GOTO 3005 
C 
3390  CONTINUE
      GOTO 15 
C 
C     **************************************************************************
C 
C     RE-NAME AN ENTRY AND ALL OF ITS EXTENTS.
C 
C     **************************************************************************
C 
4000  CONTINUE
      IEXTNT = 0
4005  CONTINUE
      IFLAG = 0 
      JFLAG = 0 
      JK = IFENT(JBUF,IPBUF6,TRACKS,LUDISC,NDIREC,IFLAG,NDSPT,IEXTNT, 
     & NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX)
C                   DOES FILE EXIST?
      IF((JK .EQ. 0) .AND. (IEXTNT .EQ. 0)) GOTO 4520 
C                   YES. HAVE WE TRANSFERRED LAST EXTENT? 
      IF(JK .EQ. 0) GOTO 15 
C                   NO. RE-NAME FILE
      DO 4010 K = 1,3 
4010  JBUF(JK+K-1) = IPBUF(K+9) 
      CALL WDIRC(LUDISC,LU2TK,TRACKS,TRAK2,IFLAG,JBUF,TTRK,JJX,JLS,JLX) 
      IEXTNT = IEXTNT + 1 
      GOTO 4005 
C     *********************************************************************** 
C 
C       PURGE AN ENTRY FROM THE DIRECTORY 
C 
4500  CONTINUE
      JFL = 0 
4503  CONTINUE
      IEXTNT = IPBF10 
4505  CONTINUE
      IFLAG = 0 
      JFLAG = -1
      JK = IFENT(JBUF,IPBUF6,TRACKS,LUDISC,NDIREC,IFLAG,NDSPT,IEXTNT, 
     & NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX)
C                   DOES FILE EXIST?
      IF(JK .EQ. 0) GOTO 4515 
C                   'PURGE' THIS ENTRY. 
      JBUF(JK) = -1 
      JFL = 1 
      CALL WDIRC(LUDISC,LU2TK,TRACKS,TRAK2,IFLAG,JBUF,TTRK,JJX,JLS,JLX) 
      IEXTNT = IEXTNT + 1 
      GOTO 4505 
C 
C                   NO ENTRY FOUND. 
4515  CONTINUE
C                   WAS ANY ENTRY FOUND?
      IF((IEXTNT .EQ. 0) .AND. (JFL .EQ. 0)) GOTO 4520
      IF(IEXTNT .EQ. 0) GOTO 15 
      GOTO 4503 
4519  FORMAT("FILE NOT FOUND")
4520  CONTINUE
      ASSIGN 4519 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      GOTO 15 
C 
C     *************************************************************************** 
C 
C     DELETE ALL ENTRIES UP TO BUT NOT INCLUDING THE
C     GIVEN FILE. 
C 
C     *************************************************************************** 
C 
5000  CONTINUE
      IFLAG = -1
      JFLAG = 0 
      IEXTNT = IPBF10 
      JK =IFENT(JBUF,IPBUF6,TRACKS,LUDISC,NDIREC,IFLAG,NDSPT,IEXTNT,
     &NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX) 
      ASSIGN 5001 TO IFRMT
      IF(JK .EQ. 0) CALL MSGFR(IFRMT,LUTTY) 
      GOTO 15 
5001  FORMAT("WARNING: FILE NOT FOUND!")
C 
C     ******************************************************************
C 
C     SET A DIFFERENT SECTOR-SKIPPING VALUE 
C 
C     ******************************************************************
5500  CONTINUE
      NSKIP = IPBUF6
      IF(NSKIP .LT. 1) NSKIP = 14 
      GOTO 15 
C 
C     *********************************************************************** 
C 
C       CLEAR THE "DON'T TAKE" FLAG FROM AN ENTRY 
C 
5700  CONTINUE
      JFLAG = 1 
      JFL = 0 
5703  CONTINUE
      IEXTNT = IPBF10 
5705  CONTINUE
      IFLAG = 0 
      JK = IFENT(JBUF,IPBUF6,TRACKS,LUDISC,NDIREC,IFLAG,NDSPT,IEXTNT, 
     & NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX)
C                   DOES FILE EXIST?
      IF(JK .EQ. 0) GOTO 5715 
      JFL = 1 
      IEXTNT = IEXTNT + 1 
      GOTO 5705 
C 
5715  CONTINUE
C                   WAS ANY ENTRY FOUND?
      IF((IEXTNT .EQ. 0) .AND. (JFL .EQ. 0)) GOTO 4520
      GOTO 15 
C 
C     *********************************************************************** 
C 
C       MARK AN ENTRY AS "DON'T TAKE" 
C 
5800  CONTINUE
      JFL = 0 
      JFLAG = 2 
5803  CONTINUE
      IEXTNT = IPBF10 
5805  CONTINUE
      IFLAG = 0 
      JK = IFENT(JBUF,IPBUF6,TRACKS,LUDISC,NDIREC,IFLAG,NDSPT,IEXTNT, 
     & NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX)
C                   DOES FILE EXIST?
      IF(JK .EQ. 0) GOTO 15 
      IEXTNT = IEXTNT + 1 
      GOTO 5805 
C 
C 
C     *********************************************************************** 
C 
C     PROVIDE HELP FOR THE USER.
C 
C     ****************************************************************************
9000  CONTINUE
      ASSIGN 9901 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9902 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9903 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9904 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9905 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9906 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9907 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9908 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9909 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9910 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9911 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9912 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9913 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9914 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9915 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 99151 TO IFRMT 
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9916 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9917 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9918 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9919 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9920 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9921 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9922 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9923 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9924 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9925 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      ASSIGN 9926 TO IFRMT
      CALL MSGFR(IFRMT,LUTTY) 
      GOTO 15 
9901  FORMAT("COMMANDS ARE:") 
9902  FORMAT("DL[,LU]       DIRECTORY LISTING(DEFAULT LU = TERMINAL)")
9903  FORMAT("PU,NAME[,EXT#]   DELETE FILE NAME FROM DIRECTORY")
9904  FORMAT( 
     &"DELETE,NAME[,EXT#]   MARK ALL FILES IN DIRECTORY UP THRU BUT") 
9905  FORMAT("              NOT INCLUDING 'NAME' SO THAT THEY WILL")
9906  FORMAT("              NOT BE INCLUDED WHEN FILES ARE ADDED TO") 
9907  FORMAT("              EXISTING DISC.")
9908  FORMAT("RN,OLDNAM,NEWNAM  CHANGE THE NAME OF A FILE,")
9909  FORMAT("                  SO THAT WHEN IT IS ADDED TO THE") 
9910  FORMAT("                  EXISTING DISC, IT WILL HAVE A NEW") 
9911  FORMAT("                  NAME.") 
9912  FORMAT("ADD[,SC[,CR]] ALL FILES NOT EXPLICITLY EITHER PURGED")
9913  FORMAT("              OR REMOVED VIA THE 'DELETE' OR 'REMOVE'") 
9914  FORMAT("              COMMANDS WILL BE ADDED TO THE EXISTING")
9915  FORMAT("              FILE SYSTEM,WITH SECURITY CODE SC, ON") 
99151 FORMAT("              CARTRIDGE 'CR'.") 
9916  FORMAT("              DEFAULTING <CR> SPECIFIES THAT FILES MAY")
9917  FORMAT("              BE ADDED WHEREVER THERE IS ENOUGH ROOM.") 
9918  FORMAT("SK,N          SET # SECTORS SKIPPED IN DIRECTORY TO N") 
9919  FORMAT("              (DEFAULT IS 14, USABLE FOR MOST") 
9920  FORMAT("              DIRECTORIES)")
9921  FORMAT("MA,NAME       MARK FILE 'NAME' AS 'DON'T TAKE'")
9922  FORMAT("CL,NAME       CLEAR THE 'DON'T TAKE' FLAG FROM FILE") 
9923  FORMAT("              'NAME'")
9924  FORMAT("EX            END") 
9925  FORMAT("EN            END") 
9926  FORMAT("/E            END") 
C 
C                   FILE ERROR
C     REPORT ERROR NUMBER.
C
120   CALL ASCII(-IRE,MES11(11),10) 
      MES11(12)=26440B
      CALL REIO(2,LUTTY,MES11,13) 
C 
C 
C                   EXIT. 
C 
100   CONTINUE
      REWIND MTLU 
      END 
      FUNCTION IFEXI(IANS)
      LOGICAL IFEXI 
      IFEXI = .FALSE. 
      IF(IANS .EQ. 2HEX) IFEXI = .TRUE. 
      IF(IANS .EQ. 2HEN) IFEXI = .TRUE. 
      IF(IANS .EQ. 2H/E) IFEXI = .TRUE. 
      RETURN
      END 
      SUBROUTINE RDIRC(LUDISC,LU2TK,TRACKS,TRAK2,JJ,JBUF,TTRK,JJX,
     &JLS,JLX)
C 
C     SUBROUTINE TO READ DIRECTORY TRACKS FROM THE SCRATCH-TRACK
C     AREA OF THE DISC.  IF TTRK < 0, THEN TWO TRACKS ARE 
C     READ
C 
      INTEGER LUDISC(1),LU2TK(1),TRACKS(1),TRAK2(1),JBUF(8192), 
     &TTRK
C 
      CALL EXEC(1,LUDISC(JJ),JBUF,JLS,TRACKS(JJ),0) 
      IF(TTRK .GE. 0) RETURN
      CALL EXEC(1,LU2TK(JJ),JBUF(JJX),JLX,TRAK2(JJ),0)
      RETURN
      END 
      SUBROUTINE WDIRC(LUDISC,LU2TK,TRACKS,TRAK2,JJ,JBUF,TTRK,JJX,
     &JLS,JLX)
C 
C     SUBROUTINE TO WRITE DIRECTORY TRACKS BACK TO THE SCRATCH-TRACK
C     AREA OF THE DISC.  IF TTRK < 0, THEN TWO TRACKS ARE WRITTEN.
C 
      INTEGER LUDISC(1),LU2TK(1),TRACKS(1),TRAK2(1),JBUF(8192),TTRK 
      CALL EXEC(2,LUDISC(JJ),JBUF,JLS,TRACKS(JJ),0) 
      IF(TTRK .GE. 0) RETURN
      CALL EXEC(2,LU2TK(JJ),JBUF(JJX),JLX,TRAK2(JJ),0)
      RETURN
      END 
      END$
ASMB,L,C
      NAM ASCII        BINARY TO ASCII WITH ZEROS 
      ENT ASCII 
      EXT .ENTR 
A     EQU 0 
B     EQU 1 
NUM   NOP 
PUT   NOP 
E     NOP 
ASCII NOP 
      JSB .ENTR        GET CALLING PARMS
      DEF NUM 
      CLA 
      STA FLAG
      LDA DM3 
      STA CNT 
      LDA PUT          SAVE DESTINATION ADDRESS 
      ADA .2
      STA PUTT
      LDA NUM,I 
      STA NUMM
      LDA E,I 
      STA BASE
      CPA .8
      JMP LOP 
      LDA NUMM
      SSA,RSS 
      JMP LOP 
      CCB 
      CMA,INA 
      STA NUMM
      STB FLAG
LOP   LDA NUMM
      CLB 
      DIV BASE
      ADB B60 
      STB PUTT,I
      CLB 
      DIV BASE
      STA NUMM
      LDA B 
      ADA B60 
      ALF,ALF 
      IOR PUTT,I
      STA PUTT,I
      LDA PUTT
      ADA DM1 
      STA PUTT
      ISZ CNT 
      JMP LOP 
      LDA FLAG
      SZA,RSS 
      JMP ASCII,I 
      ISZ PUTT
      LDA B377
      AND PUTT,I
      IOR MIN 
      STA PUTT,I
      JMP ASCII,I 
CNT   NOP 
DM3   DEC -3
DM1   DEC -1
.2    DEC 2 
.8    DEC 8 
B60   OCT 60
B377  OCT 377 
MIN   OCT 26400 
BASE  NOP 
NUMM  NOP 
PUTT  NOP 
FLAG NOP
      END 
FTN4,L,C
      FUNCTION IFENT(IBUF,NAME,TRACKS,LUDISC,NDIREC,FLAG,NDSPT,IEXTNT,
     &NSKIP,JFLAG,TRAK2,LU2TK,TTRK,JJX,JLS,JLX),11-20-79
C 
C     FUNCTION TO FIND A DIRECTORY ENTRY WHICH MATCHES FILE 
C     "NAME". 
C 
C     TTRK = FLAG, INDICATING WHETHER THE SCRATCH TRACKS ARE
C            SUFFICIENT TO CONTAIN ALL OF ONE TAPE DIRECTORY
C            RECORD.  IF SO, TTRK = 0, ELSE -1 INDICATES
C            THAT 2ND PORTION IS STORED ON TRACKS AND 
C            LUS DESCRIBED BY TRAK2 & LU2TK, RESPECTIVELY.
C 
C     IBUF = TRACK BUFFER 
C 
C     NAME = 6-CHARACTER FILE NAME
C 
C     TRACKS = ARRAY CONTAINING TRACK ADDRESSES OF THE SCRATCH AREA 
C              WHERE THE DIRECTORY TRACKS ARE STORED.  IF THE ORIGINAL
C              TAPE RECORDS WERE LARGER THAN THE SCRATCH TRACKS,
C              THEN THIS IS THE AREA WHERE THE FIRST PORTION IS STORED. 
C 
C     LUDISC = ARRAY CONTAINING THE DISC LUS FOR 'TRACK'.  AGAIN, IF
C              THE SCRATCH TRACKS COULDN'T CONTAIN ALL OF THE DIRECTORY 
C              RECORDS, THEN THIS IS THE LU OF THE FIRST PORTION. 
C 
C     LU2TK = SAME AS 'LUDISC', BUT DESCRIBES 2ND PORTION OF
C             SCRATCH-TRACK AREA WHERE DIRECTORY RECORDS ARE
C             STORED. 
C 
C     TRAK2 = SAME AS 'TRACKS', BUT DESCRIBES 2ND PORTION OF
C             SCRATCH-TRACK AREA WHERE DIRECTORY RECORDS ARE STORED.
C 
C     NDIREC = NUMBER OF DIRECTORY TRACKS 
C 
C     FLAG   = -1 THEN ALL ENTRIES FOUND WHICH DO NOT 
C              COMPARE TO 'NAME' WILL BE 'PURGED'.
C            = 0  THEN DO NOT PURGE ENTRIES WHICH DO NOT MATCH. 
C 
C     NDSPT = NUMBER OF SECTORS PER TRACK ON DIRECTORY
C 
C     NSKIP = NUMBER OF SECTORS SKIPPED BETWEEN BLOCKS ON 
C             DIRECTORY.
C 
C     JJX = SUBSCRIPT OF ARRAY IN TRACK BUFFER WHERE
C           2ND PORTION BEGINS
C 
C     JLS = # WORDS IN FIRST PORTION OF TRACK BUFFER
C 
C     JLX = SIZE OF 2ND PORTION, IN WORDS 
C     JFLAG = CONTROL FLAG: 
C                   IF # 0 THEN IGNORE ALL ENTRIES WITH 
C                   THEIR "DON'T TAKE" FLAGS SET
C 
C     IEXTNT = EXTENT NUMBER OF FILE BEING LOOKED FOR.
C 
C 
C     IF FOUND, IFENT RETURNS WITH THE ARRAY INDEX OF THE 
C     ENTRY IN 'IBUF', AND 'FLAG' RETURNS WITH THE INDEX IN 
C     'TRACK' AND 'LUDISC'. 
C 
C     IF NOT FOUND, IFENT RETURNS WITH 0. 
C 
C 
      INTEGER IBUF(6144),NAME(3),TRACKS(1),LUDISC(1)
      INTEGER TRAK2(1),LU2TK(1),TTRK
      INTEGER SECTOR,FLAG 
      LOGICAL WRFLG 
C 
      JEXTNT = 256 * IEXTNT 
      IFENT = 0 
      JOFF = 17 
      DO 1000 I = 1,NDIREC
      SECTOR = 0
      WRFLG = .FALSE. 
      CALL RDIRC(LUDISC,LU2TK,TRACKS,TRAK2,I,IBUF,TTRK,JJX,JLS,JLX) 
100   CONTINUE
      IOFSET = 64 * SECTOR
      I22 = IOFSET + 128
      IOFSET = IOFSET + JOFF
      DO 200 K = IOFSET,I22,16
      IF(IBUF(K) .EQ. -1) GOTO 200
      IF(IBUF(K) .EQ. 0) GOTO 140 
      IF(IBUF(K+3) .LT. 1) GOTO 150 
      IF(IAND(IBUF(K+5),177400B) .NE. JEXTNT) GOTO 150
      IF((JFLAG .EQ. 0) .AND. (IBUF(K+9) .LT. 0)) GOTO 200
C                   DOES FILE NAME MATCH? 
      DO 125  J = 1,3 
      N1 = NAME(J)
      N2 = IBUF(K+J-1)
C                   CHECK FOR (-) CHAR
      IF(IAND(N1,77400B) .EQ. 26400B) N1 = IAND(N1,177B) +
     & IAND(N2,77400B)
      IF(IAND(N1,177B) .EQ. 55B) N1 = IAND(N1,77400B) + IAND(N2,177B) 
      IF(N1 .NE. N2) GOTO 150 
125   CONTINUE
C 
C                   FOUND IT! 
C 
      IFENT = K 
      FLAG = I
      IF((JFLAG .NE. 1) .AND. (JFLAG .NE. 2)) GOTO 140
C                   WE'RE BEING ASKED TO CLEAR OR SET THE 
C                   "DON'T TAKE" FLAG 
      WRFLG = .TRUE.
      IF(JFLAG .EQ. 1) IBUF(K+9) = 0
      IF(JFLAG .EQ. 2) IBUF(K+9) = -1 
      GOTO 200
140   CONTINUE
      IF(WRFLG) CALL WDIRC(LUDISC,LU2TK,TRACKS,TRAK2,I,IBUF,TTRK, 
     &               JJX,JLS,JLX) 
      RETURN
150   CONTINUE
C 
C     THIS IS A FILE ENTRY, BUT THE NAME DOESN'T MATCH. 
C     SHOULD I PURGE IT?
C 
      IF(FLAG .NE. -1) GOTO 200 
      IBUF(K) = -1
      WRFLG = .TRUE.
200   CONTINUE
      JOFF = 1
      SECTOR = MOD(SECTOR + NSKIP,NDSPT)
      IF(SECTOR .NE. 0) GOTO 100
C                   FILE HAS NOT BEEN FOUND ON THIS DIRECTORY TRACK.
C     IF IT'S BEEN MODIFIED, WRITE IT BACK TO THE DISC. 
      IF(WRFLG) CALL WDIRC(LUDISC,LU2TK,TRACKS,TRAK2,I,IBUF,TTRK, 
     &               JJX,JLS,JLX) 
1000  CONTINUE
C                   DIDN'T FIND IT. 
      IFENT = 0 
      RETURN
      END 
      END$