!
!##################################################################
!##################################################################
!######                                                      ######
!######                SUBROUTINE BINREAD                    ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!


SUBROUTINE binread(nx,ny,nz,nstyps,grdbas,inch,time,x,y,z,zp,           & 2,4
           uprt, vprt, wprt, ptprt, pprt,                               &
           qvprt, qc, qr, qi, qs, qh, tke,kmh,kmv,                      &
           ubar, vbar, wbar, ptbar, pbar, rhobar, qvbar,                &
           soiltyp,stypfrct,vegtyp,lai,roufns,veg,                      &
           tsfc,tsoil,wetsfc,wetdp,wetcanp,snowdpth,                    &
           raing,rainc,prcrate,                                         &
           radfrc,radsw,rnflx,                                          &
           usflx,vsflx,ptsflx,qvsflx,                                   &
           ireturn)

!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Read in binary data set created by ARPS using history dump format
!  No. 1.
!  All data read in are located at the original staggered grid points
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Ming Xue
!  2/27/92.
!
!  MODIFICATION HISTORY:
!
!  6/08/92
!  Added full documentation (K. Brewster)
!
!  7/14/92 (K. Brewster)
!  Added runname, comment and version number reading
!
!  8/20/92 (M. Xue)
!  Added data reading of computational z coordinate array z.
!
!  4/23/93 (M. Xue)
!  New data format.
!
!  02/06/95 (Y. Liu)
!  Added map projection parameters into the binary dumping
!
!  03/26/96 (G. Bassett)
!  Backwards compatibility added for ARPS 3.2 and ARPS 4.0 binary
!  history dump formats.
!
!  12/09/1998 (Donghai Wang)
!  Added the snow cover.
!
!-----------------------------------------------------------------------
!
!  INPUT :
!
!    nx       Number of grid points in the x-direction (east/west)
!    ny       Number of grid points in the y-direction (north/south)
!    nz       Number of grid points in the vertical
!
!    grdbas   Data read flag.
!             =1, only grid and base state arrays will be read
!             =0, all arrays will be read based on data
!                 parameter setting.
!    inch     Channel number for binary reading.
!             This channel must be opened for unformatted reading
!             by the calling routine.
!
!  OUTPUT:
!
!    time     Time in seconds of data read from "filename"
!
!    x        x coordinate of grid points in physical/comp. space (m)
!    y        y coordinate of grid points in physical/comp. space (m)
!    z        z coordinate of grid points in computational space (m)
!    zp       z coordinate of grid points in physical space (m)
!
!    uprt     x component of perturbation velocity (m/s)
!    vprt     y component of perturbation velocity (m/s)
!    wprt     Vertical component of perturbation velocity in
!             Cartesian coordinates (m/s).
!    ptprt    Perturbation potential temperature (K)
!    pprt     Perturbation pressure (Pascal)
!
!    qvprt    Perturbation water vapor mixing ratio (kg/kg)
!    qc       Cloud water mixing ratio (kg/kg)
!    qr       Rainwater mixing ratio (kg/kg)
!    qi       Cloud ice mixing ratio (kg/kg)
!    qs       Snow mixing ratio (kg/kg)
!    qh       Hail mixing ratio (kg/kg)
!    tke      Turbulent Kinetic Energy ((m/s)**2)
!
!    kmh      Horizontal turb. mixing coef. for momentum ( m**2/s )
!    kmv      Vertical turb. mixing coef. for momentum ( m**2/s )
!
!    ubar     Base state x velocity component (m/s)
!    vbar     Base state y velocity component (m/s)
!    wbar     Base state z velocity component (m/s)
!    ptbar    Base state potential temperature (K)
!    pbar     Base state pressure (Pascal)
!    rhobar   Base state air density (kg/m**3)
!    qvbar    Base state water vapor mixing ratio (kg/kg)
!
!    soiltyp  Soil type
!    stypfrct  Soil type fraction
!    vegtyp   Vegetation type
!    lai      Leaf Area Index
!    roufns   Surface roughness
!    veg      Vegetation fraction
!
!    tsfc     Temperature at surface (K)
!    tsoil    Deep soil temperature (K)
!    wetsfc   Surface soil moisture
!    wetdp    Deep soil moisture
!    wetcanp  Canopy water amount
!
!    raing    Grid supersaturation rain
!    rainc    Cumulus convective rain
!    prcrate  Precipitation rates
!
!    radfrc   Radiation forcing (K/s)
!    radsw    Solar radiation reaching the surface
!    rnflx    Net radiation flux absorbed by surface
!
!    usflx    Surface flux of u-momentum (kg/(m*s**2))
!    vsflx    Surface flux of v-momentum (kg/(m*s**2))
!    ptsflx   Surface heat flux (K*kg/(m**2 * s ))
!    qvsflx   Surface moisture flux of (kg/(m**2 * s))
!
!    ireturn  Return status indicator
!             =0, successful read of all data
!             =1, error reading data
!             =2, end-of-file reached during read attempt
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: nx,ny,nz          ! Number of grid points in 3 directions
  REAL :: x     (nx)           ! x-coord. of the physical and compu
                               ! -tational grid. Defined at u-point(m).
  REAL :: y     (ny)           ! y-coord. of the physical and compu
                               ! -tational grid. Defined at v-point(m).
  REAL :: z     (nz)           ! z-coord. of the computational grid.
                               ! Defined at w-point on the staggered
                               ! grid(m).
  REAL :: zp    (nx,ny,nz)     ! Physical height coordinate defined at
                               ! w-point of the staggered grid(m).

  INTEGER :: grdbas            ! Data read flag.
  INTEGER :: inch              ! Channel number for binary reading
  REAL :: time                 ! Time in seconds of data read
                               ! from "filename"

  REAL :: uprt  (nx,ny,nz)     ! Perturbation u-velocity (m/s)
  REAL :: vprt  (nx,ny,nz)     ! Perturbation v-velocity (m/s)
  REAL :: wprt  (nx,ny,nz)     ! Perturbation w-velocity (m/s)
  REAL :: ptprt (nx,ny,nz)     ! Perturbation potential temperature (K)
  REAL :: pprt  (nx,ny,nz)     ! Perturbation pressure (Pascal)

  REAL :: qvprt (nx,ny,nz)     ! Perturbation water vapor mixing
                               ! ratio (kg/kg)
  REAL :: qc    (nx,ny,nz)     ! Cloud water mixing ratio (kg/kg)
  REAL :: qr    (nx,ny,nz)     ! Rain water mixing ratio (kg/kg)
  REAL :: qi    (nx,ny,nz)     ! Cloud ice mixing ratio (kg/kg)
  REAL :: qs    (nx,ny,nz)     ! Snow mixing ratio (kg/kg)
  REAL :: qh    (nx,ny,nz)     ! Hail mixing ratio (kg/kg)
  REAL :: tke  (nx,ny,nz)      ! Turbulent Kinetic Energy ((m/s)**2)
  REAL :: kmh   (nx,ny,nz)     ! Horizontal turb. mixing coef. for
                               ! momentum. ( m**2/s )
  REAL :: kmv   (nx,ny,nz)     ! Vertical turb. mixing coef. for
                               ! momentum. ( m**2/s )

  REAL :: ubar  (nx,ny,nz)     ! Base state u-velocity (m/s)
  REAL :: vbar  (nx,ny,nz)     ! Base state v-velocity (m/s)
  REAL :: wbar  (nx,ny,nz)     ! Base state w-velocity (m/s)
  REAL :: ptbar (nx,ny,nz)     ! Base state potential temperature (K)
  REAL :: pbar  (nx,ny,nz)     ! Base state pressure (Pascal)
  REAL :: rhobar(nx,ny,nz)     ! Base state air density (kg/m**3)
  REAL :: qvbar (nx,ny,nz)     ! Base state water vapor mixing ratio

  INTEGER :: nstyps                    ! Number of soil type
  INTEGER :: soiltyp(nx,ny,nstyps)     ! Soil type
  REAL :: stypfrct(nx,ny,nstyps)    ! Soil type fraction
  INTEGER :: vegtyp(nx,ny)             ! Vegetation type
  REAL :: lai    (nx,ny)            ! Leaf Area Index
  REAL :: roufns (nx,ny)            ! Surface roughness
  REAL :: veg    (nx,ny)            ! Vegetation fraction

  REAL :: tsfc   (nx,ny,0:nstyps)      ! Temperature at surface (K)
  REAL :: tsoil  (nx,ny,0:nstyps)      ! Deep soil temperature (K)
  REAL :: wetsfc (nx,ny,0:nstyps)      ! Surface soil moisture
  REAL :: wetdp  (nx,ny,0:nstyps)      ! Deep soil moisture
  REAL :: wetcanp(nx,ny,0:nstyps)      ! Canopy water amount
  REAL :: snowdpth(nx,ny)              ! Snow depth (m)

  REAL :: raing(nx,ny)         ! Grid supersaturation rain
  REAL :: rainc(nx,ny)         ! Cumulus convective rain
  REAL :: prcrate(nx,ny,4)     ! precipitation rate (kg/(m**2*s))
                               ! prcrate(1,1,1) = total precip. rate
                               ! prcrate(1,1,2) = grid scale precip. rate
                               ! prcrate(1,1,3) = cumulus precip. rate
                               ! prcrate(1,1,4) = microphysics precip. rate

  REAL :: radfrc(nx,ny,nz)     ! Radiation forcing (K/s)
  REAL :: radsw (nx,ny)        ! Solar radiation reaching the surface
  REAL :: rnflx (nx,ny)        ! Net radiation flux absorbed by surface

  REAL :: usflx (nx,ny)        ! Surface flux of u-momentum (kg/(m*s**2))
  REAL :: vsflx (nx,ny)        ! Surface flux of v-momentum (kg/(m*s**2))
  REAL :: ptsflx(nx,ny)        ! Surface heat flux (K*kg/(m**2*s))
  REAL :: qvsflx(nx,ny)        ! Surface moisture flux (kg/(m**2*s))

  INTEGER :: ireturn           ! Return status indicator
!
!-----------------------------------------------------------------------
!
!  Parameters describing routine that wrote the gridded data
!
!-----------------------------------------------------------------------
!
  CHARACTER (LEN=40) :: fmtver0,fmtver1,fmtver,fmtverin
  PARAMETER (fmtver='004.10 Binary Data')
  PARAMETER (fmtver0='003.20 Binary Data')
  PARAMETER (fmtver1='004.00 Binary Data')
  INTEGER :: oldver            ! Flag indicating if the file is an old
                               ! (oldver=1) or current format (oldver=0).

  CHARACTER (LEN=10) :: tmunit
!
!-----------------------------------------------------------------------
!
!  Misc. local variables
!
!-----------------------------------------------------------------------
!
  INTEGER :: lchanl
  PARAMETER (lchanl=6)      ! Channel number for formatted printing.

  INTEGER :: i,j,k,is
  INTEGER :: nstyp1
  CHARACTER (LEN=12) :: label
  INTEGER :: nxin,nyin,nzin
  INTEGER :: bgrdin,bbasin,bvarin,bicein,btkein,btrbin
  INTEGER :: idummy
  REAL :: rdummy
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'indtflg.inc'
  INCLUDE 'globcst.inc'
  INCLUDE 'grid.inc'          ! Grid & map parameters.
  INCLUDE 'mp.inc'            ! mpi parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!
!-----------------------------------------------------------------------
!
!  Read header info
!
!-----------------------------------------------------------------------
!
  READ(inch,ERR=110,END=120) fmtverin

  IF(( fmtverin /= fmtver ) .AND. ( fmtverin /= fmtver0 )               &
        .AND. ( fmtverin /= fmtver1 )) THEN
    IF (myproc == 0)  &
       WRITE(6,'(/1x,a/1x,2a/1x,2a/1x,2a/1x,a)')                           &
        'Data format incompatible with the data reader.',               &
        'Format of data is ',fmtverin,' Format of reader is ',fmtver1,  &
        'compitable to ',fmtver0, '. Job stopped.'
    CALL arpsstop('arpstop called from binread header read',1)
  END IF

  IF ( fmtverin == fmtver ) THEN
    oldver = 0
  ELSE
    oldver = 1
  END IF

  READ(inch,ERR=110,END=120) runname
  READ(inch,ERR=110,END=120) nocmnt
  IF( nocmnt > 0 ) THEN
    DO i=1,nocmnt
      READ(inch,ERR=110,END=120) cmnt(i)
    END DO
  END IF

  IF (myproc == 0)  &
     WRITE(6,'(//''  THE NAME OF THIS RUN IS:  '',A//)') runname

  IF( nocmnt > 0 ) THEN
    IF(myproc == 0)THEN
      DO i=1,nocmnt
        WRITE(6,'(1x,a)') cmnt(i)
      END DO
    END IF
  END IF

  READ(inch,ERR=110,END=120) time,tmunit
!
!-----------------------------------------------------------------------
!
!  Get dimensions of data in binary file and check against
!  the dimensions passed to BINREAD
!
!-----------------------------------------------------------------------
!
  READ(inch,ERR=110,END=120) nxin, nyin, nzin

  IF( nxin /= nx .OR. nyin /= ny .OR. nzin /= nz ) THEN
    IF(myproc == 0)THEN
      WRITE(6,'(1x,a)')                                                   &
         ' Dimensions in BINREAD inconsistent with data.'
      WRITE(6,'(1x,a,3I15)') ' Read were: ', nxin, nyin, nzin
      WRITE(6,'(1x,a,3I15)') ' Expected:  ', nx, ny, nz
      WRITE(6,'(1x,a)')                                                   &
         ' Program aborted in BINREAD.'
    END IF
    CALL arpsstop('arpstop called from binread nx-ny-nz read ',1)
  END IF
!
!-----------------------------------------------------------------------
!
!  Read in flags for different data groups
!
!-----------------------------------------------------------------------
!
  IF( grdbas == 1 ) THEN ! Read grid and base state arrays

    IF (myproc == 0)  &
       WRITE(lchanl,'(1x,a,f8.1,a,f8.3,a/)')                               &
         'To read grid and base state data at time ', time,             &
         ' secs = ',(time/60.),' mins.'

    READ(inch,ERR=110,END=120)                                          &
         bgrdin,bbasin,bvarin,mstin,bicein,                             &
         btrbin,idummy,idummy,landin,totin,                             &
         btkein,idummy,idummy,mapproj,month,                            &
         day, year, hour, minute, second

  ELSE ! Normal data reading

    IF (myproc == 0)  &
       WRITE(lchanl,'(1x,a,f8.1,a,f8.3,a/)')'To read data for time:',      &
         time,' secs = ',(time/60.),' mins.'

    READ(inch,ERR=110,END=120)                                          &
         grdin,basin,varin,mstin,icein,                                 &
         trbin, sfcin,rainin,landin,totin,                              &
         tkein,idummy,idummy,mapproj, month,                            &
         day, year, hour, minute, second

  END IF

  READ(inch,ERR=110,END=120)                                            &
                  umove,vmove,xgrdorg,ygrdorg,trulat1,                  &
                  trulat2,trulon,sclfct,rdummy,rdummy,                  &
                  rdummy,rdummy,rdummy,rdummy,rdummy,                   &
                  tstop,thisdmp,latitud,ctrlat,ctrlon

  IF ( totin /= 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Read in additional parameters for ARPS history dump 4.0 or later
!  version.
!
!-----------------------------------------------------------------------
!
    READ(inch,ERR=110,END=120)                                          &
         nstyp1,  prcin, radin, flxin,snowcin,                           &
         snowin,idummy,idummy,idummy,idummy,                            &
         idummy,idummy,idummy,idummy,idummy,                            &
         idummy,idummy,idummy,idummy,idummy

    IF ( nstyp1 < 1 ) THEN
      nstyp1 = 1
    END IF

    READ(inch,ERR=110,END=120)                                          &
         rdummy,rdummy,rdummy,rdummy,rdummy,                            &
         rdummy,rdummy,rdummy,rdummy,rdummy,                            &
         rdummy,rdummy,rdummy,rdummy,rdummy,                            &
         rdummy,rdummy,rdummy,rdummy,rdummy
  END IF
!
!-----------------------------------------------------------------------
!
!  Read in x, y, z and zp arrays.
!
!----------------------------------------------------------------------
!
  IF( grdin == 1 .OR. grdbas == 1 ) THEN
    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) x
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' x.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) y
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' y.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) z
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' z.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) zp
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' zp.'
  END IF  ! grdin
!
!-----------------------------------------------------------------------
!
!  Read in base state fields
!
!----------------------------------------------------------------------
!
  IF( basin == 1 .OR. grdbas == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ubar
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' ubar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) vbar
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' vbar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) wbar
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' wbar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ptbar
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' ptbar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) pbar
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' pbar.'

    IF( mstin == 1) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) qvbar
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' qvbar.'
    END IF

    IF (landin == 1) THEN

      IF (nstyp1 <= 1) THEN

        READ(inch,ERR=110,END=120) label
        READ(inch,ERR=110,END=120) ((soiltyp(i,j,1),i=1,nx),j=1,ny)
        IF (myproc == 0)  &
           WRITE(lchanl,910) label,' soiltyp.'

      ELSE

        DO is=1,nstyp1
          IF (is <= nstyps) THEN
            READ(inch,ERR=110,END=120) label
            READ(inch,ERR=110,END=120)                                    &
                  ((soiltyp(i,j,is),i=1,nx),j=1,ny)
            IF (myproc == 0)  &
               WRITE(lchanl,910) label,' soiltyp.'
  
            READ(inch,ERR=110,END=120) label
            READ(inch,ERR=110,END=120)                                    &
                  ((stypfrct(i,j,is),i=1,nx),j=1,ny)
            IF (myproc == 0)  &
               WRITE(lchanl,910) label,' stypfrct.'
          ELSE
            READ(inch,ERR=110,END=120) label
            IF (myproc == 0)  &
               WRITE(lchanl,910) label,'skipping soiltyp'
            READ(inch,ERR=110,END=120)
            READ(inch,ERR=110,END=120) label
            IF (myproc == 0)  &
               WRITE(lchanl,910) label,'skipping stypfrct.'
            READ(inch,ERR=110,END=120) 
          ENDIF
        END DO

      END IF

      CALL fix_stypfrct_nstyp(nx,ny,nstyp1,nstyp,stypfrct)

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) vegtyp
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' vegtyp.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) lai
      IF (myproc == 0)  &
        WRITE(lchanl,910) label,' lai.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) roufns
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' roufns.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) veg
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' veg.'

    END IF

  END IF

  IF( grdbas == 1 ) GO TO 930

  IF( varin == 1 ) THEN

    IF ( totin == 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Read in perturbations from history dump
!
!-----------------------------------------------------------------------
!
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) uprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' uprt.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) vprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' vprt.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) wprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' wprt.'
!
!-----------------------------------------------------------------------
!
!  Read in scalars
!
!----------------------------------------------------------------------
!
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ptprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' ptprt.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) pprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' pprt.'

    ELSE
!
!-----------------------------------------------------------------------
!
!  Read in total values of variables from history dump
!
!----------------------------------------------------------------------
!
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) uprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' u.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx
            uprt(i,j,k) = uprt(i,j,k) - ubar(i,j,k)
          END DO
        END DO
      END DO

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) vprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' v.'
      DO k=1,nz-1
        DO j=1,ny
          DO i=1,nx-1
            vprt(i,j,k) = vprt(i,j,k) - vbar(i,j,k)
          END DO
        END DO
      END DO

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) wprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' w.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ptprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' pt.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            ptprt(i,j,k) = ptprt(i,j,k) - ptbar(i,j,k)
          END DO
        END DO
      END DO

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) pprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' p.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            pprt(i,j,k) = pprt(i,j,k) - pbar(i,j,k)
          END DO
        END DO
      END DO

    END IF

  END IF
!
!-----------------------------------------------------------------------
!
!  Read in moisture variables
!
!-----------------------------------------------------------------------
!
  IF( mstin == 1 ) THEN

    IF ( totin == 0 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) qvprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' qvprt.'

    ELSE

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) qvprt
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' qv.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            qvprt(i,j,k) = qvprt(i,j,k) - qvbar(i,j,k)
          END DO
        END DO
      END DO

    END IF

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) qc
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' qc.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) qr
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' qr.'

    IF( rainin == 1 ) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) raing
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' raing.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) rainc
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' rainc.'
    END IF

    IF( prcin == 1 ) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((prcrate(i,j,1),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' prcrate1.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((prcrate(i,j,2),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' prcrate2.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((prcrate(i,j,3),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' prcrate3.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((prcrate(i,j,4),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' prcrate4.'
    END IF

    IF( icein == 1 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) qi
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' qi.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) qs
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' qs.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) qh
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' qh.'

    END IF
  END IF

  IF( tkein == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) tke
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' tke.'

  END IF

  IF( trbin == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) kmh
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' kmh.'

    IF ( oldver == 0 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) kmv
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' kmv.'

    END IF

  END IF

  IF( sfcin == 1 ) THEN

    IF (nstyp1 <= 1) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((tsfc(i,j,0),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' tsfc.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((tsoil(i,j,0),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' tsoil.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((wetsfc(i,j,0),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' wetsfc.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((wetdp(i,j,0),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' wetdp.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((wetcanp(i,j,0),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' wetcanp.'

    ELSE

      DO is=0,nstyp1
        IF (is <= nstyps) THEN
          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)                                      &
                ((tsfc(i,j,is),i=1,nx),j=1,ny)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,' tsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)                                      &
                ((tsoil(i,j,is),i=1,nx),j=1,ny)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,' tsoil.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)                                      &
                ((wetsfc(i,j,is),i=1,nx),j=1,ny)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,' wetsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)                                      &
                ((wetdp(i,j,is),i=1,nx),j=1,ny)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,' wetdp.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)                                      &
                ((wetcanp(i,j,is),i=1,nx),j=1,ny)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,' wetcanp.'
        ELSE
          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,'skipping tsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,'skipping tsoil.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,'skipping wetsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,'skipping wetdp.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          IF (myproc == 0)  &
             WRITE(lchanl,910) label,'skipping wetcanp.'
        ENDIF
      END DO

    END IF

    CALL fix_soil_nstyp(nx,ny,nstyp1,nstyp,tsfc,tsoil,wetsfc,wetdp,wetcanp)

    IF (snowcin == 1) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' snowcvr -- discarding.'
    END IF

    IF (snowin == 1) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          ((snowdpth(i,j),i=1,nx),j=1,ny)
      IF (myproc == 0)  &
         WRITE(lchanl,910) label,' snowdpth.'
    END IF

  END IF

  IF( radin == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) radfrc
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' radfrc.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) radsw
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' radsw.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) rnflx
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' rnflx.'

  END IF

  IF( flxin == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) usflx
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' usflx.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) vsflx
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' vsflx.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ptsflx
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' ptsflx.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) qvsflx
    IF (myproc == 0)  &
       WRITE(lchanl,910) label,' qvsflx.'

  END IF

  910   FORMAT(1X,'Field ',a12,' was read into array',a)

!
!-----------------------------------------------------------------------
!
!  Friendly exit message
!
!----------------------------------------------------------------------
!
  930   CONTINUE

  IF (myproc == 0)  &
     WRITE(6,'(/a,F8.1,a/)')                                               &
      ' Data at time=', time/60,' (min) were successfully read.'

  ireturn = 0

  RETURN
!
!-----------------------------------------------------------------------
!
!  Error during read
!
!----------------------------------------------------------------------
!

  110   CONTINUE
  WRITE(6,'(/a/)') ' Error reading data in BINREAD'
  ireturn=1
  RETURN
!
!-----------------------------------------------------------------------
!
!  End-of-file during read
!
!----------------------------------------------------------------------
!

  120   CONTINUE
  WRITE(6,'(/a/)') ' End of file reached in BINREAD'
  ireturn=2
  RETURN
END SUBROUTINE binread
!
!
!##################################################################
!##################################################################
!######                                                      ######
!######                SUBROUTINE BN2READ                    ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!


SUBROUTINE bn2read(nx,ny,nz,nstyps,grdbas,inch,time,x,y,z,zp,           & 2,4
           uprt, vprt, wprt, ptprt, pprt,                               &
           qvprt, qc, qr, qi, qs, qh, tke,kmh,kmv,                      &
           ubar, vbar, wbar, ptbar, pbar, rhobar, qvbar,                &
           soiltyp,stypfrct,vegtyp,lai,roufns,veg,                      &
           tsfc,tsoil,wetsfc,wetdp,wetcanp,snowdpth,                    &
           raing,rainc,prcrate,                                         &
           radfrc,radsw,rnflx,                                          &
           usflx,vsflx,ptsflx,qvsflx,                                   &
           ireturn)

!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Read in binary data set created by ARPS using history dump format
!  No.2.
!  All data read in are located at the original staggered grid points
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Ming Xue
!  2/27/92.
!
!  MODIFICATION HISTORY:
!
!  6/08/92  Added full documentation (K. Brewster)
!
!  7/14/92 (K. Brewster)
!  Added runname, comment and version number reading
!
!  8/20/92 (M. Xue)
!  Added data reading of computational z coordinate array z.
!
!  4/23/93 (M. Xue)
!  New data format.
!
!  02/06/95 (Y. Liu)
!  Added map projection parameters into the second binary dumping
!
!  12/09/1998 (Donghai Wang)
!  Added the snow cover.
!
!-----------------------------------------------------------------------
!
!  INPUT :
!
!    nx       Number of grid points in the x-direction (east/west)
!    ny       Number of grid points in the y-direction (north/south)
!    nz       Number of grid points in the vertical
!
!    grdbas   Data read flag.
!             =1, only grid and base state arrays will be read
!             =0, all arrays will be read based on data
!                          parameter setting.
!    inch     Channel number for binary reading.
!             This channel must be opened for unformatted reading
!             by the calling routine.
!
!  OUTPUT:
!
!    time     Time in seconds of data read from "filename"
!
!    x        x coordinate of grid points in physical/comp. space (m)
!    y        y coordinate of grid points in physical/comp. space (m)
!    z        z coordinate of grid points in computational space (m)
!    zp       z coordinate of grid points in physical space (m)
!
!    uprt     x component of perturbation velocity (m/s)
!    vprt     y component of perturbation velocity (m/s)
!    wprt     Vertical component of perturbation velocity in
!             Cartesian coordinates (m/s).
!    ptprt    Perturbation potential temperature (K)
!    pprt     Perturbation pressure (Pascal)
!
!    qvprt    Perturbation water vapor mixing ratio (kg/kg)
!    qc       Cloud water mixing ratio (kg/kg)
!    qr       Rainwater mixing ratio (kg/kg)
!    qi       Cloud ice mixing ratio (kg/kg)
!    qs       Snow mixing ratio (kg/kg)
!    qh       Hail mixing ratio (kg/kg)
!    tke      Turbulent Kinetic Energy ((m/s)**2)
!
!    kmh      Horizontal turb. mixing coef. for momentum ( m**2/s )
!    kmv      Vertical turb. mixing coef. for momentum ( m**2/s )
!
!    ubar     Base state x velocity component (m/s)
!    vbar     Base state y velocity component (m/s)
!    wbar     Base state z velocity component (m/s)
!    ptbar    Base state potential temperature (K)
!    pbar     Base state pressure (Pascal)
!    rhobar   Base state air density (kg/m**3)
!    qvbar    Base state water vapor mixing ratio (kg/kg)
!
!    soiltyp  Soil type
!    stypfrct  Soil type fraction
!    vegtyp   Vegetation type
!    lai      Leaf Area Index
!    roufns   Surface roughness
!    veg      Vegetation fraction
!
!    tsfc     Temperature at surface (K)
!    tsoil    Deep soil temperature (K)
!    wetsfc   Surface soil moisture
!    wetdp    Deep soil moisture
!    wetcanp  Canopy water amount
!
!    raing    Grid supersaturation rain
!    rainc    Cumulus convective rain
!    prcrate  Precipitation rates
!
!    radfrc   Radiation forcing (K/s)
!    radsw    Solar radiation reaching the surface
!    rnflx    Net radiation flux absorbed by surface
!
!    usflx    Surface flux of u-momentum (kg/(m*s**2))
!    vsflx    Surface flux of v-momentum (kg/(m*s**2))
!    ptsflx   Surface heat flux (K*kg/(m**2 * s ))
!    qvsflx   Surface moisture flux of (kg/(m**2 * s))
!
!    ireturn  Return status indicator
!             =0   successful read of all data
!             =1   error reading data
!             =2   end-of-file reached during read attempt
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: nx,ny,nz          ! Number of grid points in 3 directions

  REAL :: x     (nx)           ! x-coord. of the physical and compu
                               ! -tational grid. Defined at u-point(m).
  REAL :: y     (ny)           ! y-coord. of the physical and compu
                               ! -tational grid. Defined at v-point(m).
  REAL :: z     (nz)           ! z-coord. of the computational grid.
                               ! Defined at w-point on the staggered
                               ! grid(m).
  REAL :: zp    (nx,ny,nz)     ! Physical height coordinate defined at
                               ! w-point of the staggered grid(m).
  INTEGER :: grdbas            ! Data read flag.
  INTEGER :: inch              ! Channel number for binary reading
  REAL :: time                 ! Time in seconds of data read
                               ! from "filename"

  REAL :: uprt  (nx,ny,nz)     ! Perturbation u-velocity (m/s)
  REAL :: vprt  (nx,ny,nz)     ! Perturbation v-velocity (m/s)
  REAL :: wprt  (nx,ny,nz)     ! Perturbation w-velocity (m/s)
  REAL :: ptprt (nx,ny,nz)     ! Perturbation potential temperature (K)
  REAL :: pprt  (nx,ny,nz)     ! Perturbation pressure (Pascal)

  REAL :: qvprt (nx,ny,nz)     ! Perturbation water vapor mixing
                               ! ratio (kg/kg)
  REAL :: qc    (nx,ny,nz)     ! Cloud water mixing ratio (kg/kg)
  REAL :: qr    (nx,ny,nz)     ! Rain water mixing ratio (kg/kg)
  REAL :: qi    (nx,ny,nz)     ! Cloud ice mixing ratio (kg/kg)
  REAL :: qs    (nx,ny,nz)     ! Snow mixing ratio (kg/kg)
  REAL :: qh    (nx,ny,nz)     ! Hail mixing ratio (kg/kg)
  REAL :: tke  (nx,ny,nz)      ! Turbulent Kinetic Energy ((m/s)**2)
  REAL :: kmh   (nx,ny,nz)     ! Horizontal turb. mixing coef. for
                               ! momentum. ( m**2/s )
  REAL :: kmv   (nx,ny,nz)     ! Vertical turb. mixing coef. for
                               ! momentum. ( m**2/s )

  REAL :: ubar  (nx,ny,nz)     ! Base state u-velocity (m/s)
  REAL :: vbar  (nx,ny,nz)     ! Base state v-velocity (m/s)
  REAL :: wbar  (nx,ny,nz)     ! Base state w-velocity (m/s)
  REAL :: ptbar (nx,ny,nz)     ! Base state potential temperature (K)
  REAL :: pbar  (nx,ny,nz)     ! Base state pressure (Pascal)
  REAL :: rhobar(nx,ny,nz)     ! Base state air density (kg/m**3)
  REAL :: qvbar (nx,ny,nz)     ! Base state water vapor mixing ratio

  INTEGER :: nstyps                   ! Number of soil type
  INTEGER :: soiltyp(nx,ny,nstyps)    ! Soil type
  REAL :: stypfrct(nx,ny,nstyps)   ! Soil type
  INTEGER :: vegtyp(nx,ny)            ! Vegetation type
  REAL :: lai    (nx,ny)           ! Leaf Area Index
  REAL :: roufns (nx,ny)           ! Surface roughness
  REAL :: veg    (nx,ny)           ! Vegetation fraction

  REAL :: tsfc   (nx,ny,0:nstyps)     ! Temperature at surface (K)
  REAL :: tsoil  (nx,ny,0:nstyps)     ! Deep soil temperature (K)
  REAL :: wetsfc (nx,ny,0:nstyps)     ! Surface soil moisture
  REAL :: wetdp  (nx,ny,0:nstyps)     ! Deep soil moisture
  REAL :: wetcanp(nx,ny,0:nstyps)     ! Canopy water amount
  REAL :: snowdpth(nx,ny)             ! Snow depth (m)

  REAL :: raing(nx,ny)         ! Grid supersaturation rain
  REAL :: rainc(nx,ny)         ! Cumulus convective rain
  REAL :: prcrate(nx,ny,4)     ! precipitation rate (kg/(m**2*s))
                               ! prcrate(1,1,1) = total precip. rate
                               ! prcrate(1,1,2) = grid scale precip. rate
                               ! prcrate(1,1,3) = cumulus precip. rate
                               ! prcrate(1,1,4) = microphysics precip. rate

  REAL :: radfrc(nx,ny,nz)     ! Radiation forcing (K/s)
  REAL :: radsw (nx,ny)        ! Solar radiation reaching the surface
  REAL :: rnflx (nx,ny)        ! Net radiation flux absorbed by surface

  REAL :: usflx (nx,ny)        ! Surface flux of u-momentum (kg/(m*s**2))
  REAL :: vsflx (nx,ny)        ! Surface flux of v-momentum (kg/(m*s**2))
  REAL :: ptsflx(nx,ny)        ! Surface heat flux (K*kg/(m**2*s))
  REAL :: qvsflx(nx,ny)        ! Surface moisture flux (kg/(m**2*s))

  INTEGER :: ireturn           ! Return status indicator
!
!-----------------------------------------------------------------------
!
!  Parameters describing routine that wrote the gridded data
!
!-----------------------------------------------------------------------
!
  CHARACTER (LEN=40) :: fmtver0,fmtver1,fmtverin
  PARAMETER (fmtver0='004.10 2nd Binary Data')
  PARAMETER (fmtver1='004.10 2nd Binary Data')
  CHARACTER (LEN=10) :: tmunit
!
!-----------------------------------------------------------------------
!
!  Misc. local variables
!
!-----------------------------------------------------------------------
!
  INTEGER :: lchanl
  PARAMETER (lchanl=6)      ! Channel number for formatted printing.

  INTEGER :: i,j,k,is
  INTEGER :: nstyp1
  CHARACTER (LEN=12) :: label
  INTEGER :: nxin,nyin,nzin
  INTEGER :: bgrdin,bbasin,bvarin,bicein,btkein,btrbin,idummy
  REAL :: rdummy
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'indtflg.inc'
  INCLUDE 'globcst.inc'
  INCLUDE 'grid.inc'          ! Grid & map parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!
!-----------------------------------------------------------------------
!
!  Read header info
!
!-----------------------------------------------------------------------
!
  READ(inch,ERR=110,END=120) fmtverin

  IF( fmtverin /= fmtver0 .AND. fmtverin /= fmtver1 ) THEN
    WRITE(6,'(/1x,a/1x,2a/1x,2a/1x,2a/1x,a)')                           &
        'Data format incompatible with the data reader.',               &
        'Format of data is ',fmtverin,' Format of reader is ',fmtver1,  &
        'compitable to ',fmtver0, '. Job stopped.'
    CALL arpsstop('arpstop called from bn2read header read ',1)
  END IF

  READ(inch,ERR=110,END=120) runname
  READ(inch,ERR=110,END=120) nocmnt
  IF( nocmnt > 0 ) THEN
    DO i=1,nocmnt
      READ(inch,ERR=110,END=120) cmnt(i)
    END DO
  END IF

  WRITE(6,'(//''  THE NAME OF THIS RUN IS:  '',A//)') runname

  IF( nocmnt > 0 ) THEN
    DO i=1,nocmnt
      WRITE(6,'(1x,a)') cmnt(i)
    END DO
  END IF

  READ(inch,ERR=110,END=120) time,tmunit
!
!-----------------------------------------------------------------------
!
!  Get dimensions of data in binary file and check against
!  the dimensions passed to BN2READ
!
!-----------------------------------------------------------------------
!
  READ(inch,ERR=110,END=120) nxin, nyin, nzin

  IF( nxin /= nx .OR. nyin /= ny .OR. nzin /= nz ) THEN
    WRITE(6,'(1x,a)')                                                   &
         ' Dimensions in BN2READ inconsistent with data.'
    WRITE(6,'(1x,a,3I15)') ' Read were: ', nxin, nyin, nzin
    WRITE(6,'(1x,a)')                                                   &
         ' Program aborted in BN2READ.'
    CALL arpsstop('arpstop called from bn2read nx-ny-nz read',1)
  END IF
!
!-----------------------------------------------------------------------
!
!  Read in flags for different data groups
!
!-----------------------------------------------------------------------
!
  IF( grdbas == 1 ) THEN ! Read grid and base state arrays

    WRITE(lchanl,'(1x,a,f8.1,a,f8.3,a/)')                               &
         'To read grid and base state data at time ', time,             &
         ' secs = ',(time/60.),' mins.'

    READ(inch,ERR=110,END=120)                                          &
         bgrdin,bbasin,bvarin,mstin,bicein,                             &
         btrbin,idummy,idummy,landin,totin,                             &
         btkein,idummy,idummy,mapproj,month,                            &
         day,year,hour,minute,second

  ELSE ! Normal data reading

    WRITE(lchanl,'(1x,a,f8.1,a,f8.3,a/)')'To read data for time:',      &
         time,' secs = ',(time/60.),' mins.'

    READ(inch,ERR=110,END=120)                                          &
         grdin,basin,varin,mstin,icein,                                 &
         trbin,sfcin,rainin,landin,totin,                               &
         tkein,idummy,idummy,mapproj,month,                             &
         day,year,hour,minute,second

  END IF

  READ(inch,ERR=110,END=120)                                            &
                  umove,vmove,xgrdorg,ygrdorg,trulat1,                  &
                  trulat2,trulon,sclfct,rdummy,rdummy,                  &
                  rdummy,rdummy,rdummy,rdummy,rdummy,                   &
                  tstop,thisdmp,latitud,ctrlat,ctrlon

  IF ( totin /= 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Read in additional parameters for ARPS history dump 4.1 or later
!  version.
!
!-----------------------------------------------------------------------
!
    READ(inch,ERR=110,END=120)                                          &
         nstyp1,  prcin, radin, flxin,snowcin,                           &
         snowin,idummy,idummy,idummy,idummy,                            &
         idummy,idummy,idummy,idummy,idummy,                            &
         idummy,idummy,idummy,idummy,idummy

    IF ( nstyp1 < 1 ) THEN
      nstyp1 = 1
    END IF

    READ(inch,ERR=110,END=120)                                          &
         rdummy,rdummy,rdummy,rdummy,rdummy,                            &
         rdummy,rdummy,rdummy,rdummy,rdummy,                            &
         rdummy,rdummy,rdummy,rdummy,rdummy,                            &
         rdummy,rdummy,rdummy,rdummy,rdummy
  END IF
!
!-----------------------------------------------------------------------
!
!  Read in x,y and z at grid cell centers (scalar points).
!
!----------------------------------------------------------------------
!
  IF( grdin == 1 .OR. grdbas == 1 ) THEN
    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) (x(i),i=1,nx)
    WRITE(lchanl,910) label,' x.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) (y(j),j=1,ny)
    WRITE(lchanl,910) label,' y.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) (z(k),k=1,nz)
    WRITE(lchanl,910) label,' z.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((zp(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' zp.'
  END IF  ! grdin
!
!-----------------------------------------------------------------------
!
!  Read in base state fields
!
!----------------------------------------------------------------------
!
  IF( basin == 1 .OR. grdbas == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((ubar(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' ubar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((vbar(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' vbar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((wbar(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' wbar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((ptbar(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' ptbar.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((pbar(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' pbar.'


    IF( mstin == 1) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((qvbar(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' qvbar.'
    END IF

    IF(landin == 1) THEN

      IF( nstyp1 <= 1 ) THEN

        READ(inch,ERR=110,END=120) label
        READ(inch,ERR=110,END=120)                                      &
              ((soiltyp(i,j,1),i=1,nx),j=1,ny)
        WRITE(lchanl,910) label,' soiltyp.'

      ELSE

        DO is=1,nstyp1
          IF (is <= nstyps) THEN
            READ(inch,ERR=110,END=120) label
            READ(inch,ERR=110,END=120)                                  &
                  ((soiltyp(i,j,is),i=1,nx),j=1,ny)
            WRITE(lchanl,910) label,' soiltyp.'

            READ(inch,ERR=110,END=120) label
            READ(inch,ERR=110,END=120)                                  &
                  ((stypfrct(i,j,is),i=1,nx),j=1,ny)
            WRITE(lchanl,910) label,' stypfrct.'
          ELSE
            READ(inch,ERR=110,END=120) label
            READ(inch,ERR=110,END=120)
            WRITE(lchanl,910) label,'skipping soiltyp.'

            READ(inch,ERR=110,END=120) label
            READ(inch,ERR=110,END=120)
            WRITE(lchanl,910) label,'skipping stypfrct.'
          ENDIF
        END DO

      END IF

      CALL fix_stypfrct_nstyp(nx,ny,nstyp1,nstyp,stypfrct)

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((vegtyp (i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' vegtyp.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((lai    (i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' lai.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((roufns (i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' roufns.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((veg    (i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' veg.'

    END IF

  END IF

  IF( grdbas == 1 ) GO TO 930

  IF( varin == 1 ) THEN

    IF ( totin == 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Read in uprt, vprt, and wprt
!
!----------------------------------------------------------------------
!
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((uprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' uprt.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((vprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' vprt.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((wprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' wprt.'
!
!-----------------------------------------------------------------------
!
!  Read in scalars
!
!----------------------------------------------------------------------
!
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((ptprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' ptprt.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((pprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' pprt.'

    ELSE

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((uprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' u.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx
            uprt(i,j,k) = uprt(i,j,k) - ubar(i,j,k)
          END DO
        END DO
      END DO

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((vprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' v.'
      DO k=1,nz-1
        DO j=1,ny
          DO i=1,nx-1
            vprt(i,j,k) = vprt(i,j,k) - vbar(i,j,k)
          END DO
        END DO
      END DO

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((wprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' w.'
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((ptprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' pt.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            ptprt(i,j,k) = ptprt(i,j,k) - ptbar(i,j,k)
          END DO
        END DO
      END DO

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((pprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' p.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            pprt(i,j,k) = pprt(i,j,k) - pbar(i,j,k)
          END DO
        END DO
      END DO

    END IF

  END IF
!
!-----------------------------------------------------------------------
!
!  Read in moisture variables
!
!----------------------------------------------------------------------
!
  IF( mstin == 1 ) THEN

    IF ( totin == 0 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((qvprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' qvprt.'

    ELSE

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((qvprt(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' qv.'
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            qvprt(i,j,k) = qvprt(i,j,k) - qvbar(i,j,k)
          END DO
        END DO
      END DO

    END IF

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((qc(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' qc.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
        (((qr(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' qr.'

    IF( rainin == 1 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((raing(i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' raing.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((rainc(i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' rainc.'

    END IF

    IF( prcin == 1 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((prcrate(i,j,1),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' prcrate1.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((prcrate(i,j,2),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' prcrate2.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((prcrate(i,j,3),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' prcrate3.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
            ((prcrate(i,j,4),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' prcrate4.'

    END IF

    IF( icein == 1 ) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((qi(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' qi.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((qs(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' qs.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)                                        &
          (((qh(i,j,k),i=1,nx),j=1,ny),k=1,nz)
      WRITE(lchanl,910) label,' qh.'

    END IF
  END IF

  IF( tkein == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
          (((tke(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' tke.'

  END IF

  IF( trbin == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
          (((kmh(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' kmh.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
          (((kmv(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' kmv.'

  END IF

  IF( sfcin == 1 ) THEN

    IF (nstyp1 <= 1) THEN

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((tsfc(i,j,0),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' tsfc.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((tsoil(i,j,0),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' tsoil.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((wetsfc(i,j,0),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' wetsfc.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((wetdp(i,j,0),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' wetdp.'

      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120) ((wetcanp(i,j,0),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' wetcanp.'

    ELSE

      DO is=0,nstyp1
        IF (is <= nstyps) THEN
          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)((tsfc(i,j,is),i=1,nx),j=1,ny)
          WRITE(lchanl,910) label,' tsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)((tsoil(i,j,is),i=1,nx),j=1,ny)
          WRITE(lchanl,910) label,' tsoil.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)((wetsfc(i,j,is),i=1,nx),j=1,ny)
          WRITE(lchanl,910) label,' wetsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)((wetdp(i,j,is),i=1,nx),j=1,ny)
          WRITE(lchanl,910) label,' wetdp.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)((wetcanp(i,j,is),i=1,nx),j=1,ny)
          WRITE(lchanl,910) label,' wetcanp.'
        ELSE
          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          WRITE(lchanl,910) label,'skipping tsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          WRITE(lchanl,910) label,'skipping tsoil.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          WRITE(lchanl,910) label,'skipping wetsfc.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          WRITE(lchanl,910) label,'skipping wetdp.'

          READ(inch,ERR=110,END=120) label
          READ(inch,ERR=110,END=120)
          WRITE(lchanl,910) label,'skipping wetcanp.'
        ENDIF
      END DO

    END IF

    CALL fix_soil_nstyp(nx,ny,nstyp1,nstyp,tsfc,tsoil,wetsfc,wetdp,wetcanp)

    IF(snowcin == 1) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)
      WRITE(lchanl,910) label,' snowcvr -- discarding.'
    END IF

    IF(snowin == 1) THEN
      READ(inch,ERR=110,END=120) label
      READ(inch,ERR=110,END=120)((snowdpth(i,j),i=1,nx),j=1,ny)
      WRITE(lchanl,910) label,' snowdpth.'
    END IF

  END IF

  IF( radin == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120)                                          &
          (((radfrc(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    WRITE(lchanl,910) label,' radfrc.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ((radsw(i,j),i=1,nx),j=1,ny)
    WRITE(lchanl,910) label,' radsw.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ((rnflx(i,j),i=1,nx),j=1,ny)
    WRITE(lchanl,910) label,' rnflx.'

  END IF

  IF( flxin == 1 ) THEN

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ((usflx(i,j),i=1,nx),j=1,ny)
    WRITE(lchanl,910) label,' usflx.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ((vsflx(i,j),i=1,nx),j=1,ny)
    WRITE(lchanl,910) label,' vsflx.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ((ptsflx(i,j),i=1,nx),j=1,ny)
    WRITE(lchanl,910) label,' ptsflx.'

    READ(inch,ERR=110,END=120) label
    READ(inch,ERR=110,END=120) ((qvsflx(i,j),i=1,nx),j=1,ny)
    WRITE(lchanl,910) label,' qvsflx.'

  END IF

  910   FORMAT(1X,'Field ',a12,' was read into array',a)

!
!-----------------------------------------------------------------------
!
!  Friendly exit message
!
!----------------------------------------------------------------------
!
  930   CONTINUE

  WRITE(6,'(/a,F8.1,a/)')                                               &
      ' Data at time=', time/60,' (min) were successfully read.'

  ireturn = 0

  RETURN
!
!-----------------------------------------------------------------------
!
!  Error during read
!
!----------------------------------------------------------------------
!

  110   CONTINUE
  WRITE(6,'(/a/)') ' Error reading data in BN2READ'
  ireturn=1
  RETURN
!
!-----------------------------------------------------------------------
!
!  End-of-file during read
!
!----------------------------------------------------------------------
!

  120   CONTINUE
  WRITE(6,'(/a/)') ' End of file reached in BN2READ'
  ireturn=2
  RETURN
END SUBROUTINE bn2read
!
!##################################################################
!##################################################################
!######                                                      ######
!######                SUBROUTINE BINDUMP                    ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!


SUBROUTINE bindump(nx,ny,nz,nstyps, nchanl, grdbas,                     & 1,54
           u,v,w,ptprt,pprt,qv,qc,qr,qi,qs,qh,tke,kmh,kmv,              &
           ubar,vbar,ptbar,pbar,rhobar,qvbar,                           &
           x,y,z,zp,hterain, j1,j2,j3,                                  &
           soiltyp,stypfrct,vegtyp,lai,roufns,veg,                      &
           tsfc,tsoil,wetsfc,wetdp,wetcanp,snowdpth,                    &
           raing,rainc,prcrate,                                         &
           radfrc,radsw,rnflx,                                          &
           usflx,vsflx,ptsflx,qvsflx,                                   &
           tem1)
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Write history data into channel nchanl as binary data.
!
!  All data read in are located at the original staggered grid points.
!
!  Note: coordinate fields are dumped as 3 dimensional fields which
!  have been converted from meters to kilometers.  This is for the
!  convenience of the plotting applications.
!
!  The last 4 characters of the 12 character label written out
!  with each 1-,2-, or 3-d array is used by the splitdump and
!  joinfiles subroutines used by the message passing version of the
!  ARPS (and also by some auxiliary ARPS I/O routines)
!  to determine the data type of the array.
!  Key to the labels:
!
!    'nnnnnnn tdds'
!
!     n  - characters containing the name of the variable.
!     t  - type of variable:  "r" for real and "i" for integer.
!     dd - number of dimensions:  "1d" "2d" or "3d".
!     s  - staggered dimension: "0" for centered,
!                               "1" for staggered in x,
!                               "2" for staggered in y,
!                               "3" for staggered in z.
!
!-----------------------------------------------------------------------
!
!
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Ming Xue
!  3/10/92.
!
!  MODIFICATION HISTORY:
!
!  6/06/92 (M. Xue)
!  Added full documentation.
!
!  7/13/92 (K. Brewster)
!  Added runname, comment and version number writing
!
!  8/23/92 (M. Xue)
!  Modify to perform the dumping of both base and t-dependent arrays
!  and added control on grid staggering.
!
!  4/4/93  (M. Xue)
!  Modified, so that data on the original staggered grid are written
!  out. Averaging to the volume center is no longer done.
!
!  9/1/94 (Y. Lu)
!  Cleaned up documentation.
!
!  02/06/95 (Y. Liu)
!  Added map projection parameters into the binary dumping
!
!  03/26/96 (G. Bassett)
!  Labels were modified to include information about array type.
!  This information is used by splitdump and joinfiles subroutines.
!
!  12/09/1998 (Donghai Wang)
!  Added the snow cover.
!
!-----------------------------------------------------------------------
!
!  INPUT:
!
!    nx       Number of grid points in the x-direction (east/west)
!    ny       Number of grid points in the y-direction (north/south)
!    nz       Number of grid points in the vertical
!
!    nchanl   FORTRAN I/O channel number for history data output.
!    grdbas   Flag indicating if this is a call for the data dump
!             of grid and base state arrays only. If so, grdbas=1.
!
!    u        x component of velocity at a given time level (m/s)
!    v        y component of velocity at a given time level (m/s)
!    w        Vertical component of Cartesian velocity at a given
!             time level (m/s)
!    ptprt    Perturbation potential temperature at a given time
!             level (K)
!    pprt     Perturbation pressure at a given time level (Pascal)
!    qv       Water vapor specific humidity at a given time level (kg/kg)
!    qc       Cloud water mixing ratio at a given time level (kg/kg)
!    qr       Rainwater mixing ratio at a given time level (kg/kg)
!    qi       Cloud ice mixing ratio at a given time level (kg/kg)
!    qs       Snow mixing ratio at a given time level (kg/kg)
!    qh       Hail mixing ratio at a given time level (kg/kg)
!    tke      Turbulent Kinetic Energy ((m/s)**2)
!
!    kmh      Horizontal turb. mixing coef. for momentum ( m**2/s )
!    kmv      Vertical turb. mixing coef. for momentum ( m**2/s )
!
!    ubar     Base state zonal velocity component (m/s)
!    vbar     Base state meridional velocity component (m/s)
!    ptbar    Base state potential temperature (K)
!    pbar     Base state pressure (Pascal)
!    rhobar   Base state density (kg/m**3)
!    qvbar    Base state water vapor specific humidity (kg/kg)
!
!    x        x coordinate of grid points in physical/comp. space (m)
!    y        y coordinate of grid points in physical/comp. space (m)
!    z        z coordinate of grid points in computational space (m)
!    zp       Vertical coordinate of grid points in physical space (m)
!    hterain  Terrain height (m)
!
!    j1       Coordinate transformation Jacobian -d(zp)/dx
!    j2       Coordinate transformation Jacobian -d(zp)/dy
!    j3       Coordinate transformation Jacobian  d(zp)/dz
!
!    soiltyp  Soil type
!    stypfrct  Soil type fraction
!    vegtyp   Vegetation type
!    lai      Leaf Area Index
!    roufns   Surface roughness
!    veg      Vegetation fraction
!
!    tsfc     Skin temperature at the ground or ocean surface (K)
!    tsoil    Deep soil temperature (K) (in deep 1 m layer)
!    wetsfc   Surface soil moisture
!    wetdp    Deep soil moisture
!    wetcanp  Canopy water amount
!
!    raing    Grid supersaturation rain
!    rainc    Cumulus convective rain
!    prcrate  Precipitation rates
!
!    radfrc   Radiation forcing (K/s)
!    radsw    Solar radiation reaching the surface
!    rnflx    Net radiation flux absorbed by surface
!
!    usflx    Surface flux of u-momentum (kg/(m*s**2))
!    vsflx    Surface flux of v-momentum (kg/(m*s**2))
!    ptsflx   Surface heat flux (K*kg/(m**2*s))
!    qvsflx   Surface moisture flux (kg/(m**2*s))
!
!  OUTPUT:
!
!    None.
!
!  WORK ARRAY:
!
!    tem1     Temporary work array.
!
!
!-----------------------------------------------------------------------
!
!  The following parameters are passed into this subroutine through
!  a common block in globcst.inc, and they determine which
!  variables are output.
!
!  grdout =0 or 1. If grdout=0, grid variables are not dumped.
!  basout =0 or 1. If basout=0, base state variables are not dumped.
!  varout =0 or 1. If varout=0, model perturbation variables are not dumped.
!  mstout =0 or 1. If mstout=0, water variables are not dumped.
!  rainout=0 or 1. If rainout=0, rain variables are not dumped.
!  prcout =0 or 1. If prcout=0, precipitation rates are not dumped.
!  iceout =0 or 1. If iceout=0, qi, qs and qh are not dumped.
!  tkeout =0 or 1. If tkeout=0, tke is not dumped.
!  trbout =0 or 1. If trbout=0, turbulence parameter km is not dumped.
!  sfcout =0 or 1. If sfcout=0, surface variables are not dumped.
!  landout=0 or 1. If landout=0, surface propertty arrays are not dumped.
!  radout =0 or 1. If radout =0, radiation arrays are not dumped.
!  flxout =0 or 1. If flxout =0, surface flux arrays are not dumped.
!
!  These following parameters are also passed in through common
!  blocks in globcst.inc.
!
!  runname,curtim,umove,vmove,xgrdorg,ygrdorg
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: nx,ny,nz          ! Number of grid points in 3 directions

  INTEGER :: nchanl            ! FORTRAN I/O channel number for output
  INTEGER :: grdbas            ! If this is a grid/base state array dump

  REAL :: u     (nx,ny,nz)     ! Total u-velocity (m/s)
  REAL :: v     (nx,ny,nz)     ! Total v-velocity (m/s)
  REAL :: w     (nx,ny,nz)     ! Total w-velocity (m/s)
  REAL :: ptprt (nx,ny,nz)     ! Perturbation potential temperature (K)
  REAL :: pprt  (nx,ny,nz)     ! Perturbation pressure (Pascal)

  REAL :: qv    (nx,ny,nz)     ! Water vapor specific humidity (kg/kg)
  REAL :: qc    (nx,ny,nz)     ! Cloud water mixing ratio (kg/kg)
  REAL :: qr    (nx,ny,nz)     ! Rain water mixing ratio (kg/kg)
  REAL :: qi    (nx,ny,nz)     ! Cloud ice mixing ratio (kg/kg)
  REAL :: qs    (nx,ny,nz)     ! Snow mixing ratio (kg/kg)
  REAL :: qh    (nx,ny,nz)     ! Hail mixing ratio (kg/kg)
  REAL :: tke   (nx,ny,nz)     ! Turbulent Kinetic Energy ((m/s)**2)

  REAL :: kmh   (nx,ny,nz)     ! Horizontal turb. mixing coef. for
                               ! momentum. ( m**2/s )
  REAL :: kmv   (nx,ny,nz)     ! Vertical turb. mixing coef. for
                               ! momentum. ( m**2/s )

  REAL :: ubar  (nx,ny,nz)     ! Base state u-velocity (m/s)
  REAL :: vbar  (nx,ny,nz)     ! Base state v-velocity (m/s)
  REAL :: ptbar (nx,ny,nz)     ! Base state potential temperature (K)
  REAL :: pbar  (nx,ny,nz)     ! Base state pressure (Pascal)
  REAL :: rhobar(nx,ny,nz)     ! Base state air density (kg/m**3)
  REAL :: qvbar (nx,ny,nz)     ! Base state water vapor specific humidity
                               ! (kg/kg)

  REAL :: x     (nx)           ! The x-coord. of the physical and
                               ! computational grid. Defined at u-point.
  REAL :: y     (ny)           ! The y-coord. of the physical and
                               ! computational grid. Defined at v-point.
  REAL :: z     (nz)           ! The z-coord. of the computational grid.
                               ! Defined at w-point on the staggered grid.
  REAL :: zp    (nx,ny,nz)     ! The physical height coordinate defined at
                               ! w-point of the staggered grid.

  REAL :: hterain(nx,ny)       ! Terrain height.

  REAL :: j1    (nx,ny,nz)     ! Coordinate transformation Jacobian defined
                               ! as - d( zp )/d( x )
  REAL :: j2    (nx,ny,nz)     ! Coordinate transformation Jacobian defined
                               ! as - d( zp )/d( y )
  REAL :: j3    (nx,ny,nz)     ! Coordinate transformation Jacobian defined
                               ! as d( zp )/d( z )

  INTEGER :: nstyps                  ! Number of soil types
  INTEGER :: soiltyp(nx,ny,nstyps)   ! Soil type
  REAL :: stypfrct(nx,ny,nstyps)  ! Soil type fractions
  INTEGER :: vegtyp (nx,ny)          ! Vegetation type
  REAL :: lai    (nx,ny)          ! Leaf Area Index
  REAL :: roufns (nx,ny)          ! Surface roughness
  REAL :: veg    (nx,ny)          ! Vegetation fraction

  REAL :: tsfc   (nx,ny,0:nstyps)    ! Temperature at surface (K)
                                     ! (in top 1 cm layer)
  REAL :: tsoil  (nx,ny,0:nstyps)    ! Deep soil temperature (K)
                                     ! (in deep 1 m layer)
  REAL :: wetsfc (nx,ny,0:nstyps)    ! Surface soil moisture
  REAL :: wetdp  (nx,ny,0:nstyps)    ! Deep soil moisture
  REAL :: wetcanp(nx,ny,0:nstyps)    ! Canopy water amount
  REAL :: snowdpth(nx,ny)            ! Snow depth (m)

  REAL :: raing(nx,ny)         ! Grid supersaturation rain
  REAL :: rainc(nx,ny)         ! Cumulus convective rain
  REAL :: prcrate(nx,ny,4)     ! precipitation rate (kg/(m**2*s))
                               ! prcrate(1,1,1) = total precip. rate
                               ! prcrate(1,1,2) = grid scale precip. rate
                               ! prcrate(1,1,3) = cumulus precip. rate
                               ! prcrate(1,1,4) = microphysics precip. rate

  REAL :: radfrc(nx,ny,nz)     ! Radiation forcing (K/s)
  REAL :: radsw (nx,ny)        ! Solar radiation reaching the surface
  REAL :: rnflx (nx,ny)        ! Net radiation flux absorbed by surface

  REAL :: usflx (nx,ny)        ! Surface flux of u-momentum (kg/(m*s**2))
  REAL :: vsflx (nx,ny)        ! Surface flux of v-momentum (kg/(m*s**2))
  REAL :: ptsflx(nx,ny)        ! Surface heat flux (K*kg/(m**2*s))
  REAL :: qvsflx(nx,ny)        ! Surface moisture flux (kg/(m**2*s))

  REAL :: tem1  (nx,ny,nz)     ! Temporary work array
!
!-----------------------------------------------------------------------
!
!  Parameters describing this routine
!
!-----------------------------------------------------------------------
!
  CHARACTER (LEN=40) :: fmtver
  PARAMETER (fmtver='004.10 Binary Data')
  CHARACTER (LEN=10) :: tmunit
  PARAMETER (tmunit='seconds   ')
!
!-----------------------------------------------------------------------
!
!  Misc. local variables:
!
!-----------------------------------------------------------------------
!
  INTEGER :: i,j,k,l,is
  INTEGER :: idummy
  REAL :: rdummy
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'globcst.inc'
  INCLUDE 'grid.inc'           ! Grid & map parameters.
  INCLUDE 'mp.inc'             ! mpi parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
  IF (myproc == 0)  &
     WRITE(6,'(1x,a,f13.3/)') 'Writing history data at time=', curtim
!
!-----------------------------------------------------------------------
!
!  Write header info
!
!-----------------------------------------------------------------------
!
  WRITE(nchanl) fmtver
  WRITE(nchanl) runname
  WRITE(nchanl) nocmnt
  IF( nocmnt > 0 ) THEN
    DO l=1,nocmnt
      WRITE(nchanl) cmnt(l)
    END DO
  END IF

  WRITE(nchanl) curtim,tmunit

  WRITE(nchanl) nx,ny,nz
!
!-----------------------------------------------------------------------
!
!  Write the flags for different data groups.
!
!-----------------------------------------------------------------------
!
  idummy = 0

  IF( grdbas == 1 ) THEN

    WRITE(nchanl)      1,      1,      0, mstout,      0,               &
                       0,      0,      0, landout,totout,               &
                       0, idummy, idummy, mapproj, month,               &
                     day,   year,   hour, minute, second

  ELSE

    WRITE(nchanl) grdout, basout, varout, mstout, iceout,               &
                  trbout, sfcout, rainout,landout,totout,               &
                  tkeout, idummy, idummy, mapproj, month,               &
                     day,   year,   hour, minute, second

  END IF

  rdummy = 0.0
  WRITE(nchanl)   umove,   vmove, xgrdorg, ygrdorg, trulat1,            &
                trulat2,  trulon,  sclfct,  rdummy,  rdummy,            &
                 rdummy,  rdummy,  rdummy,  rdummy,  rdummy,            &
                  tstop, thisdmp,  latitud, ctrlat,  ctrlon
!
!-----------------------------------------------------------------------
!
!  If totout=1, write additional parameters to history dump files.
!  This is for ARPS version 4.1.2 or later.
!
!-----------------------------------------------------------------------
!
  IF ( totout == 1 ) THEN
    WRITE(nchanl) nstyp,  prcout, radout, flxout,      0,  & ! 0 for snowcvr
              snowout,idummy, idummy, idummy, idummy,                   &
                  idummy, idummy, idummy, idummy, idummy,               &
                  idummy, idummy, idummy, idummy, idummy

    WRITE(nchanl) rdummy, rdummy, rdummy, rdummy, rdummy,               &
                  rdummy, rdummy, rdummy, rdummy, rdummy,               &
                  rdummy, rdummy, rdummy, rdummy, rdummy,               &
                  rdummy, rdummy, rdummy, rdummy, rdummy
  END IF
!
!-----------------------------------------------------------------------
!
!  If grdout=1 or grdbas=1, write out grid variables
!
!-----------------------------------------------------------------------
!
  IF(grdout == 1 .OR. grdbas == 1 ) THEN

    WRITE(nchanl) 'x coord r1d1'
    WRITE(nchanl) x

    WRITE(nchanl) 'y coord r1d2'
    WRITE(nchanl) y

    WRITE(nchanl) 'z coord r1d3'
    WRITE(nchanl) z

    CALL edgfill(zp,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz)
    WRITE(nchanl) 'zp coor r3d0'
    WRITE(nchanl) zp

  END IF    ! grdout
!
!-----------------------------------------------------------------------
!
!  If basout=1, write out base state variables.
!
!-----------------------------------------------------------------------
!
  IF(basout == 1 .OR. grdbas == 1 ) THEN

    CALL edgfill(ubar,1,nx,1,nx, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'ubar    r3d1'
    WRITE(nchanl) ubar

    CALL edgfill(vbar,1,nx,1,nx-1, 1,ny,1,ny, 1,nz,1,nz-1)
    WRITE(nchanl) 'vbar    r3d2'
    WRITE(nchanl) vbar

    DO k=1,nz
      DO j=1,ny
        DO i=1,nx
          tem1(i,j,k) = 0.0
        END DO
      END DO
    END DO
    WRITE(nchanl) 'wbar    r3d3'
    WRITE(nchanl) tem1

    CALL edgfill(ptbar,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'ptbar   r3d0'
    WRITE(nchanl)  ptbar

    CALL edgfill(pbar,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'pbar    r3d0'
    WRITE(nchanl)  pbar

    IF(mstout == 1) THEN

      CALL edgfill(qvbar,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'qvbar   r3d0'
      WRITE(nchanl)  qvbar

    END IF

    IF(landout == 1) THEN

      IF( nstyp <= 1 ) THEN

        CALL iedgfill(soiltyp(1,1,1),1,nx,1,nx-1, 1,ny,1,ny-1,          &
                      1,1,1,1)
        WRITE(nchanl) 'soiltyp i2d0'
        WRITE(nchanl) ((soiltyp(i,j,1),i=1,nx),j=1,ny)

      ELSE
        DO is=1,nstyp

          CALL iedgfill(soiltyp(1,1,is),1,nx,1,nx-1, 1,ny,1,ny-1,       &
                        1,1,1,1)
          WRITE(nchanl) 'soiltyp i2d0'
          WRITE(nchanl) ((soiltyp(i,j,is),i=1,nx),j=1,ny)

          CALL edgfill(stypfrct(1,1,is),1,nx,1,nx-1, 1,ny,1,ny-1,       &
                       1,1,1,1)
          WRITE(nchanl) 'stypfrc r2d0'
          WRITE(nchanl) ((stypfrct(i,j,is),i=1,nx),j=1,ny)

        END DO

      END IF

      CALL iedgfill(vegtyp ,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
      WRITE(nchanl) 'vegtyp  i2d0'
      WRITE(nchanl)  vegtyp

      CALL edgfill(lai    ,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
      WRITE(nchanl) 'lai     r2d0'
      WRITE(nchanl)  lai

      CALL edgfill(roufns ,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
      WRITE(nchanl) 'roufns  r2d0'
      WRITE(nchanl)  roufns

      CALL edgfill(veg    ,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
      WRITE(nchanl) 'veg     r2d0'
      WRITE(nchanl)  veg

    END IF

  END IF

  IF ( grdbas == 1 ) RETURN
!
!-----------------------------------------------------------------------
!
!  If varout = 1, Write out uprt, vprt, wprt, ptprt, pprt.
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
!  Write out u,v and w.
!
!-----------------------------------------------------------------------
!
  IF(varout == 1) THEN

    IF ( totout == 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Write out perturbations to history dump
!
!-----------------------------------------------------------------------
!
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx
            tem1(i,j,k)=u(i,j,k)-ubar(i,j,k)
          END DO
        END DO
      END DO
      CALL edgfill(tem1,1,nx,1,nx, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'uprt    r3d1'
      WRITE(nchanl) tem1

      DO k=1,nz-1
        DO i=1,nx-1
          DO j=1,ny
            tem1(i,j,k)=v(i,j,k)-vbar(i,j,k)
          END DO
        END DO
      END DO
      CALL edgfill(tem1,1,nx,1,nx-1, 1,ny,1,ny, 1,nz,1,nz-1)
      WRITE(nchanl) 'vprt    r3d2'
      WRITE(nchanl) tem1

      CALL edgfill(w,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz)
      WRITE(nchanl) 'wprt    r3d3'
      WRITE(nchanl) w
!
!-----------------------------------------------------------------------
!
!  Write out scalars
!
!-----------------------------------------------------------------------
!
      CALL edgfill(ptprt,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'ptprt   r3d0'
      WRITE(nchanl) ptprt

      CALL edgfill(pprt,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'pprt    r3d0'
      WRITE(nchanl) pprt

    ELSE
!
!-----------------------------------------------------------------------
!
!  Write out total values to history dump
!
!-----------------------------------------------------------------------
!
      CALL edgfill(u,1,nx,1,nx, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'u       r3d1'
      WRITE(nchanl) u

      CALL edgfill(v,1,nx,1,nx-1, 1,ny,1,ny, 1,nz,1,nz-1)
      WRITE(nchanl) 'v       r3d2'
      WRITE(nchanl) v

      CALL edgfill(w,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz)
      WRITE(nchanl) 'w       r3d3'
      WRITE(nchanl) w
!
!-----------------------------------------------------------------------
!
!  Write out scalars
!
!-----------------------------------------------------------------------
!
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            tem1(i,j,k) = ptbar(i,j,k) + ptprt(i,j,k)
          END DO
        END DO
      END DO
      CALL edgfill(tem1,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'pt      r3d0'
      WRITE(nchanl) tem1

      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            tem1(i,j,k) = pbar(i,j,k) + pprt(i,j,k)
          END DO
        END DO
      END DO
      CALL edgfill(tem1,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'p       r3d0'
      WRITE(nchanl) tem1

    END IF

  END IF     ! varout
!
!-----------------------------------------------------------------------
!
!  If mstout = 1, write out moisture scalars.
!
!-----------------------------------------------------------------------
!
  IF(mstout == 1) THEN

    IF( totout == 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Write out perturbation to history dump
!
!-----------------------------------------------------------------------
!
      DO k=1,nz-1
        DO j=1,ny-1
          DO i=1,nx-1
            tem1(i,j,k)=qv(i,j,k)-qvbar(i,j,k)
          END DO
        END DO
      END DO

      CALL edgfill(tem1,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'qvprt   r3d0'
      WRITE(nchanl)  tem1

    ELSE
!
!-----------------------------------------------------------------------
!
!  Write out total values to history dump
!
!-----------------------------------------------------------------------
!
      CALL edgfill(qv,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'qv      r3d0'
      WRITE(nchanl)  qv

    END IF

    CALL edgfill(qc,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'qc      r3d0'
    WRITE(nchanl)  qc

    CALL edgfill(qr,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'qr      r3d0'
    WRITE(nchanl)  qr

    IF(rainout == 1) THEN

      CALL edgfill(raing,   1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
      WRITE(nchanl) 'raing   r2d0'
      WRITE(nchanl)  raing

      CALL edgfill(rainc,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
      WRITE(nchanl) 'rainc   r2d0'
      WRITE(nchanl)  rainc

    END IF   !rainout

    IF ( prcout == 1 ) THEN
      CALL edgfill(prcrate,1,nx,1,nx-1, 1,ny,1,ny-1, 1,4,1,4)
      WRITE(nchanl) 'prcrat1 r2d0'
      WRITE(nchanl) ((prcrate(i,j,1),i=1,nx),j=1,ny)
      WRITE(nchanl) 'prcrat2 r2d0'
      WRITE(nchanl) ((prcrate(i,j,2),i=1,nx),j=1,ny)
      WRITE(nchanl) 'prcrat3 r2d0'
      WRITE(nchanl) ((prcrate(i,j,3),i=1,nx),j=1,ny)
      WRITE(nchanl) 'prcrat4 r2d0'
      WRITE(nchanl) ((prcrate(i,j,4),i=1,nx),j=1,ny)
    END IF

    IF(iceout == 1) THEN

      CALL edgfill(qi,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'qi      r3d0'
      WRITE(nchanl)  qi

      CALL edgfill(qs,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'qs      r3d0'
      WRITE(nchanl)  qs

      CALL edgfill(qh,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
      WRITE(nchanl) 'qh      r3d0'
      WRITE(nchanl)  qh

    END IF   !iceout

  END IF   !mstout
!
!-----------------------------------------------------------------------
!
!  If tkeout = 1, write out tke.
!
!-----------------------------------------------------------------------
!
  IF( tkeout == 1 ) THEN

    CALL edgfill(tke,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'tke     r3d0'
    WRITE(nchanl) tke

  END IF
!
!-----------------------------------------------------------------------
!
!  If trbout = 1, write out the turbulence parameter, km.
!
!-----------------------------------------------------------------------
!
  IF( trbout == 1 ) THEN

    CALL edgfill(kmh,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'kmh     r3d0'
    WRITE(nchanl) kmh

    CALL edgfill(kmv,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'kmv     r3d0'
    WRITE(nchanl) kmv

  END IF   ! trbout

!
!-----------------------------------------------------------------------
!
!  If sfcout = 1, write out the surface variables,
!  tsfc, tsoil, wetsfc, wetdp, and wetcanp.
!
!-----------------------------------------------------------------------
!
  IF( sfcout == 1) THEN

    IF( nstyp <= 1 ) THEN

      CALL edgfill(tsfc(1,1,0),   1,nx,1,nx-1, 1,ny,1,ny-1,             &
                   1,1,1,1)
      WRITE(nchanl) 'tsfc    r2d0'
      WRITE(nchanl) ((tsfc(i,j,0),i=1,nx),j=1,ny)

      CALL edgfill(tsoil(1,1,0),  1,nx,1,nx-1, 1,ny,1,ny-1,             &
                   1,1,1,1)
      WRITE(nchanl) 'tsoil   r2d0'
      WRITE(nchanl) ((tsoil(i,j,0),i=1,nx),j=1,ny)

      CALL edgfill(wetsfc(1,1,0), 1,nx,1,nx-1, 1,ny,1,ny-1,             &
                   1,1,1,1)
      WRITE(nchanl) 'wetsfc  r2d0'
      WRITE(nchanl) ((wetsfc(i,j,0),i=1,nx),j=1,ny)

      CALL edgfill(wetdp(1,1,0),  1,nx,1,nx-1, 1,ny,1,ny-1,             &
                   1,1,1,1)
      WRITE(nchanl) 'wetdp   r2d0'
      WRITE(nchanl) ((wetdp(i,j,0),i=1,nx),j=1,ny)

      CALL edgfill(wetcanp(1,1,0),1,nx,1,nx-1, 1,ny,1,ny-1,             &
                   1,1,1,1)
      WRITE(nchanl) 'wetcanp r2d0'
      WRITE(nchanl) ((wetcanp(i,j,0),i=1,nx),j=1,ny)

    ELSE

      DO is=0,nstyp

        CALL edgfill(tsfc(1,1,is),   1,nx,1,nx-1, 1,ny,1,ny-1,          &
                     1,1,1,1)
        WRITE(nchanl) 'tsfc    r2d0'
        WRITE(nchanl) ((tsfc(i,j,is),i=1,nx),j=1,ny)

        CALL edgfill(tsoil(1,1,is),  1,nx,1,nx-1, 1,ny,1,ny-1,          &
                     1,1,1,1)
        WRITE(nchanl) 'tsoil   r2d0'
        WRITE(nchanl) ((tsoil(i,j,is),i=1,nx),j=1,ny)

        CALL edgfill(wetsfc(1,1,is), 1,nx,1,nx-1, 1,ny,1,ny-1,          &
                     1,1,1,1)
        WRITE(nchanl) 'wetsfc  r2d0'
        WRITE(nchanl) ((wetsfc(i,j,is),i=1,nx),j=1,ny)

        CALL edgfill(wetdp(1,1,is),  1,nx,1,nx-1, 1,ny,1,ny-1,          &
                     1,1,1,1)
        WRITE(nchanl) 'wetdp   r2d0'
        WRITE(nchanl) ((wetdp(i,j,is),i=1,nx),j=1,ny)

        CALL edgfill(wetcanp(1,1,is),1,nx,1,nx-1, 1,ny,1,ny-1,          &
                     1,1,1,1)
        WRITE(nchanl) 'wetcanp r2d0'
        WRITE(nchanl) ((wetcanp(i,j,is),i=1,nx),j=1,ny)

      END DO
    END IF

    IF (snowout == 1) THEN

      CALL edgfill(snowdpth,1,nx,1,nx-1, 1,ny,1,ny-1,                   &
                    1,1,1,1)
      WRITE(nchanl) 'snowdpthr2d0'
      WRITE(nchanl) ((snowdpth(i,j),i=1,nx),j=1,ny)
    END IF

  END IF
!
!-----------------------------------------------------------------------
!
!  If radout = 1, write out the radiation arrays
!
!-----------------------------------------------------------------------
!
  IF( radout == 1 ) THEN

    CALL edgfill(radfrc,1,nx,1,nx-1, 1,ny,1,ny-1, 1,nz,1,nz-1)
    WRITE(nchanl) 'radfrc  r3d0'
    WRITE(nchanl) radfrc

    CALL edgfill(radsw,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
    WRITE(nchanl) 'radsw   r2d0'
    WRITE(nchanl) radsw

    CALL edgfill(rnflx,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
    WRITE(nchanl) 'rnflx   r2d0'
    WRITE(nchanl) rnflx

  END IF   ! radout
!
!-----------------------------------------------------------------------
!
!  If flxout = 1, write out the surface fluxes
!
!-----------------------------------------------------------------------
!
  IF( flxout == 1 ) THEN

    CALL edgfill(usflx,1,nx,1,nx, 1,ny,1,ny-1, 1,1,1,1)
    WRITE(nchanl) 'usflx   r2d0'
    WRITE(nchanl) usflx

    CALL edgfill(vsflx,1,nx,1,nx-1, 1,ny,1,ny, 1,1,1,1)
    WRITE(nchanl) 'vsflx   r2d0'
    WRITE(nchanl) vsflx

    CALL edgfill(ptsflx,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
    WRITE(nchanl) 'ptsflx  r2d0'
    WRITE(nchanl) ptsflx

    CALL edgfill(qvsflx,1,nx,1,nx-1, 1,ny,1,ny-1, 1,1,1,1)
    WRITE(nchanl) 'qvsflx  r2d0'
    WRITE(nchanl) qvsflx

  END IF   ! flxout

  RETURN
END SUBROUTINE bindump
!
!##################################################################
!##################################################################
!######                                                      ######
!######                SUBROUTINE BN2DUMP                    ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!


SUBROUTINE bn2dump(nx,ny,nz, nstyps, nchanl, grdbas,                    & 1
           u,v,w,ptprt,pprt,qv,qc,qr,qi,qs,qh,tke,kmh,kmv,              &
           ubar,vbar,ptbar,pbar,rhobar,qvbar,                           &
           x,y,z,zp,hterain, j1,j2,j3,                                  &
           soiltyp,stypfrct,vegtyp,lai,roufns,veg,                      &
           tsfc,tsoil,wetsfc,wetdp,wetcanp,snowdpth,                    &
           raing,rainc,prcrate,                                         &
           radfrc,radsw,rnflx,                                          &
           usflx,vsflx,ptsflx,qvsflx,                                   &
           tem1)
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Write history data into channel nchanl as binary data.
!
!  This routine can dump the data arrays in a model subdomain and
!  at selected data points.
!
!  All data read in are located at the original staggered grid points.
!
!  Note: coordinate fields are dumped as 3 dimensional fields which
!  have been converted from meters to kilometers.  This is for the
!  convenience of the plotting applications.
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Ming Xue
!  3/10/92.
!
!  MODIFICATION HISTORY:
!
!  4/4/93  (M. Xue)
!  Modified, so that data on the original staggered grid are written
!  out. Averaging to the volume center is no longer done.
!
!  9/1/94 (Y. Lu)
!  Cleaned up documentation.
!
!  02/06/95 (Y. Liu)
!  Added map projection parameters into the second binary dumping
!
!  12/09/1998 (Donghai Wang)
!  Added the snow cover.
!
!-----------------------------------------------------------------------
!
!  INPUT:
!
!    nx       Number of grid points in the x-direction (east/west)
!    ny       Number of grid points in the y-direction (north/south)
!    nz       Number of grid points in the vertical
!
!    nchanl   FORTRAN I/O channel number for history data output.
!    grdbas   Flag indicating if this is a call for the data dump
!             of grid and base state arrays only. If so, grdbas=1.
!
!    u        x component of velocity at a given time level (m/s)
!    v        y component of velocity at a given time level (m/s)
!    w        Vertical component of Cartesian velocity at a given
!             time level (m/s)
!    ptprt    Perturbation potential temperature at a given time
!             level (K)
!    pprt     Perturbation pressure at  a given time level (Pascal)
!    qv       Water vapor specific humidity at a given time level (kg/kg)
!    qc       Cloud water mixing ratio at a given time level (kg/kg)
!    qr       Rainwater mixing ratio at a given time level (kg/kg)
!    qi       Cloud ice mixing ratio at a given time level (kg/kg)
!    qs       Snow mixing ratio at a given time level (kg/kg)
!    qh       Hail mixing ratio at a given time level (kg/kg)
!    tke      Turbulent Kinetic Energy ((m/s)**2)
!
!    kmh      Horizontal turb. mixing coef. for momentum ( m**2/s )
!    kmv      Vertical turb. mixing coef. for momentum ( m**2/s )
!
!    ubar     Base state zonal velocity component (m/s)
!    vbar     Base state meridional velocity component (m/s)
!    ptbar    Base state potential temperature (K)
!    pbar     Base state pressure (Pascal)
!    rhobar   Base state density (kg/m**3)
!    qvbar    Base state water vapor specific humidity (kg/kg)
!
!    x        x coordinate of grid points in physical/comp. space (m)
!    y        y coordinate of grid points in physical/comp. space (m)
!    z        z coordinate of grid points in computational space (m)
!    zp       Vertical coordinate of grid points in physical space (m)
!    hterain  Terrain height (m)
!
!    j1       Coordinate transformation Jacobian -d(zp)/dx
!    j2       Coordinate transformation Jacobian -d(zp)/dy
!    j3       Coordinate transformation Jacobian  d(zp)/dz
!
!    soiltyp  Soil type
!    vegtyp   Vegetation type
!    lai      Leaf Area Index
!    roufns   Surface roughness
!    veg      Vegetation fraction
!
!    tsfc     Temperature at ground (K) (in top 1 cm layer)
!    tsoil    Deep soil temperature (K) (in deep 1 m layer)
!    wetsfc   Surface soil moisture in the top 1 cm layer
!    wetdp    Deep soil moisture in the deep 1 m layer
!    wetcanp  Canopy water amount
!
!    raing    Grid supersaturation rain
!    rainc    Cumulus convective rain
!    prcrate  Precipitation rates
!
!    radfrc   Radiation forcing (K/s)
!    radsw    Solar radiation reaching the surface
!    rnflx    Net radiation flux absorbed by surface
!
!    usflx    Surface flux of u-momentum (kg/(m*s**2))
!    vsflx    Surface flux of v-momentum (kg/(m*s**2))
!    ptsflx   Surface heat flux (K*kg/(m**2 * s ))
!    qvsflx   Surface moisture flux of (kg/(m**2 * s))
!
!  OUTPUT:
!
!    None.
!
!  WORK ARRAY:
!
!    tem1     Temporary work array.
!
!
!-----------------------------------------------------------------------
!
!  The following parameters are passed into this subroutine through
!  a common block in globcst.inc.  These parameters determine which
!  variables are output.
!
!  grdout =0 or 1. If grdout=0, grid variables are not dumped.
!  basout =0 or 1. If basout=0, base state variables are not dumped.
!  varout =0 or 1. If varout=0, model perturbation variables are not dumped.
!  mstout =0 or 1. If mstout=0, water variables are not dumped.
!  rainout=0 or 1. If rainout=0, rain variables are not dumped.
!  prcout =0 or 1. If prcout=0, precipitation rates are not dumped.
!  iceout =0 or 1. If iceout=0, qi, qs and qh are not dumped.
!  trbout =0 or 1. If trbout=0, turbulence parameter km is not dumped.
!  tkeout =0 or 1. If tkeout=0, tke is not dumped.
!  radout =0 or 1. If radout=0, radiation arrays are not dumped.
!  flxout =0 or 1. If flxout=0, surface fluxes are not dumped.
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: nx,ny,nz          ! Number of grid points in 3 directions

  INTEGER :: nchanl            ! FORTRAN I/O channel number for output
  INTEGER :: grdbas            ! If this is a grid/base state array dump

  REAL :: u     (nx,ny,nz)     ! Total u-velocity (m/s)
  REAL :: v     (nx,ny,nz)     ! Total v-velocity (m/s)
  REAL :: w     (nx,ny,nz)     ! Total w-velocity (m/s)
  REAL :: ptprt (nx,ny,nz)     ! Perturbation potential temperature (K)
  REAL :: pprt  (nx,ny,nz)     ! Perturbation pressure (Pascal)

  REAL :: qv    (nx,ny,nz)     ! Water vapor specific humidity (kg/kg)
  REAL :: qc    (nx,ny,nz)     ! Cloud water mixing ratio (kg/kg)
  REAL :: qr    (nx,ny,nz)     ! Rain water mixing ratio (kg/kg)
  REAL :: qi    (nx,ny,nz)     ! Cloud ice mixing ratio (kg/kg)
  REAL :: qs    (nx,ny,nz)     ! Snow mixing ratio (kg/kg)
  REAL :: qh    (nx,ny,nz)     ! Hail mixing ratio (kg/kg)
  REAL :: tke   (nx,ny,nz)     ! Turbulent Kinetic Energy ((m/s)**2)

  REAL :: kmh   (nx,ny,nz)     ! Horizontal turb. mixing coef. for
                               ! momentum. ( m**2/s )
  REAL :: kmv   (nx,ny,nz)     ! Vertical turb. mixing coef. for
                               ! momentum. ( m**2/s )

  REAL :: ubar  (nx,ny,nz)     ! Base state u-velocity (m/s)
  REAL :: vbar  (nx,ny,nz)     ! Base state v-velocity (m/s)
  REAL :: ptbar (nx,ny,nz)     ! Base state potential temperature (K)
  REAL :: pbar  (nx,ny,nz)     ! Base state pressure (Pascal)
  REAL :: rhobar(nx,ny,nz)     ! Base state air density (kg/m**3)
  REAL :: qvbar (nx,ny,nz)     ! Base state water vapor specific humidity
                               ! (kg/kg)

  REAL :: x     (nx)           ! The x-coord. of the physical and
                               ! computational grid. Defined at u-point.
  REAL :: y     (ny)           ! The y-coord. of the physical and
                               ! computational grid. Defined at v-point.
  REAL :: z     (nz)           ! The z-coord. of the computational grid.
                               ! Defined at w-point on the staggered grid.
  REAL :: zp    (nx,ny,nz)     ! The physical height coordinate defined at
                               ! w-point of the staggered grid.

  REAL :: hterain(nx,ny)       ! Terrain height.

  REAL :: j1    (nx,ny,nz)     ! Coordinate transformation Jacobian defined
                               ! as - d( zp )/d( x )
  REAL :: j2    (nx,ny,nz)     ! Coordinate transformation Jacobian defined
                               ! as - d( zp )/d( y )
  REAL :: j3    (nx,ny,nz)     ! Coordinate transformation Jacobian defined
                               ! as d( zp )/d( z )

  INTEGER :: nstyps                  ! Number of soil types
  INTEGER :: soiltyp(nx,ny,nstyps)   ! Soil type
  REAL :: stypfrct(nx,ny,nstyps)  ! Soil type
  INTEGER :: vegtyp(nx,ny)           ! Vegetation type
  REAL :: lai    (nx,ny)          ! Leaf Area Index
  REAL :: roufns (nx,ny)          ! Surface roughness
  REAL :: veg    (nx,ny)          ! Vegetation fraction

  REAL :: tsfc   (nx,ny,0:nstyps)    ! Temperature at surface (K)
  REAL :: tsoil  (nx,ny,0:nstyps)    ! Deep soil temperature (K)
  REAL :: wetsfc (nx,ny,0:nstyps)    ! Surface soil moisture
  REAL :: wetdp  (nx,ny,0:nstyps)    ! Deep soil moisture
  REAL :: wetcanp(nx,ny,0:nstyps)    ! Canopy water amount
  REAL :: snowdpth(nx,ny)            ! Snow depth (m)

  REAL :: raing(nx,ny)         ! Grid supersaturation rain
  REAL :: rainc(nx,ny)         ! Cumulus convective rain
  REAL :: prcrate(nx,ny,4)     ! precipitation rate (kg/(m**2*s))
                               ! prcrate(1,1,1) = total precip. rate
                               ! prcrate(1,1,2) = grid scale precip. rate
                               ! prcrate(1,1,3) = cumulus precip. rate
                               ! prcrate(1,1,4) = microphysics precip. rate

  REAL :: radfrc(nx,ny,nz)     ! Radiation forcing (K/s)
  REAL :: radsw (nx,ny)        ! Solar radiation reaching the surface
  REAL :: rnflx (nx,ny)        ! Net radiation flux absorbed by surface

  REAL :: usflx (nx,ny)        ! Surface flux of u-momentum (kg/(m*s**2))
  REAL :: vsflx (nx,ny)        ! Surface flux of v-momentum (kg/(m*s**2))
  REAL :: ptsflx(nx,ny)        ! Surface heat flux (K*kg/(m**2*s))
  REAL :: qvsflx(nx,ny)        ! Surface moisture flux (kg/(m**2*s))

  REAL :: tem1  (nx,ny,nz)     ! Temporary work array
!
!-----------------------------------------------------------------------
!
!  Parameters describing this routine
!
!-----------------------------------------------------------------------
!
  CHARACTER (LEN=40) :: fmtver
  PARAMETER (fmtver='004.10 2nd Binary Data')
  CHARACTER (LEN=10) :: tmunit
  PARAMETER (tmunit='seconds   ')
!
!-----------------------------------------------------------------------
!
!  Misc. local variables:
!
!-----------------------------------------------------------------------
!
  INTEGER :: i,j,k,l,is, idummy
  REAL :: rdummy

  INTEGER :: nxout,nyout,nzout ! The size of array to be written out.

  INTEGER :: ist ,ind ,isk ,jst ,jnd ,jsk ,kst ,knd ,ksk
  INTEGER :: ist1,ind1,isk1,jst1,jnd1,jsk1,kst1,knd1,ksk1

  INTEGER :: setdomn,setskip
  SAVE setdomn, setskip
  SAVE ist,ind,isk,jst,jnd,jsk,kst,knd,ksk

  DATA setdomn, setskip /0,0/
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'globcst.inc'
  INCLUDE 'grid.inc'          ! Grid & map parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

  IF( setdomn == 0) THEN  ! If these parameters are nevers set ...

    ist = 1
    jst = 1
    kst = 1
    ind = nx
    jnd = ny
    knd = nz

  END IF

  IF( setskip == 0) THEN  ! If these parameters are nevers set ...

    isk = 1
    jsk = 1
    ksk = 1

  END IF

  WRITE(6,'(1x,a,f13.3/)') 'Writing history data at time=', curtim
!
!-----------------------------------------------------------------------
!
!  Write header info
!
!-----------------------------------------------------------------------
!
  WRITE(nchanl) fmtver
  WRITE(nchanl) runname
  WRITE(nchanl) nocmnt
  IF( nocmnt > 0 ) THEN
    DO l=1,nocmnt
      WRITE(nchanl) cmnt(l)
    END DO
  END IF
  WRITE(nchanl) curtim,tmunit

  nxout = ist+(ind-ist)/isk
  nyout = jst+(jnd-jst)/jsk
  nzout = kst+(knd-kst)/ksk

  WRITE(nchanl) nxout, nyout, nzout
  PRINT*,'nxout= ',nxout,'nyout= ',nyout,'nzout= ',nzout
!
!-----------------------------------------------------------------------
!
!  Write the flags for different data groups.
!
!-----------------------------------------------------------------------
!
  idummy = 0

  IF( grdbas == 1 ) THEN

    WRITE(nchanl)      1,      1,      0, mstout,      0,               &
                       0, idummy, idummy, landout, totout,              &
                  idummy, idummy, idummy, mapproj, month,               &
                     day,   year,   hour, minute, second

  ELSE

    WRITE(nchanl) grdout, basout, varout, mstout, iceout,               &
                  trbout, sfcout, rainout,landout,totout,               &
                  tkeout, idummy, idummy, mapproj, month,               &
                     day,   year,   hour, minute, second

  END IF

  rdummy = 0.0
  WRITE(nchanl)   umove,   vmove, xgrdorg, ygrdorg, trulat1,            &
                trulat2,  trulon,  sclfct,  rdummy,  rdummy,            &
                 rdummy,  rdummy,  rdummy,  rdummy,  rdummy,            &
                  tstop, thisdmp,  latitud, ctrlat,  ctrlon

  IF ( totout /= 0 ) THEN
!
!-----------------------------------------------------------------------
!
!  Add new parameters for new version of history data dump
!
!-----------------------------------------------------------------------
!
    WRITE(nchanl) nstyp,  prcout, radout, flxout,      0,  & ! 0 for snowcvr
              snowout,idummy, idummy, idummy, idummy,                   &
                  idummy, idummy, idummy, idummy, idummy,               &
                  idummy, idummy, idummy, idummy, idummy

    WRITE(nchanl) rdummy, rdummy, rdummy, rdummy, rdummy,               &
                  rdummy, rdummy, rdummy, rdummy, rdummy,               &
                  rdummy, rdummy, rdummy, rdummy, rdummy,               &
                  rdummy, rdummy, rdummy, rdummy, rdummy

  END IF
!
!-----------------------------------------------------------------------
!
!  If grdout=1 or grdbas=1, write out grid variables
!
!-----------------------------------------------------------------------
!
  IF(grdout == 1 .OR. grdbas == 1 ) THEN

    WRITE(nchanl) 'x coordinate'
    WRITE(nchanl) ( x(i), i=ist,ind,isk)

    WRITE(nchanl) 'y coordinate'
    WRITE(nchanl) ( y(j), j=jst,jnd,jsk)

    WRITE(nchanl) 'z coordinate'
    WRITE(nchanl) ( z(k), k=kst,knd,ksk)

    WRITE(nchanl) 'zp coord    '
    WRITE(nchanl) ((( zp(i,j,k),                                        &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

  END IF    ! grdout
!
!-----------------------------------------------------------------------
!
!  If basout=1, write out base state variables.
!
!-----------------------------------------------------------------------
!
  IF(basout == 1 .OR. grdbas == 1 ) THEN

    WRITE(nchanl) 'ubar        '
    WRITE(nchanl) ((( ubar(i,j,k),                                      &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    WRITE(nchanl) 'vbar        '
    WRITE(nchanl) ((( vbar(i,j,k),                                      &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    DO k=kst,knd,ksk
      DO j=jst,jnd,jsk
        DO i=ist,ind,isk
          tem1(i,j,k) = 0.0
        END DO
      END DO
    END DO
    WRITE(nchanl) 'wbar        '
    WRITE(nchanl) (((tem1(i,j,k),                                       &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    WRITE(nchanl) 'ptbar       '
    WRITE(nchanl) (((ptbar(i,j,k),                                      &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    WRITE(nchanl) 'pbar        '
    WRITE(nchanl) (((pbar(i,j,k),                                       &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    IF(mstout == 1) THEN

      WRITE(nchanl) 'qvbar       '
      WRITE(nchanl) (((qvbar(i,j,k),                                    &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    END IF

    IF(landout == 1) THEN

      IF( nstyp <= 1 ) THEN
        WRITE(nchanl) 'soiltyp     '
        WRITE(nchanl) ((soiltyp(i,j,1),i=ist,ind,isk),                  &
                        j=jst,jnd,jsk)
      ELSE
        DO is=1,nstyp
          WRITE(nchanl) 'soiltyp     '
          WRITE(nchanl) ((soiltyp(i,j,is),i=ist,ind,isk),               &
                        j=jst,jnd,jsk)

          WRITE(nchanl) 'stypfrct    '
          WRITE(nchanl) ((stypfrct(i,j,is),i=ist,ind,isk),              &
                        j=jst,jnd,jsk)
        END DO
      END IF

      WRITE(nchanl) 'vegtyp      '
      WRITE(nchanl) ((vegtyp (i,j),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'lai         '
      WRITE(nchanl) ((lai    (i,j),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'roufns      '
      WRITE(nchanl) ((roufns (i,j),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'veg         '
      WRITE(nchanl) ((veg    (i,j),i=ist,ind,isk),j=jst,jnd,jsk)

    END IF

  END IF


  IF ( grdbas == 1 ) RETURN

!
!-----------------------------------------------------------------------
!
!  If varout = 1, Write out uprt, vprt, wprt, ptprt, pprt.
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
!  Write out u, v and w
!
!-----------------------------------------------------------------------
!
  IF(varout == 1) THEN

    IF ( totout == 0 ) THEN
!
!-----------------------------------------------------------------------
!
!    Write out perturbatios to history dump
!
!-----------------------------------------------------------------------
!
      WRITE(nchanl) 'uprt        '
      WRITE(nchanl) ((( u(i,j,k)-ubar(i,j,k),                           &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'vprt        '
      WRITE(nchanl) ((( v(i,j,k)-vbar(i,j,k),                           &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'wprt        '
      WRITE(nchanl) ((( w(i,j,k),                                       &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)
!
!-----------------------------------------------------------------------
!
!  Write out scalars
!
!-----------------------------------------------------------------------
!
      WRITE(nchanl) 'ptprt       '
      WRITE(nchanl) ((( ptprt(i,j,k),                                   &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'pprt        '
      WRITE(nchanl) ((( pprt(i,j,k),                                    &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    ELSE
!
!-----------------------------------------------------------------------
!
!    Write out total values to history dump
!
!-----------------------------------------------------------------------
!
      WRITE(nchanl) 'u           '
      WRITE(nchanl) ((( u(i,j,k),                                       &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'v           '
      WRITE(nchanl) ((( v(i,j,k),                                       &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'w           '
      WRITE(nchanl) ((( w(i,j,k),                                       &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)
!
!-----------------------------------------------------------------------
!
!  Write out scalars
!
!-----------------------------------------------------------------------
!
      WRITE(nchanl) 'pt          '
      WRITE(nchanl) ((( ptprt(i,j,k)+ptbar(i,j,k),                      &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'p           '
      WRITE(nchanl) ((( pprt(i,j,k)+pbar(i,j,k),                        &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    END IF

  END IF     ! varout
!
!-----------------------------------------------------------------------
!
!  If mstout = 1, write out moisture scalars.
!
!-----------------------------------------------------------------------
!
  IF(mstout == 1) THEN

    IF ( totout == 0 ) THEN
!
!-----------------------------------------------------------------------
!
!    Write out perturbations to history dump
!
!-----------------------------------------------------------------------
!
      WRITE(nchanl) 'qvprt       '
      WRITE(nchanl) ((( qv(i,j,k)-qvbar(i,j,k),                         &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    ELSE
!
!-----------------------------------------------------------------------
!
!    Write out total values to history dump
!
!-----------------------------------------------------------------------
!
      WRITE(nchanl) 'qv          '
      WRITE(nchanl) ((( qv(i,j,k),                                      &
                    i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    END IF

    WRITE(nchanl) 'qc          '
    WRITE(nchanl) ((( qc(i,j,k),                                        &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    WRITE(nchanl) 'qr          '
    WRITE(nchanl) ((( qr(i,j,k),                                        &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    IF(rainout == 1) THEN

      WRITE(nchanl) 'raing       '
      WRITE(nchanl) ((raing(i,j),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'rainc       '
      WRITE(nchanl) ((rainc(i,j),i=ist,ind,isk),j=jst,jnd,jsk)

    END IF   !rainout

    IF ( prcout == 1 ) THEN

      WRITE(nchanl) 'prcrate1    '
      WRITE(nchanl) ((prcrate(i,j,1),i=ist,ind,isk),j=jst,jnd,jsk)
      WRITE(nchanl) 'prcrate2    '
      WRITE(nchanl) ((prcrate(i,j,2),i=ist,ind,isk),j=jst,jnd,jsk)
      WRITE(nchanl) 'prcrate3    '
      WRITE(nchanl) ((prcrate(i,j,3),i=ist,ind,isk),j=jst,jnd,jsk)
      WRITE(nchanl) 'prcrate4    '
      WRITE(nchanl) ((prcrate(i,j,4),i=ist,ind,isk),j=jst,jnd,jsk)

    END IF   ! prcout

    IF(iceout == 1) THEN

      WRITE(nchanl) 'qi          '
      WRITE(nchanl) ((( qi(i,j,k),                                      &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'qs          '
      WRITE(nchanl) ((( qs(i,j,k),                                      &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

      WRITE(nchanl) 'qh          '
      WRITE(nchanl) ((( qh(i,j,k),                                      &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    END IF   !iceout

  END IF   !mstout
!
!-----------------------------------------------------------------------
!
!  If tkeout = 1, write out turbulence parameter, km.
!
!-----------------------------------------------------------------------
!
  IF( tkeout == 1 ) THEN

    WRITE(nchanl) 'tke          '
    WRITE(nchanl) ((( tke(i,j,k),                                       &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

  END IF   ! tkeout

!
!-----------------------------------------------------------------------
!
!  If trbout = 1, write out turbulence parameter, km.
!
!-----------------------------------------------------------------------
!
  IF( trbout == 1 ) THEN

    WRITE(nchanl) 'kmh          '
    WRITE(nchanl) ((( kmh(i,j,k),                                       &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    WRITE(nchanl) 'kmv          '
    WRITE(nchanl) ((( kmv(i,j,k),                                       &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

  END IF   ! trbout
!
!-----------------------------------------------------------------------
!
!  If sfcout = 1, write out the surface variables, tsfc, tsoil,
!  wetsfc, wetdp, and wetcanp.
!
!-----------------------------------------------------------------------
!
  IF( sfcout == 1) THEN

    IF( nstyp <= 1 ) THEN

      WRITE(nchanl) 'tsfc         '
      WRITE(nchanl) ((tsfc(i,j,0),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'tsoil         '
      WRITE(nchanl) ((tsoil(i,j,0),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'wetsfc       '
      WRITE(nchanl) ((wetsfc(i,j,0),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'wetdp        '
      WRITE(nchanl) ((wetdp(i,j,0),i=ist,ind,isk),j=jst,jnd,jsk)

      WRITE(nchanl) 'wetcanp      '
      WRITE(nchanl) ((wetcanp(i,j,0),i=ist,ind,isk),j=jst,jnd,jsk)

    ELSE

      DO is=0,nstyp
        WRITE(nchanl) 'tsfc         '
        WRITE(nchanl) ((tsfc(i,j,is),i=ist,ind,isk),                    &
                      j=jst,jnd,jsk)

        WRITE(nchanl) 'tsoil         '
        WRITE(nchanl) ((tsoil(i,j,is),i=ist,ind,isk),                   &
                      j=jst,jnd,jsk)

        WRITE(nchanl) 'wetsfc       '
        WRITE(nchanl) ((wetsfc(i,j,is),i=ist,ind,isk),                  &
                      j=jst,jnd,jsk)

        WRITE(nchanl) 'wetdp        '
        WRITE(nchanl) ((wetdp(i,j,is),i=ist,ind,isk),                   &
                      j=jst,jnd,jsk)

        WRITE(nchanl) 'wetcanp      '
        WRITE(nchanl) ((wetcanp(i,j,is),i=ist,ind,isk),                 &
                      j=jst,jnd,jsk)
      END DO

    END IF

    IF(snowout == 1) THEN

      WRITE(nchanl) 'snowdpth     '
      WRITE(nchanl) ((snowdpth(i,j),i=ist,ind,isk),                     &
                    j=jst,jnd,jsk)
    END IF

  END IF   ! sfcout done
!
!-----------------------------------------------------------------------
!
!  If radout = 1, write out radiation arrays, radfrc, radsw and
!  rnflx.
!
!-----------------------------------------------------------------------
!
  IF( radout == 1 ) THEN

    WRITE(nchanl) 'radfrc       '
    WRITE(nchanl) ((( radfrc(i,j,k),                                    &
                  i=ist,ind,isk),j=jst,jnd,jsk),k=kst,knd,ksk)

    WRITE(nchanl) 'radsw        '
    WRITE(nchanl) (( radsw(i,j),                                        &
                  i=ist,ind,isk),j=jst,jnd,jsk)

    WRITE(nchanl) 'rnflx'
    WRITE(nchanl) (( rnflx(i,j),                                        &
                  i=ist,ind,isk),j=jst,jnd,jsk)

  END IF   ! radout
!
!-----------------------------------------------------------------------
!
!  If flxout = 1, write out surface fluxes
!
!-----------------------------------------------------------------------
!
  IF( flxout == 1 ) THEN

    WRITE(nchanl) 'usflx        '
    WRITE(nchanl) (( usflx(i,j),i=ist,ind,isk),j=jst,jnd,jsk)

    WRITE(nchanl) 'vsflx        '
    WRITE(nchanl) (( vsflx(i,j),i=ist,ind,isk),j=jst,jnd,jsk)

    WRITE(nchanl) 'ptsflx       '
    WRITE(nchanl) (( ptsflx(i,j),i=ist,ind,isk),j=jst,jnd,jsk)

    WRITE(nchanl) 'qvsflx       '
    WRITE(nchanl) (( qvsflx(i,j),i=ist,ind,isk),j=jst,jnd,jsk)

  END IF   ! flxout

  RETURN

  ENTRY bdmpdomn(ist1,ind1,jst1,jnd1,kst1,knd1)
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  To set the start and end indicies of the model subdomain
!  in which the data is dumped out.
!
!-----------------------------------------------------------------------
!
  ist = ist1
  jst = jst1
  kst = kst1
  ind = ind1
  jnd = jnd1
  knd = knd1

  setdomn = 1

  RETURN

  ENTRY bdmpskip(isk1, jsk1, ksk1)
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  To set data skip parameters for data dump.
!
!-----------------------------------------------------------------------
!

  isk = isk1
  jsk = jsk1
  ksk = ksk1

  setskip = 1

  RETURN
END SUBROUTINE bn2dump