PROGRAM arpscvt,14
!
!##################################################################
!##################################################################
!######                                                      ######
!######                   PROGRAM ARPSCVT                    ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!
!
!-----------------------------------------------------------------------
!
!  PURPOSE:
!
!  Program to read history data dump from ARPS and convert it
!  into another format.
!
!  Parameters grdin,basin,mstin,rainin,icein,trbin are read in from
!  the data file itself, therefore are determined internally.
!  Arrays that are not read in retains their initial zero values.
!  These parameters are passed among subroutines through
!  a common block defined in 'indtflg.inc'.
!
!-----------------------------------------------------------------------
!
!  AUTHOR: Ming Xue
!    8/10/1992
!
!  MODIFICATION HISTORY:
!    Consolidated version for ARPS 3.1 release.
!
!    4/13/93 M. Xue.
!    Modified to conform to the new data dump format.
!
!    10/26/93 Y. Liu
!    Added GrADS format.
!
!    10/26/93 Y. Liu
!    Added surface fields.
!
!    Version 1.1. 11/13/94 M. Xue
!    Changed to namelist input format.
!
!    09/25/95 Yuhe Liu
!    Fixed a bug. Previously parameter nhisfile was used before it
!    was read in from input namelist.
!
!    Version 1.2. 12/07/95 (Yuhe Liu)
!
!    12/07/95 (Yuhe Liu)
!    Updated namelist parameters for landout and rainout.
!
!    12/07/95 (Yuhe Liu)
!    Added conversion of GRIB dump format
!
!    3/13/96 (Ming Xue)
!    Added tke. Changed km to kmh and kmv.
!
!    4/30/1997 (Fanyou Kong -- CMRP)
!    Add Vis5D format output
!
!    12/14/1998 (Donghai Wang)
!    Added the snow cover.
!
!    2000/04/17 (Ming Xue)
!    Added an option that allows one to specify input history data
!    at a constant time interval.
!
!    2000/05/19 (Gene Bassett)
!    Converted to F90, creating allocation and main subroutines.
!
!  DATA ARRAYS READ IN:
!
!    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)
!
!    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)
!
!  CALCULATED DATA ARRAYS:
!
!    u        x component of total velocity (m/s)
!    v        y component of total velocity (m/s)
!    w        z component of total velocity (m/s)
!    qv       total water vapor mixing ratio (kg/kg)
!
!  WORK ARRAYS:
!
!    tem1     Temporary work array.
!    tem2     Temporary work array.
!    tem3     Work array for Savi3D dump
!
!-----------------------------------------------------------------------
!
!  Variable Declarations:
!
!-----------------------------------------------------------------------
!
  IMPLICIT NONE

  INTEGER :: nx,ny,nz          ! Grid dimensions.
  INTEGER :: nstyps            ! Maximum number of soil types.

  INTEGER :: hinfmt,nhisfile_max,nhisfile,lengbf,nf,lenfil
  PARAMETER (nhisfile_max=200)
  CHARACTER (LEN=132) :: grdbasfn,hisfile(nhisfile_max)
!
!-----------------------------------------------------------------------
!
!  Include files:
!
!-----------------------------------------------------------------------
!
  INCLUDE 'globcst.inc'
  INCLUDE 'grid.inc'
  INCLUDE 'indtflg.inc'
!wdt Copyright (c) 2001 Weather Decision Technologies, Inc.
  INCLUDE 'exbc.inc'
!
!-----------------------------------------------------------------------
!
!  Parameters to be passed in BN2DUMP and SVIDUMP.
!
!-----------------------------------------------------------------------
!
  INTEGER :: ist,ind,isk,jst,jnd,jsk,kst,knd,ksk
  COMMON /dfndomn/ ist,ind,isk,jst,jnd,jsk,kst,knd,ksk
!
!-----------------------------------------------------------------------
!
!  Arrays to be read in:
!
!-----------------------------------------------------------------------
!
  REAL, ALLOCATABLE :: x(:)       ! The x-coord. of the physical and
                                  ! computational grid.
                                  ! Defined at u-point.
  REAL, ALLOCATABLE :: y(:)       ! The y-coord. of the physical and
                                  ! computational grid.
                                  ! Defined at v-point.
  REAL, ALLOCATABLE :: z(:)       ! The z-coord. of the computational
                                  ! grid. Defined at w-point.

  REAL, ALLOCATABLE :: zp(:,:,:)  ! The height of the terrain.
  REAL, ALLOCATABLE :: hterain(:,:)    ! Terrain height.

  REAL, ALLOCATABLE :: j1(:,:,:)  ! Coordinate transformation
                                  ! Jacobian -d(zp)/d(x)
  REAL, ALLOCATABLE :: j2(:,:,:)  ! Coordinate transformation
                                  ! Jacobian -d(zp)/d(y)
  REAL, ALLOCATABLE :: j3(:,:,:)  ! Coordinate transformation
                                  ! Jacobian  d(zp)/d(z)

  REAL, ALLOCATABLE :: uprt   (:,:,:) ! Perturbation u-velocity (m/s)
  REAL, ALLOCATABLE :: vprt   (:,:,:) ! Perturbation v-velocity (m/s)
  REAL, ALLOCATABLE :: wprt   (:,:,:) ! Perturbation w-velocity (m/s)
  REAL, ALLOCATABLE :: ptprt  (:,:,:) ! Perturbation potential temperature (K)
  REAL, ALLOCATABLE :: pprt   (:,:,:) ! Perturbation pressure (Pascal)
  REAL, ALLOCATABLE :: qvprt  (:,:,:) ! Perturbation water vapor specific
                                      ! humidity (kg/kg)
  REAL, ALLOCATABLE :: qc     (:,:,:) ! Cloud water mixing ratio (kg/kg)
  REAL, ALLOCATABLE :: qr     (:,:,:) ! Rain water mixing ratio (kg/kg)
  REAL, ALLOCATABLE :: qi     (:,:,:) ! Cloud ice mixing ratio (kg/kg)
  REAL, ALLOCATABLE :: qs     (:,:,:) ! Snow mixing ratio (kg/kg)
  REAL, ALLOCATABLE :: qh     (:,:,:) ! Hail mixing ratio (kg/kg)

  REAL, ALLOCATABLE :: tke    (:,:,:) ! Turbulent Kinetic Energy ((m/s)**2)
  REAL, ALLOCATABLE :: kmh    (:,:,:) ! Horizontal turb. mixing coef. for
                                      ! momentum. ( m**2/s )
  REAL, ALLOCATABLE :: kmv    (:,:,:) ! Vertical turb. mixing coef. for
                                      ! momentum. ( m**2/s )
  REAL, ALLOCATABLE :: ubar   (:,:,:) ! Base state u-velocity (m/s)
  REAL, ALLOCATABLE :: vbar   (:,:,:) ! Base state v-velocity (m/s)
  REAL, ALLOCATABLE :: wbar   (:,:,:) ! Base state w-velocity (m/s)
  REAL, ALLOCATABLE :: ptbar  (:,:,:) ! Base state potential temperature (K)
  REAL, ALLOCATABLE :: pbar   (:,:,:) ! Base state pressure (Pascal)
  REAL, ALLOCATABLE :: rhobar (:,:,:) ! Base state air density (kg/m**3)
  REAL, ALLOCATABLE :: qvbar  (:,:,:) ! Base state water vapor specific
                                      ! humidity (kg/kg)

  REAL, ALLOCATABLE :: u      (:,:,:) ! Total u-velocity (m/s)
  REAL, ALLOCATABLE :: v      (:,:,:) ! Total v-velocity (m/s)
  REAL, ALLOCATABLE :: w      (:,:,:) ! Total w-velocity (m/s)
  REAL, ALLOCATABLE :: qv     (:,:,:) ! Water vapor specific humidity (kg/kg)

  INTEGER, ALLOCATABLE :: soiltyp (:,:,:) ! Soil type
  REAL, ALLOCATABLE :: stypfrct(:,:,:)    ! Soil type
  INTEGER, ALLOCATABLE :: vegtyp(:,:)     ! Vegetation type
  REAL, ALLOCATABLE :: lai    (:,:)   ! Leaf Area Index
  REAL, ALLOCATABLE :: roufns (:,:)   ! Surface roughness
  REAL, ALLOCATABLE :: veg    (:,:)   ! Vegetation fraction

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

  REAL, ALLOCATABLE :: raing(:,:)     ! Grid supersaturation rain
  REAL, ALLOCATABLE :: rainc(:,:)     ! Cumulus convective rain
  REAL, ALLOCATABLE :: prcrate(:,:,:) ! 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, ALLOCATABLE :: radfrc(:,:,:)  ! Radiation forcing (K/s)
  REAL, ALLOCATABLE :: radsw (:,:)    ! Solar radiation reaching the surface
  REAL, ALLOCATABLE :: rnflx (:,:)    ! Net radiation flux absorbed by surface

  REAL, ALLOCATABLE :: usflx (:,:)    ! Surface flux of u-momentum (kg/(m*s**2))
  REAL, ALLOCATABLE :: vsflx (:,:)    ! Surface flux of v-momentum (kg/(m*s**2))
  REAL, ALLOCATABLE :: ptsflx(:,:)    ! Surface heat flux (K*kg/(m*s**2))
  REAL, ALLOCATABLE :: qvsflx(:,:)    ! Surface moisture flux (kg/(m**2*s))
!
!-----------------------------------------------------------------------
!
!  Temporary working arrays:
!
!-----------------------------------------------------------------------
!
  REAL, ALLOCATABLE :: tem1(:,:,:)
  REAL, ALLOCATABLE :: tem2(:,:,:)
  REAL, ALLOCATABLE :: tem3(:,:,:)
!
!-----------------------------------------------------------------------
!
!  Misc. internal variables
!
!-----------------------------------------------------------------------
!
  INTEGER :: houtfmt, nchin, nchout

  CHARACTER (LEN=132) :: houtfn
  CHARACTER (LEN=132) :: basoutfn
  INTEGER :: lbasoutf, loutf

  INTEGER :: grdbas
  INTEGER :: i,j,k,ireturn

  REAL :: alatnot(2)
  REAL :: ctrx, ctry, swx, swy

  REAL :: time
  INTEGER :: gboutcnt, vroutcnt
  DATA    gboutcnt, vroutcnt /0,0/

  INTEGER :: nfile

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc.: ngbrz,zbrdmp
  NAMELIST /output/ hdmpfmt,exbcdmp,grdout,basout,                      &
            varout,mstout,iceout,tkeout,trbout,rainout,                 &
            sfcout,landout,prcout,radout,flxout,                        &
            qcexout,qrexout,qiexout,qsexout,qhexout,                    &
            filcmprs,dirname,grbpkbit,istager,hdfcompr,                 &
            ngbrz,zbrdmp

!wdt tmp
!  REAL :: zpmax

  INTEGER :: length, ierr

!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
!  Beginning of executable code...
!
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
!
  WRITE(6,'(/9(/5x,a)/)')                                               &
     '###############################################################', &
     '###############################################################', &
     '###                                                         ###', &
     '###                Welcome to ARPSCVT                       ###', &
     '###      This program converts the history dump data        ###', &
     '###      sets generated by ARPS, between various formats.   ###', &
     '###                                                         ###', &
     '###############################################################', &
     '###############################################################'
!
!-----------------------------------------------------------------------
!
!  Get the names of the input data files.
!
!-----------------------------------------------------------------------
!
  CALL get_input_file_names(hinfmt,grdbasfn,hisfile,nhisfile)

  lengbf = len_trim(grdbasfn)

  CALL get_dims_from_data(hinfmt,grdbasfn(1:lengbf),                    &
       nx,ny,nz,nstyps, ireturn)

  IF (nstyps <= 0) nstyps = 1
  nstyp = nstyps

  IF( ireturn /= 0 ) THEN
    PRINT*,'Problem occured when trying to get dimensions from data.'
    PRINT*,'Program stopped.'
    STOP
  END IF

  WRITE(6,'(3(a,i5))') 'nx =',nx,', ny=',ny,', nz=',nz
!
  ALLOCATE(x      (nx))       
  ALLOCATE(y      (ny))       
  ALLOCATE(z      (nz))       
  ALLOCATE(zp     (nx,ny,nz)) 
  ALLOCATE(hterain(nx,ny))    

  ALLOCATE(j1     (nx,ny,nz)) 
  ALLOCATE(j2     (nx,ny,nz)) 
  ALLOCATE(j3     (nx,ny,nz)) 
  ALLOCATE(uprt   (nx,ny,nz)) 
  ALLOCATE(vprt   (nx,ny,nz)) 
  ALLOCATE(wprt   (nx,ny,nz)) 
  ALLOCATE(ptprt  (nx,ny,nz)) 
  ALLOCATE(pprt   (nx,ny,nz)) 
  ALLOCATE(qvprt  (nx,ny,nz)) 
  ALLOCATE(qc     (nx,ny,nz)) 
  ALLOCATE(qr     (nx,ny,nz)) 
  ALLOCATE(qi     (nx,ny,nz)) 
  ALLOCATE(qs     (nx,ny,nz)) 
  ALLOCATE(qh     (nx,ny,nz)) 
  ALLOCATE(tke    (nx,ny,nz)) 
  ALLOCATE(kmh    (nx,ny,nz)) 
  ALLOCATE(kmv    (nx,ny,nz)) 
  ALLOCATE(ubar   (nx,ny,nz)) 
  ALLOCATE(vbar   (nx,ny,nz)) 
  ALLOCATE(wbar   (nx,ny,nz)) 
  ALLOCATE(ptbar  (nx,ny,nz)) 
  ALLOCATE(pbar   (nx,ny,nz)) 
  ALLOCATE(rhobar (nx,ny,nz)) 
  ALLOCATE(qvbar  (nx,ny,nz)) 
  ALLOCATE(u      (nx,ny,nz)) 
  ALLOCATE(v      (nx,ny,nz)) 
  ALLOCATE(w      (nx,ny,nz)) 
  ALLOCATE(qv     (nx,ny,nz)) 

  ALLOCATE(soiltyp (nx,ny,nstyps))    
  ALLOCATE(stypfrct(nx,ny,nstyps))    
  ALLOCATE(vegtyp (nx,ny))     
  ALLOCATE(lai    (nx,ny))    
  ALLOCATE(roufns (nx,ny))    
  ALLOCATE(veg    (nx,ny))    

  ALLOCATE(tsfc   (nx,ny,0:nstyps))    
  ALLOCATE(tsoil  (nx,ny,0:nstyps))    
  ALLOCATE(wetsfc (nx,ny,0:nstyps))    
  ALLOCATE(wetdp  (nx,ny,0:nstyps))    
  ALLOCATE(wetcanp(nx,ny,0:nstyps))    
  ALLOCATE(snowdpth(nx,ny))            

  ALLOCATE(raing(nx,ny))         
  ALLOCATE(rainc(nx,ny))         
  ALLOCATE(prcrate(nx,ny,4))     

  ALLOCATE(radfrc(nx,ny,nz))     
  ALLOCATE(radsw (nx,ny))        
  ALLOCATE(rnflx (nx,ny))        

  ALLOCATE(usflx (nx,ny))        
  ALLOCATE(vsflx (nx,ny))        
  ALLOCATE(ptsflx(nx,ny))        
  ALLOCATE(qvsflx(nx,ny))        
  ALLOCATE(tem1(nx,ny,nz))
  ALLOCATE(tem2(nx,ny,nz))
  ALLOCATE(tem3(nx,ny,nz))

  x      =0.0
  y      =0.0
  z      =0.0
  zp     =0.0
  hterain=0.0

  j1     =0.0
  j2     =0.0
  j3     =0.0
  uprt   =0.0
  vprt   =0.0
  wprt   =0.0
  ptprt  =0.0
  pprt   =0.0
  qvprt  =0.0
  qc     =0.0
  qr     =0.0
  qi     =0.0
  qs     =0.0
  qh     =0.0
  tke    =0.0
  kmh    =0.0
  kmv    =0.0
  ubar   =0.0
  vbar   =0.0
  wbar   =0.0
  ptbar  =0.0
  pbar   =0.0
  rhobar =0.0
  qvbar  =0.0
  u      =0.0
  v      =0.0
  w      =0.0
  qv     =0.0

  soiltyp =0.0
  stypfrct=0.0
  vegtyp =0.0
  lai    =0.0
  roufns =0.0
  veg    =0.0

  tsfc   =0.0
  tsoil  =0.0
  wetsfc =0.0
  wetdp  =0.0
  wetcanp=0.0
  snowdpth=0.0

  raing=0.0
  rainc=0.0
  prcrate=0.0

  radfrc=0.0
  radsw =0.0
  rnflx =0.0

  usflx =0.0
  vsflx =0.0
  ptsflx=0.0
  qvsflx=0.0
  tem1=0.0
  tem2=0.0
  tem3=0.0

!wdt Copyright (c) 2001 Weather Decision Technologies, Inc.: ngbrz,zbrdmp
  ngbrz = 5
  zbrdmp = 10000.0

!
!-----------------------------------------------------------------------
!
!  Set the control parameters for output:
!
!-----------------------------------------------------------------------
!
  READ (5,output,END=100)

  WRITE(6,'(/a/)') 'Output control parameters read in are:'

  WRITE(6,output)

  houtfmt = hdmpfmt

  IF( houtfmt == 0 ) THEN
    WRITE(6,'(/1x,a/)') 'Output format is 0, no data is dumped.'
    STOP
!  ELSE IF( houtfmt.eq.hinfmt ) THEN
!    write(6,'(/2(1x,a/))')
!    : 'Specified output data format was the same as the input,',
!    : 'no conversion will be done. Job stopped.'
!    STOP
  END IF

  IF ( houtfmt == 10 .AND. grbpkbit <= 0 ) THEN
    WRITE(6,'(a,a,i2/a)')                                               &
        'The bit width for packing GRIB data was invalid, ',            &
        'The old value was ', grbpkbit, 'Reset it to 16 bits'
    grbpkbit = 16
  END IF

  totout = 1

  GO TO 10

  100   WRITE(6,'(a)')                                                  &
          'Error reading NAMELIST file. Program ARPSCVT stopped.'
  STOP

  10    CONTINUE
!
!-----------------------------------------------------------------------
!
!  Get the name of the input data set.
!
!-----------------------------------------------------------------------
!
  ldirnam=LEN(dirname)
  CALL strlnth( dirname , ldirnam)

  lengbf=len_trim(grdbasfn)
  WRITE(6,'(/a,a)')' The grid/base name is ', grdbasfn(1:lengbf)

  DO nfile = 1,nhisfile

    lenfil=len_trim(hisfile(nfile))
    WRITE(6,'(/a,a,a)')                                                 &
        ' Data set ', trim(hisfile(nfile)),' to be converted.'
!
!-----------------------------------------------------------------------
!
!  Set the parameters that define the subdomain and skip points to
!  be used by svidump.
!
!-----------------------------------------------------------------------
!
!  CALL sdmpskip(2,2,1)
!  CALL sdmpdomn(1,nx-1,1,ny-1,1,nz-1)
!  CALL sdmpdomn(12,55,3,47,1,nz-1)
!
!-----------------------------------------------------------------------
!
!  Set the parameters that define the subdomain and skip points to
!  be used by dn2dump.
!
!-----------------------------------------------------------------------
!
!  CALL bdmpskip(2,2,1)
!  CALL bdmpdomn(1,nx-1,1,ny-1,1,nz-1)
!
!-----------------------------------------------------------------------
!
!  Read all input data arrays
!
!-----------------------------------------------------------------------
!

    102   CONTINUE

    CALL dtaread(nx,ny,nz,nstyps,                                       &
                 hinfmt, nchin,grdbasfn(1:lengbf),lengbf,               &
                 hisfile(nfile)(1:lenfil),lenfil,time,                  &
                 x,y,z,zp, 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, tem1, tem2, tem3)

    curtim = time

    IF ( basin == 0  ) basout  = 0
    IF ( grdin == 0  ) grdout  = 0
    IF ( varin == 0  ) varout  = 0
    IF ( mstin == 0  ) mstout  = 0
    IF ( icein == 0  ) iceout  = 0
    IF ( tkein == 0  ) tkeout  = 0
    IF ( trbin == 0  ) trbout  = 0
    IF ( rainin == 0 ) rainout = 0
    IF ( sfcin == 0  ) sfcout  = 0
    IF ( landin == 0 ) landout = 0
    IF ( prcin == 0  ) prcout  = 0
    IF ( radin == 0  ) radout  = 0
    IF ( flxin == 0  ) flxout  = 0

    IF ( sfcout == 1) THEN
      snowout = 1
    END IF

    IF ( exbcdmp == 0 .OR. mstout == 0 ) THEN
      qcexout = 0
      qrexout = 0
      qiexout = 0
      qsexout = 0
      qhexout = 0
    ELSE IF ( iceout == 0 ) THEN
      qiexout = 0
      qsexout = 0
      qhexout = 0
    END IF
!wdt Copyright (c) 2001 Weather Decision Technologies, Inc.
    IF ( exbcdmp == 4 ) rayklow = -1

    IF( hinfmt == 9 .AND. ireturn == 2 ) THEN
      WRITE(6,'(/1x,a/)') 'The end of GrADS file was reached.'
      CLOSE ( nchin )
      CALL retunit( nchin )
      CYCLE
    END IF

    IF( ireturn /= 0 ) GO TO 997             ! Read was unsuccessful

    dx = x(2) - x(1)
    dy = y(2) - y(1)

    IF ( mapproj /= 0 ) THEN
      alatnot(1) = trulat1
      alatnot(2) = trulat2

      CALL setmapr(mapproj, 1.0, alatnot, trulon)
      CALL lltoxy( 1,1, ctrlat,ctrlon, ctrx, ctry )

      swx = ctrx - (FLOAT(nx-3)/2.) * dx - x(2)
      swy = ctry - (FLOAT(ny-3)/2.) * dy - y(2)

      CALL setorig( 1, swx, swy)

      CALL setcornerll( nx,ny, x,y )       ! set corner lat/lon
    ELSE
      swlats = ctrlat
      swlons = ctrlon
      nelats = ctrlat
      nelons = ctrlon
      swlatu = ctrlat
      swlonu = ctrlon
      nelatu = ctrlat
      nelonu = ctrlon
      swlatv = ctrlat
      swlonv = ctrlon
      nelatv = ctrlat
      nelonv = ctrlon
    END IF

    ternopt = 0
    DO j=1,ny-1
      DO i=1,nx-1
        IF ( zp(i,j,2) /= zp(1,1,2) ) THEN
          ternopt = 2
          GO TO 85
        END IF
      END DO
    END DO

    85    CONTINUE

    CALL gtlfnkey( runname, lfnkey )
!
!-----------------------------------------------------------------------
!
!  Calculate total fields from that for base state and perturbations
!
!-----------------------------------------------------------------------
!
    DO k=1,nz
      DO j=1,ny
        DO i=1,nx
          u(i,j,k) = ubar(i,j,k) + uprt(i,j,k)
          v(i,j,k) = vbar(i,j,k) + vprt(i,j,k)
          w(i,j,k) = wbar(i,j,k) + wprt(i,j,k)
          qv(i,j,k) = qvbar(i,j,k) + qvprt(i,j,k)
        END DO
      END DO
    END DO
!
!-----------------------------------------------------------------------
!
!  If grid/base state data has been written out once, skip
!  the following writing block. Also no need to write out
!  separate data for Savi3D dump.
!
!  For GrADS dump, too.
!
!-----------------------------------------------------------------------
!
    IF(houtfmt == 5.OR.houtfmt == 9.OR.houtfmt == 11) GO TO 300

    IF( gboutcnt == 1 ) GO TO 300 ! If done already, skip this part.

    CALL gtbasfn(runname(1:lfnkey),dirname,ldirnam,hdmpfmt,             &
                 1,0,basoutfn,lbasoutf)

    PRINT*
    PRINT*,'Output grid/base state file is ', basoutfn(1:lbasoutf)

    grdbas = 1      ! Dump out grd and base state arrays only

!
!-----------------------------------------------------------------------
!
!  Do the data dump.
!
!-----------------------------------------------------------------------
!
    CALL dtadump(nx,ny,nz, nstyps,                                      &
                 houtfmt,nchout,basoutfn(1:lbasoutf),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)

    gboutcnt = 1

    300   CONTINUE
!
!-----------------------------------------------------------------------
!
!  Then the time dependent fields:
!
!-----------------------------------------------------------------------
!
    IF( houtfmt == 5 .AND. vroutcnt == 1 ) GO TO 130
    IF( houtfmt == 9 .AND. vroutcnt == 1 ) GO TO 130
                             ! use the same file name
!
!-----------------------------------------------------------------------
!
!  Reconstruct the file name using the specified directory name
!
!-----------------------------------------------------------------------
!
    CALL gtdmpfn(runname(1:lfnkey),dirname,                             &
                 ldirnam,curtim,hdmpfmt,                                &
                 1,0, houtfn, loutf)

    CALL fnversn(houtfn, loutf )

    130   CONTINUE

    PRINT*
    WRITE(6,'(1x,a,f8.1,a,a)')                                          &
          'Output file at time ',curtim,' (s) is ', houtfn(1:loutf)

    grdbas = 0      ! Not just dump out grd and base state arrays only

    CALL dtadump(nx,ny,nz,nstyps,                                       &
                 houtfmt,nchout,houtfn(1:loutf),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)

    vroutcnt = 1 ! Variables have been written out at least once

    IF ( hinfmt == 9 .AND. ireturn /= 2 ) GO TO 102

  END DO

  IF (houtfmt == 5) THEN

    CALL mclosescheme (gridid, ierr)
    CALL mclosedataset (dsindex, ierr)

  END IF

  IF ( houtfmt == 9 ) THEN
    CLOSE (UNIT=nchout)
  END IF

  STOP

  997   CONTINUE
  WRITE(6,'(1x,a,i2,/1x,a)')                                            &
      'Data read was unsuccessful. ireturn =', ireturn,                 &
      'Job stopped.'
  STOP

  801   FORMAT(a)

END PROGRAM ARPSCVT