/wrfv2_fire/external/io_grib2/io_grib2.F

Large files files are truncated, but you can click here to view the full file

!*-----------------------------------------------------------------------------
!*
!*  Todd Hutchinson
!*  WSI
!*  400 Minuteman Road
!*  Andover, MA     01810
!*  thutchinson@wsi.com
!*
!*  August, 2005
!*-----------------------------------------------------------------------------

!*
!* This io_grib2 API is designed to read WRF input and write WRF output data
!*   in grib version 2 format.  
!*


#include "wrf_projection.h"

module gr2_data_info

!*
!* This module will hold data internal to this I/O implementation.
!*   The variables will be accessible by all functions (provided they have a
!*   "USE gr2_data_info" line).
!*

  USE grib2tbls_types

  integer                , parameter       :: FATAL            = 1
  integer                , parameter       :: DEBUG            = 100
  integer                , parameter       :: DateStrLen       = 19
  integer                , parameter       :: maxMsgSize       = 300
  integer                , parameter       :: firstFileHandle  = 8
  integer                , parameter       :: maxFileHandles   = 200
  integer                , parameter       :: maxLevels        = 1000
  integer                , parameter       :: maxSoilLevels    = 100
  integer                , parameter       :: maxDomains       = 500
  character(200)                           :: mapfilename = 'grib2map.tbl'

  integer                , parameter       :: JIDSSIZE = 13
  integer                , parameter       :: JPDTSIZE = 15
  integer                , parameter       :: JGDTSIZE = 30

  logical                                  :: grib2map_table_filled = .FALSE.

  logical                                  :: WrfIOnotInitialized = .true.

  integer, dimension(maxDomains)           :: domains
  integer                                  :: max_domain = 0

  character*24                             :: StartDate = ''
  character*24                             :: InputProgramName = ''
  real                                     :: timestep
  integer                                  :: full_xsize, full_ysize
  REAL,          dimension(maxSoilLevels)  :: soil_depth, soil_thickness
  REAL,          dimension(maxLevels)      :: half_eta, full_eta

  integer                                  :: wrf_projection
  integer                                  :: background_proc_id
  integer                                  :: forecast_proc_id
  integer                                  :: production_status
  integer                                  :: compression
  real                                     :: center_lat, center_lon
  real                                     :: dx,dy
  real                                     :: truelat1, truelat2
  real                                     :: proj_central_lon

  TYPE :: HandleVar
     character, dimension(:), pointer      :: fileindex(:)
     integer                               :: CurrentTime
     integer                               :: NumberTimes
     integer                               :: sizeAllocated = 0
     logical                               :: write = .FALSE.
     character (DateStrLen), dimension(:),allocatable  :: Times(:)
     logical                               :: committed, opened, used
     character*128                         :: DataFile
     integer                               :: FileFd
     integer                               :: FileStatus
     integer                               :: recnum
     real                                  :: last_scalar_time_written
  ENDTYPE
  TYPE (HandleVar), dimension(maxFileHandles),SAVE :: fileinfo

  character(len=30000), dimension(maxFileHandles) :: td_output
  character(len=30000), dimension(maxFileHandles) :: ti_output
  character(len=30000), dimension(maxFileHandles) :: scalar_output
  character(len=30000), dimension(maxFileHandles) :: global_input = ''
  character(len=30000), dimension(maxFileHandles) :: scalar_input = ''

  real                                     :: last_fcst_secs
  real                                     :: fcst_secs

  logical                                  :: half_eta_init       = .FALSE.
  logical                                  :: full_eta_init       = .FALSE.
  logical                                  :: soil_thickness_init = .FALSE.
  logical                                  :: soil_depth_init     = .FALSE.

end module gr2_data_info


!*****************************************************************************

subroutine ext_gr2_ioinit(SysDepInfo,Status)

  USE gr2_data_info
  implicit none
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  CHARACTER*(*), INTENT(IN) :: SysDepInfo
  integer ,intent(out) :: Status
  integer :: i
  CHARACTER (LEN=300) :: wrf_err_message

  call wrf_debug ( DEBUG , 'Entering ext_gr2_ioinit')

  do i=firstFileHandle, maxFileHandles
        fileinfo(i)%used = .false.
        fileinfo(i)%committed = .false.
        fileinfo(i)%opened = .false.
        td_output(i) = ''
        ti_output(i) = ''
        scalar_output(i) = ''
  enddo
  domains(:) = -1
  last_fcst_secs = -1.0

  fileinfo(1:maxFileHandles)%FileStatus = WRF_FILE_NOT_OPENED
  WrfIOnotInitialized = .false.

  Status = WRF_NO_ERR

  return
end subroutine ext_gr2_ioinit

!*****************************************************************************

subroutine ext_gr2_ioexit(Status)

  USE gr2_data_info
  implicit none
#include "wrf_status_codes.h"
  integer ,intent(out) :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_ioexit')

  Status = WRF_NO_ERR

  if (grib2map_table_filled) then
     call free_grib2map()
     grib2map_table_filled = .FALSE.
  endif

  return
end subroutine ext_gr2_ioexit

!*****************************************************************************

SUBROUTINE ext_gr2_open_for_read_begin ( FileName , Comm_compute, Comm_io, &
     SysDepInfo, DataHandle , Status )

  USE gr2_data_info
  USE grib2tbls_types
  USE grib_mod
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  CHARACTER*(*) :: FileName
  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
  CHARACTER*(*) :: SysDepInfo
  INTEGER ,       INTENT(OUT) :: DataHandle
  INTEGER ,       INTENT(OUT) :: Status
  CHARACTER (LEN=maxMsgSize) :: msg

  integer :: center, subcenter, MasterTblV, &
       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl

  integer :: fields_to_skip
  integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
       JGDT(JGDTSIZE)
  logical :: UNPACK
  character*(100) :: VarName
  type(gribfield) :: gfld
  integer         :: idx
  character(len=DateStrLen) :: theTime,refTime
  integer         :: time_range_convert(13)
  integer         :: fcstsecs
  integer         :: endchar
  integer         :: ierr

  INTERFACE
     Subroutine load_grib2map (filename, message, status)
       USE grib2tbls_types
       character*(*), intent(in)                   :: filename
       character*(*), intent(inout)                :: message
       integer      , intent(out)                  :: status
     END subroutine load_grib2map
  END INTERFACE

  call wrf_debug ( DEBUG , &
       'Entering ext_gr2_open_for_read_begin, opening '//trim(FileName))

  CALL gr2_get_new_handle(DataHandle)

  !
  ! Open grib file
  !
  if (DataHandle .GT. 0) then
     
     call baopenr(DataHandle,trim(FileName),status)

     if (status .ne. 0) then
        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
     else
        fileinfo(DataHandle)%opened = .true.
        fileinfo(DataHandle)%DataFile = TRIM(FileName)
        fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
!        fileinfo(DataHandle)%CurrentTime = 1
     endif
  else
     Status = WRF_WARN_TOO_MANY_FILES
     return
  endif
 
  fileinfo(DataHandle)%recnum = -1

  !
  ! Fill up the grib2tbls structure from data in the grib2map file.
  !
  if (.NOT. grib2map_table_filled) then
     grib2map_table_filled = .TRUE.
     CALL load_grib2map(mapfilename, msg, status)
     if (status .ne. 0) then
        call wrf_message(trim(msg))
        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
        return
     endif
  endif


  !
  ! Get the parameter info for metadata
  !
  VarName = "WRF_GLOBAL"
  CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
  if (status .ne. 0) then
     write(msg,*) 'Could not find parameter for '//   &
          trim(VarName)//'   Skipping output of '//trim(VarName)
     call wrf_message(trim(msg))
     Status =  WRF_GRIB2_ERR_GRIB2MAP
     return
  endif

  !
  ! Read the metadata
  !
  fields_to_skip = 0
  
  !
  ! First, set all values to the wildcard, then reset values that we wish
  !    to specify.
  !
  call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
  
  JIDS(1) = center
  JIDS(2) = subcenter
  JIDS(3) = MasterTblV
  JIDS(4) = LocalTblV
  JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
  JIDS(13) = 1          ! Type of processed data (1 for forecast products)
  
  JPDTN = 0             ! Product definition template number
  JPDT(1) = Category
  JPDT(2) = ParmNum
  JPDT(3) = 2           ! Generating process id
  JPDT(9) = 0           ! Forecast time 

  JGDTN    = -1         ! Indicates that any Grid Display Template is a match
  
  UNPACK   = .FALSE.    ! Dont unpack bitmap and data values

  CALL GETGB2(DataHandle, DataHandle, fields_to_skip, -1, Disc, JIDS, JPDTN, &
       JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, gfld, status)
  if (status .ne. 0) then
     if (status .eq. 99) then
        write(msg,*)'Could not find metadata field named '//trim(VarName)
     else
        write(msg,*)'Retrieving grib field '//trim(VarName)//' failed, ',status
     endif
     call wrf_message(trim(msg))
     status = WRF_GRIB2_ERR_GETGB2
     return
  endif

  global_input(DataHandle) = transfer(gfld%local,global_input(DataHandle))
  global_input(DataHandle)(gfld%locallen+1:30000) = ' '

  call gf_free(gfld)

  !
  ! Read and index all scalar data
  !
  VarName = "WRF_SCALAR"
  CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
  if (status .ne. 0) then
     write(msg,*) 'Could not find parameter for '//   &
          trim(VarName)//'   Skipping reading of '//trim(VarName)
     call wrf_message(trim(msg))
     Status =  WRF_GRIB2_ERR_GRIB2MAP
     return
  endif

  !
  ! Read the metadata
  !
  ! First, set all values to wild, then specify necessary values
  !
  call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)

  JIDS(1) = center
  JIDS(2) = subcenter
  JIDS(3) = MasterTblV
  JIDS(4) = LocalTblV

  JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
  JIDS(13) = 1          ! Type of processed data (1 for forecast products)
  
  JPDTN = 0             ! Product definition template number
  JPDT(1) = Category
  JPDT(2) = ParmNum
  JPDT(3) = 2           ! Generating process id

  JGDTN    = -1         ! Indicates that any Grid Display Template is a match
  
  UNPACK   = .FALSE.    ! Dont unpack bitmap and data values

  fields_to_skip = 0
  do while (status .eq. 0) 
     CALL GETGB2(DataHandle, 0, fields_to_skip, -1, -1, JIDS, JPDTN, &
          JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, &
          gfld, status)
     if (status .eq. 99) then
        exit
     else if (status .ne. 0) then
        write(msg,*)'Finding data field '//trim(VarName)//' failed 1.'
        call wrf_message(trim(msg))
        Status = WRF_GRIB2_ERR_READ
        return
     endif
     
     ! Build times list here
     write(refTime,'(I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)')      &
          gfld%idsect(6),'-',gfld%idsect(7),'-',gfld%idsect(8),'_',&
          gfld%idsect(9),':',gfld%idsect(10),':',gfld%idsect(11)

     time_range_convert(:) = -1
     time_range_convert(1) = 60
     time_range_convert(2) = 60*60
     time_range_convert(3) = 24*60*60
     time_range_convert(10) = 3*60*60
     time_range_convert(11) = 6*60*60
     time_range_convert(12) = 12*60*60
     time_range_convert(13) = 1
     
     if (time_range_convert(gfld%ipdtmpl(8)) .gt. 0) then
        fcstsecs = gfld%ipdtmpl(9)*time_range_convert(gfld%ipdtmpl(8))
     else 
        write(msg,*)'Invalid time range in input data: ',gfld%ipdtmpl(8),&
             ' Skipping'
        call wrf_message(trim(msg))
        call gf_free(gfld)
        cycle
     endif
     call advance_wrf_time(refTime,fcstsecs,theTime)

     call gr2_add_time(DataHandle,theTime)

     fields_to_skip = fields_to_skip + fileinfo(DataHandle)%recnum

     scalar_input(DataHandle) = transfer(gfld%local,scalar_input(DataHandle))
     scalar_input(DataHandle)(gfld%locallen+1:30000) = ' '
     
     call gf_free(gfld)
  enddo

  !
  ! Fill up the eta levels variables
  !

  if (.not. full_eta_init) then
     CALL gr2_fill_levels(DataHandle, "ZNW", full_eta, ierr)
     if (ierr .eq. 0) then
        full_eta_init = .TRUE.
     endif
  endif
  if (.not. half_eta_init) then
     CALL gr2_fill_levels(DataHandle, "ZNU", half_eta, ierr)
     if (ierr .eq. 0) then 
        half_eta_init = .TRUE.
     endif
  endif
  !
  ! Fill up the soil levels
  !
  if (.not. soil_depth_init) then
     call gr2_fill_levels(DataHandle,"ZS",soil_depth, ierr)
     if (ierr .eq. 0) then
        soil_depth_init = .TRUE.
     endif
  endif
  if (.not. soil_thickness_init) then
     call gr2_fill_levels(DataHandle,"DZS",soil_thickness, ierr)
     if (ierr .eq. 0) then
        soil_thickness_init = .TRUE.
     endif
  endif

  ! 
  ! Fill up any variables from the global metadata
  !

  CALL gr2_get_metadata_value(global_input(DataHandle), &
       'START_DATE', StartDate, status)
  if (status .ne. 0) then
     write(msg,*)'Could not find metadata value for START_DATE, continuing'
     call wrf_message(trim(msg))
  endif
 
  CALL gr2_get_metadata_value(global_input(DataHandle), &
       'PROGRAM_NAME', InputProgramName, status)
  if (status .ne. 0) then
     write(msg,*)'Could not find metadata value for PROGRAM_NAME, continuing'
     call wrf_message(trim(msg))
  else
     endchar = SCAN(InputProgramName," ")
     InputProgramName = InputProgramName(1:endchar)
  endif


  Status = WRF_NO_ERR

  call wrf_debug ( DEBUG , 'Exiting ext_gr2_open_for_read_begin')

  RETURN
END SUBROUTINE ext_gr2_open_for_read_begin

!*****************************************************************************

SUBROUTINE ext_gr2_open_for_read_commit( DataHandle , Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  character(len=maxMsgSize) :: msg
  INTEGER ,       INTENT(IN ) :: DataHandle
  INTEGER ,       INTENT(OUT) :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_read_commit')

  Status = WRF_NO_ERR
  if(WrfIOnotInitialized) then
    Status = WRF_IO_NOT_INITIALIZED
    write(msg,*) 'ext_gr2_ioinit was not called ',__FILE__,', line', __LINE__
    call wrf_debug ( FATAL , msg)
    return
  endif
  fileinfo(DataHandle)%committed = .true.
  fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_FOR_READ

  Status = WRF_NO_ERR

  RETURN
END SUBROUTINE ext_gr2_open_for_read_commit

!*****************************************************************************

SUBROUTINE ext_gr2_open_for_read ( FileName , Comm_compute, Comm_io, &
     SysDepInfo, DataHandle , Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
  CHARACTER*(*) :: FileName
  INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
  CHARACTER*(*) :: SysDepInfo
  INTEGER ,       INTENT(OUT) :: DataHandle
  INTEGER ,       INTENT(OUT) :: Status


  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_read')

  DataHandle = 0   ! dummy setting to quiet warning message
  CALL ext_gr2_open_for_read_begin( FileName, Comm_compute, Comm_io, &
       SysDepInfo, DataHandle, Status )
  IF ( Status .EQ. WRF_NO_ERR ) THEN
    CALL ext_gr2_open_for_read_commit( DataHandle, Status )
  ENDIF
  return

  RETURN  
END SUBROUTINE ext_gr2_open_for_read

!*****************************************************************************

SUBROUTINE ext_gr2_open_for_write_begin(FileName, Comm, IOComm, SysDepInfo, &
     DataHandle, Status)
  
  USE gr2_data_info
  implicit none
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"

  character*(*)        ,intent(in)  :: FileName
  integer              ,intent(in)  :: Comm
  integer              ,intent(in)  :: IOComm
  character*(*)        ,intent(in)  :: SysDepInfo
  integer              ,intent(out) :: DataHandle
  integer              ,intent(out) :: Status
  integer :: ierr
  CHARACTER (LEN=maxMsgSize) :: msg

  INTERFACE
     Subroutine load_grib2map (filename, message, status)
       USE grib2tbls_types
       character*(*), intent(in)                   :: filename
       character*(*), intent(inout)                :: message
       integer      , intent(out)                  :: status
     END subroutine load_grib2map
  END INTERFACE

  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_write_begin')

  Status = WRF_NO_ERR

  if (.NOT. grib2map_table_filled) then
     grib2map_table_filled = .TRUE.
     CALL load_grib2map(mapfilename, msg, status)
     if (status .ne. 0) then
        call wrf_message(trim(msg))
        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
        return
     endif
  endif

  CALL gr2_get_new_handle(DataHandle)

  if (DataHandle .GT. 0) then

     call baopenw(DataHandle,trim(FileName),ierr)

     if (ierr .ne. 0) then
        Status = WRF_ERR_FATAL_BAD_FILE_STATUS
     else
        fileinfo(DataHandle)%opened = .true.
        fileinfo(DataHandle)%DataFile = TRIM(FileName)
        fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
     endif
     fileinfo(DataHandle)%last_scalar_time_written = -1
     fileinfo(DataHandle)%committed = .false.
     td_output(DataHandle) = ''
     ti_output(DataHandle) = ''
     scalar_output(DataHandle) = ''
     fileinfo(DataHandle)%write = .true.
  else
     Status = WRF_WARN_TOO_MANY_FILES
  endif

  RETURN  
END SUBROUTINE ext_gr2_open_for_write_begin

!*****************************************************************************

SUBROUTINE ext_gr2_open_for_write_commit( DataHandle , Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  INTEGER ,       INTENT(IN ) :: DataHandle
  INTEGER ,       INTENT(OUT) :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_write_commit')

  IF ( fileinfo(DataHandle)%opened ) THEN
    IF ( fileinfo(DataHandle)%used ) THEN
      fileinfo(DataHandle)%committed = .true.
      fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_FOR_WRITE
    ENDIF
  ENDIF

  Status = WRF_NO_ERR

  RETURN  
END SUBROUTINE ext_gr2_open_for_write_commit

!*****************************************************************************

subroutine ext_gr2_inquiry (Inquiry, Result, Status)
  use gr2_data_info
  implicit none
#include "wrf_status_codes.h"
  character *(*), INTENT(IN)    :: Inquiry
  character *(*), INTENT(OUT)   :: Result
  integer        ,INTENT(INOUT) :: Status
  SELECT CASE (Inquiry)
  CASE ("RANDOM_WRITE","RANDOM_READ")
     Result='ALLOW'
  CASE ("SEQUENTIAL_WRITE","SEQUENTIAL_READ")
     Result='NO'
  CASE ("OPEN_READ", "OPEN_WRITE", "OPEN_COMMIT_WRITE")
     Result='REQUIRE'
  CASE ("OPEN_COMMIT_READ","PARALLEL_IO")
     Result='NO'
  CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS")
     Result='YES'
  CASE ("MEDIUM")
     Result ='FILE'
  CASE DEFAULT
     Result = 'No Result for that inquiry!'
  END SELECT
  Status=WRF_NO_ERR
  return
end subroutine ext_gr2_inquiry

!*****************************************************************************

SUBROUTINE ext_gr2_inquire_opened ( DataHandle, FileName , FileStat, Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  INTEGER ,       INTENT(IN)  :: DataHandle
  CHARACTER*(*) :: FileName
  INTEGER ,       INTENT(OUT) :: FileStat
  INTEGER ,       INTENT(OUT) :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_opened')

  FileStat = WRF_NO_ERR
  if ((DataHandle .ge. firstFileHandle) .and. &
       (DataHandle .le. maxFileHandles)) then
     FileStat = fileinfo(DataHandle)%FileStatus
  else
     FileStat = WRF_FILE_NOT_OPENED
  endif
  
  Status = FileStat

  RETURN
END SUBROUTINE ext_gr2_inquire_opened

!*****************************************************************************

SUBROUTINE ext_gr2_ioclose ( DataHandle, Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  INTEGER DataHandle, Status
  INTEGER istat
  character(len=1000) :: outstring
  character :: lf
  character*(maxMsgSize) :: msg
  integer   :: idx

  lf=char(10)
  call wrf_debug ( DEBUG , 'Entering ext_gr2_ioclose')

  Status = WRF_NO_ERR

  if (fileinfo(DataHandle)%write .eqv. .TRUE.) then
     call gr2_fill_local_use(DataHandle,scalar_output(DataHandle),&
          "WRF_SCALAR",fcst_secs,msg,status)
     if (status .ne. 0) then
        call wrf_message(trim(msg))
        return
     endif
     fileinfo(DataHandle)%last_scalar_time_written = fcst_secs
     scalar_output(DataHandle) = ''
     
     call gr2_fill_local_use(DataHandle,&
          trim(ti_output(DataHandle))//trim(td_output(DataHandle)),&
          "WRF_GLOBAL",0,msg,status)
     if (status .ne. 0) then
        call wrf_message(trim(msg))
        return
     endif
     ti_output(DataHandle) = ''
     td_output(DataHandle) = ''
  endif

  do idx = 1,fileinfo(DataHandle)%NumberTimes 
     if (allocated(fileinfo(DataHandle)%Times)) then
        deallocate(fileinfo(DataHandle)%Times)
     endif
  enddo
  fileinfo(DataHandle)%NumberTimes = 0
  fileinfo(DataHandle)%sizeAllocated = 0
  fileinfo(DataHandle)%CurrentTime = 0
  fileinfo(DataHandle)%write = .FALSE.

  call baclose(DataHandle,status)
  if (status .ne. 0) then
     call wrf_message("Closing file failed, continuing")
  else
     fileinfo(DataHandle)%opened = .true.
     fileinfo(DataHandle)%DataFile = ''
     fileinfo(DataHandle)%FileStatus = WRF_FILE_NOT_OPENED
  endif

  fileinfo(DataHandle)%used = .false.

  RETURN
END SUBROUTINE ext_gr2_ioclose

!*****************************************************************************

SUBROUTINE ext_gr2_write_field( DataHandle , DateStrIn , VarName , &
     Field , FieldType , Comm , IOComm, &
     DomainDesc , MemoryOrder , Stagger , &
     DimNames , &
     DomainStart , DomainEnd , &
     MemoryStart , MemoryEnd , &
     PatchStart , PatchEnd , &
     Status )

  USE gr2_data_info
  USE grib2tbls_types
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  integer                       ,intent(in)    :: DataHandle 
  character*(*)                 ,intent(in)    :: DateStrIn
  character*(*)                 ,intent(in)    :: VarName
  integer                       ,intent(in)    :: FieldType
  integer                       ,intent(inout) :: Comm
  integer                       ,intent(inout) :: IOComm
  integer                       ,intent(in)    :: DomainDesc
  character*(*)                 ,intent(in)    :: MemoryOrder
  character*(*)                 ,intent(in)    :: Stagger
  character*(*) , dimension (*) ,intent(in)    :: DimNames
  integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
  integer                       ,intent(out)   :: Status

  real                          , intent(in), &
       dimension( 1:1,MemoryStart(1):MemoryEnd(1), &
       MemoryStart(2):MemoryEnd(2), &
       MemoryStart(3):MemoryEnd(3) )           :: Field


  character (120)                              :: DateStr

  character (maxMsgSize)                       :: msg
  integer                                      :: xsize, ysize, zsize
  integer                                      :: x, y, z
  integer                                      :: &
       x_start,x_end,y_start,y_end,z_start,z_end
  integer                                      :: idx
  integer                                      :: proj_center_flag
  logical                                      :: vert_stag = .false.
  real,    dimension(:,:), pointer             :: data
  integer                                      :: istat
  integer                                      :: accum_period
  integer, dimension(maxLevels)                :: level1, level2
  integer, dimension(maxLevels)                :: grib_levels
  logical                                      :: soil_layers, fraction
  integer                                      :: vert_unit1, vert_unit2
  integer                                      :: vert_sclFctr1, vert_sclFctr2
  integer                                      :: this_domain
  logical                                      :: new_domain
  real                                         :: &
       region_center_lat, region_center_lon
  integer                                      :: dom_xsize, dom_ysize;
  integer , parameter                          :: lcgrib = 2000000
  character (lcgrib)                           :: cgrib
  integer                                      :: ierr
  integer                                      :: lengrib

  integer                                     :: center, subcenter, &
       MasterTblV, LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
  CHARACTER(len=100)  :: tmpstr
  integer             :: ndims
  integer             :: dim1size, dim2size, dim3size, dim3
  integer             :: numlevels
  integer             :: ngrdpts
  integer             :: bytes_written
  
  call wrf_debug ( DEBUG , 'Entering ext_gr2_write_field for parameter '//&
       VarName)

  !
  ! If DateStr is all 0s, we reset it to StartDate.  For some reason, 
  !   in idealized simulations, StartDate is 0001-01-01_00:00:00 while
  !   the first DateStr is 0000-00-00_00:00:00.  
  !
  if (DateStrIn .eq. '0000-00-00_00:00:00') then
     DateStr = TRIM(StartDate)
  else
     DateStr = DateStrIn
  endif

  !
  ! Check if this is a domain that we haven t seen yet.  If so, add it to 
  !   the list of domains.
  !
  this_domain = 0
  new_domain = .false.
  do idx = 1, max_domain
     if (DomainDesc .eq. domains(idx)) then
        this_domain = idx
     endif
  enddo
  if (this_domain .eq. 0) then
     max_domain = max_domain + 1
     domains(max_domain) = DomainDesc
     this_domain = max_domain
     new_domain = .true.
  endif

  zsize = 1
  xsize = 1
  ysize = 1
  soil_layers = .false.
  fraction = .false.

  ! First, handle then special cases for the boundary data.

  CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndims, x_start, x_end, &
       y_start, y_end,z_start,z_end)
  xsize = x_end - x_start + 1
  ysize = y_end - y_start + 1
  zsize = z_end - z_start + 1

  do idx = 1, len(MemoryOrder)
     if ((MemoryOrder(idx:idx) .eq. 'Z') .and. &
          (DimNames(idx) .eq. 'soil_layers_stag')) then
        soil_layers = .true.
     else if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCBOT') .or. &
          (VarName .eq. 'SOILCTOP')) then
        fraction = .true.
     endif
  enddo

  if (zsize .eq. 0) then 
     zsize = 1
  endif

  !
  ! Fill up the variables that hold the vertical coordinate data
  !

  if (VarName .eq. 'ZNU') then
     do idx = 1, zsize
        half_eta(idx) = Field(1,idx,1,1)
     enddo
     half_eta_init = .TRUE.
  endif

  if (VarName .eq. 'ZNW') then
     do idx = 1, zsize
        full_eta(idx) = Field(1,idx,1,1)
     enddo
     full_eta_init = .TRUE.
  endif
  
  if (VarName .eq. 'ZS') then
     do idx = 1, zsize
        soil_depth(idx) = Field(1,idx,1,1)
     enddo
     soil_depth_init = .TRUE.
  endif

  if (VarName .eq. 'DZS') then
     do idx = 1, zsize
        soil_thickness(idx) = Field(1,idx,1,1)
     enddo
     soil_thickness_init = .TRUE.
  endif

  ! 
  ! Check to assure that dimensions are valid
  !

  if ((xsize .lt. 1) .or. (ysize .lt. 1) .or. (zsize .lt. 1)) then
     write(msg,*) 'Cannot output field with memory order: ', &
          MemoryOrder,Varname
     call wrf_message(trim(msg))
     return
  endif
     

  if (fileinfo(DataHandle)%opened .and. fileinfo(DataHandle)%committed) then

     if (StartDate == '') then
        StartDate = DateStr
     endif
     
     CALL geth_idts(DateStr,StartDate,fcst_secs)

     !
     ! If this is a new forecast time, and we have not written the 
     !   last_fcst_secs scalar output yet, then write it here.
     !

     if ((abs(fcst_secs - 0.0) .gt. 0.01) .and. &
          (last_fcst_secs .ge. 0) .and. &
          (abs(fcst_secs - last_fcst_secs) .gt. 0.01) .and. &
          (abs(last_fcst_secs - fileinfo(DataHandle)%last_scalar_time_written) .gt. 0.01) ) then
        call gr2_fill_local_use(DataHandle,scalar_output(DataHandle),&
             "WRF_SCALAR",last_fcst_secs,msg,status)
        if (status .ne. 0) then
           call wrf_message(trim(msg))
           return
        endif
        fileinfo(DataHandle)%last_scalar_time_written = last_fcst_secs
        scalar_output(DataHandle) = ''
     endif

     call get_vert_stag(VarName,Stagger,vert_stag)
     
     do idx = 1, zsize
        call gr2_get_levels(VarName, idx, zsize, soil_layers, vert_stag, &
             fraction, vert_unit1, vert_unit2, vert_sclFctr1, &
             vert_sclFctr2, level1(idx), level2(idx))
     enddo
     
     ! 
     ! Get the center lat/lon for the area being output.  For some cases (such
     !    as for boundary areas, the center of the area is different from the
     !    center of the model grid.
     !
     if (index(Stagger,'X') .le. 0) then
        dom_xsize = full_xsize - 1
     else
        dom_xsize = full_xsize
     endif
     if (index(Stagger,'Y') .le. 0) then
        dom_ysize = full_ysize - 1
     else
        dom_ysize = full_ysize
     endif
     

     CALL get_region_center(MemoryOrder, wrf_projection, center_lat, &
          center_lon, dom_xsize, dom_ysize, dx, dy, proj_central_lon, &
          proj_center_flag, truelat1, truelat2, xsize, ysize, &
          region_center_lat, region_center_lon)
     

     if (ndims .eq. 0) then        ! Scalar quantity

        ALLOCATE(data(1:1,1:1), STAT=istat)

        call gr2_retrieve_data(MemoryOrder, MemoryStart, MemoryEnd, &
             xsize, ysize, zsize, z, FieldType, Field, data)
        write(tmpstr,'(G17.10)')data(1,1)
        CALL gr2_build_string (scalar_output(DataHandle), &
             trim(adjustl(VarName)), tmpstr, 1, Status)

        DEALLOCATE(data)

     else if (ndims .ge. 1) then   ! Vector (1-D) and 2/3 D quantities

        if (ndims .eq. 1) then     ! Handle Vector (1-D) parameters
           dim1size = zsize
           dim2size = 1
           dim3size = 1
        else                       ! Handle 2/3 D parameters
           dim1size = xsize
           dim2size = ysize
           dim3size = zsize
        endif
        
        ALLOCATE(data(1:dim1size,1:dim2size), STAT=istat)

        CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
             LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
        if (status .ne. 0) then
           write(msg,*) 'Could not find parameter for '//   &
                trim(VarName)//'   Skipping output of '//trim(VarName)
           call wrf_message(trim(msg))
           Status =  WRF_GRIB2_ERR_GRIB2MAP
           return
        endif

        VERTDIM : do dim3 = 1, dim3size

           call gr2_retrieve_data(MemoryOrder, MemoryStart, MemoryEnd, xsize, &
                ysize, zsize, dim3, FieldType, Field, data)
        
           ! 
           ! Here, we do any necessary conversions to the data.
           !
           
           ! Potential temperature is sometimes passed in as perturbation 
           !   potential temperature (i.e., POT-300).  Other times (i.e., from 
           !   WRF SI), it is passed in as full potential temperature.
           ! Here, we convert to full potential temperature by adding 300
           !   only if POT < 200 K.
           !
           if (VarName == 'T') then
              if ((data(1,1) < 200) .and. (data(1,1) .ne. 0)) then
                 data = data + 300
              endif
           endif
           
           ! 
           ! For precip, we setup the accumulation period, and output a precip
           !    rate for time-step precip.
           !
           if ((VarName .eq. 'RAINCV') .or. (VarName .eq. 'RAINNCV')) then
              ! Convert time-step precip to precip rate.
              data = data/timestep
              accum_period = 0
           else
              accum_period = 0
           endif
           
           !
           ! Create indicator and identification sections (sections 0 and 1)
           !
           CALL gr2_create_w(StartDate, cgrib, lcgrib, production_status, &
                Disc, center, subcenter, MasterTblV, LocalTblV, ierr, msg)
           if (ierr .ne. 0) then
              call wrf_message(trim(msg))
              Status = WRF_GRIB2_ERR_GRIBCREATE
              return
           endif

           !
           ! Add the grid definition section (section 3) using a 1x1 grid
           !
           call gr2_addgrid_w(cgrib, lcgrib, center_lat, proj_central_lon,  &
                wrf_projection, truelat1, truelat2, xsize, ysize, dx, dy, &
                region_center_lat, region_center_lon, ierr, msg)
           if (ierr .ne. 0) then
              call wrf_message(trim(msg))
              Status = WRF_GRIB2_ERR_ADDGRIB
              return
           endif

           if (ndims .eq. 1) then
              numlevels = zsize
              grib_levels(:) = level1(:)
              ngrdpts = zsize
           else
              numlevels = 2
              grib_levels(1) = level1(dim3)
              grib_levels(2) = level2(dim3)
              ngrdpts = xsize*ysize
           endif
           
           !
           ! Add the Product Definition, Data representation, bitmap 
           !      and data sections (sections 4-7)
           !
           
           call gr2_addfield_w(cgrib, lcgrib, VarName, Category, ParmNum, &
                DecScl, BinScl, fcst_secs, vert_unit1, vert_unit2, &
                vert_sclFctr1, vert_sclFctr2, numlevels, &
                grib_levels, ngrdpts,  background_proc_id, forecast_proc_id, &
                compression, data, ierr, msg)
           if (ierr .eq. 11) then
              write(msg,'(A,I7,A)') 'WARNING: decimal scale for field '//&
                   trim(VarName)//' at level ',grib_levels(1),&
                   ' was reduced to fit field into 24 bits.  '//&
                   ' Some precision may be lost!'//&
                   '     To prevent this message, reduce decimal scale '//&
                   'factor in '//trim(mapfilename)
              call wrf_message(trim(msg))
           else if (ierr .eq. 12) then
              write(msg,'(A,I7,A)') 'WARNING: binary scale for field '//&
                   trim(VarName)//' at level ',grib_levels(1), &
                   ' was reduced to fit field into 24 bits.  '//&
                   ' Some precision may be lost!'//&
                   '     To prevent this message, reduce binary scale '//&
                   'factor in '//trim(mapfilename)
              call wrf_message(trim(msg))
           else if (ierr .ne. 0) then
              call wrf_message(trim(msg))
              Status = WRF_GRIB2_ERR_ADDFIELD
              return
           endif

           !
           ! Close out the message
           !
           
           call gribend(cgrib,lcgrib,lengrib,ierr)
           if (ierr .ne. 0) then
              write(msg,*) 'gribend failed with ierr: ',ierr     
              call wrf_message(trim(msg))
              Status = WRF_GRIB2_ERR_GRIBEND
              return
           endif

           ! 
           ! Write the data to the file
           !
           
!           call write_file_n(fileinfo(DataHandle)%FileFd, cgrib, lengrib, ierr)
           call bawrite(DataHandle, -1, lengrib, bytes_written, cgrib)
           if (bytes_written .ne. lengrib) then
              write(msg,*) '1 Error writing cgrib to file, wrote: ', &
                   bytes_written, ' bytes.  Tried to write ', lengrib, ' bytes'
              call wrf_message(trim(msg))
              Status = WRF_GRIB2_ERR_WRITE
              return
           endif

        ENDDO VERTDIM
        
        DEALLOCATE(data)

     endif

     last_fcst_secs = fcst_secs

  endif

  deallocate(data, STAT = istat)

  Status = WRF_NO_ERR

  call wrf_debug ( DEBUG , 'Leaving ext_gr2_write_field')

  RETURN
END SUBROUTINE ext_gr2_write_field

!*****************************************************************************

SUBROUTINE ext_gr2_read_field ( DataHandle , DateStr , VarName , Field , &
     FieldType , Comm , IOComm, DomainDesc , MemoryOrder , Stagger ,     &
     DimNames , DomainStart , DomainEnd , MemoryStart , MemoryEnd ,      &
     PatchStart , PatchEnd ,  Status )

  USE gr2_data_info
  USE grib_mod
  IMPLICIT NONE  
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  INTEGER                       ,intent(in)       :: DataHandle 
  CHARACTER*(*)                 ,intent(in)       :: DateStr
  CHARACTER*(*)                 ,intent(in)       :: VarName
  integer                       ,intent(inout)    :: FieldType
  integer                       ,intent(inout)    :: Comm
  integer                       ,intent(inout)    :: IOComm
  integer                       ,intent(inout)    :: DomainDesc
  character*(*)                 ,intent(inout)    :: MemoryOrder
  character*(*)                 ,intent(inout)    :: Stagger
  character*(*) , dimension (*) ,intent(inout)    :: DimNames
  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
  integer                       ,intent(out)      :: Status
  INTEGER                       ,intent(out)      :: Field(*)
  integer                       :: xsize,ysize,zsize
  integer                       :: x_start,x_end,y_start,y_end,z_start,z_end
  integer                       :: ndims
  character (len=1000)          :: Value
  character (maxMsgSize)        :: msg
  integer                       :: ierr
  real                          :: Data
  integer                       :: center, subcenter, MasterTblV, &
       LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
  integer                       :: dim1size,dim2size,dim3size,dim3

  integer :: idx
  integer :: fields_to_skip
  integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
       JGDT(JGDTSIZE)
  logical :: UNPACK
  type(gribfield) :: gfld
  logical                                      :: soil_layers, fraction
  logical                                      :: vert_stag = .false.
  integer                                      :: vert_unit1, vert_unit2
  integer                                      :: vert_sclFctr1, vert_sclFctr2
  integer                                      :: level1, level2
  integer                                      :: di
  real                                         :: tmpreal

  call wrf_debug ( DEBUG , 'Entering ext_gr2_read_field'//fileinfo(DataHandle)%DataFile)
  
  CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndims, x_start, x_end, &
       y_start, y_end,z_start,z_end)
  xsize = x_end - x_start + 1
  ysize = y_end - y_start + 1
  zsize = z_end - z_start + 1

  ! 
  ! Check to assure that dimensions are valid
  !

  if ((xsize .lt. 1) .or. (ysize .lt. 1) .or. (zsize .lt. 1)) then
     write(msg,*) 'Cannot retrieve field with memory order: ', &
          MemoryOrder,Varname
     Status = WRF_GRIB2_ERR_READ
     call wrf_message(trim(msg))
     return
  endif
     

  if (ndims .eq. 0) then    ! Scalar quantity

     call gr2_get_metadata_value(scalar_input(DataHandle),trim(VarName),&
          Value,ierr)
     if (ierr /= 0) then
        Status = WRF_GRIB2_ERR_READ
        CALL wrf_message ( &
             "gr2_get_metadata_value failed for Scalar variable "//&
             trim(VarName))
        return
     endif

     READ(Value,*,IOSTAT=ierr)Data
     if (ierr .ne. 0) then
        CALL wrf_message("Reading data from "//trim(VarName)//" failed")
        Status = WRF_GRIB2_ERR_READ
        return
     endif

     if (FieldType .eq. WRF_INTEGER) then
        Field(1:1) = data
     else if ((FieldType .eq. WRF_REAL) .or. (FieldType .eq. WRF_DOUBLE)) then
        Field(1:1) = TRANSFER(data,Field(1),1)
     else
        write (msg,*)'Reading of type ',FieldType,'from grib data not supported, not reading ',VarName
        call wrf_message(msg)
     endif

  else if (ndims .ge. 1) then   ! Vector (1-D) and 2/3 D quantities
     
     if (ndims .eq. 1) then     ! Handle Vector (1-D) parameters
        dim1size = zsize
        dim2size = 1
        dim3size = 1
     else                       ! Handle 2/3 D parameters
        dim1size = xsize
        dim2size = ysize
        dim3size = zsize
     endif
     
     CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
          LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
     if (status .ne. 0) then
        write(msg,*) 'Could not find parameter for '//   &
             trim(VarName)//'   Skipping output of '//trim(VarName)
        call wrf_message(trim(msg))
        Status =  WRF_GRIB2_ERR_GRIB2MAP
        return
     endif
     
     CALL get_vert_stag(VarName,Stagger,vert_stag)
     CALL get_soil_layers(VarName,soil_layers)

     VERTDIM : do dim3 = 1, dim3size

        fields_to_skip = 0

        !
        ! First, set all values to wild, then specify necessary values
        !
        call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)

        JIDS(1) = center
        JIDS(2) = subcenter
        JIDS(3) = MasterTblV
        JIDS(4) = LocalTblV
        JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
        
        READ (StartDate,'(I4.4,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2)') &
             (JIDS(idx),idx=6,11)
        JIDS(13) = 1          ! Type of processed data(1 for forecast products)
        
        JPDT(1) = Category
        JPDT(2) = ParmNum
        JPDT(3) = 2           ! Generating process id

        CALL geth_idts(DateStr,StartDate,tmpreal)  ! Forecast time 
        
        JPDT(9) = NINT(tmpreal)

        if (ndims .eq. 1) then
           jpdtn = 1000       ! Product definition tmplate (1000 for cross-sxn)
        else
           call gr2_get_levels(VarName, dim3, dim3size, soil_layers, &
                vert_stag, .false., vert_unit1, vert_unit2, vert_sclFctr1, &
                vert_sclFctr2, level1, level2)
           
           jpdtn = 0          ! Product definition template (0 for horiz grid)
           JPDT(10) = vert_unit1     ! Type of first surface
           JPDT(11) = vert_sclFctr1  ! Scale factor first surface
           JPDT(12) = level1         ! First surface
           JPDT(13) = vert_unit2     ! Type of second surface
           JPDT(14) = vert_sclFctr2  ! Scale factor second surface
           JPDT(15) = level2         ! Second fixed surface
        endif

        JGDTN    = -1    ! Indicates that any Grid Display Template is a match
        
        UNPACK   = .TRUE.! Unpack bitmap and data values
        
        fields_to_skip = 0
        CALL GETGB2(DataHandle, 0, fields_to_skip, &
             fileinfo(DataHandle)%recnum+1, &
             Disc, JIDS, JPDTN, JPDT, JGDTN, JGDT, UNPACK, &
             fileinfo(DataHandle)%recnum, gfld, status)
        if (status .eq. 99) then
           write(msg,*)'Could not find data for field '//trim(VarName)//&
                ' in file '//trim(fileinfo(DataHandle)%DataFile)
           call wrf_message(trim(msg))
           Status = WRF_GRIB2_ERR_READ
           return
        else if (status .ne. 0) then
           write(msg,*)'Retrieving data field '//trim(VarName)//' failed 2.',status,dim3,DataHandle
           call wrf_message(trim(msg))
           Status = WRF_GRIB2_ERR_READ
           return
        endif

        if(FieldType == WRF_DOUBLE) then
           di = 2
        else 
           di = 1
        endif

        ! 
        ! Here, we do any necessary conversions to the data.
        !
        ! The WRF executable (wrf.exe) expects perturbation potential
        !   temperature.  However, real.exe expects full potential T.
        ! So, if the program is WRF, subtract 300 from Potential Temperature 
        !   to get perturbation potential temperature.
        !
        if (VarName == 'T') then
           if ( &
                (InputProgramName .eq. 'REAL_EM') .or. &
                (InputProgramName .eq. 'IDEAL') .or. &
                (InputProgramName .eq. 'NDOWN_EM')) then
              gfld%fld = gfld%fld - 300
           endif
        endif


        if (ndims .eq. 1) then
           CALL Transpose1D_grib(MemoryOrder, di, FieldType, Field, &
                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
                MemoryStart(3), MemoryEnd(3), &
                gfld%fld, zsize)
        else
           CALL Transpose_grib(MemoryOrder, di, FieldType, Field, &
                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
                MemoryStart(3), MemoryEnd(3), &
                gfld%fld, dim3, ysize,xsize)
        endif

        call gf_free(gfld)
        
     enddo VERTDIM
  endif

  Status = WRF_NO_ERR


  call wrf_debug ( DEBUG , 'Leaving ext_gr2_read_field')

  RETURN
END SUBROUTINE ext_gr2_read_field

!*****************************************************************************

SUBROUTINE ext_gr2_get_next_var ( DataHandle, VarName, Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
  INTEGER ,       INTENT(IN)  :: DataHandle
  CHARACTER*(*) :: VarName
  INTEGER ,       INTENT(OUT) :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_var')

  Status = WRF_WARN_NOOP

  RETURN
END SUBROUTINE ext_gr2_get_next_var

!*****************************************************************************

subroutine ext_gr2_end_of_frame(DataHandle, Status)

  USE gr2_data_info
  implicit none
#include "wrf_status_codes.h"
  integer               ,intent(in)     :: DataHandle
  integer               ,intent(out)    :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_end_of_frame')

  Status = WRF_WARN_NOOP

  return
end subroutine ext_gr2_end_of_frame

!*****************************************************************************

SUBROUTINE ext_gr2_iosync ( DataHandle, Status )

  USE gr2_data_info  
  IMPLICIT NONE
#include "wrf_status_codes.h"
  INTEGER ,       INTENT(IN)  :: DataHandle
  INTEGER ,       INTENT(OUT) :: Status
  integer                     :: ierror

  call wrf_debug ( DEBUG , 'Entering ext_gr2_iosync')

  Status = WRF_NO_ERR
  if (DataHandle .GT. 0) then
     CALL flush_file(fileinfo(DataHandle)%FileFd)
  else
     Status = WRF_WARN_TOO_MANY_FILES
  endif

  RETURN
END SUBROUTINE ext_gr2_iosync

!*****************************************************************************

SUBROUTINE ext_gr2_inquire_filename ( DataHandle, FileName , FileStat, &
     Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
#include "wrf_io_flags.h"
  INTEGER ,       INTENT(IN)  :: DataHandle
  CHARACTER*(*) :: FileName
  INTEGER ,       INTENT(OUT) :: FileStat
  INTEGER ,       INTENT(OUT) :: Status
  CHARACTER *80   SysDepInfo

  call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_filename')

  FileName = fileinfo(DataHandle)%DataFile 

  if ((DataHandle .ge. firstFileHandle) .and. &
       (DataHandle .le. maxFileHandles)) then
     FileStat = fileinfo(DataHandle)%FileStatus
  else
     FileStat = WRF_FILE_NOT_OPENED
  endif
  Status = WRF_NO_ERR

  RETURN
END SUBROUTINE ext_gr2_inquire_filename

!*****************************************************************************

SUBROUTINE ext_gr2_get_var_info ( DataHandle , VarName , NDim , &
     MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
  integer               ,intent(in)     :: DataHandle
  character*(*)         ,intent(in)     :: VarName
  integer               ,intent(out)    :: NDim
  character*(*)         ,intent(out)    :: MemoryOrder
  character*(*)         ,intent(out)    :: Stagger
  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
  integer               ,intent(out)    :: WrfType
  integer               ,intent(out)    :: Status

  call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_info')

  MemoryOrder = ""
  Stagger = ""
  DomainStart(1) = 0
  DomainEnd(1) = 0
  WrfType = 0
  NDim = 0

  CALL wrf_message('ext_gr2_get_var_info not supported for grib version2 data')
  Status = WRF_NO_ERR

  RETURN
END SUBROUTINE ext_gr2_get_var_info

!*****************************************************************************

SUBROUTINE ext_gr2_set_time ( DataHandle, DateStr, Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
  INTEGER ,       INTENT(IN)  :: DataHandle
  CHARACTER*(*) :: DateStr
  INTEGER ,       INTENT(OUT) :: Status
  integer       :: found_time
  integer       :: idx

  call wrf_debug ( DEBUG , 'Entering ext_gr2_set_time')

  found_time = 0
  do idx = 1,fileinfo(DataHandle)%NumberTimes
     if (fileinfo(DataHandle)%Times(idx) == DateStr) then
        found_time = 1
        fileinfo(DataHandle)%CurrentTime = idx
     endif
  enddo
  if (found_time == 0) then 
     Status = WRF_WARN_TIME_NF
  else
     Status = WRF_NO_ERR
  endif

  RETURN
END SUBROUTINE ext_gr2_set_time

!*****************************************************************************

SUBROUTINE ext_gr2_get_next_time ( DataHandle, DateStr, Status )

  USE gr2_data_info
  IMPLICIT NONE
#include "wrf_status_codes.h"
  INTEGER ,       INTENT(IN)  :: DataHandle
  CHARACTER*(*) , INTENT(OUT) :: DateStr
  INTEGER ,       INTE…