C
C	SUBROUTINE REDSUB
C
C	FUNCTION
C
C		TO REDUCE WORD GROUPS TO BYTE COLLECTIONS IF MAX < 255
C
C	WHERE
C
C			STUDY IS FILE SPEC OF STUDY TO BE REDUCED
C			ODISK IS FILE SPEC FOR OUTPUT FILE
C
C			IJOB IS TO FLAG LOOKUP OR ENTER
C
C			IJOB = 0 SEARCH FOR GAMMA FILES
C			IJOB = 1 SEARCH AND COMPRSS
C			IJOB = 2 COMPRESS FILES IN LIST
C
C			MAX IS MAXIMUM FILE SIZE OF STUDIES TO BE COMPRESSED
C
C
C
	SUBROUTINE REDSUB(STUDY,ODISK,IJOB,MAX)
	REAL*4 B(3,42)
	INTEGER*2 MAT(4096),IP(75),ADMN(256),STUDY(4),ODISK(4)
	INTEGER*2 IDEV(4),NEWSTY(4)
	LOGICAL*1 BMAT(4096),TITLE(12),BADMN(512)
	1,BYTFLG(13)
	EQUIVALENCE (ADMN,BADMN,MAT,BMAT)
	EQUIVALENCE (B,MAT(2000))
	DATA IT /5/
	IBUFSZ=4096		!NUMBER OF WORDS
	NJOB = IJOB
	IF (IJOB.EQ.2) GOTO 3
	DO 1 I = 2,4
1	ODISK(I) = STUDY(I)
C
C	OPEN STUDY
C
3	CALL CRTFIL(STUDY,IBLKS,ISTUDY,1)
	IRD=0
	CALL READW(256,ADMN,IRD,ISTUDY)
	IF (BADMN(1).EQ."1) GOTO 2
C
C	FLAG NOT TO INCLUDE THIS FILE ON LIST
C
	TYPE *,'NOT GAMMA FILE'
7	STUDY(1) = -1
	GOTO 910
C
C	CHECK STUDY TYPE
C
2	IF (BADMN(190).GE.0) GOTO 4		!DYNAMIC OR STATIC
	TYPE *,'LIST STUDY - DO NOT COMPRESS OR TRANSFER'
	GOTO 7
4	IF(BADMN(190).GT.0)GO TO 740	!STATIC
C
C	CHECK DYNAMIC FOR COMPRSSION
C
	CALL FGADM1(ADMN,IP,B)
C
C	CHECK ADMIN BLOCK FOR WORD GROUPS
C
	NGROUP=ADMN(117)
	JJ=11
	IF (IJOB.EQ.1.OR.IJOB.EQ.2) GOTO 395
	DO 380 I = 1,NGROUP
	IF (MOD(IP(JJ+1),2).EQ.0) GOTO 390
	JJ = JJ + 5
380	CONTINUE
	GOTO 7		!ALL GROUPS BYTE
C
C	CHECK WORD GROUPS FOR COMPRESSION
C
390	IF (IJOB.EQ.0) GOTO 910
395	JJ = 11
	MDOFF=IP(6)
	NBLKS=MDOFF
	ISUMFG=0
	IRD=MDOFF
	DO 400 I=1,NGROUP
	BYTFLG(I)=0
	NBKFRM=2**IP(JJ+1)
	NWDRD=NBKFRM*256
	NRDFRM=MAX0(1,NWDRD/IBUFSZ)
	NWDRD=MIN0(NWDRD,4096)
	NFRAME=IP(JJ)
	NBKGRP=NFRAME*NBKFRM
	IF(MOD(IP(JJ+1),2).GT.0) GO TO 350
C
C	 CHECK MAXCOUNTS > 255 FOR WORD FRAMES
C
	JRD=IRD
	DO 100 J=1,NFRAME
	DO 100 K=1,NRDFRM
	CALL READW(NWDRD,MAT,JRD,ISTUDY)
	DO 100 L=1,NWDRD
	IF(MAT(L).GT.255) GO TO 350
100	CONTINUE
	BYTFLG(I)=1
350	NBLKS=NBLKS+NBKGRP/(BYTFLG(I)+1)
	ISUMFG=ISUMFG+BYTFLG(I)
	IRD=IRD+NBKGRP
	JJ=JJ+5
400	CONTINUE
	IF (ISUMFG.EQ.0) GO TO 720
	IF (IJOB.EQ.1) CALL CRTCMP(STUDY,ITEMP,IBLKS,NEWSTY,ODISK(1))
	IF (IJOB.EQ.2) CALL CRTFIL(ODISK,MAX,ITEMP,0)
	JJ=11
	IRD=MDOFF
	IWRT=MDOFF
	DO 700 I=1,NGROUP
	NBKFRM=2**IP(JJ+1)
	NWDRD=NBKFRM*256
	NRDFRM=MAX0(1,NWDRD/IBUFSZ)
	NWDRD=MIN0(NWDRD,4096)
	NFRAME=IP(JJ)
C
C	 WRITE MATRIX DATA TO TEMP FILE
C
	NWDWRT=NWDRD/(BYTFLG(I)+1)
	DO 600 J=1,NFRAME
	DO 600 K=1,NRDFRM
	CALL READW(NWDRD,MAT,IRD,ISTUDY)
	IF(BYTFLG(I).EQ.0) GO TO 560
	DO 550 L=1,NWDRD
	BMAT(L)=LBYTE(MAT(L))
550	CONTINUE
	CALL WRITW(NWDWRT,BMAT,IWRT,ITEMP)
	GO TO 600
560	CALL WRITW(NWDWRT,MAT,IWRT,ITEMP)
600	CONTINUE
	JJ=JJ+5
700	CONTINUE
C
C	 UPDATE ADMIN BLOCK
C	UPDATE ADMIN BLOCK
C
	IRD=0
	CALL READW(256,ADMN,IRD,ISTUDY)
	ADMN(98)=NBLKS
	J=239
	DO 710 K=1,NGROUP
	IF(BYTFLG(K)) BADMN(J)=BADMN(J)-1
	J=J+17
710	CONTINUE
	IWRT=0
	CALL WRITW(256,ADMN,IWRT,ITEMP)
	DO 715 J=1,MDOFF-1
	CALL READW(256,ADMN,IRD,ISTUDY)
	CALL WRITW(256,ADMN,IWRT,ITEMP)
715	CONTINUE
	GO TO 900
720	CONTINUE
D	WRITE(IT,730)
730	FORMAT(' STUDY UNCHANGED')
	IF (NJOB.EQ.2) GOTO 802
	GO TO 800
740	CONTINUE
D	WRITE(IT,750)
750	FORMAT(' STUDY NON-DYNAMIC')
	GO TO 800
C
C	DO NOT MOVE STUDIES NO SAME DISK
C
800	IF (STUDY(1).NE.ODISK(1)) GOTO 805
802	STUDY(1) = -1
	NJOB = 0
	GOTO 910
805	CALL CRTCMP(STUDY,ITEMP,IBLKS,NEWSTY,ODISK(1))
806	ITRAN = IBUFSZ/256.
	IRD = 0
	IWRT = 0
	DO 810 I = 1,IBLKS
	IF ((IBLKS-IWRT).LT.ITRAN) ITRAN = IBLKS - IWRT
	IWDS = ITRAN*256
	CALL READW(IWDS,ADMN,IRD,ISTUDY)
	CALL WRITW(IWDS,ADMN,IWRT,ITEMP)
	IF (IWRT.EQ.IBLKS) GOTO 900
810	CONTINUE
900	CALL CLOSEC(ITEMP)
	CALL IFREEC(ITEMP)
910	CALL CLOSEC(ISTUDY)
	CALL IFREEC(ISTUDY)
	IF (NJOB.NE.2) GOTO 920
C
C	SETUP TO MOVE STUDY BACK
C
	CALL CRTFIL(ODISK,IBLKS,ISTUDY,1)
	CALL CRTFIL(STUDY,IBLKS,ITEMP,0)
	NJOB = 0
	GOTO 806
920	RETURN
	END
