C	SUBROUTINE FILERD
C
C
C	SUBROUTINE FILERD LOCATES RT - 11 FILE WITH EXTENSION AEXT
C	COLLECTION FILES ON DISK DRIVES SY0: AND SY1:
C
C
C
C
C	NB THE DIRECTORY STARTS FROM BLOCK 7 AND THE ARE 36
C	ENTERIES IN EACH 'PAIR' OF DIRECTORY BLOCKS .
C
C	TO EXAMINE THE DIRECTORY USE R DUMP
C	I.E. T1:=DK1:/S:6/X/N
C
C
C
	SUBROUTINE FILERD(FILSPC,AEXT)
	COMMON /DDIP/ITTY,ISTAT
	INTEGER REXT,NAMES(4,101),IIDISK(4)
	INTEGER FILSPC(39)
	REAL*8 IDISK(2)
	DIMENSION IB(512),NFILES(2,100)
	LOGICAL*1 YDATA,NDATA,AEXT(4),IBYTES(512),IBUFF(100),ANS(2)
	LOGICAL*1 DSKSPC(12),LDISK(20),LBYT(12)
	EQUIVALENCE (IB,IBYTES,IBUFF)
	EQUIVALENCE(IDISK(1),DSKSPC(1)),(IIDISK,IDISK(2))
	DATA NDATA/'N'/,YDATA/'Y'/
	DATA DSKSPC/'S','Y',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '/
C
C	CONVERT EXTENSION TO RAD50
C
	IR = IRAD50(3,AEXT,REXT)
C
C	INITIALISE FILSPC TO NO SPEC LOADED
C
	FILSPC(16) = 0
C
C
C	SET UP POINTERS 
C
	ITTY = 7
102	NNNCNT = 0
	LCNT = 1
	NCNT = 1
D	CALL RCTRLO
	WRITE(7,100)
100	FORMAT('$ENTER SY DRIVE NOS. STUDIES OR RETURN TO ENTER FILSPC    ')
	READ(5,101)(LDISK(L),L=1,20)
101	FORMAT(20A1)
	TYPE *
	IF (LDISK(1).EQ.'-'.OR.LDISK(1).EQ.' ') RETURN	!ENTER FILE SPEC
	LLL = 1
105	DO 114 I = LLL,20
C
C	IGNORE SPACES AND COMMAS
C
	IF (LDISK(I).NE."40.AND.LDISK(I).NE."54) GOTO 115
114	CONTINUE
	GOTO 7
115	IF (LDISK(I).LT."60.OR.LDISK(I).GT."70) GOTO 102
	DSKSPC(3) = LDISK(I)
	LLL = I + 1
	CALL IRAD50(12,DSKSPC,IDISK(2))
	ICHAN = IGETC(IGC)
	IF (ICHAN.LT.0) STOP 'NO CHANNEL AVAILABLE '
	IF (IFETCH(IDISK(2)).NE.0) STOP 'BAD FETCH '
	IF (LOOKUP(ICHAN,IDISK(2)).LT.0) STOP 'BAD LOOKUP '
C
C	OBTAIN NUMBER OF DISK BLOCKS IN DIRECTORY
C
	IV = 6
	CALL READW (256,IB,IV,ICHAN)
	IBLK = IB(3)
	ICNT = 6
	LINK = 1
C
C
C
C	THE DIRECTORY IS STRUCTURED IN SEGMENTS AND ARE LINKED
C	BY THE 2 WORD OF THE FIRST BLOCK OF THE SEGMENT. EACH SEGMENT 
C	IS 2 BLOCKS LONG OR 512 WORDS WHICH CAN HOLD UP
C	TO 72 FILE NAMES .
C
C	THE ABSOLUTE DISK BLOCK NUMBER WHERE STUDY STARTS AND THE
C	CHANNEL ASSIGNED TO THE DISK ARE STORED IN COMMON AREA /FILES/
C
C
	DO 2 I = 1,IBLK
C
C	CALCULATE BLOCK ADDRESS OF NEXT SEGMENT
C
	IV = (LINK*2 - 2) + 6
	CALL READW (512,IB,IV,ICHAN)
	IBLKCT = IB (5)
	LINK = IB(2)
	   DO 4 M = 1,72
C
C	CHECK FOR END OF SEGMENT
C
	    IF (IB(ICNT).EQ.2048) GOTO 2
C
C	CHECK IF PERMANENT FILE ??
C
	   IF (IB(ICNT).NE.1024) GOTO 5
	   IBB = IB(ICNT + 3)

C
C	CHECK IF RT - 11 FILE
C
	    IF (IBB.NE.REXT) GOTO 5
C
C	STORE ABSOLUTE DISK BLOCK NUMBER FOR STUDY AND CHANNEL FOR DISK
C
12	      NFILES(1,LCNT) = IBLKCT
	      NFILES(2,LCNT) = ICHAN
C
C	CREATE FILE SPEC FOR EACH FILE
C
	      NAMES(1,LCNT) = IIDISK(1)		!STORE DISK
	      NAMES(2,LCNT) = IB(ICNT+1)
	      NAMES(3,LCNT) = IB(ICNT+2)
	      NAMES(4,LCNT) = REXT
	      LCNT = LCNT + 1
	      IF (LCNT.EQ.101) GOTO 17
5	    IBLKCT = IBLKCT + IB (ICNT + 4)
4	 ICNT = ICNT + 7
2	ICNT = 6
C
C	REARRANGE FILES TO BE IN THE SAME ORDER AS GAMMA PRINTS THEM
C
17	LCNT = LCNT - 1
	IF (NCNT.NE.LCNT+1) GOTO 18
	WRITE(7,300)(AEXT(I),I=1,4),LDISK(LLL-1)
	REWIND 7
300	FORMAT('0THERE ARE NO ',4A1,' STUDIES ON SY: DISK ',A1)
	GOTO 9
18	NNCNT = NNNCNT
	IF (ANS(1).EQ.'B'.OR.ANS(1).EQ.'N') CALL NEWPAG
	ICNT = 0
	IPAGE = 12
	IF (LCNT.LE.IPAGE) IPAGE = LCNT
	DO 8 I =LCNT , NCNT , -1
	NNCNT = NNCNT +1
	IF (ICNT.EQ.0) TYPE *,'           INDEX TO PATIENT STUDIES '
	IV = NFILES(1,I)		!HEADER BLOCK
	CALL READW (256,IB,IV,NFILES(2,I))

C
C	PACK NAME INTO IBUFF
C
	IC = 1
	CALL PACK (IBYTES,IBUFF,IC,21,40)
C
C	PACK PATIENTS NUMBER INTO IBUFF
C
	CALL PACK (IBYTES,IBUFF,IC,41,60)
C
C	STORE STUDY TYPE
C
	CALL PACK(AEXT,IBUFF,IC,1,3)
C
C	PACK STUDY DATE INTO IBUFF
C
	CALL PACK(IBYTES,IBUFF,IC,81,100)
C
C	STORE FILE NAME
C
	CALL R50ASC(12,NAMES(1,I),LBYT)
	CALL PACK(LBYT,IBUFF,IC,4,9)
	IBUFF(IC-2) = '.'
	IC = IC - 1
	CALL PACK(AEXT,IBUFF,IC,1,3)
	IC = IC - 3
C
C	WRITE STUDY I.D. AND STUDY DETAILS ON CONSOLE
C
	WRITE(7,200)NNCNT,(IBUFF(N1),N1=1,IC)
	REWIND 7
200	FORMAT(' ',I2,'  ',65A1)
	TYPE *
	IF (NNCNT.EQ.100) GOTO 16
	ICNT = ICNT + 1
	IF (I.EQ.NCNT) GOTO 24		!END OF LIST
	IF (ICNT.NE.IPAGE) GOTO 8	!END OF PAGE ?
24	TYPE*
	TYPE *,'SELECT STUDY BY NUMBER, OR'
	IF (ICNT.EQ.12) TYPE *,'TYPE N FOR NEXT PAGE'
	IF (NNCNT.GE.12) TYPE *,'TYPE B TO RETURN TO BEGINNING'
	TYPE *
	READ(5,101)ANS
	IF (ANS(1).EQ.'N') GOTO 11		!NEXT PAGE ?
	IF (ANS(1).EQ.'B') GOTO 18		!BACK TO BEGINING
	IF (ANS(2).NE.' ') GOTO 109
	ANS(2) = ANS(1)
	ANS(1) = ' '
109	DECODE(2,108,ANS)NUM
108	FORMAT(I2)
	IF (NUM.GE.1.AND.NUM.LE.LCNT) GOTO 7	!SELECTION OK  ??
	IF (NUM.EQ.0)	GOTO 13		!REPRINT PAGE OF DATA
	CALL NEWPAG			!ERROR - GOTO BEGINNING
	GOTO 18
11	IF (LCNT.EQ.NCNT) GOTO 9	!SET UP FOR NEXT PAGE
13	CALL NEWPAG
	ICNT =0
8	CONTINUE
9	CALL CLOSEC(ICHAN)
	CALL IFREEC(ICHAN)
	LCNT = LCNT + 1
	IBLK = 4
	NCNT = LCNT - 1
	NNNCNT = LCNT - 1
	CALL RCTRLO
	GOTO 105
7	CONTINUE
D	CALL RCTRLO
C
C	STORE FILE NAME AS EQUIVALENT FOR CSI INPUT
C
C
C	TO DANGEROUS TO USE DISK AS UNSTRUCTURED DEVICE
C
	ISTUDY = LCNT - NUM + 1 + NNNCNT
C
C	STORE FILE SPEC FOR LOOKUP
C
	DO 27 I = 1,4
27	FILSPC(15+I) = NAMES(I,ISTUDY)
	CALL R50ASC(12,NAMES(1,ISTUDY),LBYT)
D	WRITE(7,107)(LBYT(I),I=1,12)
107	FORMAT(' ','FILNAME',12A1)
	IF (NUM.GT.0) CALL NEWPAG
	CALL CLOSEC(ICHAN)
	CALL IFREEC(ICHAN)
	RETURN
16	WRITE(7,290)
290	FORMAT(//' MORE THAN 100 FILES ON DISK(S) OTHERS CAN NOT
	1 BE ACCESSED'//)
	GOTO 7
	END
C
C
C	PACK IS USED TO CREATE IDENTIFICATION OF STUDY
C
C
	SUBROUTINE PACK(IBYTES,IBUFF,IC,I4,I5)
	LOGICAL*1 IBYTES(1),IBUFF(1)
	DO 10 N1 = I4,I5
	IF (IBYTES(N1).EQ.' '.AND.IBYTES(N1+1).EQ.' ') GOTO 12
	IF (IBYTES(N1).EQ."0) GOTO 12
	IBUFF(IC) = IBYTES(N1)
10	IC = IC +1
12	IBUFF(IC) = 44.
	IBUFF(IC+1) = 32.
	IC = IC + 2
	RETURN
	END
