PROGRAM CMPRSS
C
C
C	CMPRSS  LOCATES RT - 11 GAMMA
C	COLLECTION FILES ON DISK DRIVES DL1,DM2  ??
C
C	FOR RT -11 GAMMA THE FILES MUST HAVE THE STANDARD EXTENSION
C	X00 TO X99 .
C
C	N.B. THIS EXTENSION CAN BE CHANGED TO S00 TO S99 AFTER TRANSFERRING
C	RT - 11 GAMMA FILES TO MAG TAPE WITH THE TS
C	COMMAND AND RETIEVING THEM WITH PIP. RENAME THE FILES WITH PIP .
C
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. TT:=DL0:/S:6/X/N
C
C
C	TO EXAMINE EXPANDED FILE  COMPARE ORIGINAL WITH EXPANDED FILE
C	WITH BINCOM
C
C	IE
C
C		R BINCOM
C		TT:=DL0:*.X*,DL1:*.X*		DL0 ORIGINAL GAMMA FILES
C								DL1 EXPANDED FILES
C
C								ONLY DIFFERENCE SHOULD BE  SPACE EX
C
C
C
C	N.B.	CAUTION SHOULD BE USED IN TRANFERRING FILES
C		IE USE COPY OR PIP AS GAMMA CAN RENAME FILES
C
C
C
C	COMMENTS ON EXP
C
C
C		EXP ONLY CREATES FILE OF SAME NAME IF FILE IS NOT ON THAT DISK
C		IF SY' NUMBER GREATER THAN 3 - CREATED FILE IS STORED ON SY1
C		 REQUIRED AT QE2
C
C
C
	REAL*8 STUDYS,RNAME,OFILSP
	VIRTUAL STUDYS(300),ISIZE(300)
	INTEGER*2 IDISK(4),ODISK(4),NAME(4),IFILSP(4)
	DIMENSION IB(512)
	INTEGER EXTX00,EXTX99,EXT000,EXT099
	LOGICAL*1 YDATA,NDATA,NVAL,ANS,IBYTES(512)
	LOGICAL*1 DSKSPC(12),LDISK(20),SDISK(20)
	EQUIVALENCE (IB,IBYTES),(RNAME,NAME)
	EQUIVALENCE (IFILSP,OFILSP)
	DATA EXTX00/3RX00/,EXTX99/3RX99/,EXT000/3R000/,EXT099/3R099/
	DATA OFILSP/12RHRTTEMPFLDAT/
	DATA NDATA/'N'/,YDATA/'Y'/
	DATA DSKSPC/' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '/
	CALL CNTXSW
	TYPE *,'CMPRSS V3.6 80K'
	TYPE *,' '
	WRITE(7,100)
100	FORMAT('$ ENTER DRIVE (S) WHICH CONTAIN GAMMA
	1 STUDIES EG DL0,DM2,SY3    ')
	READ(5,101)(LDISK(L),L=1,20)
101	FORMAT(20A1)
102	WRITE(7,110)
110	FORMAT('$ ENTER OUTPUT DRIVE EG SY2   ')
	READ(5,101)(SDISK(L),L=1,20)
	IF (SDISK(1).NE.' '.AND.SDISK(1).NE.'M') GOTO 104
	TYPE *,'OUTPUT DEVICE MUST NOT INCLUDE LEADING SPACES
	1 OR BE MAG-TAPE'
	TYPE *,' '
	GOTO 102
C
C	DECODE OUTPUT DRIVE
C
104	CALL IRAD50(3,SDISK,ODISK(1))
D	WRITE(7,103)(LDISK(L),L=1,20)
D103	FORMAT(' ',20A1)
	LLL = 1
105	II = 1
	DO 114 I = LLL,20
	DSKSPC(I+1) = "40
	IF (LDISK(I).EQ."40.AND.LDISK(I+1).EQ."40) GOTO 116
	IF (LDISK(I).EQ."40.OR.LDISK(I).EQ."54) GOTO 115
	DSKSPC(II) = LDISK(I)
	II = II + 1
114	CONTINUE
116	IF (II.GT.1) GOTO 115
	GOTO 106
115	LLL = I + 1
	CALL IRAD50(12,DSKSPC,IDISK)
D	WRITE(7,103)(DSKSPC(I),I=1,12)
	REWIND 7
	ICHAN = IGETC()
	IF (ICHAN.LT.0) STOP 'NO CHANNEL AVAILABLE '
	IF (IFETCH(IDISK).NE.0) STOP 'BAD FETCH '
	IF (LOOKUP(ICHAN,IDISK).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
	IJOB = 1
	IF (IDISK(1).EQ.ODISK(1)) IJOB = 0
	ISTCNT = 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."4000) GOTO 2
C
C	CHECK IF PERMANENT FILE ??
C
	   IF (IB(ICNT).NE."2000) GOTO 5
	   IBB = IB(ICNT + 3)

C
C	CHECK IF RT - 11 FILE
C
	IF (IBB.LT.EXTX00.OR.IBB.GT.EXTX99) GOTO 3
	GOTO 1
C
C	GAMMA MAG-TAPE FORMAT
C
3	IF (IBB.LT.EXT000.OR.IBB.GT.EXT099) GOTO 5
C
C	REDUCE STUDY ??
C
1	IB(ICNT)= IDISK(1)
	JJJ = 1
	DO 11 JJ = ICNT,ICNT+3
	NAME(JJJ) = IB(JJ)
11	JJJ = JJJ + 1
	STUDYS(ISTCNT) = RNAME
	ISIZE(ISTCNT) = IB(ICNT+4)
	RNAME = STUDYS(ISTCNT)
	   CALL REDSUB(IB(ICNT),ODISK,IJOB,MAX)
	   IF (IB(ICNT).NE.-1) ISTCNT = ISTCNT + 1
5	  IBLKCT = IBLKCT + IB (ICNT + 4)
4	 ICNT = ICNT + 7
2	ICNT = 6
	IF (IJOB.EQ.1) GOTO 105
C
C	SORT STUDIES
C
	ISTCNT = ISTCNT - 1
	IF (ISTCNT.GT.1)CALL GSORT(ISTCNT,MAX,STUDYS,ISIZE)
C
C	COMPRESS STUDIES
C
	IJOB = 2
C
C	TEMPFL.DAT CREATED ON DISK HRT:
C
C	IFILSP(1) = IDISK(1)
	TYPE *,'CMPRSS CANNOT BE STOPPED FOR SAME DISK COMPRESSION'
	1,'FOR ',ISTCNT,' STUDIES'
	IF (ISTCNT.EQ.0) GOTO 105
	CALL SCCA(NFLAG)		!PREVENT CONTROL C ABORT
	DO 20 I = 1, ISTCNT
	RNAME = STUDYS(I)
	MAX = ISIZE(I)
	CALL REDSUB(RNAME,IFILSP,IJOB,MAX)
20	CONTINUE
	ITEMP = IGETC()
	CALL IDELET(ITEMP,IFILSP)
	CALL CLOSEC(ITEMP)
	CALL IFREEC(ITEMP)
107	CALL	SCCA(NFLAG)		!RESET CONTROL C ABORT
	GOTO 105
C
106	TYPE *,'END  OF CMPRSS'
	END