      SUBROUTINE RECPK2 (IBUF,MAXPK,LCM)
C
C     * JUL 07/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)
C     * MAR 05/02 - F.MAJAESS- REVISE FOR "CHAR" KIND RECORDS.
C     * OCT 02/00 - F.MAJAESS- LIMIT PACKING DENSITY TO NO MORE THAN 4.
C     *                        ISSUE AN ADVISORY FOR PACKING DENSITY OF 3.
C     * JUL 23/92 - E.CHAN   - ENSURE THAT THE DATA IS OBTAINED FROM IBUF
C     *                        BEGINNING AT WORD 9. 
C     * APR  1/92 - J.STACEY - IMPLEMENT CHANGES TO ASSURE PORTABILITY
C     *                        BETWEEN BOTH 32-BIT AND 64-BIT MACHINES.
C     * JAN 20/84 - R.LAPRISE, J.F.FORTIN.
C     *
C     * PLACES LABEL AND DATA RECORD IMAGES INTO IBUF. 
C     * LCM CONTAINS THE FLOATING POINT DATA. 
C     *
C     * INPUT:
C     * IBUF(1-8) CONTAINS THE LABEL (WHICH MUST BE PREVIOUSLY SET)...
C     *  1 = TYPE (4HSPEC,4HFOUR,4HGRID,4HZONL) (SPEC,FOUR = COMPLEX).
C     *  2 = TIMESTEP NUMBER. 
C     *  3 = NAME OF THE VARIABLE (EG. 4H PHI). 
C     *  4 = LEVEL NUMBER.
C     *  5,6 = SIZE (COMPLEX = (LA,1), REAL = (LI,LJ)  ). 
C     *  7 = KHEM (GRIDS OR FOUR) OR LRLMT (SPEC).
C     *  8 = NPACK (PACKING DENSITY). 
C     * THIS IS FOLLOWED BY MAXPK WORDS. THIS MUST BE ENOUGH TO 
C     * HOLD THE DATA AS IT IS TO BE WRITTEN TO THE FILE. 
C     * (EITHER PACKED OR UNPACKED).
C 
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)
      DIMENSION LCM(*), IBUF(*) 
CCRN  INTEGER ENCODR
      INTEGER IPKGT4,IPK3WR
      LOGICAL SF
      SAVE    IPKGT4,IPK3WR
      COMMON /MACHTYP/ MACHINE,INTSIZE
C     DATA    IBLANK/4H    /
C
C     * THE FOLLOWING CONSTANTS DEFINE THE DATA STANDARD FOR 64-BIT MACHINES.
C     * THEY MUST NOT BE CHANGED EVEN IF THE PRESENT CODE IS TO BE RUN ON
C     * 32 BIT MACHINES SINCE SUBSEQUENT 32-BIT CODE IS RELATED TO A 64-BIT 
C     * STANDARD.
C
      DATA LHEAD,NBW/8,64/
C ------------------------------------------------------------------
      IBLANK=NC4TO8("    ")
C     * LIMIT PACKING DENSITY TO NO MORE THAN 4.
C
      IF(IABS(IBUF(8)).GT.4) THEN
        IBUF(8)=4*IBUF(8)/IABS(IBUF(8))

C       * ISSUE A WARNING MESSAGE IF NONE WAS ISSUED BEFORE.

        IF (IPKGT4.NE.-1) THEN
          IPKGT4=-1
          WRITE(6,6000)
        ENDIF

      ENDIF

C     * ISSUE AN ADVISORY FOR PACKING DENSITY OF 3.

      IF(IABS(IBUF(8)).EQ.3) THEN
        IF (IPK3WR.NE.-1) THEN
          IPK3WR=-1
          WRITE(6,6010)
        ENDIF
      ENDIF
      
C     * GET LABEL INFORMATION.
C     * STOP IF IBUF IS TOO SMALL.
C
      CALL LBLCHK(LEN,NWDS,NPACK,IBUF) 
      IF (LEN - LHEAD*MACHINE .GT. MAXPK) THEN 
C        WRITE(6,6025) (IBUF(I),I=1,8) 
         CALL PRTLAB (IBUF)
         CALL XIT ('RECPK2',-2)
      ENDIF
C
C     * ENSURE NO PACKING OF "CHAR" KIND RECORDS.
C
      IF(IBUF(1).EQ.NC4TO8("CHAR").AND.NPACK.GT.1) NPACK=1
C 
C     * IF DATA IS NOT TO BE PACKED MOVE IT TO IBUF AND RETURN. 
C 
      IF (NPACK .NE. 0 .AND. NPACK .NE. 1) GO TO 150
C
C     * NPACK=0: DATA IS STORED IN NATIVE FORMAT.  THIS IS HIGHLY
C     * NON-PORTABLE DATA AND IS USED ONLY FOR TESTING PURPOSES.
C
      IF (NPACK .EQ. 0) THEN
          IF (IBUF(1).EQ.NC4TO8("CHAR")) THEN
           NNWDS=NWDS*MACHINE
          ELSE
           NNWDS=NWDS*INTSIZE
          ENDIF
          DO 100 N=1,NNWDS
  100     IBUF(8+N) = LCM(N)
      END IF
C
C     * NPACK=1: DATA IS STORED IN IEEE 64-BIT FLOATING POINT.
C
      IF (NPACK .EQ. 1) THEN
        IF (IBUF(1).EQ.NC4TO8("LABL").OR.IBUF(1).EQ.NC4TO8("CHAR")) THEN
          IF (IBUF(1).EQ.NC4TO8("CHAR")) THEN
           NNWDS=NWDS*MACHINE
          ELSE
           NNWDS=NWDS*INTSIZE
          ENDIF
          DO 125 N=1,NNWDS
  125     IBUF(8+N) = LCM(N)
        ELSE
          CALL IEEEPK(NWDS,LCM,IBUF(9))
        END IF
      END IF

      RETURN
C 
C     * PACK THE FIELD INTO IBUF IF NPACK .NE. 0 .AND. NPACK .NE. 1.
C     * SPECTRAL MEAN IS NOT PACKED. FOURIER IS PACKED LIKE SPECTRAL. 
C 
  150 NPACK = ABS(IBUF(8)) 
      IBUF(8)=NPACK 
      NBITS = NBW/MAX(1,NPACK)
      SF = (IBUF(1) .EQ. NC4TO8("SPEC"))
      IBIAS = 0 
      IND = LHEAD + 2*MACHINE + 1
      IF (SF) IND = IND + 1*MACHINE 
      J = 1
      IF (SF) J = J + INTSIZE 
      IF (SF) NWDS=NWDS-1 
      CALL PACCRN(LCM(J),LCM(J),IBUF(IND),NWDS,NBITS,XMIN,XMAX,1) 
CCRN  IBUF(LHEAD+1) =ENCODR(IXMIN)
CCRN  IBUF(LHEAD+2) =ENCODR(IXSCAL) 
CCRN  IF(SF)IBUF(LHEAD+3)=ENCODR(LCM(1))
      CALL ENCODR2(IBUF(9),XMIN)
      CALL ENCODR2(IBUF(LHEAD+MACHINE+1),XMAX)
      IF (SF) CALL ENCODR2(IBUF(LHEAD+2*MACHINE+1),LCM(1))
      RETURN
C-------------------------------------------------------------------
 6000 FORMAT(/,'0 RECPK2 - WARNING: A MAXIMUM PACKING DENSITY OF',
     +         ' 4 IS ENFORCED ON ALL WRITTEN RECORDS.'/)
 6010 FORMAT(/,'0 RECPK2 - ADVISORY: A PACKING DENSITY OF 3 IS ',
     +         'DETECTED. RECOMMEND THE USE OF A',/,21X,'PACKING ',
     +         'DENSITY OF 2 INSTEAD; (BETTER ACCURACY FOR THE ',
     +         'SAME',/,21X,'DATA STORAGE SPACE).'/)
 6025 FORMAT(' ',A4,I10,2X,A4,5I6)
      END 
