C******************** START FILE UFCPRD.FOR ; GROUP UFCMPR ******************
C--------------------------------------------------------------------
C  UFCPRD
C
C  MODIF DMC APR 1984-- TREAT ALL ARRAYS AS 2D.  SUPPORT READ/WRITE
C  OF 2D DATA THAT IS NOT CONTIGUOUSLY STORED
C
C  MODIF DMC APR 1985-- CHECK FOR UNCOMPRESSED BINARY RECORDS
C   (SEE UFCPWR ROUTINE - OUTPUT OF NOISY RECORDS WHICH DO NOT COMPRESS
C    SATISFACTORILY)
C
C  MODIF DMC APR 1986-- 3D ARRAY READ CAPABILITY.  NEW PASSED ARGS.
C
C  READ COMPRESSED DATA FROM ILUN AND CONVERT TO A 1-D ARRAY
C  UTILITY ROUTINE FOR UF1DRD AND UF2DRD
C
      SUBROUTINE UFCPRD(ILUN,ARRAY,NA1,NA2,NA3,NAA1,NAA2,IERR)
C
C  ILUN-- LOGICAL UNIT NUMBER ON WHICH TO WRITE
C  ARRAY-- 1D ARRAY CONTAINING DATA TO BE COMPRESSED AND WRITTEN
C  NA1  -  ARRAY 1ST DIMENSION
C  NA2  -  ARRAY 2ND DIMENSION
C  NA3  -  ARRAY 3RD DIMENSION
C  NAA1  -  NUMBER OF PTS ACTIVE IN ARRAY 1ST DIMENSION
C  NAA2  -  NUMBER OF PTS ACTIVE IN ARRAY 2ND DIMENSION
C  IERR--  RETURNED ERROR CODE; 0 IF OK
C
      USE UFILES
C
      REAL ARRAY(NA1,NA2,NA3)
C
      COMMON /UFTPACKU/ TUNPK,TPACK,CDATA,CTEST
      INTEGER*2 TUNPK(UFMAXR)	!UNPACKED INTEGERS
      INTEGER*4 TPACK(UFMAXR)	!PACKED INTEGERS
      REAL CDATA(UFMAXR),CTEST(UFMAXR)
C
      INTEGER IBITR             !BITS FOR REAL-TO-INTEGER
      INTEGER IBITS             !BITS FOR INTEGER COMPRESS
C
      CHARACTER*64 ERRSTR
C
      data ibitr/15/
      data ibits/16/
C------------------------------------------------------------------
C
      NAACT=NAA1*NAA2*NA3
C
      ERRSTR='COMPRESSED DATA RECORD HEADER'
      READ(ILUN,ERR=8900,END=8900) ZOFFS,ZSCAL,IMONO
      IF(IMONO.EQ.1) THEN
C
C  DMC -- READ UNCOMPRESSED X COORDINATE DATA -- DMC Aug 1994
C
         IF((NA2.GT.1).OR.(NA3.GT.1)) THEN
            WRITE(UFELUN,9900)
 9900       FORMAT(
     >' ?UFCPRD -- MONOTONICITY FLAG ON DEPENDENT COORD DATA')
            GO TO 8900
         ENDIF
         READ(ILUN,ERR=8900,END=8900) (ARRAY(IX,1,1),IX=1,NA1)
         IERR=0
         RETURN
      ENDIF
C
C  ok, not monotonic indep. coordinate data ...
C  proceed as before (dmc Aug 1994)
C
      READ(ILUN,ERR=8900,END=8900) IMAXU,IWRDS,IMONO
C
      IF(IMAXU.GT.UFMAXR) THEN
        IMAX=UFMAXR
        WRITE(UFELUN,9901) IMAXU,IMAX
 9901 FORMAT(' ?UFCPRD - COMPRESSED UFILE RECORD SIZE= ',I8/
     >'  TOO LARGE!  MAXIMUM SIZE (UFILES COMMON) = ',I8)
        IMAXU=IMAX
        GO TO 9000
      ENDIF
C
      IWROT=IMAXU
      IMAXU=MAX0(1,IMAXU)
C
      DO IDON=0,NAACT-1,IMAXU
C
        IF(IDON.GT.0) THEN
          ERRSTR='COMPRESSED DATA RECORD HEADER'
          READ(ILUN,ERR=8900,END=8900) ZOFFS,ZSCAL,IMONO
          READ(ILUN,ERR=8900,END=8900) IWROT,IWRDS,IMONO
        ENDIF
C
        IF (IWROT.EQ.0) THEN
C
C  DATA STORED WAS START, STEP SIZE (1D INDEPENDENT AXES ONLY)
          ZSTART = ZOFFS
          ZDELT = ZSCAL
          ARRAY(1,1,1) = ZSTART
          DO II=2,NAA1
            ARRAY(II,1,1) = ZSTART+(II-1)*ZDELT
          ENDDO
          GO TO 8000
        ENDIF
C
        ICOMP=MIN(NAACT-IDON,IMAXU)
        IF(IWROT.NE.ICOMP) THEN
          WRITE(UFELUN,9701) IWROT,ICOMP
 9701     FORMAT(' ? UFCPRD - FOUND ',I4,' WORDS, EXPECTED ',I4)
          GO TO 9000
        ENDIF
C
C  DECOMPRESS INTEGERS
CX	  READ(ILUN,3016) (TPACK(JJ),JJ=1,IWRDS)
CX 3016	  FORMAT(8Z9)
C  DATA WAS WRITTEN COMPRESSED?
C
        IF(IWRDS.GT.0) THEN
          ERRSTR='COMPRESSED BINARY DATA RECORD'
          READ(ILUN,ERR=8900,END=8900) (TPACK(JJ),JJ=1,IWRDS)
C
          ILOCB = 0
          CALL XPANDI(IBITS,TPACK,ILOCB,TUNPK,1,IWROT,IERR)
          IF (IERR.NE.0) THEN
            WRITE(UFELUN,9700) IERR
 9700       FORMAT(' ? DATA WONT DECOMPRESS, REASON=',I3)
            GO TO 9000
          ENDIF
        ELSE
          ERRSTR='UNCOMPRESSED BINARY DATA RECORD'
          READ(ILUN,ERR=8900,END=8900) (TUNPK(JJ),JJ=1,IWROT)
        ENDIF
C
C  CONVERT BACK TO REAL
        DO II=1,IWROT
          CTEST(II) = (ZSCAL * TUNPK(II)) + ZOFFS
        ENDDO
C  SORT AND PUT IN (2D) OUTPUT ARRAY
      CALL UFP2DA(ARRAY,NA1,NA2,NA3,NAA1,NAA2,IDON,CTEST,IWROT)
C
      ENDDO
C
 8000 CONTINUE
      IERR = 0
      RETURN
C
 8900 CONTINUE
      WRITE(UFELUN,8901) ERRSTR
 8901 FORMAT(' ? ERROR READING UFILES COMPRESSED BINARY DATA:'/6X,A)
      IERR = 1
      RETURN
C
 9000 IERR = 3
      RETURN
      END
C******************** END FILE UFCPRD.FOR ; GROUP UFCMPR ******************
