C******************** START FILE UFCPWR.FOR ; GROUP UFCMPR ******************
C---------------------------------------------------------------------
C  UFCPWR
C
C  mod dmc Aug 1994 -- write monotonic independent coordinates without
C    compression -- burn some space to avoid errors that trash
C    monotonicity
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 1984-- ADD ERROR CHECKING
C
C  MODIF DMC APR 1986-- 3D ARRAY CAPACITY ADDED
C   CALLING ARGUMENTS MODIFIED ***
C
C  CONVERT A 1-D ARRAY TO INTEGER, COMPRESS IT AND WRITE TO ILUN
C  UTILITY ROUTINE FOR UF1DWR AND UF2DWR
C
      SUBROUTINE UFCPWR(ILUN,ARRAY,ANAME,NA1,NA2,NA3,
     >     NAA1,NAA2,ZTOL,IERR)
C
C  ILUN-- LOGICAL UNIT NUMBER ON WHICH TO WRITE
C  ARRAY-- 1D ARRAY CONTAINING DATA TO BE COMPRESSED AND WRITTEN
C  ANAME-- TEXT IDENTIFYING ARRAY (X,Y,F)
C  NA1  -  1ST DIMENSION OF ARRAY
C  NA2  -  2ND DIMENSION OF ARRAY
C  NA3  -  3RD DIMENSION OF ARRAY
C  NAA1 -  NUMBER OF PTS "ACTIVE" IN ARRAY 1ST DIMENSION
C  NAA2 -  NUMBER OF PTS "ACTIVE" IN ARRAY 2ND DIMENSION
C
C  ZTOL -  THRESHOLD FOR WARNING ERROR IN RTOI CONVERSION
C  IERR--  RETURNED ERROR CODE; 0 IF OK
C
      USE UFILES
C
      REAL ARRAY(NA1,NA2,NA3)
      CHARACTER*1 ANAME
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
      data ibitr/15/
      data ibits/16/
C------------------------------------------------------------------
C  DUMMY FLAG PUT IN FILE FOR POSSIBLE LATER USE--
C
CXXX	DATA IDUMF/0/  -- replaced by IMONO
C
C-----
C  determine monotonicity
C
      IMONO=1
      IF((NA2.NE.1).OR.(NA3.NE.1)) IMONO=0
      IF(IMONO.EQ.1) THEN
         IF((ANAME.NE.'X').AND.(ANAME.NE.'Y').AND.
     >        (ANAME.NE.'Z')) IMONO=0
      ENDIF
C
      IF(IMONO.EQ.1) THEN
         DO IX=2,NA1
            IXM1=IX-1
            IF(ARRAY(IXM1,1,1).GE.ARRAY(IX,1,1)) THEN
      	 IMONO=0
      	 GO TO 10
            ENDIF
         ENDDO
      ELSE
         GO TO 10  ! IMONO=0
      ENDIF
C
C  WRITE MONOTONIC INDEP. COORD. DATA OUT UNCOMPRESSED
C
C  IMONO=1 HERE
C
      ZOFFS=0.0
      ZSCAL=0.0
      WRITE(ILUN) ZOFFS,ZSCAL,IMONO
      WRITE(ILUN) (ARRAY(IX,1,1),IX=1,NA1)
      ierr=0
      RETURN
C
C  IMONO = 0 from here on down
C
C  INITIALIZE ERROR CHECKING
C
 10   CONTINUE
      ZMIN=ARRAY(1,1,1)
      ZMAX=ARRAY(1,1,1)
C  MIN AND MAX OF ARRAY
      DO I3=1,NA3
       DO I2=1,NAA2
        DO I1=1,NAA1
          Z=ARRAY(I1,I2,I3)
          ZMIN=AMIN1(ZMIN,Z)
          ZMAX=AMAX1(ZMAX,Z)
        ENDDO
       ENDDO
      ENDDO
C
      ZZAMAX=AMAX1(ABS(ZMIN),ABS(ZMAX))
      ZZAMIN=AMIN1(ABS(ZMIN),ABS(ZMAX))
      IF(((SIGN(1.0,ZMIN)*SIGN(1.0,ZMAX)).LE.0.0) .OR.
     >      ((ZZAMIN*10.0).LT.ZZAMAX)) THEN
        IRELE2=1
        ZR2LIM=0.1*ZZAMAX
        RL2ERR=0.0
        RL2AVG=0.0
        ICTE2=0
      ELSE
        IRELE2=0
      ENDIF
C
      RELERR=0.0
      RELAVG=0.0
      ABSERR=0.0
      ABSAVG=0.0
C
      NAACT=NAA1*NAA2*NA3
C
      WRITE(UFCLUN,8001) ANAME,NAACT,ZMIN,ZMAX
 8001 FORMAT(1x,'"',a,'" data compression, n = ',i7,' range = ',
     >1pe11.4,' to ',1pe11.4/
     >' >error classification        maximum value   average value')
C
C  SUM UP POST-COMPRESSION NO. OF WORDS
      ITWDS=0
C
      IMAXU=UFRSIZ
      DO IDON=0,NAACT-1,IMAXU	!TAKE DATA IN CHUNKS OF IMAXU WORDS
C
        ICOMP=MIN(NAACT-IDON,IMAXU)
        CALL UFG2DA(ARRAY,NA1,NA2,NA3,NAA1,NAA2,IDON,CDATA,ICOMP)
        CALL UFRTOI(IBITR,ICOMP,CDATA,
     >              TUNPK,ZSCAL,ZOFFS,IERR)
C
CX	  WRITE(ILUN,3012) ZOFFS,ZSCAL,ANAME
CX 3012	  FORMAT(1X,2(E14.7),T32,';-OFFSET, SCALE FOR ',A,' RTOI-')
        WRITE(ILUN) ZOFFS,ZSCAL,IMONO
C
C  BIT COMPRESS INTEGERS
        ILOCB=0	  	  !BIT OFFSET IN TUNPK ARRAY
        DO JJ=1,IMAXU
          TPACK(JJ) = 0
        ENDDO
        CALL CMPRSI(IBITS,ICOMP,TPACK,TUNPK,ILOCB,IMAXU,IERR)
        IF (IERR.NE.0) THEN
          WRITE(UFELUN,9700) IERR
 9700     FORMAT(' ? DATA WONT COMPRESS, REASON=',I3)
          GO TO 9000
        ENDIF
C
        IWRDS = ILOCB/32 + 1
        IWRDS2 = 2*IWRDS
C
C  MODIF DMC APR 1985 - IF COMPRESSION BIT STREAM IS LONGER THAN THE
C    UNCOMPRESSED DATA STREAM, WRITE THE UNCOMPRESSED STREAM.
C    FLAG THIS BY WRITING A NEGATIVE WORD COUNT.  SEE CORRESPONDING
C    CHANGES IN READ ROUTINE
C
C---------------------------------------
      IF(IWRDS2.LE.ICOMP) THEN
C
CX	  WRITE(ILUN,3014) ICOMP, IWRDS
CX 3014	  FORMAT(1X,2I10,T32,';-# WORDS BEFORE,AFTER COMPRESSION')
        WRITE(ILUN) ICOMP,IWRDS,IMONO
C
        ITWDS=ITWDS+IWRDS
C
CX	  WRITE(ILUN,3016) (TPACK(JJ),JJ=1,IWRDS)
CX 3016	  FORMAT(8Z9)
        WRITE(ILUN) (TPACK(IJ),IJ=1,IWRDS)
C
C ERROR STATS-- DECOMPRESS AND COMPARE DATA
C
        IWROT=IWRDS
C
        ILOCB = 0
        CALL XPANDI(IBITS,TPACK,ILOCB,TUNPK,1,IWROT,IERR)
        IF (IERR.NE.0) THEN
          WRITE(UFELUN,9701) IERR
 9701     FORMAT(' ? DATA WONT DECOMPRESS, REASON=',I3)
        GO TO 9000
        ENDIF
C------------------------------------
      ELSE
C
C  WRITE DATA UNCOMPRESSED WITH WARNING MESSAGE-- NO GAIN FROM
C  FROM COMPRESSION.  THIS USUALLY INDICATES EXTREMELY NOISY DATA
C
        IWROT=ICOMP
        IWDS2=IWRDS
        IWRDS=-IWRDS
        WRITE(ILUN) ICOMP,IWRDS,IMONO
C
        IWDS1=(ICOMP+1)/2
        ITWDS=ITWDS+IWDS1
C
        WRITE(ILUN) (TUNPK(IJ),IJ=1,ICOMP)
C
C  WARNING MESSAGE IF THIS IS NOT A SHORT TRAILER RECORD
C
        IF(IWROT.GT.IMAXU/10) THEN
          WRITE(UFELUN,9009) IWDS1,IWDS2
 9009 FORMAT(' % HIGH VARIANCE DATA:  ',
     >'COMPRESSION NOT USED:  NIN=',i7,' NOUT=',i7)
        ENDIF
C
      ENDIF
C----------------------------------------
C
C  CONVERT BACK TO REAL - ERROR CHECKING
C
        DO II=1,IWROT
          CTEST(II) = (ZSCAL * TUNPK(II)) + ZOFFS
        ENDDO
C
C  COMPARE TO ORIGINAL DATA
C
        DO II=1,IWROT
          ERR1 = ABS (CTEST(II) - CDATA(II))
          ERR2 = 0.0
C  EVALUATE ABSOLUTE AND RELATIVE ERROR PT BY PT.
          IF(ERR1.NE.0.0) THEN
            DENOM = 0.5 * ABS(CTEST(II) + CDATA(II))
            IF(DENOM.EQ.0.0) THEN
              ERR2=1.0
            ELSE
              ERR2=AMIN1(1.0,ERR1/DENOM)
            ENDIF
          ENDIF
C
          ABSERR=AMAX1(ABSERR,ERR1)
          RELERR=AMAX1(RELERR,ERR2)
          ABSAVG=ABSAVG+ERR1
          RELAVG=RELAVG+ERR2
C  RELATIVE ERROR FOR PTS BOUNDED AWAY FROM ZERO
          IF(IRELE2.EQ.1) THEN
            IF(CDATA(II).GT.0.1*ZZAMAX) THEN
              RL2ERR=AMAX1(RL2ERR,ERR2)
              RL2AVG=RL2AVG+ERR2
              ICTE2=ICTE2+1
            ENDIF
          ENDIF
        ENDDO
C  END OF MAIN COMPRESSION LOOP
      ENDDO
C
C  WRITE ERROR STATS
C
      ABSAVG=ABSAVG/NAACT
      RELAVG=RELAVG/NAACT
C
      IF(IRELE2.EQ.1) THEN
        RL2AVG=RL2AVG/MAX(1,ICTE2)
      ELSE
        RL2ERR=RELERR
        RL2AVG=RELAVG
      ENDIF
C
      WRITE(UFCLUN,8002) ABSERR,ABSAVG,RELERR,RELAVG,RL2ERR,RL2AVG,
     >        ITWDS
 8002 FORMAT(5x,'absolute',t30,1pe11.4,5x,1pe11.4/
     >         5x,'relative',t30,1pe11.4,5x,1pe11.4/
     >         5x,'rel (|data| > 0.1*|max|)',t30,1pe11.4,5x,1pe11.4/
     >  10x,' ... number of words after compression:  ',i7)
C
      IERR = 0
      RETURN
C
 9000 IERR = 3
      RETURN
      END
C******************** END FILE UFCPWR.FOR ; GROUP UFCMPR ******************
