      SUBROUTINE WRITE_FIELDREC(                                                 WRITE_FIELDREC.1
     +                            IUNIT,                                         WRITE_FIELDREC.2
     +                            NDIM,                                          WRITE_FIELDREC.3
     +                            INEST,                                         WRITE_FIELDREC.4
     +                            BUFFER,                                        WRITE_FIELDREC.5
     +                            XTIME,                                         WRITE_FIELDREC.6
     +                            ANAME,                                         WRITE_FIELDREC.7
     +                            ACURRENT_DATE,                                 WRITE_FIELDREC.8
     +                            ASTAGGERING,                                   WRITE_FIELDREC.9
     +                            AORDERING,                                     WRITE_FIELDREC.10
     +                            AUNITS,                                        WRITE_FIELDREC.11
     +                            ADESCRIPTION,                                  WRITE_FIELDREC.12
     +                            IR, JR, KR,                                    WRITE_FIELDREC.13
     +                            IM, JM, KM )                                   WRITE_FIELDREC.14
C                                                                                WRITE_FIELDREC.15
C Called by version 3 outtap.                                                    WRITE_FIELDREC.16
C                                                                                WRITE_FIELDREC.17
      IMPLICIT NONE                                                              WRITE_FIELDREC.18

#ifdef MPP1
#include <parame.incl>
#endif
      INTEGER        NDIM                                                        WRITE_FIELDREC.19
      INTEGER        IUNIT                                                       WRITE_FIELDREC.20
                                                                                 WRITE_FIELDREC.21
      CHARACTER*(*)  ANAME                                                       WRITE_FIELDREC.22
      CHARACTER*(*)  ASTAGGERING                                                 WRITE_FIELDREC.23
      CHARACTER*(*)  AORDERING                                                   WRITE_FIELDREC.24
      CHARACTER*(*)  ACURRENT_DATE                                               WRITE_FIELDREC.25
      CHARACTER*(*)  AUNITS                                                      WRITE_FIELDREC.26
      CHARACTER*(*)  ADESCRIPTION                                                WRITE_FIELDREC.27
      CHARACTER*9    NAME                                                        WRITE_FIELDREC.28
      CHARACTER*4    STAGGERING                                                  WRITE_FIELDREC.29
      CHARACTER*4    ORDERING                                                    WRITE_FIELDREC.30
      CHARACTER*24   CURRENT_DATE                                                WRITE_FIELDREC.31
      CHARACTER*25   UNITS                                                       WRITE_FIELDREC.32
      CHARACTER*46   DESCRIPTION                                                 WRITE_FIELDREC.33
                                                                                 WRITE_FIELDREC.34
#ifdef MPP1                                                                      WRITE_FIELDREC.35
C CHARACTER ARRAYS SUITABLE FOR PASSING TO NON-FORTRAN ROUTINES                  WRITE_FIELDREC.36
      CHARACTER      SNAME         (9)                                           WRITE_FIELDREC.37
      CHARACTER      SSTAGGERING   (4)                                           WRITE_FIELDREC.38
      CHARACTER      SORDERING     (4)                                           WRITE_FIELDREC.39
      CHARACTER      SCURRENT_DATE (24)                                          WRITE_FIELDREC.40
      CHARACTER      SUNITS        (25)                                          WRITE_FIELDREC.41
      CHARACTER      SDESCRIPTION  (46)                                          WRITE_FIELDREC.42
      REAL           BUFFER2(MIX*MJX*MKX)
#endif                                                                           WRITE_FIELDREC.43
                                                                                 WRITE_FIELDREC.44
      REAL           BUFFER(*)                                                   WRITE_FIELDREC.45
      INTEGER        INEST                                                       WRITE_FIELDREC.46
      REAL           XTIME                                                       WRITE_FIELDREC.47
      INTEGER        IR, JR, KR                                                  WRITE_FIELDREC.48
      INTEGER        IM, JM, KM                                                  WRITE_FIELDREC.49
      LOGICAL        DM_IONODE                                                   WRITE_FIELDREC.50
      EXTERNAL       DM_IONODE                                                   WRITE_FIELDREC.51
C                                                                                WRITE_FIELDREC.52
      INTEGER        I,J,K,IC                                                       07NOV00.804
      INTEGER        SH_FLAG                                                     WRITE_FIELDREC.54
C                                                                                WRITE_FIELDREC.55
      NAME         = '         '                                                 WRITE_FIELDREC.56
      STAGGERING   = '    '                                                      WRITE_FIELDREC.57
      ORDERING     = '    '                                                      WRITE_FIELDREC.58
      CURRENT_DATE = '                        '                                  WRITE_FIELDREC.59
      UNITS        = '                         '                                 WRITE_FIELDREC.60
      DESCRIPTION  = '                                              '            WRITE_FIELDREC.61
      NAME(1:LEN(ANAME))=ANAME                                                   WRITE_FIELDREC.62
      STAGGERING(1:LEN(ASTAGGERING))=ASTAGGERING                                 WRITE_FIELDREC.63
      ORDERING(1:LEN(AORDERING))=AORDERING                                       WRITE_FIELDREC.64
      CURRENT_DATE(1:LEN(ACURRENT_DATE))=ACURRENT_DATE                           WRITE_FIELDREC.65
      UNITS(1:LEN(AUNITS))=AUNITS                                                WRITE_FIELDREC.66
      DESCRIPTION(1:LEN(ADESCRIPTION))=ADESCRIPTION                              WRITE_FIELDREC.67
      SH_FLAG=1                                                                  WRITE_FIELDREC.68
      CALL WRITE_FLAG(IUNIT,SH_FLAG)                                             WRITE_FIELDREC.69
#ifndef MPP1                                                                     WRITE_FIELDREC.70
      WRITE (IUNIT)NDIM,1,1,1,1,IR,JR,KR,1,XTIME,STAGGERING,ORDERING,            WRITE_FIELDREC.71
     +             CURRENT_DATE,NAME,UNITS,DESCRIPTION                           WRITE_FIELDREC.72
      WRITE (IUNIT)(BUFFER(I),I=1,IR*JR*KR)                                      WRITE_FIELDREC.73
#else                                                                            WRITE_FIELDREC.74
      DO I=1,9                                                                   WRITE_FIELDREC.75
        SNAME(I)=NAME(I:I)                                                       WRITE_FIELDREC.76
      ENDDO                                                                      WRITE_FIELDREC.77
      DO I=1,4                                                                   WRITE_FIELDREC.78
        SSTAGGERING(I)=STAGGERING(I:I)                                           WRITE_FIELDREC.79
      ENDDO                                                                      WRITE_FIELDREC.80
      DO I=1,4                                                                   WRITE_FIELDREC.81
        SORDERING(I)=ORDERING(I:I)                                               WRITE_FIELDREC.82
      ENDDO                                                                      WRITE_FIELDREC.83
      DO I=1,24                                                                  WRITE_FIELDREC.84
        SCURRENT_DATE(I)=CURRENT_DATE(I:I)                                       WRITE_FIELDREC.85
      ENDDO                                                                      WRITE_FIELDREC.86
      DO I=1,25                                                                  WRITE_FIELDREC.87
        SUNITS(I)=UNITS(I:I)                                                     WRITE_FIELDREC.88
      ENDDO                                                                      WRITE_FIELDREC.89
      DO I=1,46                                                                  WRITE_FIELDREC.90
        SDESCRIPTION(I)=DESCRIPTION(I:I)                                         WRITE_FIELDREC.91
      ENDDO                                                                      WRITE_FIELDREC.92
      CALL RSL_WRITE_MM5V3_SM_HEADER(IUNIT,NDIM,1,1,1,1,IR,JR,KR,1,              WRITE_FIELDREC.93
     +     IWORDSIZE,XTIME,RWORDSIZE,SSTAGGERING,4,SORDERING,4,                  WRITE_FIELDREC.94
     +     SCURRENT_DATE,24,SNAME,9,SUNITS,25,SDESCRIPTION,46)                   WRITE_FIELDREC.95
C                                                                                WRITE_FIELDREC.96
      IF(NDIM.GE.2.AND.NDIM.LE.3.AND.ORDERING(1:2).EQ.'YX')THEN                  WRITE_FIELDREC.97
        CALL DM_DIST_WRITE(IUNIT,INEST,BUFFER,NDIM,IR,JR,KR,IM,JM,KM)            WRITE_FIELDREC.98
      ELSE IF(NDIM.EQ.2.AND.ORDERING(1:2).EQ.'CA')THEN                           07NOV00.805
        IF ( DM_IONODE() ) THEN                                                  07NOV00.806
          IC = 1
          DO J=1,JR
            DO I=1,IR
              IF ( IC .GT. MIX*MJX*MKX ) THEN
		WRITE(0,*)'FATAL INTERNAL ERROR: WRITE_FIELDREC'
		WRITE(0,*)'WOULD OVERWRITE BUFFER2'
		WRITE(0,*)'Contact mesouser@ucar.edu'
		STOP
              ENDIF
              BUFFER2(IC) = BUFFER(I+(J-1)*IM)
              IC = IC+1
            ENDDO
          ENDDO
          CALL RSL_WRITE_1D_DATA(IUNIT,BUFFER2,IC-1,RSL_REAL)
        ENDIF                                                                           07NOV00.808
      ELSE                                                                       WRITE_FIELDREC.99
        CALL RSL_WRITE_1D_DATA(IUNIT,BUFFER,IR*JR*KR,RSL_REAL)                   WRITE_FIELDREC.100
      ENDIF                                                                      WRITE_FIELDREC.101
#endif                                                                           WRITE_FIELDREC.102
      RETURN                                                                     WRITE_FIELDREC.103
      END                                                                        WRITE_FIELDREC.104
                                                                                 WRITE_FIELDREC.105
