PROGRAM REDUCE
	REAL*8 STUDY,XSTUDY,TEMP,RENAM(2),XTITLE(2)
	REAL*4 B(3,42)
	INTEGER*2 MAT(4096),IP(75),ADMN(256)
	LOGICAL*1 BMAT(4096),TITLE(12),BADMN(512)
	1 ,BYTFLG(13)
	EQUIVALENCE (XSTUDY,ADMN,BADMN,MAT),(XTITLE,TITLE)
	EQUIVALENCE (RENAM(1),TEMP),(RENAM(2),STUDY)
	EQUIVALENCE (B,BMAT),(IDEV,STUDY),(JDEV,TEMP)
	DATA XTITLE /'REDUCED ','STUDY   '/
	DATA TEMP/12RSY0TEMPFLDAT/
	DATA IT /5/
	IBUFSZ=4096
C
C	OPEN SAVE AREA 0 TO GET STUDY NAME
C
	CALL SAVOP(0,ISAVE0,ADMN,IERR)
	CALL CLOSEC(ISAVE0)
	CALL IFREEC(ISAVE0)
	STUDY=XSTUDY
	JDEV=IDEV
C
C	OPEN STUDY
C
	CALL CRTFIL(STUDY,IBLKS,ISTUDY,1)
	IRD=0
	CALL READW(256,ADMN,IRD,ISTUDY)
C
C	CHECK IF STUDY DYNAMIC
C
	IF(BADMN(190).NE.0)GO TO 740
C
	CALL FGADM1(ADMN,IP,B)
	NGROUP=ADMN(117)
	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)) GO TO 350
C
C	 CHECK MAXCOUNTS > 255
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
	CALL CRTFIL(TEMP,NBLKS,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
C
C	REPLACE OLD STUDY WITH NEW STUDY
C
	CALL CLOSEC(ISTUDY)
	CALL IFREEC(ISTUDY)
	ISTUDY=IGETC()
	IDEL= IDELET(ISTUDY,STUDY)
	IF(IDEL.NE.0) GO TO 760
	CALL CLOSEC(ITEMP)
	CALL IFREEC(ITEMP)
	ITEMP=IGETC()
	IREN=IRENAM(ITEMP,RENAM)
	IF(IREN.NE.0)GO TO 780
	GO TO 900
720	WRITE(IT,730)
730	FORMAT(' STUDY UNCHANGED')
	GO TO 900
740	WRITE(IT,750)
750	FORMAT(' STUDY NON-DYNAMIC')
	GO TO 900
760	WRITE(IT,770)IDEL
770	FORMAT(' DELETE STUDY ERROR ',I2)
	GO TO 900
780	WRITE(IT,790)IREN
790	FORMAT(' RENAME FILE ERROR ',I2)
900	CALL CLOSEC(ISTUDY)
	CALL IFREEC(ISTUDY)
	CALL CLOSEC(ITEMP)
	CALL IFREEC(ITEMP)
	CALL EXIT
	END