!wdt update filename(1:lfname) below
!
!##################################################################
!##################################################################
!######                                                      ######
!######                SUBROUTINE READEXBC                   ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!


SUBROUTINE readexbc(nx,ny,nz,                                           & 5,63
           filename,lfname, ctime,                                      &
           u,v,w,pt,pr,qv,qc,qr,qi,qs,qh, ierr)
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Read in 6 primary fields for use as external boundary
!  conditions.
!
!  In general these data will come from another model.
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Keith Brewster
!  May, 1994
!
!  MODIFICATION HISTORY:
!
!  5/26/94 (Yuhe Liu)
!  Merged into the part of ARPS for external boundary conditions.
!
!  8/8/95 (M. Xue)
!  Added water and ice variables to the EXBC files.
!  To read earlier version EXBC files, one has to set old_v=1.
!
!-----------------------------------------------------------------------
!
!  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
!
!  dx       Expected x grid spacing
!  dy       Expected y grid spacing
!  dz       Expected z grid spacing
!
!  ctrlat   Expected center latitude
!  ctrlon   Expected center longitude
!
!  filename File name of EXBC boundary data set.
!  lfname   Length of the filename
!
!  OUTPUT:
!
!  ctime    Charater representation of the time of EXBC data
!
!  ubcrd    Flag indicating (1) if the u  field is valid
!  vbcrd    Flag indicating (1) if the v  field is valid
!  wbcrd    Flag indicating (1) if the w  field is valid
!  ptbcrd   Flag indicating (1) if the pt field is valid
!  prbcrd   Flag indicating (1) if the pr field is valid
!  qvbcrd   Flag indicating (1) if the qv field is valid
!  qcbcrd   Flag indicating (1) if the qc field is valid
!  qrbcrd   Flag indicating (1) if the qr field is valid
!  qibcrd   Flag indicating (1) if the qi field is valid
!  qsbcrd   Flag indicating (1) if the qs field is valid
!  qhbcrd   Flag indicating (1) if the qh field is valid
!
!  u        x component of velocity (m/s)
!  v        y component of velocity (m/s)
!  w        Vertical component of Cartesian velocity (m/s)
!  pt       Potential temperature (K)
!  pr       Pressure (Pascal)
!  qv       Water vapor mixing ratio humidity (kg/kg)
!  qc       Cloud water mixing ratio humidity (kg/kg)
!  qr       Rain water mixing ratio humidity (kg/kg)
!  qi       Cloud ice mixing ratio humidity (kg/kg)
!  qs       Snow mixing ratio humidity (kg/kg)
!  qh       Hail water mixing ratio humidity (kg/kg)
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE
  INTEGER :: nx,ny,nz       ! Number of grid points in x, y, and z dir.
  CHARACTER (LEN=80) :: filename
  INTEGER :: lfname
  CHARACTER (LEN=15) :: ctime

  REAL :: u(nx,ny,nz)       ! u-velocity (m/s)
  REAL :: v(nx,ny,nz)       ! v-velocity (m/s)
  REAL :: w(nx,ny,nz)       ! w-velocity (m/s)
  REAL :: pt(nx,ny,nz)      ! Potential temperature (K)
  REAL :: pr(nx,ny,nz)      ! Pressure (Pascal)
  REAL :: qv(nx,ny,nz)      ! 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)
!
!-----------------------------------------------------------------------
!
!  Misc internal variables
!
!-----------------------------------------------------------------------
!
  INTEGER :: nch
  INTEGER :: nxin,nyin,nzin
  REAL :: ctrlatin,ctrlonin

  INTEGER :: istat, ierr, idummy, old_v
  REAL :: amax, amin

  INTEGER :: ireturn
  INTEGER :: strhoptin
  REAL :: dxin,dyin,dzin,dzminin,zrefsfcin,dlayer1in,                   &
          dlayer2in,zflatin,strhtunein
  REAL :: trulat1in,trulat2in,trulonin,sclfctin
  INTEGER :: maprojin

  INTEGER(2), allocatable :: itmp(:,:,:) ! Temporary array
  REAL, allocatable :: hmax(:), hmin(:) ! Temporary array

  INTEGER :: clipxy, clipz

  INTEGER :: sd_id
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'globcst.inc'
  INCLUDE 'exbc.inc'
  INCLUDE 'grid.inc'          ! Grid & map parameters.
  INCLUDE 'mp.inc'            ! mpi parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
  IF (exbcfmt /= 0) THEN
    ALLOCATE (itmp(nx,ny,nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "READEXBC: ERROR allocating itmp, returning"
      ierr = 1
      RETURN
    END IF
    ALLOCATE (hmax(nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "READEXBC: ERROR allocating hmax, returning"
      ierr = 1
      RETURN
    END IF
    ALLOCATE (hmin(nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "READEXBC: ERROR allocating hmin, returning"
      ierr = 1
      RETURN
    END IF
  END IF
!wdt end block

  IF (myproc == 0) &
     WRITE (6,*) "READEXBC: reading in external boundary data ",           &
              "from file ",filename(1:lfname)
!
!-----------------------------------------------------------------------
!
!  Read in header information.
!
!-----------------------------------------------------------------------
!
  IF (exbcfmt == 0) THEN

!-----------------------------------------------------------------------
!
!  Fortran unformatted dump.
!
!-----------------------------------------------------------------------

    CALL getunit( nch )

    CALL asnctl ('NEWLOCAL', 1, ierr)
    CALL asnfile(filename(1:lfname), '-F f77 -N ieee', ierr)

    OPEN(nch,FILE=filename(1:lfname),STATUS='old',                &
        FORM='unformatted',IOSTAT=istat)

    IF ( istat /= 0 ) THEN
      ierr = 1
      GO TO 900
    END IF

    READ(nch,ERR=999) nxin,nyin,nzin,dxin,dyin,dzin,                    &
                      ctrlatin,ctrlonin
!
    READ(nch,ERR=999) ctime

    old_v = 0 ! In case that the EXBC files are of an earlier
              ! version that does not contain water and ice variables,
              ! set old_v to 1. Otherwise, set it to 0.

    IF( old_v == 1 ) THEN

      READ(nch,ERR=999) ubcrd,vbcrd,wbcrd,ptbcrd,prbcrd,qvbcrd

      qcbcrd=0
      qrbcrd=0
      qibcrd=0
      qsbcrd=0
      qhbcrd=0

    ELSE

      READ(nch,ERR=999) ubcrd,vbcrd,wbcrd,ptbcrd,prbcrd,                &
                      qvbcrd,qcbcrd,qrbcrd,qibcrd,qsbcrd,               &
                      qhbcrd,idummy,idummy,idummy,idummy,               &
                      idummy,idummy,idummy,idummy,idummy,               &
                      idummy,idummy,idummy,idummy,idummy,               &
                      idummy,idummy,idummy,idummy,idummy,               &
                      idummy,idummy,idummy,idummy,idummy,               &
                      idummy,idummy,idummy,idummy,idummy

    END IF

  ELSE

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
!-----------------------------------------------------------------------
!
!  HDF4 format.
!
!-----------------------------------------------------------------------

    CALL hdfopen(trim(filename(1:lfname)), 1, sd_id)
    IF (sd_id < 0) THEN
      WRITE (6,*) "READEXBC: ERROR opening ",                           &
                 trim(filename(1:lfname))," for reading."
      ierr = 1
      GO TO 900
    END IF

    CALL hdfrdc(sd_id,15,"ctime",ctime,istat)

    CALL hdfrdi(sd_id,"nx",nxin,istat)
    CALL hdfrdi(sd_id,"ny",nyin,istat)
    CALL hdfrdi(sd_id,"nz",nzin,istat)
    CALL hdfrdr(sd_id,"dx",dxin,istat)
    CALL hdfrdr(sd_id,"dy",dyin,istat)
    CALL hdfrdr(sd_id,"dz",dzin,istat)
    CALL hdfrdr(sd_id,"dzmin",dzminin,istat)
    CALL hdfrdi(sd_id,"strhopt",strhoptin,istat)
    CALL hdfrdr(sd_id,"zrefsfc",zrefsfcin,istat)
    CALL hdfrdr(sd_id,"dlayer1",dlayer1in,istat)
    CALL hdfrdr(sd_id,"dlayer2",dlayer2in,istat)
    CALL hdfrdr(sd_id,"zflat",zflatin,istat)
    CALL hdfrdr(sd_id,"strhtune",strhtunein,istat)
    CALL hdfrdi(sd_id,"mapproj",maprojin,istat)
    CALL hdfrdr(sd_id,"trulat1",trulat1in,istat)
    CALL hdfrdr(sd_id,"trulat2",trulat2in,istat)
    CALL hdfrdr(sd_id,"trulon",trulonin,istat)
    CALL hdfrdr(sd_id,"sclfct",sclfctin,istat)
    CALL hdfrdr(sd_id,"ctrlat",ctrlatin,istat)
    CALL hdfrdr(sd_id,"ctrlon",ctrlonin,istat)

    CALL hdfrdi(sd_id,"ubcflg",ubcrd,istat)
    CALL hdfrdi(sd_id,"vbcflg",vbcrd,istat)
    CALL hdfrdi(sd_id,"wbcflg",wbcrd,istat)
    CALL hdfrdi(sd_id,"ptbcflg",ptbcrd,istat)
    CALL hdfrdi(sd_id,"prbcflg",prbcrd,istat)
    CALL hdfrdi(sd_id,"qvbcflg",qvbcrd,istat)
    CALL hdfrdi(sd_id,"qcbcflg",qcbcrd,istat)
    CALL hdfrdi(sd_id,"qrbcflg",qrbcrd,istat)
    CALL hdfrdi(sd_id,"qibcflg",qibcrd,istat)
    CALL hdfrdi(sd_id,"qsbcflg",qsbcrd,istat)
    CALL hdfrdi(sd_id,"qhbcflg",qhbcrd,istat)

    CALL hdfrdi(sd_id, 'clipxy', clipxy,istat)
    IF (istat == 0 .AND. clipxy < ngbrz) THEN
      WRITE (6,*) "READEXBC: ERROR, clipxy (ngbrz) in exbc file too small"
      ierr = 1
      GO TO 900
    END IF
    CALL hdfrdi(sd_id, 'clipz', clipz,istat)
    IF (istat == 0 .AND. clipz > rayklow) THEN
      WRITE (6,*) "READEXBC: ERROR, clipz (rayklow) in exbc file too large"
      ierr = 1
      GO TO 900
    END IF
!wdt end block
    ! alternate dump format ...

  END IF

!-----------------------------------------------------------------------
!
!  Check the data file for consistent grid parameters.
!
!-----------------------------------------------------------------------

  IF (exbcfmt == 0) THEN

    IF (myproc == 0)  &
      WRITE (6,*)                                                         &
        "READEXBC: WARNING, not checking all map projection parameters"
    CALL checkgrid2d(nx,ny,nxin,nyin,                                   &
        dx,dy,ctrlat,ctrlon,                                            &
        mapproj,trulat1,trulat2,trulon,sclfct,                          &
        dxin,dyin,ctrlatin,ctrlonin,                                    &
        mapproj,trulat1,trulat2,trulon,sclfct,ireturn)

  ELSE

    CALL checkgrid3d(nx,ny,nz,nxin,nyin,nzin,                           &
        dx,dy,dz,dzmin,ctrlat,ctrlon,                                   &
        strhopt,zrefsfc,dlayer1,dlayer2,zflat,strhtune,                 &
        mapproj,trulat1,trulat2,trulon,sclfct,                          &
        dxin,dyin,dzin,dzminin,ctrlatin,ctrlonin,                       &
        strhoptin,zrefsfcin,dlayer1in,dlayer2in,zflatin,strhtunein,     &
        maprojin,trulat1in,trulat2in,trulonin,sclfctin,ireturn)

  END IF

  IF (ireturn /= 0) THEN
    WRITE (6,*) "READEXBC: ERROR, grid parameter mismatch"
    ierr = 1
    GO TO 900
  END IF

!-----------------------------------------------------------------------
!
!  Read in the external boundary file data
!
!-----------------------------------------------------------------------

  IF (exbcfmt == 0) THEN

    READ(nch,ERR=999) u
    READ(nch,ERR=999) v
    READ(nch,ERR=999) w
    READ(nch,ERR=999) pt
    READ(nch,ERR=999) pr

    IF(qvbcrd == 1) READ(nch,ERR=999) qv
    IF(qcbcrd == 1) READ(nch,ERR=999) qc
    IF(qrbcrd == 1) READ(nch,ERR=999) qr
    IF(qibcrd == 1) READ(nch,ERR=999) qi
    IF(qsbcrd == 1) READ(nch,ERR=999) qs
    IF(qhbcrd == 1) READ(nch,ERR=999) qh

  ELSE

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
    IF (ubcrd == 1) THEN
      CALL hdfrd3d(sd_id,"u",nx,ny,nz,u,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (vbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"v",nx,ny,nz,v,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (wbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"w",nx,ny,nz,w,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (ptbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"pt",nx,ny,nz,pt,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (prbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"p",nx,ny,nz,pr,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (qvbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"qv",nx,ny,nz,qv,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (qcbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"qc",nx,ny,nz,qc,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (qrbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"qr",nx,ny,nz,qr,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (qibcrd == 1) THEN
      CALL hdfrd3d(sd_id,"qi",nx,ny,nz,qi,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (qsbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"qs",nx,ny,nz,qs,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
    IF (qhbcrd == 1) THEN
      CALL hdfrd3d(sd_id,"qh",nx,ny,nz,qh,istat,itmp,hmax,hmin)
      IF (istat > 1) GO TO 999
    END IF
!wdt end block
    ! alternate dump format ...

  END IF

  IF(myproc == 0)THEN
    write(6,'(/1x,a/)') 'Max. and Min. of EXBC data variables:'

    CALL a3dmax0lcl(u,1,nx,1,nx,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'umin = ', amin,',  umax =',amax

    CALL a3dmax0lcl(v,1,nx,1,nx-1,1,ny,1,ny,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'vmin = ', amin,',  vmax =',amax

    CALL a3dmax0lcl(w,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'wmin = ', amin,',  wmax =',amax

    CALL a3dmax0lcl(pt,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'ptmin= ', amin,',  ptmax=',amax

    CALL a3dmax0lcl(pr,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'pmin = ', amin,',  pmax =',amax

    CALL a3dmax0lcl(qv,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'qvmin= ', amin,',  qvmax=',amax

    CALL a3dmax0lcl(qc,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'qcmin= ', amin,',  qcmax=',amax

    CALL a3dmax0lcl(qr,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'qrmin= ', amin,',  qrmax=',amax

    CALL a3dmax0lcl(qi,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'qimin= ', amin,',  qimax=',amax

    CALL a3dmax0lcl(qs,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'qsmin= ', amin,',  qsmax=',amax

    CALL a3dmax0lcl(qh,1,nx,1,nx-1,1,ny,1,ny-1,1,nz,1,nz-1,amax,amin)
    write(6,'(1x,2(a,e13.6))') 'qhmin= ', amin,',  qhmax=',amax
  END IF

  ierr = 0

  GO TO 900

  999   CONTINUE

  WRITE (6,*) "READEXBC: ERROR reading data ",                          &
              "from file ",trim(filename(1:lfname))," returning"
  ierr = 2

  900   CONTINUE

  IF (exbcfmt == 0) THEN

    CLOSE (nch)
    CALL retunit( nch )

  ELSE

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
    CALL hdfclose(sd_id,istat)

    DEALLOCATE (itmp,stat=istat)
    DEALLOCATE (hmax,stat=istat)
    DEALLOCATE (hmin,stat=istat)
!wdt end block
    ! alternate dump format ...

  END IF

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


SUBROUTINE getbcfn( abstsec, exbcnam, tinite, tintve,                   & 3,3
           filename, lfname, istat )
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Get the external boundary data file name.
!
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Yuhe Liu
!  5/26/1994
!
!  MODIFICATION HISTORY:
!
!  2000/03/24 (Gene Basett)
!  Added HDF4 format dumps.
!
!-----------------------------------------------------------------------
!
!  INPUT:
!
!    abstsec  Absolute seconds from 00:00:00, Jan. 1, 1980
!    exbcnam  A prefix of the external boundary condition file.
!
!    tinite   The boundary forecast initial time in yydddhhmm, In
!             general, the boundary files are named in yydddhhmm.
!    tintve   EXBC forecast time interval in seconds
!
!  OUTPUT:
!
!    filename  File name of EXBC boundary data set.
!    lfname    Length of the filename
!
!    istat     Status of finding the file.
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
!  Variable Declarations and COMMON blocks.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: abstsec

  CHARACTER (LEN=80) :: filename
  INTEGER :: lfname

  CHARACTER (LEN=80) :: exbcnam
  CHARACTER (LEN=19) :: tinite
  INTEGER :: tintve

  INTEGER :: lenstr,istat
!
!-----------------------------------------------------------------------
!
!  Misc. local variables:
!
!-----------------------------------------------------------------------
!
  CHARACTER (LEN=15) :: ctime
  CHARACTER (LEN=1) :: chr

  INTEGER :: abstsec1
  INTEGER :: bcfcst, bcfcstop
  INTEGER :: iyr, imon, idy, ihr, imin, isec

  INTEGER :: maxtry
  PARAMETER ( maxtry = 10 )

  LOGICAL :: iexist

  INTEGER :: sd_id
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'exbc.inc'
  INCLUDE 'globcst.inc'
  INCLUDE 'mp.inc'            ! Message passing parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
  READ (tinite,'(i4,a,i2,a,i2,a,i2,a,i2,a,i2)')                         &
       iyr,chr,imon,chr,idy,chr,ihr,chr,imin,chr,isec

  CALL ctim2abss( iyr,imon,idy,ihr,imin,isec, abstsec1 )

  bcfcstop = abststop + maxtry * tintve

  bcfcst = abstsec - MOD( abstsec-abstsec1, tintve )
  IF ( abstsec < abstsec1 ) bcfcst = bcfcst - tintve

  100   CONTINUE

  bcfcst = bcfcst + tintve

  IF ( bcfcst == abstsec .OR. bcfcst < abstsec1 ) GO TO 100

  CALL abss2ctim( bcfcst, iyr, imon, idy, ihr, imin, isec )

  WRITE (ctime,'(i4.4,2i2.2,a,3i2.2)')                                  &
        iyr,imon,idy,'.',ihr,imin,isec

  lenstr = 80
  CALL strlnth( exbcnam, lenstr )
  lfname = lenstr + 16

  filename(1:lfname) = exbcnam(1:lenstr)//'.'//ctime

  IF (mp_opt > 0) THEN
    WRITE(filename,'(a,a,a,a,2i2.2)')                                   &
        exbcnam(1:lenstr),'.',ctime,'_',loc_x,loc_y
    lfname  = lfname + 5
  END IF

  INQUIRE(FILE=filename(1:lfname),EXIST=iexist)

  IF ( iexist ) THEN
    istat = 0
    WRITE (6,'(a,a)')                                                   &
        'External boundary data file has been found: ',                 &
                      filename(1:lfname)
  ELSE IF ( bcfcst <= bcfcstop ) THEN
    WRITE (6,'(a,a,a)')                                                 &
        'External BC data file ', filename(1:lfname),                   &
        ' could not be found. Try another time.'
    GO TO 100
  ELSE
    WRITE (6,'(a,a)')                                                   &
        'No external BC data file could not be found within a time range' &
        ,'Job will stop.'
    istat = 1
  END IF

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


SUBROUTINE writexbc(nx,ny,nz,filename,lfname,ctime,                     & 2,61
           ubcdmp,vbcdmp,wbcdmp,ptbcdmp,prbcdmp,                        &
           qvbcdmp,qcbcdmp,qrbcdmp,qibcdmp,qsbcdmp,qhbcdmp,             &
           u,v,w,pt,pr,qv,qc,qr,qi,qs,qh)
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Output 6 primary fields for use as external boundary conditions.
!  In general these data come from another model.
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Keith Brewster
!  May, 1994
!
!  MODIFICATION HISTORY:
!
!  5/26/94 (Yuhe Liu)
!  Merged into the part of ARPS for external boundary conditions.
!
!  2000/03/24 (Gene Basett)
!  Added HDF4 format dumps.
!
!-----------------------------------------------------------------------
!
!  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
!
!  filename File name of EXBC boundary data set.
!  lfname   Length of the filename
!
!  ctime    Charater representation of the time of the EXBC data
!
!  dx       Expected x grid spacing
!  dy       Expected y grid spacing
!  dz       Expected z grid spacing
!
!  ctrlat   Expected center latitude
!  ctrlon   Expected center longitude
!
!  u        x component of velocity (m/s)
!  v        y component of velocity (m/s)
!  w        Vertical component of Cartesian velocity (m/s)
!  pt       Potential temperature (K)
!  pr       Pressure (Pascal)
!  qv       Water vapor specific humidity (kg/kg)
!  qc       Cloud water mixing ratio humidity (kg/kg)
!  qr       Rain water mixing ratio humidity (kg/kg)
!  qi       Cloud ice mixing ratio humidity (kg/kg)
!  qs       Snow mixing ratio humidity (kg/kg)
!  qh       Hail water mixing ratio humidity (kg/kg)
!
!  OUTPUT:
!
!  none
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE
  INTEGER :: nx,ny,nz
  CHARACTER (LEN=80) :: filename
  INTEGER :: lfname
  CHARACTER (LEN=15) :: ctime
  INTEGER :: ubcdmp,vbcdmp,wbcdmp,ptbcdmp,prbcdmp
  INTEGER :: qvbcdmp,qcbcdmp,qrbcdmp,qibcdmp,qsbcdmp,qhbcdmp
  REAL :: u(nx,ny,nz)       ! u-velocity (m/s)
  REAL :: v(nx,ny,nz)       ! v-velocity (m/s)
  REAL :: w(nx,ny,nz)       ! w-velocity (m/s)
  REAL :: pt(nx,ny,nz)      ! Potential temperature (K)
  REAL :: pr(nx,ny,nz)      ! Pressure (Pascal)
  REAL :: qv(nx,ny,nz)      ! 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)
!
!-----------------------------------------------------------------------
!
!  Misc internal variables
!
!-----------------------------------------------------------------------
!
  INTEGER :: nch, ierr, idummy

  INTEGER(2), allocatable :: itmp(:,:,:) ! Temporary array
  REAL, allocatable :: hmax(:), hmin(:) ! Temporary array
  REAL, allocatable :: ctmp(:,:,:) ! Temporary array
  INTEGER :: exbccompr

  INTEGER :: istat, sd_id
  INTEGER :: i,j,k
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'globcst.inc'
  INCLUDE 'grid.inc'          ! Grid & map parameters.
  INCLUDE 'exbc.inc'
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
  IF (exbcdmp == 0) RETURN

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
  IF (exbcdmp == 3) THEN
    exbccompr = hdfcompr
  ELSE IF (exbcdmp == 4) THEN
    exbccompr = 5
  ELSE
    exbccompr = 0
  END IF

  IF (exbccompr > 3) THEN
    ALLOCATE (itmp(nx,ny,nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "WRITEXBC: ERROR allocating itmp, returning"
      RETURN
    END IF
    ALLOCATE (hmax(nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "WRITEXBC: ERROR allocating hmax, returning"
      RETURN
    END IF
    ALLOCATE (hmin(nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "WRITEXBC: ERROR allocating hmin, returning"
      RETURN
    END IF
  END IF
  IF (exbcdmp == 4) THEN
    ALLOCATE (ctmp(nx,ny,nz),stat=istat)
    IF (istat /= 0) THEN
      WRITE (6,*) "WRITEXBC: ERROR allocating ctmp, returning"
      RETURN
    END IF
  END IF
!wdt end block

  WRITE (6,*) 'WRITEXBC: Opening external boundary file ',              &
              trim(filename(1:lfname))

!-----------------------------------------------------------------------
!
!  Write out in Fortran unformatted.
!
!-----------------------------------------------------------------------

  IF (exbcdmp == 1) THEN

    CALL getunit( nch )

    CALL asnctl ('NEWLOCAL', 1, ierr)
    CALL asnfile(filename(1:lfname), '-F f77 -N ieee', ierr)

    OPEN (nch,FILE=trim(filename(1:lfname)),STATUS='unknown',           &
        FORM='unformatted')
!
!-----------------------------------------------------------------------
!
!  Write grid and time descriptors
!
!-----------------------------------------------------------------------
!
    WRITE (nch) nx,ny,nz,dx,dy,dz,ctrlat,ctrlon
!
    WRITE (nch) ctime
!
!-----------------------------------------------------------------------
!
!  Write integers which indicate whether each of the
!  variables are valid.  These must be properly set
!  by the calling routine.
!
!-----------------------------------------------------------------------
!
    idummy = 0

    WRITE (nch) ubcdmp,vbcdmp,wbcdmp,ptbcdmp,prbcdmp,                   &
              qvbcdmp,qcbcdmp,qrbcdmp,qibcdmp,qsbcdmp,                  &
              qhbcdmp,idummy,idummy,idummy,idummy,                      &
              idummy,idummy,idummy,idummy,idummy,                       &
              idummy,idummy,idummy,idummy,idummy,                       &
              idummy,idummy,idummy,idummy,idummy,                       &
              idummy,idummy,idummy,idummy,idummy,                       &
              idummy,idummy,idummy,idummy,idummy
!
!-----------------------------------------------------------------------
!
!  Write each variable in a separate record
!
!-----------------------------------------------------------------------
!
    IF( ubcdmp == 1) WRITE (nch) u
    IF( vbcdmp == 1) WRITE (nch) v
    IF( wbcdmp == 1) WRITE (nch) w
    IF(ptbcdmp == 1) WRITE (nch) pt
    IF(prbcdmp == 1) WRITE (nch) pr
    IF(qvbcdmp == 1) WRITE (nch) qv
    IF(qcbcdmp == 1) WRITE (nch) qc
    IF(qrbcdmp == 1) WRITE (nch) qr
    IF(qibcdmp == 1) WRITE (nch) qi
    IF(qsbcdmp == 1) WRITE (nch) qs
    IF(qhbcdmp == 1) WRITE (nch) qh

  ELSE

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
!-----------------------------------------------------------------------
!
!  Write out in HDF4.
!
!-----------------------------------------------------------------------

    CALL hdfopen(trim(filename(1:lfname)), 2, sd_id)
    IF (sd_id < 0) THEN
      WRITE (6,*) "WRITEXBC: ERROR creating HDF4 file: ",               &
                  trim(filename(1:lfname))
      GO TO 900
    END IF

    CALL hdfwrtc(sd_id, 15, 'ctime', ctime, istat)

    CALL hdfwrti(sd_id, 'nx', nx, istat)
    CALL hdfwrti(sd_id, 'ny', ny, istat)
    CALL hdfwrti(sd_id, 'nz', nz, istat)
    CALL hdfwrtr(sd_id, 'dx', dx, istat)
    CALL hdfwrtr(sd_id, 'dy', dy, istat)
    CALL hdfwrtr(sd_id, 'dz', dz, istat)
    CALL hdfwrtr(sd_id, 'dzmin', dzmin, istat)
    CALL hdfwrti(sd_id, 'strhopt', strhopt, istat)
    CALL hdfwrtr(sd_id, 'zrefsfc', zrefsfc, istat)
    CALL hdfwrtr(sd_id, 'dlayer1', dlayer1, istat)
    CALL hdfwrtr(sd_id, 'dlayer2', dlayer2, istat)
    CALL hdfwrtr(sd_id, 'zflat', zflat, istat)
    CALL hdfwrtr(sd_id, 'strhtune', strhtune, istat)
    CALL hdfwrti(sd_id, 'mapproj', mapproj, istat)
    CALL hdfwrtr(sd_id, 'trulat1', trulat1, istat)
    CALL hdfwrtr(sd_id, 'trulat2', trulat2, istat)
    CALL hdfwrtr(sd_id, 'trulon', trulon, istat)
    CALL hdfwrtr(sd_id, 'sclfct', sclfct, istat)
    CALL hdfwrtr(sd_id, 'ctrlat', ctrlat, istat)
    CALL hdfwrtr(sd_id, 'ctrlon', ctrlon, istat)

    CALL hdfwrti(sd_id,"ubcflg",ubcdmp,istat)
    CALL hdfwrti(sd_id,"vbcflg",vbcdmp,istat)
    CALL hdfwrti(sd_id,"wbcflg",wbcdmp,istat)
    CALL hdfwrti(sd_id,"ptbcflg",ptbcdmp,istat)
    CALL hdfwrti(sd_id,"prbcflg",prbcdmp,istat)
    CALL hdfwrti(sd_id,"qvbcflg",qvbcdmp,istat)
    CALL hdfwrti(sd_id,"qcbcflg",qcbcdmp,istat)
    CALL hdfwrti(sd_id,"qrbcflg",qrbcdmp,istat)
    CALL hdfwrti(sd_id,"qibcflg",qibcdmp,istat)
    CALL hdfwrti(sd_id,"qsbcflg",qsbcdmp,istat)
    CALL hdfwrti(sd_id,"qhbcflg",qhbcdmp,istat)

    IF (exbcdmp == 4) THEN
      CALL hdfwrti(sd_id, 'clipxy', ngbrz, istat)
      CALL hdfwrti(sd_id, 'clipz', rayklow, istat)
    END IF

    IF( ubcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = u(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=2+ngbrz,nx-2-ngbrz
              ctmp(i,j,k) = u(2,2,k)   ! just need some value with max/min
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'u','u-velocity','m/s',                               &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(u,nx,ny,nz,sd_id,1,exbccompr,                     &
                  'u','u-velocity','m/s',                               &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF( vbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = v(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=2+ngbrz,ny-2-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = v(2,2,k)   ! just need some value with max/min
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'v','v-velocity','m/s',                               &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(v,nx,ny,nz,sd_id,1,exbccompr,                     &
                  'v','v-velocity','m/s',                               &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF( wbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = w(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-2
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = w(2,2,k)   ! just need some value with max/min
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'w','w-velocity','m/s',                               &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(w,nx,ny,nz,sd_id,1,exbccompr,                     &
                  'w','w-velocity','m/s',                               &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(ptbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = pt(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = pt(2,2,k)   ! just need some value with max/min
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'pt','Potential temperature','K',                     &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(pt,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'pt','Potential temperature','K',                     &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(prbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = pr(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = pr(2,2,k)   ! just need some value with max/min
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'p','Pressure','Pascal',                              &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(pr,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'p','Pressure','Pascal',                              &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(qvbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = qv(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = 0.0
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'qv','Water vapor specific humidity','kg/kg',         &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(qv,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'qv','Water vapor specific humidity','kg/kg',         &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(qcbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = qc(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = 0.0
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'qc','Cloud water mixing ratio','kg/kg',              &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(qc,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'qc','Cloud water mixing ratio','kg/kg',              &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(qrbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = qr(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = 0.0
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'qr','Rain water mixing ratio','kg/kg',               &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(qr,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'qr','Rain water mixing ratio','kg/kg',               &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(qibcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = qi(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = 0.0
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'qi','Cloud ice mixing ratio','kg/kg',                &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(qi,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'qi','Cloud ice mixing ratio','kg/kg',                &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(qsbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = qs(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = 0.0
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'qs','Snow mixing ratio','kg/kg',                     &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(qs,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'qs','Snow mixing ratio','kg/kg',                     &
                   itmp,hmax,hmin)
      END IF
    END IF

    IF(qhbcdmp == 1) THEN
      IF (exbcdmp == 4) THEN
        DO k=1,nz
          DO j=1,ny
            DO i=1,nx
              ctmp(i,j,k) = qh(i,j,k)
            END DO
          END DO
        END DO
!        reset values inside region not used by LBC forcing
        DO k=1,rayklow-1
          DO j=1+ngbrz,ny-1-ngbrz
            DO i=1+ngbrz,nx-1-ngbrz
              ctmp(i,j,k) = 0.0
            END DO
          END DO
        END DO
        CALL hdfwrt3d(ctmp,nx,ny,nz,sd_id,1,exbccompr,                  &
                  'qh','Hail mixing ratio','kg/kg',                     &
                   itmp,hmax,hmin)
      ELSE
        CALL hdfwrt3d(qh,nx,ny,nz,sd_id,1,exbccompr,                    &
                  'qh','Hail mixing ratio','kg/kg',                     &
                   itmp,hmax,hmin)
      END IF
    END IF
!wdt end block
    ! alternate dump format ...

  END IF

  900   CONTINUE

  IF (exbcdmp == 1) THEN

    CLOSE (nch)
    CALL retunit( nch )

  ELSE

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc. (HDF format exbc)
!wdt begin block
    CALL hdfclose(sd_id,istat)

    IF (exbccompr > 3) THEN
      DEALLOCATE (itmp,stat=istat)
      DEALLOCATE (hmax,stat=istat)
      DEALLOCATE (hmin,stat=istat)
    END IF
    IF (exbcdmp == 4) THEN
      DEALLOCATE (ctmp,stat=istat)
    END IF
!wdt end block
    ! alternate dump format ...

  END IF

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


SUBROUTINE exbcdump( nx,ny,nz,nstyps,                                   & 2,2
           hisfmt,hisfnm,grdbas,flcmprs,                                &
           u,v,w,ptprt,pprt,qv,qc,qr,qi,qs,qh,tke,kmh,kmv,              &
           ubar,vbar,wbar,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,                                   &
           u0exb,v0exb,w0exb,pt0exb,pr0exb,qv0exb,qc0exb,qr0exb,        &
           qi0exb,qs0exb,qh0exb,udtexb,vdtexb,wdtexb,                   &
           ptdtexb,prdtexb,qvdtexb,qcdtexb,qrdtexb,qidtexb,             &
           qsdtexb,qhdtexb,                                             &
           tem1,tem2,tem3 )
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Dump EXBC fields interpolated to the model time in history
!  dump format.
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Yuhe Liu
!  5/27/94
!
!  MODIFICATION HISTORY:
!
!  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
!
!  hisfmt
!  hisfnm
!  grdbas
!  flcmprs
!
!  u        x component of velocity (m/s)
!  v        y component of velocity (m/s)
!  w        Vertical component of Cartesian velocity (m/s)
!  ptprt    Perturbation potential temperature (K)
!  pprt     Perturbation pressure (Pascal)
!  qv       Water vapor specific humidity (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 zonal velocity component (m/s)
!  vbar     Base state meridional velocity component (m/s)
!  wbar     Base state vertical 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 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
!
!  TEMPORATY WORKING ARRAY
!
!  tem1
!  tem2
!  tem3
!
!-----------------------------------------------------------------------
!
!  Variable Declarations.
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: nx, ny, nz

  INTEGER :: hisfmt
  CHARACTER (LEN=*) :: hisfnm
  INTEGER :: grdbas
  INTEGER :: flcmprs
!
  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
  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 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
  INTEGER :: soiltyp (nx,ny,nstyps)   ! Soil type
  REAL :: stypfrct(nx,ny,nstyps)   ! Soil type fratction
  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)     ! Ground sfc. temperature (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*s**2))
  REAL :: qvsflx(nx,ny)        ! Surface moisture flux (kg/(m**2*s))

  REAL :: u0exb (nx,ny,nz)  ! External boundary u-velocity field
  REAL :: v0exb (nx,ny,nz)  ! External boundary v-velocity field
  REAL :: w0exb (nx,ny,nz)  ! External boundary w-velocity field
  REAL :: pt0exb(nx,ny,nz)  ! External boundary pt field
  REAL :: pr0exb(nx,ny,nz)  ! External boundary p field
  REAL :: qv0exb(nx,ny,nz)  ! External boundary qv field
  REAL :: qc0exb(nx,ny,nz)  ! External boundary qc field
  REAL :: qr0exb(nx,ny,nz)  ! External boundary qr field
  REAL :: qi0exb(nx,ny,nz)  ! External boundary qi field
  REAL :: qs0exb(nx,ny,nz)  ! External boundary qs field
  REAL :: qh0exb(nx,ny,nz)  ! External boundary qh field

  REAL :: udtexb (nx,ny,nz) ! Time tendency of external boundary u
  REAL :: vdtexb (nx,ny,nz) ! Time tendency of external boundary v
  REAL :: wdtexb (nx,ny,nz) ! Time tendency of external boundary w
  REAL :: ptdtexb(nx,ny,nz) ! Time tendency of external boundary pt
  REAL :: prdtexb(nx,ny,nz) ! Time tendency of external boundary p
  REAL :: qvdtexb(nx,ny,nz) ! Time tendency of external boundary qv
  REAL :: qcdtexb(nx,ny,nz) ! Time tendency of external boundary qc
  REAL :: qrdtexb(nx,ny,nz) ! Time tendency of external boundary qr
  REAL :: qidtexb(nx,ny,nz) ! Time tendency of external boundary qi
  REAL :: qsdtexb(nx,ny,nz) ! Time tendency of external boundary qs
  REAL :: qhdtexb(nx,ny,nz) ! Time tendency of external boundary qh

  REAL :: tem1 (nx,ny,nz)
  REAL :: tem2 (nx,ny,nz)
  REAL :: tem3 (nx,ny,nz)
!
!-----------------------------------------------------------------------
!
!  Misc. local variables:
!
!-----------------------------------------------------------------------
!
  INTEGER :: i, j, k

  INTEGER :: nchexbc

  REAL :: tema

  SAVE nchexbc
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'globcst.inc'
!
!-----------------------------------------------------------------------
!
!  Declare the external boundary fields
!
!-----------------------------------------------------------------------
!
  INCLUDE 'exbc.inc'
  INCLUDE 'mp.inc'            ! Message passing parameters.
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
  tema = curtim - ( abstfcst0 - abstinit )

  DO k = 1, nz-1
    DO j = 1, ny-1
      DO i = 1, nx
        u(i,j,k) = u0exb(i,j,k) + udtexb(i,j,k) * tema
      END DO
    END DO
  END DO

  DO k = 1, nz-1
    DO j = 1, ny
      DO i = 1, nx-1
        v(i,j,k) = v0exb(i,j,k) + vdtexb(i,j,k) * tema
      END DO
    END DO
  END DO

  DO k = 1, nz
    DO j = 1, ny-1
      DO i = 1, nx-1
        w(i,j,k) = w0exb(i,j,k) + wdtexb(i,j,k) * tema
      END DO
    END DO
  END DO

  DO k = 1, nz-1
    DO j = 1, ny-1
      DO i = 1, nx-1
        ptprt(i,j,k) = pt0exb(i,j,k) + ptdtexb(i,j,k) * tema
        pprt (i,j,k) = pr0exb(i,j,k) + prdtexb(i,j,k) * tema
        qv   (i,j,k) = qv0exb(i,j,k) + qvdtexb(i,j,k) * tema
!
!  Since we do not have enough tem arrays to store qctem,
!  qrtem, qitem, qstem and qhtem, we pass the model arrays
!  into dtadump.
!
!    qctem(i,j,k) = qc0exb(i,j,k) + qcdtexb(i,j,k) * tema
!    qrtem(i,j,k) = qr0exb(i,j,k) + qrdtexb(i,j,k) * tema
!    qitem(i,j,k) = qi0exb(i,j,k) + qidtexb(i,j,k) * tema
!    qstem(i,j,k) = qs0exb(i,j,k) + qsdtexb(i,j,k) * tema
!    qhtem(i,j,k) = qh0exb(i,j,k) + qhdtexb(i,j,k) * tema
      END DO
    END DO
  END DO

!    blocking inserted for ordering i/o for message passing
  DO i=0,nprocs-1,max_fopen
    IF(myproc >= i.AND.myproc <= i+max_fopen-1)THEN

      CALL dtadump( nx,ny,nz,nstyps,                                    &
                  hisfmt,nchexbc,hisfnm,grdbas,filcmprs,                &
                  u,v,w,ptprt,pprt,qv,                                  &
                  qc,qr,qi,qs,qh,tke,kmh,kmv,                           &
                  ubar,vbar,wbar,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,tem2,tem3 )

    END IF
    IF (mp_opt > 0) CALL mpbarrier
  END DO

  RETURN
END SUBROUTINE exbcdump