      SUBROUTINE WPKPHS4(NF,G,NLEV,IBUF,LON,NLAT,ILAT,ILEV,LEV,LH)

C     * MAY 01/18 - S.KHARIN.  WRITE RE-ORDERED FIELDS.
C     * JUN 30/06 - L.SOLHIEM. COSMETIC CHANGE TO ENSURE THAT POINTER
C     *                        "GBUF" DOES NOT REFERENCE OUT OF BOUNDS
C     *                        IN THE NON-MPI CASE. THE ACTUAL RUN-
C     *                        TIME CODE DOES NOT DO THIS BUT IT STILL
C     *                        GENERATES RUN-TIME ERRORS UNDER LINUX
C     *                        COMPILERS (AND WOULD UNDER AIX WITH
C     *                        DIFFERENT COMPILER FLAGS) BECAUSE IT
C     *                        "THINKS" IT IS REFERENCING OUT OF BOUNDS.
C     * DEC 19/03 - M. LAZARE. HARD CODE "XBUF" LOCAL ARRAY DIMENSION
C     *                        DUE TO ENCOUNTERED PROBLEM WITH "NANS"
C     *                        INITIALIZATION UNDER AIX.
C     * OCT 05/03 - R.MCLAY.   SUPPORT FOR MPI I/O ADDED.
C     * MAY 31/03 - M. LAZARE. NEW ROUTINE, BASED ON WPKPHS3, BUT WITH
C     *                        EXTRA "WORD" ADDED FOR EACH LEVEL, CONSISTENT
C     *                        WITH THE DIMENSION OF PAK ARRAYS BEING
C     *                        LONSL*ILAT+1, TO AVOID MEMORY-BANK CONFLICTS
C     *                        WITH NEW FORMULATION.
C     * NOV 22/94 - M. LAZARE. PREVIOUS VERSION WPKPHS3.

C     * WRITES A PACKED ARRAY G, PRECEEDED BY ITS EIGHT WORD LABEL,
C     * TO THE SEQUENTIAL FILE NF.

C     * THE REPEATING GRENWICH LONGITUDE IS ADDED BEFORE WRITING
C     * ARRAY G TO THE SEQUENTIAL FILE.
C     * NOTE THAT THIS CALCULATION, TO AVOID THE OVERHEAD OF GOING
C     * THROUGH THE PACKER, ASSUMES ALL GRID FIELDS ARE UNPACKED
C     * INTERNALLY IN THE GCM (NEW STANDARD).

C     * G CAN BE MULTIDIMENTIONAL, BUT OTHERWISE NLEV HAS TO BE SET
C     * TO ONE.

C     * THE FIELDS EMD,EMM ARE HANDLED DIFFERENTLY BECAUSE THEY HAVE
C     * "LEV" LEVELS AND ARE ORDERED BOTTOM UP.
C
C     * INPUT: NF    = SEQUENTIAL RESTART FILE.
C     *        NLEV  = NUMBER OF LEVELS. CAN BE EITHER 1,LEV,ILEV,LEVS.
C     *        IBUF  = EIGHT WORD LABEL.
C     *         LON  = NUMBER OF DISTINCT EQUALLY-SPACED LONGITUDES.
C     *        ILAT  = NUMBER OF GAUSSIAN LATITUDES.
C     *        ILEV  = NUMBER OF MODEL SIGMA LEVELS.
C     *         LEV  = ILEV+1
C     *          LH  = VECTOR OF MODEL HALF-LEVEL SIGMA VALUES.
C     *
C     * OUTPUT: G    = PACKED ARRAY PRECEDED BY THE EIGHT WORD
C     *                LABEL IBUF.
C
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)
C
      INTEGER IBUF(8),KBUF(8),LH(NLEV)

      COMMON /ICOM/ JBUF(8), IDAT(1)
      COMMON /MACHTYP/ MACHINE,INTSIZE
      INTEGER*4 MYNODE
      COMMON /MPINFO/ MYNODE

C     * COMMON BLOCK TO HOLD THE NUMBER OF NODES AND COMMUNICATOR.

      INTEGER*4 NNODE, AGCM_COMMWRLD, MY_CMPLX_TYPE, MY_REAL_TYPE
      INTEGER*4 MY_INT_TYPE
      COMMON /MPICOMM/ NNODE, AGCM_COMMWRLD, MY_CMPLX_TYPE,MY_REAL_TYPE,
     1                 MY_INT_TYPE

C
C     * On the IBM, the MPI_INTEGER is 32 bits.  MPI_INT_SZ is the number of
C     * MPI_INTEGERs that comprise an INTEGER so normally MPI_INT_SZ
C     * is 2.  That is there are 2 32 bit integers in a 64-bit integer.
C
      INTEGER*4 MPI_INT_SZ
      COMMON /MPISIZE/ MPI_INT_SZ

      REAL G( (LON*ILAT+1)*NLEV )

C     * HARD CODE "XBUF" DIMENSION DUE TO PROBLEM WITH "NANS" INITIALIZATION
C     * UNDER AIX. IT'S SET TO HANDLE UP TO 641X320 (T213 GRID).

      REAL XBUF(205120),GBUF(205120)
      INTEGER*4 SZ, MASTER, IERR
C----------------------------------------------------------------------
      IF(LON*NLAT.GT.205120) CALL                  XIT('WPKPHS4',-1)
      MASTER = 0
      SZ     = ILAT*LON*MPI_INT_SZ
      JX=1
      LON1=LON+1
C
      DO 30 I=1,8
        KBUF(I)=IBUF(I)
 30   CONTINUE
C
      DO 100 L = 1,NLEV
        IF( NLEV.EQ.1 )         THEN
          KBUF(4) = 1
        ELSE IF( NLEV.EQ.LEV )  THEN
          IF( L.EQ.LEV ) THEN
            IF(KBUF(3).NE.NC4TO8(" EMD") .AND.
     1         KBUF(3).NE.NC4TO8(" EMM")) CALL     XIT('WPKPHS4',-2)
            KBUF(4) = 0
          ELSE
            KBUF(4) = LH(LEV-L)
          ENDIF
        ELSE
          KBUF(4) = LH(L)
        ENDIF
C
        IF (NNODE > 1) THEN
          CALL WRAP_GATHER(G(JX) , SZ,            MY_INT_TYPE,
     1                     XBUF  , SZ,            MY_INT_TYPE,
     2                     MASTER, AGCM_COMMWRLD, IERR)
        ELSE
          XBUF(1:LON*NLAT)= G(JX:JX+ILAT*LON-1)
        ENDIF
        JX = JX + (ILAT*LON + 1)

        IF (MYNODE == 0) THEN
          DO J=1,NLAT
            DO I=1,LON
              GBUF((J-1)*LON1+I)=XBUF((J-1)*LON+I)
            ENDDO
            GBUF(J*LON1)=GBUF((J-1)*LON1+1)
          ENDDO
C
          DO 70 I=1,8
            JBUF(I)=KBUF(I)
 70       CONTINUE
C
          CALL CGTORG(XBUF,GBUF,JBUF(5),JBUF(6))
          CALL PUTFLD2(NF,XBUF,JBUF,JBUF(5)*JBUF(6))
        ENDIF
 100  CONTINUE
C
      DO 300 I=1,8
        IBUF(I)=KBUF(I)
 300  CONTINUE
C
      RETURN
      END
