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