external/io_grib2/io_grib2.F

   1 !*-----------------------------------------------------------------------------
   2 !*
   3 !*  Todd Hutchinson
   4 !*  WSI
   5 !*  400 Minuteman Road
   6 !*  Andover, MA     01810
   7 !*  thutchinson@wsi.com
   8 !*
   9 !*  August, 2005
  10 !*-----------------------------------------------------------------------------
  11
  12 !*
  13 !* This io_grib2 API is designed to read WRF input and write WRF output data
  14 !*   in grib version 2 format.
  15 !*
  16
  17
  18 #include "wrf_projection.h"
  19
  20 module gr2_data_info
  21
  22 !*
  23 !* This module will hold data internal to this I/O implementation.
  24 !*   The variables will be accessible by all functions (provided they have a
  25 !*   "USE gr2_data_info" line).
  26 !*
  27
  28   USE grib2tbls_types
  29
  30   integer                , parameter       :: FATAL            = 1
  31   integer                , parameter       :: DEBUG            = 100
  32   integer                , parameter       :: DateStrLen       = 19
  33   integer                , parameter       :: maxMsgSize       = 300
  34   integer                , parameter       :: firstFileHandle  = 8
  35   integer                , parameter       :: maxFileHandles   = 200
  36   integer                , parameter       :: maxLevels        = 1000
  37   integer                , parameter       :: maxSoilLevels    = 100
  38   integer                , parameter       :: maxDomains       = 500
  39   character(200)                           :: mapfilename = 'grib2map.tbl'
  40
  41   integer                , parameter       :: JIDSSIZE = 13
  42   integer                , parameter       :: JPDTSIZE = 15
  43   integer                , parameter       :: JGDTSIZE = 30
  44
  45   logical                                  :: grib2map_table_filled = .FALSE.
  46
  47   logical                                  :: WrfIOnotInitialized = .true.
  48
  49   integer, dimension(maxDomains)           :: domains
  50   integer                                  :: max_domain = 0
  51
  52   character*24                             :: StartDate = ''
  53   character*24                             :: InputProgramName = ''
  54   real                                     :: timestep
  55   integer                                  :: full_xsize, full_ysize
  56   REAL,          dimension(maxSoilLevels)  :: soil_depth, soil_thickness
  57   REAL,          dimension(maxLevels)      :: half_eta, full_eta
  58
  59   integer                                  :: wrf_projection
  60   integer                                  :: background_proc_id
  61   integer                                  :: forecast_proc_id
  62   integer                                  :: production_status
  63   integer                                  :: compression
  64   real                                     :: center_lat, center_lon
  65   real                                     :: dx,dy
  66   real                                     :: truelat1, truelat2
  67   real                                     :: proj_central_lon
  68
  69   TYPE :: HandleVar
  70      character, dimension(:), pointer      :: fileindex(:)
  71      integer                               :: CurrentTime
  72      integer                               :: NumberTimes
  73      integer                               :: sizeAllocated = 0
  74      logical                               :: write = .FALSE.
  75      character (DateStrLen), dimension(:),allocatable  :: Times(:)
  76      logical                               :: committed, opened, used
  77      character*128                         :: DataFile
  78      integer                               :: FileFd
  79      integer                               :: FileStatus
  80      integer                               :: recnum
  81      real                                  :: last_scalar_time_written
  82   ENDTYPE
  83   TYPE (HandleVar), dimension(maxFileHandles),SAVE :: fileinfo
  84
  85   character(len=30000), dimension(maxFileHandles) :: td_output
  86   character(len=30000), dimension(maxFileHandles) :: ti_output
  87   character(len=30000), dimension(maxFileHandles) :: scalar_output
  88   character(len=30000), dimension(maxFileHandles) :: global_input = ''
  89   character(len=30000), dimension(maxFileHandles) :: scalar_input = ''
  90
  91   real                                     :: last_fcst_secs
  92   real                                     :: fcst_secs
  93
  94   logical                                  :: half_eta_init       = .FALSE.
  95   logical                                  :: full_eta_init       = .FALSE.
  96   logical                                  :: soil_thickness_init = .FALSE.
  97   logical                                  :: soil_depth_init     = .FALSE.
  98
  99 end module gr2_data_info
 100
 101
 102 !*****************************************************************************
 103
 104 subroutine ext_gr2_ioinit(SysDepInfo,Status)
 105
 106   USE gr2_data_info
 107   implicit none
 108 #include "wrf_status_codes.h"
 109 #include "wrf_io_flags.h"
 110   CHARACTER*(*), INTENT(IN) :: SysDepInfo
 111   integer ,intent(out) :: Status
 112   integer :: i
 113   CHARACTER (LEN=300) :: wrf_err_message
 114
 115   call wrf_debug ( DEBUG , 'Entering ext_gr2_ioinit')
 116
 117   do i=firstFileHandle, maxFileHandles
 118         fileinfo(i)%used = .false.
 119         fileinfo(i)%committed = .false.
 120         fileinfo(i)%opened = .false.
 121         td_output(i) = ''
 122         ti_output(i) = ''
 123         scalar_output(i) = ''
 124   enddo
 125   domains(:) = -1
 126   last_fcst_secs = -1.0
 127
 128   fileinfo(1:maxFileHandles)%FileStatus = WRF_FILE_NOT_OPENED
 129   WrfIOnotInitialized = .false.
 130
 131   Status = WRF_NO_ERR
 132
 133   return
 134 end subroutine ext_gr2_ioinit
 135
 136 !*****************************************************************************
 137
 138 subroutine ext_gr2_ioexit(Status)
 139
 140   USE gr2_data_info
 141   implicit none
 142 #include "wrf_status_codes.h"
 143   integer ,intent(out) :: Status
 144
 145   call wrf_debug ( DEBUG , 'Entering ext_gr2_ioexit')
 146
 147   Status = WRF_NO_ERR
 148
 149   if (grib2map_table_filled) then
 150      call free_grib2map()
 151      grib2map_table_filled = .FALSE.
 152   endif
 153
 154   return
 155 end subroutine ext_gr2_ioexit
 156
 157 !*****************************************************************************
 158
 159 SUBROUTINE ext_gr2_open_for_read_begin ( FileName , Comm_compute, Comm_io, &
 160      SysDepInfo, DataHandle , Status )
 161
 162   USE gr2_data_info
 163   USE grib2tbls_types
 164   USE grib_mod
 165   IMPLICIT NONE
 166 #include "wrf_status_codes.h"
 167 #include "wrf_io_flags.h"
 168   CHARACTER*(*) :: FileName
 169   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
 170   CHARACTER*(*) :: SysDepInfo
 171   INTEGER ,       INTENT(OUT) :: DataHandle
 172   INTEGER ,       INTENT(OUT) :: Status
 173   CHARACTER (LEN=maxMsgSize) :: msg
 174
 175   integer :: center, subcenter, MasterTblV, &
 176        LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
 177
 178   integer :: fields_to_skip
 179   integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
 180        JGDT(JGDTSIZE)
 181   logical :: UNPACK
 182   character*(100) :: VarName
 183   type(gribfield) :: gfld
 184   integer         :: idx
 185   character(len=DateStrLen) :: theTime,refTime
 186   integer         :: time_range_convert(13)
 187   integer         :: fcstsecs
 188   integer         :: endchar
 189   integer         :: ierr
 190
 191   INTERFACE
 192      Subroutine load_grib2map (filename, message, status)
 193        USE grib2tbls_types
 194        character*(*), intent(in)                   :: filename
 195        character*(*), intent(inout)                :: message
 196        integer      , intent(out)                  :: status
 197      END subroutine load_grib2map
 198   END INTERFACE
 199
 200   call wrf_debug ( DEBUG , &
 201        'Entering ext_gr2_open_for_read_begin, opening '//trim(FileName))
 202
 203   CALL gr2_get_new_handle(DataHandle)
 204
 205   !
 206   ! Open grib file
 207   !
 208   if (DataHandle .GT. 0) then
 209
 210      call baopenr(DataHandle,trim(FileName),status)
 211
 212      if (status .ne. 0) then
 213         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 214      else
 215         fileinfo(DataHandle)%opened = .true.
 216         fileinfo(DataHandle)%DataFile = TRIM(FileName)
 217         fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
 218 !        fileinfo(DataHandle)%CurrentTime = 1
 219      endif
 220   else
 221      Status = WRF_WARN_TOO_MANY_FILES
 222      return
 223   endif
 224
 225   fileinfo(DataHandle)%recnum = -1
 226
 227   !
 228   ! Fill up the grib2tbls structure from data in the grib2map file.
 229   !
 230   if (.NOT. grib2map_table_filled) then
 231      grib2map_table_filled = .TRUE.
 232      CALL load_grib2map(mapfilename, msg, status)
 233      if (status .ne. 0) then
 234         call wrf_message(trim(msg))
 235         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 236         return
 237      endif
 238   endif
 239
 240
 241   !
 242   ! Get the parameter info for metadata
 243   !
 244   VarName = "WRF_GLOBAL"
 245   CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
 246        LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
 247   if (status .ne. 0) then
 248      write(msg,*) 'Could not find parameter for '//   &
 249           trim(VarName)//'   Skipping output of '//trim(VarName)
 250      call wrf_message(trim(msg))
 251      Status =  WRF_GRIB2_ERR_GRIB2MAP
 252      return
 253   endif
 254
 255   !
 256   ! Read the metadata
 257   !
 258   fields_to_skip = 0
 259
 260   !
 261   ! First, set all values to the wildcard, then reset values that we wish
 262   !    to specify.
 263   !
 264   call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
 265
 266   JIDS(1) = center
 267   JIDS(2) = subcenter
 268   JIDS(3) = MasterTblV
 269   JIDS(4) = LocalTblV
 270   JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
 271   JIDS(13) = 1          ! Type of processed data (1 for forecast products)
 272
 273   JPDTN = 0             ! Product definition template number
 274   JPDT(1) = Category
 275   JPDT(2) = ParmNum
 276   JPDT(3) = 2           ! Generating process id
 277   JPDT(9) = 0           ! Forecast time
 278
 279   JGDTN    = -1         ! Indicates that any Grid Display Template is a match
 280
 281   UNPACK   = .FALSE.    ! Dont unpack bitmap and data values
 282
 283   CALL GETGB2(DataHandle, DataHandle, fields_to_skip, -1, Disc, JIDS, JPDTN, &
 284        JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, gfld, status)
 285   if (status .ne. 0) then
 286      if (status .eq. 99) then
 287         write(msg,*)'Could not find metadata field named '//trim(VarName)
 288      else
 289         write(msg,*)'Retrieving grib field '//trim(VarName)//' failed, ',status
 290      endif
 291      call wrf_message(trim(msg))
 292      status = WRF_GRIB2_ERR_GETGB2
 293      return
 294   endif
 295
 296   global_input(DataHandle) = transfer(gfld%local,global_input(DataHandle))
 297   global_input(DataHandle)(gfld%locallen+1:30000) = ' '
 298
 299   call gf_free(gfld)
 300
 301   !
 302   ! Read and index all scalar data
 303   !
 304   VarName = "WRF_SCALAR"
 305   CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
 306        LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
 307   if (status .ne. 0) then
 308      write(msg,*) 'Could not find parameter for '//   &
 309           trim(VarName)//'   Skipping reading of '//trim(VarName)
 310      call wrf_message(trim(msg))
 311      Status =  WRF_GRIB2_ERR_GRIB2MAP
 312      return
 313   endif
 314
 315   !
 316   ! Read the metadata
 317   !
 318   ! First, set all values to wild, then specify necessary values
 319   !
 320   call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
 321
 322   JIDS(1) = center
 323   JIDS(2) = subcenter
 324   JIDS(3) = MasterTblV
 325   JIDS(4) = LocalTblV
 326
 327   JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
 328   JIDS(13) = 1          ! Type of processed data (1 for forecast products)
 329
 330   JPDTN = 0             ! Product definition template number
 331   JPDT(1) = Category
 332   JPDT(2) = ParmNum
 333   JPDT(3) = 2           ! Generating process id
 334
 335   JGDTN    = -1         ! Indicates that any Grid Display Template is a match
 336
 337   UNPACK   = .FALSE.    ! Dont unpack bitmap and data values
 338
 339   fields_to_skip = 0
 340   do while (status .eq. 0)
 341      CALL GETGB2(DataHandle, 0, fields_to_skip, -1, -1, JIDS, JPDTN, &
 342           JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, &
 343           gfld, status)
 344      if (status .eq. 99) then
 345         exit
 346      else if (status .ne. 0) then
 347         write(msg,*)'Finding data field '//trim(VarName)//' failed 1.'
 348         call wrf_message(trim(msg))
 349         Status = WRF_GRIB2_ERR_READ
 350         return
 351      endif
 352
 353      ! Build times list here
 354      write(refTime,'(I4,A,I2.2,A,I2.2,A,I2.2,A,I2.2,A,I2.2)')      &
 355           gfld%idsect(6),'-',gfld%idsect(7),'-',gfld%idsect(8),'_',&
 356           gfld%idsect(9),':',gfld%idsect(10),':',gfld%idsect(11)
 357
 358      time_range_convert(:) = -1
 359      time_range_convert(1) = 60
 360      time_range_convert(2) = 60*60
 361      time_range_convert(3) = 24*60*60
 362      time_range_convert(10) = 3*60*60
 363      time_range_convert(11) = 6*60*60
 364      time_range_convert(12) = 12*60*60
 365      time_range_convert(13) = 1
 366
 367      if (time_range_convert(gfld%ipdtmpl(8)) .gt. 0) then
 368         fcstsecs = gfld%ipdtmpl(9)*time_range_convert(gfld%ipdtmpl(8))
 369      else
 370         write(msg,*)'Invalid time range in input data: ',gfld%ipdtmpl(8),&
 371              ' Skipping'
 372         call wrf_message(trim(msg))
 373         call gf_free(gfld)
 374         cycle
 375      endif
 376      call advance_wrf_time(refTime,fcstsecs,theTime)
 377
 378      call gr2_add_time(DataHandle,theTime)
 379
 380      fields_to_skip = fields_to_skip + fileinfo(DataHandle)%recnum
 381
 382      scalar_input(DataHandle) = transfer(gfld%local,scalar_input(DataHandle))
 383      scalar_input(DataHandle)(gfld%locallen+1:30000) = ' '
 384
 385      call gf_free(gfld)
 386   enddo
 387
 388   !
 389   ! Fill up the eta levels variables
 390   !
 391
 392   if (.not. full_eta_init) then
 393      CALL gr2_fill_levels(DataHandle, "ZNW", full_eta, ierr)
 394      if (ierr .eq. 0) then
 395         full_eta_init = .TRUE.
 396      endif
 397   endif
 398   if (.not. half_eta_init) then
 399      CALL gr2_fill_levels(DataHandle, "ZNU", half_eta, ierr)
 400      if (ierr .eq. 0) then
 401         half_eta_init = .TRUE.
 402      endif
 403   endif
 404   !
 405   ! Fill up the soil levels
 406   !
 407   if (.not. soil_depth_init) then
 408      call gr2_fill_levels(DataHandle,"ZS",soil_depth, ierr)
 409      if (ierr .eq. 0) then
 410         soil_depth_init = .TRUE.
 411      endif
 412   endif
 413   if (.not. soil_thickness_init) then
 414      call gr2_fill_levels(DataHandle,"DZS",soil_thickness, ierr)
 415      if (ierr .eq. 0) then
 416         soil_thickness_init = .TRUE.
 417      endif
 418   endif
 419
 420   !
 421   ! Fill up any variables from the global metadata
 422   !
 423
 424   CALL gr2_get_metadata_value(global_input(DataHandle), &
 425        'START_DATE', StartDate, status)
 426   if (status .ne. 0) then
 427      write(msg,*)'Could not find metadata value for START_DATE, continuing'
 428      call wrf_message(trim(msg))
 429   endif
 430
 431   CALL gr2_get_metadata_value(global_input(DataHandle), &
 432        'PROGRAM_NAME', InputProgramName, status)
 433   if (status .ne. 0) then
 434      write(msg,*)'Could not find metadata value for PROGRAM_NAME, continuing'
 435      call wrf_message(trim(msg))
 436   else
 437      endchar = SCAN(InputProgramName," ")
 438      InputProgramName = InputProgramName(1:endchar)
 439   endif
 440
 441
 442   Status = WRF_NO_ERR
 443
 444   call wrf_debug ( DEBUG , 'Exiting ext_gr2_open_for_read_begin')
 445
 446   RETURN
 447 END SUBROUTINE ext_gr2_open_for_read_begin
 448
 449 !*****************************************************************************
 450
 451 SUBROUTINE ext_gr2_open_for_read_commit( DataHandle , Status )
 452
 453   USE gr2_data_info
 454   IMPLICIT NONE
 455 #include "wrf_status_codes.h"
 456 #include "wrf_io_flags.h"
 457   character(len=maxMsgSize) :: msg
 458   INTEGER ,       INTENT(IN ) :: DataHandle
 459   INTEGER ,       INTENT(OUT) :: Status
 460
 461   call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_read_commit')
 462
 463   Status = WRF_NO_ERR
 464   if(WrfIOnotInitialized) then
 465     Status = WRF_IO_NOT_INITIALIZED
 466     write(msg,*) 'ext_gr2_ioinit was not called ',__FILE__,', line', __LINE__
 467     call wrf_debug ( FATAL , msg)
 468     return
 469   endif
 470   fileinfo(DataHandle)%committed = .true.
 471   fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_FOR_READ
 472
 473   Status = WRF_NO_ERR
 474
 475   RETURN
 476 END SUBROUTINE ext_gr2_open_for_read_commit
 477
 478 !*****************************************************************************
 479
 480 SUBROUTINE ext_gr2_open_for_read ( FileName , Comm_compute, Comm_io, &
 481      SysDepInfo, DataHandle , Status )
 482
 483   USE gr2_data_info
 484   IMPLICIT NONE
 485 #include "wrf_status_codes.h"
 486   CHARACTER*(*) :: FileName
 487   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
 488   CHARACTER*(*) :: SysDepInfo
 489   INTEGER ,       INTENT(OUT) :: DataHandle
 490   INTEGER ,       INTENT(OUT) :: Status
 491
 492
 493   call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_read')
 494
 495   DataHandle = 0   ! dummy setting to quiet warning message
 496   CALL ext_gr2_open_for_read_begin( FileName, Comm_compute, Comm_io, &
 497        SysDepInfo, DataHandle, Status )
 498   IF ( Status .EQ. WRF_NO_ERR ) THEN
 499     CALL ext_gr2_open_for_read_commit( DataHandle, Status )
 500   ENDIF
 501   return
 502
 503   RETURN
 504 END SUBROUTINE ext_gr2_open_for_read
 505
 506 !*****************************************************************************
 507
 508 SUBROUTINE ext_gr2_open_for_write_begin(FileName, Comm, IOComm, SysDepInfo, &
 509      DataHandle, Status)
 510
 511   USE gr2_data_info
 512   implicit none
 513 #include "wrf_status_codes.h"
 514 #include "wrf_io_flags.h"
 515
 516   character*(*)        ,intent(in)  :: FileName
 517   integer              ,intent(in)  :: Comm
 518   integer              ,intent(in)  :: IOComm
 519   character*(*)        ,intent(in)  :: SysDepInfo
 520   integer              ,intent(out) :: DataHandle
 521   integer              ,intent(out) :: Status
 522   integer :: ierr
 523   CHARACTER (LEN=maxMsgSize) :: msg
 524
 525   INTERFACE
 526      Subroutine load_grib2map (filename, message, status)
 527        USE grib2tbls_types
 528        character*(*), intent(in)                   :: filename
 529        character*(*), intent(inout)                :: message
 530        integer      , intent(out)                  :: status
 531      END subroutine load_grib2map
 532   END INTERFACE
 533
 534   call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_write_begin')
 535
 536   Status = WRF_NO_ERR
 537
 538   if (.NOT. grib2map_table_filled) then
 539      grib2map_table_filled = .TRUE.
 540      CALL load_grib2map(mapfilename, msg, status)
 541      if (status .ne. 0) then
 542         call wrf_message(trim(msg))
 543         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 544         return
 545      endif
 546   endif
 547
 548   CALL gr2_get_new_handle(DataHandle)
 549
 550   if (DataHandle .GT. 0) then
 551
 552      call baopenw(DataHandle,trim(FileName),ierr)
 553
 554      if (ierr .ne. 0) then
 555         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 556      else
 557         fileinfo(DataHandle)%opened = .true.
 558         fileinfo(DataHandle)%DataFile = TRIM(FileName)
 559         fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
 560      endif
 561      fileinfo(DataHandle)%last_scalar_time_written = -1
 562      fileinfo(DataHandle)%committed = .false.
 563      td_output(DataHandle) = ''
 564      ti_output(DataHandle) = ''
 565      scalar_output(DataHandle) = ''
 566      fileinfo(DataHandle)%write = .true.
 567   else
 568      Status = WRF_WARN_TOO_MANY_FILES
 569   endif
 570
 571   RETURN
 572 END SUBROUTINE ext_gr2_open_for_write_begin
 573
 574 !*****************************************************************************
 575
 576 SUBROUTINE ext_gr2_open_for_write_commit( DataHandle , Status )
 577
 578   USE gr2_data_info
 579   IMPLICIT NONE
 580 #include "wrf_status_codes.h"
 581 #include "wrf_io_flags.h"
 582   INTEGER ,       INTENT(IN ) :: DataHandle
 583   INTEGER ,       INTENT(OUT) :: Status
 584
 585   call wrf_debug ( DEBUG , 'Entering ext_gr2_open_for_write_commit')
 586
 587   IF ( fileinfo(DataHandle)%opened ) THEN
 588     IF ( fileinfo(DataHandle)%used ) THEN
 589       fileinfo(DataHandle)%committed = .true.
 590       fileinfo(DataHandle)%FileStatus = WRF_FILE_OPENED_FOR_WRITE
 591     ENDIF
 592   ENDIF
 593
 594   Status = WRF_NO_ERR
 595
 596   RETURN
 597 END SUBROUTINE ext_gr2_open_for_write_commit
 598
 599 !*****************************************************************************
 600
 601 subroutine ext_gr2_inquiry (Inquiry, Result, Status)
 602   use gr2_data_info
 603   implicit none
 604 #include "wrf_status_codes.h"
 605   character *(*), INTENT(IN)    :: Inquiry
 606   character *(*), INTENT(OUT)   :: Result
 607   integer        ,INTENT(INOUT) :: Status
 608   SELECT CASE (Inquiry)
 609   CASE ("RANDOM_WRITE","RANDOM_READ")
 610      Result='ALLOW'
 611   CASE ("SEQUENTIAL_WRITE","SEQUENTIAL_READ")
 612      Result='NO'
 613   CASE ("OPEN_READ", "OPEN_WRITE", "OPEN_COMMIT_WRITE")
 614      Result='REQUIRE'
 615   CASE ("OPEN_COMMIT_READ","PARALLEL_IO")
 616      Result='NO'
 617   CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS")
 618      Result='YES'
 619   CASE ("MEDIUM")
 620      Result ='FILE'
 621   CASE DEFAULT
 622      Result = 'No Result for that inquiry!'
 623   END SELECT
 624   Status=WRF_NO_ERR
 625   return
 626 end subroutine ext_gr2_inquiry
 627
 628 !*****************************************************************************
 629
 630 SUBROUTINE ext_gr2_inquire_opened ( DataHandle, FileName , FileStat, Status )
 631
 632   USE gr2_data_info
 633   IMPLICIT NONE
 634 #include "wrf_status_codes.h"
 635 #include "wrf_io_flags.h"
 636   INTEGER ,       INTENT(IN)  :: DataHandle
 637   CHARACTER*(*) :: FileName
 638   INTEGER ,       INTENT(OUT) :: FileStat
 639   INTEGER ,       INTENT(OUT) :: Status
 640
 641   call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_opened')
 642
 643   FileStat = WRF_NO_ERR
 644   if ((DataHandle .ge. firstFileHandle) .and. &
 645        (DataHandle .le. maxFileHandles)) then
 646      FileStat = fileinfo(DataHandle)%FileStatus
 647   else
 648      FileStat = WRF_FILE_NOT_OPENED
 649   endif
 650
 651   Status = FileStat
 652
 653   RETURN
 654 END SUBROUTINE ext_gr2_inquire_opened
 655
 656 !*****************************************************************************
 657
 658 SUBROUTINE ext_gr2_ioclose ( DataHandle, Status )
 659
 660   USE gr2_data_info
 661   IMPLICIT NONE
 662 #include "wrf_status_codes.h"
 663 #include "wrf_io_flags.h"
 664   INTEGER DataHandle, Status
 665   INTEGER istat
 666   character(len=1000) :: outstring
 667   character :: lf
 668   character*(maxMsgSize) :: msg
 669   integer   :: idx
 670
 671   lf=char(10)
 672   call wrf_debug ( DEBUG , 'Entering ext_gr2_ioclose')
 673
 674   Status = WRF_NO_ERR
 675
 676   if (fileinfo(DataHandle)%write .eqv. .TRUE.) then
 677      call gr2_fill_local_use(DataHandle,scalar_output(DataHandle),&
 678           "WRF_SCALAR",fcst_secs,msg,status)
 679      if (status .ne. 0) then
 680         call wrf_message(trim(msg))
 681         return
 682      endif
 683      fileinfo(DataHandle)%last_scalar_time_written = fcst_secs
 684      scalar_output(DataHandle) = ''
 685
 686      call gr2_fill_local_use(DataHandle,&
 687           trim(ti_output(DataHandle))//trim(td_output(DataHandle)),&
 688           "WRF_GLOBAL",0,msg,status)
 689      if (status .ne. 0) then
 690         call wrf_message(trim(msg))
 691         return
 692      endif
 693      ti_output(DataHandle) = ''
 694      td_output(DataHandle) = ''
 695   endif
 696
 697   do idx = 1,fileinfo(DataHandle)%NumberTimes
 698      if (allocated(fileinfo(DataHandle)%Times)) then
 699         deallocate(fileinfo(DataHandle)%Times)
 700      endif
 701   enddo
 702   fileinfo(DataHandle)%NumberTimes = 0
 703   fileinfo(DataHandle)%sizeAllocated = 0
 704   fileinfo(DataHandle)%CurrentTime = 0
 705   fileinfo(DataHandle)%write = .FALSE.
 706
 707   call baclose(DataHandle,status)
 708   if (status .ne. 0) then
 709      call wrf_message("Closing file failed, continuing")
 710   else
 711      fileinfo(DataHandle)%opened = .true.
 712      fileinfo(DataHandle)%DataFile = ''
 713      fileinfo(DataHandle)%FileStatus = WRF_FILE_NOT_OPENED
 714   endif
 715
 716   fileinfo(DataHandle)%used = .false.
 717
 718   RETURN
 719 END SUBROUTINE ext_gr2_ioclose
 720
 721 !*****************************************************************************
 722
 723 SUBROUTINE ext_gr2_write_field( DataHandle , DateStrIn , VarName , &
 724      Field , FieldType , Comm , IOComm, &
 725      DomainDesc , MemoryOrder , Stagger , &
 726      DimNames , &
 727      DomainStart , DomainEnd , &
 728      MemoryStart , MemoryEnd , &
 729      PatchStart , PatchEnd , &
 730      Status )
 731
 732   USE gr2_data_info
 733   USE grib2tbls_types
 734   IMPLICIT NONE
 735 #include "wrf_status_codes.h"
 736 #include "wrf_io_flags.h"
 737   integer                       ,intent(in)    :: DataHandle
 738   character*(*)                 ,intent(in)    :: DateStrIn
 739   character*(*)                 ,intent(in)    :: VarName
 740   integer                       ,intent(in)    :: FieldType
 741   integer                       ,intent(inout) :: Comm
 742   integer                       ,intent(inout) :: IOComm
 743   integer                       ,intent(in)    :: DomainDesc
 744   character*(*)                 ,intent(in)    :: MemoryOrder
 745   character*(*)                 ,intent(in)    :: Stagger
 746   character*(*) , dimension (*) ,intent(in)    :: DimNames
 747   integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
 748   integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
 749   integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
 750   integer                       ,intent(out)   :: Status
 751
 752   real                          , intent(in), &
 753        dimension( 1:1,MemoryStart(1):MemoryEnd(1), &
 754        MemoryStart(2):MemoryEnd(2), &
 755        MemoryStart(3):MemoryEnd(3) )           :: Field
 756
 757
 758   character (120)                              :: DateStr
 759
 760   character (maxMsgSize)                       :: msg
 761   integer                                      :: xsize, ysize, zsize
 762   integer                                      :: x, y, z
 763   integer                                      :: &
 764        x_start,x_end,y_start,y_end,z_start,z_end
 765   integer                                      :: idx
 766   integer                                      :: proj_center_flag
 767   logical                                      :: vert_stag = .false.
 768   real,    dimension(:,:), pointer             :: data
 769   integer                                      :: istat
 770   integer                                      :: accum_period
 771   integer, dimension(maxLevels)                :: level1, level2
 772   integer, dimension(maxLevels)                :: grib_levels
 773   logical                                      :: soil_layers, fraction
 774   integer                                      :: vert_unit1, vert_unit2
 775   integer                                      :: vert_sclFctr1, vert_sclFctr2
 776   integer                                      :: this_domain
 777   logical                                      :: new_domain
 778   real                                         :: &
 779        region_center_lat, region_center_lon
 780   integer                                      :: dom_xsize, dom_ysize;
 781   integer , parameter                          :: lcgrib = 2000000
 782   character (lcgrib)                           :: cgrib
 783   integer                                      :: ierr
 784   integer                                      :: lengrib
 785
 786   integer                                     :: center, subcenter, &
 787        MasterTblV, LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
 788   CHARACTER(len=100)  :: tmpstr
 789   integer             :: ndims
 790   integer             :: dim1size, dim2size, dim3size, dim3
 791   integer             :: numlevels
 792   integer             :: ngrdpts
 793   integer             :: bytes_written
 794
 795   call wrf_debug ( DEBUG , 'Entering ext_gr2_write_field for parameter '//&
 796        VarName)
 797
 798   !
 799   ! If DateStr is all 0s, we reset it to StartDate.  For some reason,
 800   !   in idealized simulations, StartDate is 0001-01-01_00:00:00 while
 801   !   the first DateStr is 0000-00-00_00:00:00.
 802   !
 803   if (DateStrIn .eq. '0000-00-00_00:00:00') then
 804      DateStr = TRIM(StartDate)
 805   else
 806      DateStr = DateStrIn
 807   endif
 808
 809   !
 810   ! Check if this is a domain that we haven t seen yet.  If so, add it to
 811   !   the list of domains.
 812   !
 813   this_domain = 0
 814   new_domain = .false.
 815   do idx = 1, max_domain
 816      if (DomainDesc .eq. domains(idx)) then
 817         this_domain = idx
 818      endif
 819   enddo
 820   if (this_domain .eq. 0) then
 821      max_domain = max_domain + 1
 822      domains(max_domain) = DomainDesc
 823      this_domain = max_domain
 824      new_domain = .true.
 825   endif
 826
 827   zsize = 1
 828   xsize = 1
 829   ysize = 1
 830   soil_layers = .false.
 831   fraction = .false.
 832
 833   ! First, handle then special cases for the boundary data.
 834
 835   CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndims, x_start, x_end, &
 836        y_start, y_end,z_start,z_end)
 837   xsize = x_end - x_start + 1
 838   ysize = y_end - y_start + 1
 839   zsize = z_end - z_start + 1
 840
 841   do idx = 1, len(MemoryOrder)
 842      if ((MemoryOrder(idx:idx) .eq. 'Z') .and. &
 843           (DimNames(idx) .eq. 'soil_layers_stag')) then
 844         soil_layers = .true.
 845      else if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCBOT') .or. &
 846           (VarName .eq. 'SOILCTOP')) then
 847         fraction = .true.
 848      endif
 849   enddo
 850
 851   if (zsize .eq. 0) then
 852      zsize = 1
 853   endif
 854
 855   !
 856   ! Fill up the variables that hold the vertical coordinate data
 857   !
 858
 859   if (VarName .eq. 'ZNU') then
 860      do idx = 1, zsize
 861         half_eta(idx) = Field(1,idx,1,1)
 862      enddo
 863      half_eta_init = .TRUE.
 864   endif
 865
 866   if (VarName .eq. 'ZNW') then
 867      do idx = 1, zsize
 868         full_eta(idx) = Field(1,idx,1,1)
 869      enddo
 870      full_eta_init = .TRUE.
 871   endif
 872
 873   if (VarName .eq. 'ZS') then
 874      do idx = 1, zsize
 875         soil_depth(idx) = Field(1,idx,1,1)
 876      enddo
 877      soil_depth_init = .TRUE.
 878   endif
 879
 880   if (VarName .eq. 'DZS') then
 881      do idx = 1, zsize
 882         soil_thickness(idx) = Field(1,idx,1,1)
 883      enddo
 884      soil_thickness_init = .TRUE.
 885   endif
 886
 887   !
 888   ! Check to assure that dimensions are valid
 889   !
 890
 891   if ((xsize .lt. 1) .or. (ysize .lt. 1) .or. (zsize .lt. 1)) then
 892      write(msg,*) 'Cannot output field with memory order: ', &
 893           MemoryOrder,Varname
 894      call wrf_message(trim(msg))
 895      return
 896   endif
 897
 898
 899   if (fileinfo(DataHandle)%opened .and. fileinfo(DataHandle)%committed) then
 900
 901      if (StartDate == '') then
 902         StartDate = DateStr
 903      endif
 904
 905      CALL geth_idts(DateStr,StartDate,fcst_secs)
 906
 907      !
 908      ! If this is a new forecast time, and we have not written the
 909      !   last_fcst_secs scalar output yet, then write it here.
 910      !
 911
 912      if ((abs(fcst_secs - 0.0) .gt. 0.01) .and. &
 913           (last_fcst_secs .ge. 0) .and. &
 914           (abs(fcst_secs - last_fcst_secs) .gt. 0.01) .and. &
 915           (abs(last_fcst_secs - fileinfo(DataHandle)%last_scalar_time_written) .gt. 0.01) ) then
 916         call gr2_fill_local_use(DataHandle,scalar_output(DataHandle),&
 917              "WRF_SCALAR",last_fcst_secs,msg,status)
 918         if (status .ne. 0) then
 919            call wrf_message(trim(msg))
 920            return
 921         endif
 922         fileinfo(DataHandle)%last_scalar_time_written = last_fcst_secs
 923         scalar_output(DataHandle) = ''
 924      endif
 925
 926      call get_vert_stag(VarName,Stagger,vert_stag)
 927
 928      do idx = 1, zsize
 929         call gr2_get_levels(VarName, idx, zsize, soil_layers, vert_stag, &
 930              fraction, vert_unit1, vert_unit2, vert_sclFctr1, &
 931              vert_sclFctr2, level1(idx), level2(idx))
 932      enddo
 933
 934      !
 935      ! Get the center lat/lon for the area being output.  For some cases (such
 936      !    as for boundary areas, the center of the area is different from the
 937      !    center of the model grid.
 938      !
 939      if (index(Stagger,'X') .le. 0) then
 940         dom_xsize = full_xsize - 1
 941      else
 942         dom_xsize = full_xsize
 943      endif
 944      if (index(Stagger,'Y') .le. 0) then
 945         dom_ysize = full_ysize - 1
 946      else
 947         dom_ysize = full_ysize
 948      endif
 949
 950
 951      CALL get_region_center(MemoryOrder, wrf_projection, center_lat, &
 952           center_lon, dom_xsize, dom_ysize, dx, dy, proj_central_lon, &
 953           proj_center_flag, truelat1, truelat2, xsize, ysize, &
 954           region_center_lat, region_center_lon)
 955
 956
 957      if (ndims .eq. 0) then        ! Scalar quantity
 958
 959         ALLOCATE(data(1:1,1:1), STAT=istat)
 960
 961         call gr2_retrieve_data(MemoryOrder, MemoryStart, MemoryEnd, &
 962              xsize, ysize, zsize, z, FieldType, Field, data)
 963         write(tmpstr,'(G17.10)')data(1,1)
 964         CALL gr2_build_string (scalar_output(DataHandle), &
 965              trim(adjustl(VarName)), tmpstr, 1, Status)
 966
 967         DEALLOCATE(data)
 968
 969      else if (ndims .ge. 1) then   ! Vector (1-D) and 2/3 D quantities
 970
 971         if (ndims .eq. 1) then     ! Handle Vector (1-D) parameters
 972            dim1size = zsize
 973            dim2size = 1
 974            dim3size = 1
 975         else                       ! Handle 2/3 D parameters
 976            dim1size = xsize
 977            dim2size = ysize
 978            dim3size = zsize
 979         endif
 980
 981         ALLOCATE(data(1:dim1size,1:dim2size), STAT=istat)
 982
 983         CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
 984              LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
 985         if (status .ne. 0) then
 986            write(msg,*) 'Could not find parameter for '//   &
 987                 trim(VarName)//'   Skipping output of '//trim(VarName)
 988            call wrf_message(trim(msg))
 989            Status =  WRF_GRIB2_ERR_GRIB2MAP
 990            return
 991         endif
 992
 993         VERTDIM : do dim3 = 1, dim3size
 994
 995            call gr2_retrieve_data(MemoryOrder, MemoryStart, MemoryEnd, xsize, &
 996                 ysize, zsize, dim3, FieldType, Field, data)
 997
 998            !
 999            ! Here, we do any necessary conversions to the data.
1000            !
1001
1002            ! Potential temperature is sometimes passed in as perturbation
1003            !   potential temperature (i.e., POT-300).  Other times (i.e., from
1004            !   WRF SI), it is passed in as full potential temperature.
1005            ! Here, we convert to full potential temperature by adding 300
1006            !   only if POT < 200 K.
1007            !
1008            if (VarName == 'T') then
1009               if ((data(1,1) < 200) .and. (data(1,1) .ne. 0)) then
1010                  data = data + 300
1011               endif
1012            endif
1013
1014            !
1015            ! For precip, we setup the accumulation period, and output a precip
1016            !    rate for time-step precip.
1017            !
1018            if ((VarName .eq. 'RAINCV') .or. (VarName .eq. 'RAINNCV')) then
1019               ! Convert time-step precip to precip rate.
1020               data = data/timestep
1021               accum_period = 0
1022            else
1023               accum_period = 0
1024            endif
1025
1026            !
1027            ! Create indicator and identification sections (sections 0 and 1)
1028            !
1029            CALL gr2_create_w(StartDate, cgrib, lcgrib, production_status, &
1030                 Disc, center, subcenter, MasterTblV, LocalTblV, ierr, msg)
1031            if (ierr .ne. 0) then
1032               call wrf_message(trim(msg))
1033               Status = WRF_GRIB2_ERR_GRIBCREATE
1034               return
1035            endif
1036
1037            !
1038            ! Add the grid definition section (section 3) using a 1x1 grid
1039            !
1040            call gr2_addgrid_w(cgrib, lcgrib, center_lat, proj_central_lon,  &
1041                 wrf_projection, truelat1, truelat2, xsize, ysize, dx, dy, &
1042                 region_center_lat, region_center_lon, ierr, msg)
1043            if (ierr .ne. 0) then
1044               call wrf_message(trim(msg))
1045               Status = WRF_GRIB2_ERR_ADDGRIB
1046               return
1047            endif
1048
1049            if (ndims .eq. 1) then
1050               numlevels = zsize
1051               grib_levels(:) = level1(:)
1052               ngrdpts = zsize
1053            else
1054               numlevels = 2
1055               grib_levels(1) = level1(dim3)
1056               grib_levels(2) = level2(dim3)
1057               ngrdpts = xsize*ysize
1058            endif
1059
1060            !
1061            ! Add the Product Definition, Data representation, bitmap
1062            !      and data sections (sections 4-7)
1063            !
1064
1065            call gr2_addfield_w(cgrib, lcgrib, VarName, Category, ParmNum, &
1066                 DecScl, BinScl, fcst_secs, vert_unit1, vert_unit2, &
1067                 vert_sclFctr1, vert_sclFctr2, numlevels, &
1068                 grib_levels, ngrdpts,  background_proc_id, forecast_proc_id, &
1069                 compression, data, ierr, msg)
1070            if (ierr .eq. 11) then
1071               write(msg,'(A,I7,A)') 'WARNING: decimal scale for field '//&
1072                    trim(VarName)//' at level ',grib_levels(1),&
1073                    ' was reduced to fit field into 24 bits.  '//&
1074                    ' Some precision may be lost!'//&
1075                    '     To prevent this message, reduce decimal scale '//&
1076                    'factor in '//trim(mapfilename)
1077               call wrf_message(trim(msg))
1078            else if (ierr .eq. 12) then
1079               write(msg,'(A,I7,A)') 'WARNING: binary scale for field '//&
1080                    trim(VarName)//' at level ',grib_levels(1), &
1081                    ' was reduced to fit field into 24 bits.  '//&
1082                    ' Some precision may be lost!'//&
1083                    '     To prevent this message, reduce binary scale '//&
1084                    'factor in '//trim(mapfilename)
1085               call wrf_message(trim(msg))
1086            else if (ierr .ne. 0) then
1087               call wrf_message(trim(msg))
1088               Status = WRF_GRIB2_ERR_ADDFIELD
1089               return
1090            endif
1091
1092            !
1093            ! Close out the message
1094            !
1095
1096            call gribend(cgrib,lcgrib,lengrib,ierr)
1097            if (ierr .ne. 0) then
1098               write(msg,*) 'gribend failed with ierr: ',ierr
1099               call wrf_message(trim(msg))
1100               Status = WRF_GRIB2_ERR_GRIBEND
1101               return
1102            endif
1103
1104            !
1105            ! Write the data to the file
1106            !
1107
1108 !           call write_file_n(fileinfo(DataHandle)%FileFd, cgrib, lengrib, ierr)
1109            call bawrite(DataHandle, -1, lengrib, bytes_written, cgrib)
1110            if (bytes_written .ne. lengrib) then
1111               write(msg,*) '1 Error writing cgrib to file, wrote: ', &
1112                    bytes_written, ' bytes.  Tried to write ', lengrib, ' bytes'
1113               call wrf_message(trim(msg))
1114               Status = WRF_GRIB2_ERR_WRITE
1115               return
1116            endif
1117
1118         ENDDO VERTDIM
1119
1120         DEALLOCATE(data)
1121
1122      endif
1123
1124      last_fcst_secs = fcst_secs
1125
1126   endif
1127
1128   deallocate(data, STAT = istat)
1129
1130   Status = WRF_NO_ERR
1131
1132   call wrf_debug ( DEBUG , 'Leaving ext_gr2_write_field')
1133
1134   RETURN
1135 END SUBROUTINE ext_gr2_write_field
1136
1137 !*****************************************************************************
1138
1139 SUBROUTINE ext_gr2_read_field ( DataHandle , DateStr , VarName , Field , &
1140      FieldType , Comm , IOComm, DomainDesc , MemoryOrder , Stagger ,     &
1141      DimNames , DomainStart , DomainEnd , MemoryStart , MemoryEnd ,      &
1142      PatchStart , PatchEnd ,  Status )
1143
1144   USE gr2_data_info
1145   USE grib_mod
1146   IMPLICIT NONE
1147 #include "wrf_status_codes.h"
1148 #include "wrf_io_flags.h"
1149   INTEGER                       ,intent(in)       :: DataHandle
1150   CHARACTER*(*)                 ,intent(in)       :: DateStr
1151   CHARACTER*(*)                 ,intent(in)       :: VarName
1152   integer                       ,intent(inout)    :: FieldType
1153   integer                       ,intent(inout)    :: Comm
1154   integer                       ,intent(inout)    :: IOComm
1155   integer                       ,intent(inout)    :: DomainDesc
1156   character*(*)                 ,intent(inout)    :: MemoryOrder
1157   character*(*)                 ,intent(inout)    :: Stagger
1158   character*(*) , dimension (*) ,intent(inout)    :: DimNames
1159   integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
1160   integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
1161   integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
1162   integer                       ,intent(out)      :: Status
1163   INTEGER                       ,intent(out)      :: Field(*)
1164   integer                       :: xsize,ysize,zsize
1165   integer                       :: x_start,x_end,y_start,y_end,z_start,z_end
1166   integer                       :: ndims
1167   character (len=1000)          :: Value
1168   character (maxMsgSize)        :: msg
1169   integer                       :: ierr
1170   real                          :: Data
1171   integer                       :: center, subcenter, MasterTblV, &
1172        LocalTblV, Disc, Category, ParmNum, DecScl, BinScl
1173   integer                       :: dim1size,dim2size,dim3size,dim3
1174
1175   integer :: idx
1176   integer :: fields_to_skip
1177   integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
1178        JGDT(JGDTSIZE)
1179   logical :: UNPACK
1180   type(gribfield) :: gfld
1181   logical                                      :: soil_layers, fraction
1182   logical                                      :: vert_stag = .false.
1183   integer                                      :: vert_unit1, vert_unit2
1184   integer                                      :: vert_sclFctr1, vert_sclFctr2
1185   integer                                      :: level1, level2
1186   integer                                      :: di
1187   real                                         :: tmpreal
1188
1189   call wrf_debug ( DEBUG , 'Entering ext_gr2_read_field'//fileinfo(DataHandle)%DataFile)
1190
1191   CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndims, x_start, x_end, &
1192        y_start, y_end,z_start,z_end)
1193   xsize = x_end - x_start + 1
1194   ysize = y_end - y_start + 1
1195   zsize = z_end - z_start + 1
1196
1197   !
1198   ! Check to assure that dimensions are valid
1199   !
1200
1201   if ((xsize .lt. 1) .or. (ysize .lt. 1) .or. (zsize .lt. 1)) then
1202      write(msg,*) 'Cannot retrieve field with memory order: ', &
1203           MemoryOrder,Varname
1204      Status = WRF_GRIB2_ERR_READ
1205      call wrf_message(trim(msg))
1206      return
1207   endif
1208
1209
1210   if (ndims .eq. 0) then    ! Scalar quantity
1211
1212      call gr2_get_metadata_value(scalar_input(DataHandle),trim(VarName),&
1213           Value,ierr)
1214      if (ierr /= 0) then
1215         Status = WRF_GRIB2_ERR_READ
1216         CALL wrf_message ( &
1217              "gr2_get_metadata_value failed for Scalar variable "//&
1218              trim(VarName))
1219         return
1220      endif
1221
1222      READ(Value,*,IOSTAT=ierr)Data
1223      if (ierr .ne. 0) then
1224         CALL wrf_message("Reading data from "//trim(VarName)//" failed")
1225         Status = WRF_GRIB2_ERR_READ
1226         return
1227      endif
1228
1229      if (FieldType .eq. WRF_INTEGER) then
1230         Field(1:1) = data
1231      else if ((FieldType .eq. WRF_REAL) .or. (FieldType .eq. WRF_DOUBLE)) then
1232         Field(1:1) = TRANSFER(data,Field(1),1)
1233      else
1234         write (msg,*)'Reading of type ',FieldType,'from grib data not supported, not reading ',VarName
1235         call wrf_message(msg)
1236      endif
1237
1238   else if (ndims .ge. 1) then   ! Vector (1-D) and 2/3 D quantities
1239
1240      if (ndims .eq. 1) then     ! Handle Vector (1-D) parameters
1241         dim1size = zsize
1242         dim2size = 1
1243         dim3size = 1
1244      else                       ! Handle 2/3 D parameters
1245         dim1size = xsize
1246         dim2size = ysize
1247         dim3size = zsize
1248      endif
1249
1250      CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
1251           LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
1252      if (status .ne. 0) then
1253         write(msg,*) 'Could not find parameter for '//   &
1254              trim(VarName)//'   Skipping output of '//trim(VarName)
1255         call wrf_message(trim(msg))
1256         Status =  WRF_GRIB2_ERR_GRIB2MAP
1257         return
1258      endif
1259
1260      CALL get_vert_stag(VarName,Stagger,vert_stag)
1261      CALL get_soil_layers(VarName,soil_layers)
1262
1263      VERTDIM : do dim3 = 1, dim3size
1264
1265         fields_to_skip = 0
1266
1267         !
1268         ! First, set all values to wild, then specify necessary values
1269         !
1270         call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
1271
1272         JIDS(1) = center
1273         JIDS(2) = subcenter
1274         JIDS(3) = MasterTblV
1275         JIDS(4) = LocalTblV
1276         JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
1277
1278         READ (StartDate,'(I4.4,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2,1X,I2.2)') &
1279              (JIDS(idx),idx=6,11)
1280         JIDS(13) = 1          ! Type of processed data(1 for forecast products)
1281
1282         JPDT(1) = Category
1283         JPDT(2) = ParmNum
1284         JPDT(3) = 2           ! Generating process id
1285
1286         CALL geth_idts(DateStr,StartDate,tmpreal)  ! Forecast time
1287
1288         JPDT(9) = NINT(tmpreal)
1289
1290         if (ndims .eq. 1) then
1291            jpdtn = 1000       ! Product definition tmplate (1000 for cross-sxn)
1292         else
1293            call gr2_get_levels(VarName, dim3, dim3size, soil_layers, &
1294                 vert_stag, .false., vert_unit1, vert_unit2, vert_sclFctr1, &
1295                 vert_sclFctr2, level1, level2)
1296
1297            jpdtn = 0          ! Product definition template (0 for horiz grid)
1298            JPDT(10) = vert_unit1     ! Type of first surface
1299            JPDT(11) = vert_sclFctr1  ! Scale factor first surface
1300            JPDT(12) = level1         ! First surface
1301            JPDT(13) = vert_unit2     ! Type of second surface
1302            JPDT(14) = vert_sclFctr2  ! Scale factor second surface
1303            JPDT(15) = level2         ! Second fixed surface
1304         endif
1305
1306         JGDTN    = -1    ! Indicates that any Grid Display Template is a match
1307
1308         UNPACK   = .TRUE.! Unpack bitmap and data values
1309
1310         fields_to_skip = 0
1311         CALL GETGB2(DataHandle, 0, fields_to_skip, &
1312              fileinfo(DataHandle)%recnum+1, &
1313              Disc, JIDS, JPDTN, JPDT, JGDTN, JGDT, UNPACK, &
1314              fileinfo(DataHandle)%recnum, gfld, status)
1315         if (status .eq. 99) then
1316            write(msg,*)'Could not find data for field '//trim(VarName)//&
1317                 ' in file '//trim(fileinfo(DataHandle)%DataFile)
1318            call wrf_message(trim(msg))
1319            Status = WRF_GRIB2_ERR_READ
1320            return
1321         else if (status .ne. 0) then
1322            write(msg,*)'Retrieving data field '//trim(VarName)//' failed 2.',status,dim3,DataHandle
1323            call wrf_message(trim(msg))
1324            Status = WRF_GRIB2_ERR_READ
1325            return
1326         endif
1327
1328         if(FieldType == WRF_DOUBLE) then
1329            di = 2
1330         else
1331            di = 1
1332         endif
1333
1334         !
1335         ! Here, we do any necessary conversions to the data.
1336         !
1337         ! The WRF executable (wrf.exe) expects perturbation potential
1338         !   temperature.  However, real.exe expects full potential T.
1339         ! So, if the program is WRF, subtract 300 from Potential Temperature
1340         !   to get perturbation potential temperature.
1341         !
1342         if (VarName == 'T') then
1343            if ( &
1344                 (InputProgramName .eq. 'REAL_EM') .or. &
1345                 (InputProgramName .eq. 'IDEAL') .or. &
1346                 (InputProgramName .eq. 'NDOWN_EM')) then
1347               gfld%fld = gfld%fld - 300
1348            endif
1349         endif
1350
1351
1352         if (ndims .eq. 1) then
1353            CALL Transpose1D_grib(MemoryOrder, di, FieldType, Field, &
1354                 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
1355                 MemoryStart(3), MemoryEnd(3), &
1356                 gfld%fld, zsize)
1357         else
1358            CALL Transpose_grib(MemoryOrder, di, FieldType, Field, &
1359                 MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
1360                 MemoryStart(3), MemoryEnd(3), &
1361                 gfld%fld, dim3, ysize,xsize)
1362         endif
1363
1364         call gf_free(gfld)
1365
1366      enddo VERTDIM
1367   endif
1368
1369   Status = WRF_NO_ERR
1370
1371
1372   call wrf_debug ( DEBUG , 'Leaving ext_gr2_read_field')
1373
1374   RETURN
1375 END SUBROUTINE ext_gr2_read_field
1376
1377 !*****************************************************************************
1378
1379 SUBROUTINE ext_gr2_get_next_var ( DataHandle, VarName, Status )
1380
1381   USE gr2_data_info
1382   IMPLICIT NONE
1383 #include "wrf_status_codes.h"
1384   INTEGER ,       INTENT(IN)  :: DataHandle
1385   CHARACTER*(*) :: VarName
1386   INTEGER ,       INTENT(OUT) :: Status
1387
1388   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_var')
1389
1390   Status = WRF_WARN_NOOP
1391
1392   RETURN
1393 END SUBROUTINE ext_gr2_get_next_var
1394
1395 !*****************************************************************************
1396
1397 subroutine ext_gr2_end_of_frame(DataHandle, Status)
1398
1399   USE gr2_data_info
1400   implicit none
1401 #include "wrf_status_codes.h"
1402   integer               ,intent(in)     :: DataHandle
1403   integer               ,intent(out)    :: Status
1404
1405   call wrf_debug ( DEBUG , 'Entering ext_gr2_end_of_frame')
1406
1407   Status = WRF_WARN_NOOP
1408
1409   return
1410 end subroutine ext_gr2_end_of_frame
1411
1412 !*****************************************************************************
1413
1414 SUBROUTINE ext_gr2_iosync ( DataHandle, Status )
1415
1416   USE gr2_data_info
1417   IMPLICIT NONE
1418 #include "wrf_status_codes.h"
1419   INTEGER ,       INTENT(IN)  :: DataHandle
1420   INTEGER ,       INTENT(OUT) :: Status
1421   integer                     :: ierror
1422
1423   call wrf_debug ( DEBUG , 'Entering ext_gr2_iosync')
1424
1425   Status = WRF_NO_ERR
1426   if (DataHandle .GT. 0) then
1427      CALL flush_file(fileinfo(DataHandle)%FileFd)
1428   else
1429      Status = WRF_WARN_TOO_MANY_FILES
1430   endif
1431
1432   RETURN
1433 END SUBROUTINE ext_gr2_iosync
1434
1435 !*****************************************************************************
1436
1437 SUBROUTINE ext_gr2_inquire_filename ( DataHandle, FileName , FileStat, &
1438      Status )
1439
1440   USE gr2_data_info
1441   IMPLICIT NONE
1442 #include "wrf_status_codes.h"
1443 #include "wrf_io_flags.h"
1444   INTEGER ,       INTENT(IN)  :: DataHandle
1445   CHARACTER*(*) :: FileName
1446   INTEGER ,       INTENT(OUT) :: FileStat
1447   INTEGER ,       INTENT(OUT) :: Status
1448   CHARACTER *80   SysDepInfo
1449
1450   call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_filename')
1451
1452   FileName = fileinfo(DataHandle)%DataFile
1453
1454   if ((DataHandle .ge. firstFileHandle) .and. &
1455        (DataHandle .le. maxFileHandles)) then
1456      FileStat = fileinfo(DataHandle)%FileStatus
1457   else
1458      FileStat = WRF_FILE_NOT_OPENED
1459   endif
1460   Status = WRF_NO_ERR
1461
1462   RETURN
1463 END SUBROUTINE ext_gr2_inquire_filename
1464
1465 !*****************************************************************************
1466
1467 SUBROUTINE ext_gr2_get_var_info ( DataHandle , VarName , NDim , &
1468      MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status )
1469
1470   USE gr2_data_info
1471   IMPLICIT NONE
1472 #include "wrf_status_codes.h"
1473   integer               ,intent(in)     :: DataHandle
1474   character*(*)         ,intent(in)     :: VarName
1475   integer               ,intent(out)    :: NDim
1476   character*(*)         ,intent(out)    :: MemoryOrder
1477   character*(*)         ,intent(out)    :: Stagger
1478   integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
1479   integer               ,intent(out)    :: WrfType
1480   integer               ,intent(out)    :: Status
1481
1482   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_info')
1483
1484   MemoryOrder = ""
1485   Stagger = ""
1486   DomainStart(1) = 0
1487   DomainEnd(1) = 0
1488   WrfType = 0
1489   NDim = 0
1490
1491   CALL wrf_message('ext_gr2_get_var_info not supported for grib version2 data')
1492   Status = WRF_NO_ERR
1493
1494   RETURN
1495 END SUBROUTINE ext_gr2_get_var_info
1496
1497 !*****************************************************************************
1498
1499 SUBROUTINE ext_gr2_set_time ( DataHandle, DateStr, Status )
1500
1501   USE gr2_data_info
1502   IMPLICIT NONE
1503 #include "wrf_status_codes.h"
1504   INTEGER ,       INTENT(IN)  :: DataHandle
1505   CHARACTER*(*) :: DateStr
1506   INTEGER ,       INTENT(OUT) :: Status
1507   integer       :: found_time
1508   integer       :: idx
1509
1510   call wrf_debug ( DEBUG , 'Entering ext_gr2_set_time')
1511
1512   found_time = 0
1513   do idx = 1,fileinfo(DataHandle)%NumberTimes
1514      if (fileinfo(DataHandle)%Times(idx) == DateStr) then
1515         found_time = 1
1516         fileinfo(DataHandle)%CurrentTime = idx
1517      endif
1518   enddo
1519   if (found_time == 0) then
1520      Status = WRF_WARN_TIME_NF
1521   else
1522      Status = WRF_NO_ERR
1523   endif
1524
1525   RETURN
1526 END SUBROUTINE ext_gr2_set_time
1527
1528 !*****************************************************************************
1529
1530 SUBROUTINE ext_gr2_get_next_time ( DataHandle, DateStr, Status )
1531
1532   USE gr2_data_info
1533   IMPLICIT NONE
1534 #include "wrf_status_codes.h"
1535   INTEGER ,       INTENT(IN)  :: DataHandle
1536   CHARACTER*(*) , INTENT(OUT) :: DateStr
1537   INTEGER ,       INTENT(OUT) :: Status
1538
1539   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_time')
1540
1541   if (fileinfo(DataHandle)%CurrentTime == fileinfo(DataHandle)%NumberTimes) then
1542      Status = WRF_WARN_TIME_EOF
1543   else
1544      fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime + 1
1545      DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
1546      Status = WRF_NO_ERR
1547   endif
1548
1549   call wrf_debug ( DEBUG , 'Leaving ext_gr2_get_next_time, got time '//DateStr)
1550
1551   RETURN
1552 END SUBROUTINE ext_gr2_get_next_time
1553
1554 !*****************************************************************************
1555
1556 SUBROUTINE ext_gr2_get_previous_time ( DataHandle, DateStr, Status )
1557
1558   USE gr2_data_info
1559   IMPLICIT NONE
1560 #include "wrf_status_codes.h"
1561   INTEGER ,       INTENT(IN)  :: DataHandle
1562   CHARACTER*(*) :: DateStr
1563   INTEGER ,       INTENT(OUT) :: Status
1564
1565   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_previous_time')
1566
1567   if (fileinfo(DataHandle)%CurrentTime <= 0) then
1568      Status = WRF_WARN_TIME_EOF
1569   else
1570      fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime - 1
1571      DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
1572      Status = WRF_NO_ERR
1573   endif
1574
1575   RETURN
1576 END SUBROUTINE ext_gr2_get_previous_time
1577
1578 !******************************************************************************
1579 !* Start of get_var_ti_* routines
1580 !******************************************************************************
1581
1582 SUBROUTINE ext_gr2_get_var_ti_real ( DataHandle,Element,  Varname, Data, &
1583      Count, Outcount, Status )
1584
1585   USE gr2_data_info
1586   IMPLICIT NONE
1587 #include "wrf_status_codes.h"
1588   INTEGER ,       INTENT(IN)    :: DataHandle
1589   CHARACTER*(*) :: Element
1590   CHARACTER*(*) :: VarName
1591   real ,          INTENT(OUT)   :: Data(*)
1592   INTEGER ,       INTENT(IN)    :: Count
1593   INTEGER ,       INTENT(OUT)   :: OutCount
1594   INTEGER ,       INTENT(OUT)   :: Status
1595   INTEGER          :: idx
1596   INTEGER          :: stat
1597   CHARACTER(len=100)  :: Value
1598
1599   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_real')
1600
1601   Status = WRF_NO_ERR
1602
1603   CALL gr2_get_metadata_value(global_input(DataHandle), &
1604        trim(VarName)//';'//trim(Element), Value, stat)
1605   if (stat /= 0) then
1606      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1607      Status = WRF_WARN_VAR_NF
1608      RETURN
1609   endif
1610
1611   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1612   if (stat .ne. 0) then
1613      CALL wrf_message("Reading data from"//Value//"failed")
1614      Status = WRF_WARN_COUNT_TOO_LONG
1615      RETURN
1616   endif
1617   Outcount = idx
1618
1619   RETURN
1620 END SUBROUTINE ext_gr2_get_var_ti_real
1621
1622 !*****************************************************************************
1623
1624 SUBROUTINE ext_gr2_get_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
1625      Count, Outcount, Status )
1626
1627   USE gr2_data_info
1628   IMPLICIT NONE
1629 #include "wrf_status_codes.h"
1630   INTEGER ,       INTENT(IN)      :: DataHandle
1631   CHARACTER*(*) :: Element
1632   CHARACTER*(*) :: VarName
1633   real*8 ,        INTENT(OUT)     :: Data(*)
1634   INTEGER ,       INTENT(IN)      :: Count
1635   INTEGER ,       INTENT(OUT)     :: OutCount
1636   INTEGER ,       INTENT(OUT)     :: Status
1637   INTEGER          :: idx
1638   INTEGER          :: stat
1639   CHARACTER*(100)  :: VALUE
1640
1641   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_real8')
1642
1643   Status = WRF_NO_ERR
1644
1645   CALL gr2_get_metadata_value(global_input(DataHandle), &
1646        trim(VarName)//';'//trim(Element), Value, stat)
1647   if (stat /= 0) then
1648      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1649      Status = WRF_WARN_VAR_NF
1650      RETURN
1651   endif
1652
1653   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1654   if (stat .ne. 0) then
1655      CALL wrf_message("Reading data from"//Value//"failed")
1656      Status = WRF_WARN_COUNT_TOO_LONG
1657      RETURN
1658   endif
1659   Outcount = idx
1660
1661   RETURN
1662 END SUBROUTINE ext_gr2_get_var_ti_real8
1663
1664 !*****************************************************************************
1665
1666 SUBROUTINE ext_gr2_get_var_ti_double ( DataHandle,Element,  Varname, Data, &
1667      Count, Outcount, Status )
1668   USE gr2_data_info
1669   IMPLICIT NONE
1670 #include "wrf_status_codes.h"
1671   INTEGER ,       INTENT(IN)  :: DataHandle
1672   CHARACTER*(*) , INTENT(IN)  :: Element
1673   CHARACTER*(*) , INTENT(IN)  :: VarName
1674   real*8 ,            INTENT(OUT) :: Data(*)
1675   INTEGER ,       INTENT(IN)  :: Count
1676   INTEGER ,       INTENT(OUT)  :: OutCount
1677   INTEGER ,       INTENT(OUT) :: Status
1678   INTEGER          :: idx
1679   INTEGER          :: stat
1680   CHARACTER*(100)  :: VALUE
1681
1682   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_double')
1683
1684   Status = WRF_NO_ERR
1685
1686   CALL gr2_get_metadata_value(global_input(DataHandle), &
1687        trim(VarName)//';'//trim(Element), Value, stat)
1688   if (stat /= 0) then
1689      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1690      Status = WRF_WARN_VAR_NF
1691      RETURN
1692   endif
1693
1694   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1695   if (stat .ne. 0) then
1696      CALL wrf_message("Reading data from"//Value//"failed")
1697      Status = WRF_WARN_COUNT_TOO_LONG
1698      RETURN
1699   endif
1700   Outcount = idx
1701
1702   RETURN
1703 END SUBROUTINE ext_gr2_get_var_ti_double
1704
1705 !*****************************************************************************
1706
1707 SUBROUTINE ext_gr2_get_var_ti_integer ( DataHandle,Element,  Varname, Data, &
1708      Count, Outcount, Status )
1709
1710   USE gr2_data_info
1711   IMPLICIT NONE
1712 #include "wrf_status_codes.h"
1713   INTEGER ,       INTENT(IN)       :: DataHandle
1714   CHARACTER*(*) :: Element
1715   CHARACTER*(*) :: VarName
1716   integer ,       INTENT(OUT)      :: Data(*)
1717   INTEGER ,       INTENT(IN)       :: Count
1718   INTEGER ,       INTENT(OUT)      :: OutCount
1719   INTEGER ,       INTENT(OUT)      :: Status
1720   INTEGER          :: idx
1721   INTEGER          :: stat
1722   CHARACTER*(1000) :: VALUE
1723
1724   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_integer')
1725
1726   Status = WRF_NO_ERR
1727
1728   CALL gr2_get_metadata_value(global_input(DataHandle), &
1729        trim(VarName)//';'//trim(Element), Value, stat)
1730   if (stat /= 0) then
1731      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1732      Status = WRF_WARN_VAR_NF
1733      RETURN
1734   endif
1735
1736   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1737   if (stat .ne. 0) then
1738      CALL wrf_message("Reading data from"//Value//"failed")
1739      Status = WRF_WARN_COUNT_TOO_LONG
1740      RETURN
1741   endif
1742   Outcount = idx
1743
1744   RETURN
1745 END SUBROUTINE ext_gr2_get_var_ti_integer
1746
1747 !*****************************************************************************
1748
1749 SUBROUTINE ext_gr2_get_var_ti_logical ( DataHandle,Element,  Varname, Data, &
1750      Count, Outcount, Status )
1751
1752   USE gr2_data_info
1753   IMPLICIT NONE
1754 #include "wrf_status_codes.h"
1755   INTEGER ,       INTENT(IN)       :: DataHandle
1756   CHARACTER*(*) :: Element
1757   CHARACTER*(*) :: VarName
1758   logical ,       INTENT(OUT)      :: Data(*)
1759   INTEGER ,       INTENT(IN)       :: Count
1760   INTEGER ,       INTENT(OUT)      :: OutCount
1761   INTEGER ,       INTENT(OUT)      :: Status
1762   INTEGER          :: idx
1763   INTEGER          :: stat
1764   CHARACTER*(100) :: VALUE
1765
1766   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_logical')
1767
1768   Status = WRF_NO_ERR
1769
1770   CALL gr2_get_metadata_value(global_input(DataHandle), &
1771        trim(VarName)//';'//trim(Element), Value, stat)
1772   if (stat /= 0) then
1773      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1774      Status = WRF_WARN_VAR_NF
1775      RETURN
1776   endif
1777
1778   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1779   if (stat .ne. 0) then
1780      CALL wrf_message("Reading data from"//Value//"failed")
1781      Status = WRF_WARN_COUNT_TOO_LONG
1782      RETURN
1783   endif
1784   Outcount = idx
1785
1786   RETURN
1787 END SUBROUTINE ext_gr2_get_var_ti_logical
1788
1789 !*****************************************************************************
1790
1791 SUBROUTINE ext_gr2_get_var_ti_char ( DataHandle,Element,  Varname, Data,  &
1792      Status )
1793
1794   USE gr2_data_info
1795   IMPLICIT NONE
1796 #include "wrf_status_codes.h"
1797   INTEGER ,       INTENT(IN)  :: DataHandle
1798   CHARACTER*(*) :: Element
1799   CHARACTER*(*) :: VarName
1800   CHARACTER*(*) :: Data
1801   INTEGER ,       INTENT(OUT) :: Status
1802   INTEGER       :: stat
1803
1804   Status = WRF_NO_ERR
1805
1806   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_char')
1807
1808   CALL gr2_get_metadata_value(global_input(DataHandle), &
1809        trim(VarName)//';'//trim(Element), Data, stat)
1810   if (stat /= 0) then
1811      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1812      Status = WRF_WARN_VAR_NF
1813      RETURN
1814   endif
1815
1816   RETURN
1817 END SUBROUTINE ext_gr2_get_var_ti_char
1818
1819 !******************************************************************************
1820 !* End of get_var_ti_* routines
1821 !******************************************************************************
1822
1823
1824 !******************************************************************************
1825 !* Start of put_var_ti_* routines
1826 !******************************************************************************
1827
1828 SUBROUTINE ext_gr2_put_var_ti_real ( DataHandle,Element,  Varname, Data, &
1829      Count,  Status )
1830
1831   USE gr2_data_info
1832   IMPLICIT NONE
1833 #include "wrf_status_codes.h"
1834   INTEGER ,       INTENT(IN)  :: DataHandle
1835   CHARACTER*(*) :: Element
1836   CHARACTER*(*) :: VarName
1837   real ,          INTENT(IN)  :: Data(*)
1838   INTEGER ,       INTENT(IN)  :: Count
1839   INTEGER ,       INTENT(OUT) :: Status
1840   CHARACTER(len=1000) :: tmpstr(1000)
1841   INTEGER             :: idx
1842
1843   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_real')
1844
1845   if (fileinfo(DataHandle)%committed) then
1846
1847      do idx = 1,Count
1848         write(tmpstr(idx),'(G17.10)')Data(idx)
1849      enddo
1850
1851      CALL gr2_build_string (ti_output(DataHandle), &
1852           trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1853
1854   endif
1855
1856   RETURN
1857 END SUBROUTINE ext_gr2_put_var_ti_real
1858
1859 !*****************************************************************************
1860
1861 SUBROUTINE ext_gr2_put_var_ti_double ( DataHandle,Element,  Varname, Data, &
1862      Count,  Status )
1863   USE gr2_data_info
1864   IMPLICIT NONE
1865 #include "wrf_status_codes.h"
1866   INTEGER ,       INTENT(IN)  :: DataHandle
1867   CHARACTER*(*) , INTENT(IN)  :: Element
1868   CHARACTER*(*) , INTENT(IN)  :: VarName
1869   real*8 ,            INTENT(IN) :: Data(*)
1870   INTEGER ,       INTENT(IN)  :: Count
1871   INTEGER ,       INTENT(OUT) :: Status
1872   CHARACTER(len=1000) :: tmpstr(1000)
1873   INTEGER             :: idx
1874
1875   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_double')
1876
1877   if (fileinfo(DataHandle)%committed) then
1878
1879      do idx = 1,Count
1880         write(tmpstr(idx),'(G17.10)')Data(idx)
1881      enddo
1882
1883      CALL gr2_build_string (ti_output(DataHandle), &
1884           trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1885   endif
1886
1887   RETURN
1888 END SUBROUTINE ext_gr2_put_var_ti_double
1889
1890 !*****************************************************************************
1891
1892 SUBROUTINE ext_gr2_put_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
1893      Count,  Status )
1894
1895   USE gr2_data_info
1896   IMPLICIT NONE
1897 #include "wrf_status_codes.h"
1898   INTEGER ,       INTENT(IN)  :: DataHandle
1899   CHARACTER*(*) :: Element
1900   CHARACTER*(*) :: VarName
1901   real*8 ,        INTENT(IN)  :: Data(*)
1902   INTEGER ,       INTENT(IN)  :: Count
1903   INTEGER ,       INTENT(OUT) :: Status
1904   CHARACTER(len=1000) :: tmpstr(1000)
1905   INTEGER             :: idx
1906
1907   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_real8')
1908
1909   if (fileinfo(DataHandle)%committed) then
1910
1911      do idx = 1,Count
1912         write(tmpstr(idx),'(G17.10)')Data(idx)
1913      enddo
1914
1915      CALL gr2_build_string (ti_output(DataHandle), &
1916           trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1917   endif
1918
1919   RETURN
1920 END SUBROUTINE ext_gr2_put_var_ti_real8
1921
1922 !*****************************************************************************
1923
1924 SUBROUTINE ext_gr2_put_var_ti_integer ( DataHandle,Element,  Varname, Data, &
1925      Count,  Status )
1926
1927   USE gr2_data_info
1928   IMPLICIT NONE
1929 #include "wrf_status_codes.h"
1930   INTEGER ,       INTENT(IN)  :: DataHandle
1931   CHARACTER*(*) :: Element
1932   CHARACTER*(*) :: VarName
1933   integer ,       INTENT(IN)  :: Data(*)
1934   INTEGER ,       INTENT(IN)  :: Count
1935   INTEGER ,       INTENT(OUT) :: Status
1936   CHARACTER(len=1000) :: tmpstr(1000)
1937   INTEGER             :: idx
1938
1939   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_integer')
1940
1941   if (fileinfo(DataHandle)%committed) then
1942
1943      do idx = 1,Count
1944         write(tmpstr(idx),'(G17.10)')Data(idx)
1945      enddo
1946
1947      CALL gr2_build_string (ti_output(DataHandle), &
1948           trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1949   endif
1950
1951   RETURN
1952 END SUBROUTINE ext_gr2_put_var_ti_integer
1953
1954 !*****************************************************************************
1955
1956 SUBROUTINE ext_gr2_put_var_ti_logical ( DataHandle,Element,  Varname, Data, &
1957      Count,  Status )
1958
1959   USE gr2_data_info
1960   IMPLICIT NONE
1961 #include "wrf_status_codes.h"
1962   INTEGER ,       INTENT(IN)  :: DataHandle
1963   CHARACTER*(*) :: Element
1964   CHARACTER*(*) :: VarName
1965   logical ,       INTENT(IN)  :: Data(*)
1966   INTEGER ,       INTENT(IN)  :: Count
1967   INTEGER ,       INTENT(OUT) :: Status
1968   CHARACTER(len=1000) :: tmpstr(1000)
1969   INTEGER             :: idx
1970
1971   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_logical')
1972
1973   if (fileinfo(DataHandle)%committed) then
1974
1975      do idx = 1,Count
1976         write(tmpstr(idx),'(G17.10)')Data(idx)
1977      enddo
1978
1979      CALL gr2_build_string (ti_output(DataHandle), &
1980           trim(Varname)//';'//trim(Element), tmpstr, Count, Status)
1981
1982   endif
1983
1984 RETURN
1985 END SUBROUTINE ext_gr2_put_var_ti_logical
1986
1987 !*****************************************************************************
1988
1989 SUBROUTINE ext_gr2_put_var_ti_char ( DataHandle,Element,  Varname, Data,  &
1990      Status )
1991
1992   USE gr2_data_info
1993   IMPLICIT NONE
1994 #include "wrf_status_codes.h"
1995   INTEGER ,       INTENT(IN)  :: DataHandle
1996   CHARACTER(len=*) :: Element
1997   CHARACTER(len=*) :: VarName
1998   CHARACTER(len=*) :: Data
1999   INTEGER ,       INTENT(OUT) :: Status
2000   REAL dummy
2001   INTEGER                     :: Count
2002   CHARACTER(len=1000) :: tmpstr(1)
2003   INTEGER             :: idx
2004
2005   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_char')
2006
2007   if (fileinfo(DataHandle)%committed) then
2008
2009      write(tmpstr(1),*)trim(Data)
2010
2011      CALL gr2_build_string (ti_output(DataHandle), &
2012           trim(VarName)//';'//trim(Element), tmpstr, 1, Status)
2013
2014   endif
2015
2016   RETURN
2017 END SUBROUTINE ext_gr2_put_var_ti_char
2018
2019 !******************************************************************************
2020 !* End of put_var_ti_* routines
2021 !******************************************************************************
2022
2023 !******************************************************************************
2024 !* Start of get_var_td_* routines
2025 !******************************************************************************
2026
2027 SUBROUTINE ext_gr2_get_var_td_double ( DataHandle,Element,  DateStr, &
2028      Varname, Data, Count, Outcount, Status )
2029   USE gr2_data_info
2030   IMPLICIT NONE
2031 #include "wrf_status_codes.h"
2032   INTEGER ,       INTENT(IN)  :: DataHandle
2033   CHARACTER*(*) , INTENT(IN)  :: Element
2034   CHARACTER*(*) , INTENT(IN)  :: DateStr
2035   CHARACTER*(*) , INTENT(IN)  :: VarName
2036   real*8 ,            INTENT(OUT) :: Data(*)
2037   INTEGER ,       INTENT(IN)  :: Count
2038   INTEGER ,       INTENT(OUT)  :: OutCount
2039   INTEGER ,       INTENT(OUT) :: Status
2040   INTEGER          :: idx
2041   INTEGER          :: stat
2042   CHARACTER*(1000) :: VALUE
2043
2044   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_double')
2045
2046   Status = WRF_NO_ERR
2047
2048   CALL gr2_get_metadata_value(global_input(DataHandle), &
2049        trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2050   if (stat /= 0) then
2051      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2052      Status = WRF_WARN_VAR_NF
2053      RETURN
2054   endif
2055
2056   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2057   if (stat .ne. 0) then
2058      CALL wrf_message("Reading data from"//Value//"failed")
2059      Status = WRF_WARN_COUNT_TOO_LONG
2060      RETURN
2061   endif
2062   Outcount = idx
2063
2064 RETURN
2065 END SUBROUTINE ext_gr2_get_var_td_double
2066
2067 !*****************************************************************************
2068
2069 SUBROUTINE ext_gr2_get_var_td_real ( DataHandle,Element,  DateStr,Varname, &
2070      Data, Count, Outcount, Status )
2071
2072   USE gr2_data_info
2073   IMPLICIT NONE
2074 #include "wrf_status_codes.h"
2075   INTEGER ,       INTENT(IN)  :: DataHandle
2076   CHARACTER*(*) :: Element
2077   CHARACTER*(*) :: DateStr
2078   CHARACTER*(*) :: VarName
2079   real ,          INTENT(OUT) :: Data(*)
2080   INTEGER ,       INTENT(IN)  :: Count
2081   INTEGER ,       INTENT(OUT) :: OutCount
2082   INTEGER ,       INTENT(OUT) :: Status
2083   INTEGER          :: idx
2084   INTEGER          :: stat
2085   CHARACTER*(1000) :: VALUE
2086
2087   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_real')
2088
2089   Status = WRF_NO_ERR
2090
2091   CALL gr2_get_metadata_value(global_input(DataHandle), &
2092        trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2093   if (stat /= 0) then
2094      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2095      Status = WRF_WARN_VAR_NF
2096      RETURN
2097   endif
2098
2099   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2100   if (stat .ne. 0) then
2101      CALL wrf_message("Reading data from"//Value//"failed")
2102      Status = WRF_WARN_COUNT_TOO_LONG
2103      RETURN
2104   endif
2105   Outcount = idx
2106
2107   RETURN
2108 END SUBROUTINE ext_gr2_get_var_td_real
2109
2110 !*****************************************************************************
2111
2112 SUBROUTINE ext_gr2_get_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
2113      Data, Count, Outcount, Status )
2114
2115   USE gr2_data_info
2116   IMPLICIT NONE
2117 #include "wrf_status_codes.h"
2118   INTEGER ,       INTENT(IN)  :: DataHandle
2119   CHARACTER*(*) :: Element
2120   CHARACTER*(*) :: DateStr
2121   CHARACTER*(*) :: VarName
2122   real*8 ,        INTENT(OUT) :: Data(*)
2123   INTEGER ,       INTENT(IN)  :: Count
2124   INTEGER ,       INTENT(OUT) :: OutCount
2125   INTEGER ,       INTENT(OUT) :: Status
2126   INTEGER          :: idx
2127   INTEGER          :: stat
2128   CHARACTER*(1000) :: VALUE
2129
2130   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_real8')
2131
2132   Status = WRF_NO_ERR
2133
2134   CALL gr2_get_metadata_value(global_input(DataHandle), &
2135        trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2136   if (stat /= 0) then
2137      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2138      Status = WRF_WARN_VAR_NF
2139      RETURN
2140   endif
2141
2142   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2143   if (stat .ne. 0) then
2144      CALL wrf_message("Reading data from"//Value//"failed")
2145      Status = WRF_WARN_COUNT_TOO_LONG
2146      RETURN
2147   endif
2148   Outcount = idx
2149
2150   RETURN
2151 END SUBROUTINE ext_gr2_get_var_td_real8
2152
2153 !*****************************************************************************
2154
2155 SUBROUTINE ext_gr2_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, &
2156      Data, Count, Outcount, Status )
2157
2158   USE gr2_data_info
2159   IMPLICIT NONE
2160 #include "wrf_status_codes.h"
2161   INTEGER ,       INTENT(IN)  :: DataHandle
2162   CHARACTER*(*) :: Element
2163   CHARACTER*(*) :: DateStr
2164   CHARACTER*(*) :: VarName
2165   integer ,       INTENT(OUT) :: Data(*)
2166   INTEGER ,       INTENT(IN)  :: Count
2167   INTEGER ,       INTENT(OUT) :: OutCount
2168   INTEGER ,       INTENT(OUT) :: Status
2169   INTEGER          :: idx
2170   INTEGER          :: stat
2171   CHARACTER*(1000) :: VALUE
2172
2173   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_integer')
2174
2175   Status = WRF_NO_ERR
2176
2177   CALL gr2_get_metadata_value(global_input(DataHandle), &
2178        trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2179   if (stat /= 0) then
2180      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2181      Status = WRF_WARN_VAR_NF
2182      RETURN
2183   endif
2184
2185   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2186   if (stat .ne. 0) then
2187      CALL wrf_message("Reading data from"//Value//"failed")
2188      Status = WRF_WARN_COUNT_TOO_LONG
2189      RETURN
2190   endif
2191   Outcount = idx
2192
2193   RETURN
2194 END SUBROUTINE ext_gr2_get_var_td_integer
2195
2196 !*****************************************************************************
2197
2198 SUBROUTINE ext_gr2_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, &
2199      Data, Count, Outcount, Status )
2200
2201   USE gr2_data_info
2202   IMPLICIT NONE
2203 #include "wrf_status_codes.h"
2204   INTEGER ,       INTENT(IN)  :: DataHandle
2205   CHARACTER*(*) :: Element
2206   CHARACTER*(*) :: DateStr
2207   CHARACTER*(*) :: VarName
2208   logical ,       INTENT(OUT) :: Data(*)
2209   INTEGER ,       INTENT(IN)  :: Count
2210   INTEGER ,       INTENT(OUT) :: OutCount
2211   INTEGER ,       INTENT(OUT) :: Status
2212   INTEGER          :: idx
2213   INTEGER          :: stat
2214   CHARACTER*(1000) :: VALUE
2215
2216   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_logical')
2217
2218   Status = WRF_NO_ERR
2219
2220   CALL gr2_get_metadata_value(global_input(DataHandle), &
2221        trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2222   if (stat /= 0) then
2223      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2224      Status = WRF_WARN_VAR_NF
2225      RETURN
2226   endif
2227
2228   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2229   if (stat .ne. 0) then
2230      CALL wrf_message("Reading data from"//Value//"failed")
2231      Status = WRF_WARN_COUNT_TOO_LONG
2232      RETURN
2233   endif
2234   Outcount = idx
2235
2236   RETURN
2237 END SUBROUTINE ext_gr2_get_var_td_logical
2238
2239 !*****************************************************************************
2240
2241 SUBROUTINE ext_gr2_get_var_td_char ( DataHandle,Element,  DateStr,Varname, &
2242      Data,  Status )
2243
2244   USE gr2_data_info
2245   IMPLICIT NONE
2246 #include "wrf_status_codes.h"
2247   INTEGER ,       INTENT(IN)  :: DataHandle
2248   CHARACTER*(*) :: Element
2249   CHARACTER*(*) :: DateStr
2250   CHARACTER*(*) :: VarName
2251   CHARACTER*(*) :: Data
2252   INTEGER ,       INTENT(OUT) :: Status
2253   INTEGER       :: stat
2254
2255   Status = WRF_NO_ERR
2256
2257   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_char')
2258
2259   CALL gr2_get_metadata_value(global_input(DataHandle), &
2260        trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Data, stat)
2261   if (stat /= 0) then
2262      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2263      Status = WRF_WARN_VAR_NF
2264      RETURN
2265   endif
2266
2267   RETURN
2268 END SUBROUTINE ext_gr2_get_var_td_char
2269
2270 !******************************************************************************
2271 !* End of get_var_td_* routines
2272 !******************************************************************************
2273
2274 !******************************************************************************
2275 !* Start of put_var_td_* routines
2276 !******************************************************************************
2277
2278 SUBROUTINE ext_gr2_put_var_td_double ( DataHandle, Element, DateStr, Varname, &
2279      Data, Count,  Status )
2280   USE gr2_data_info
2281   IMPLICIT NONE
2282 #include "wrf_status_codes.h"
2283   INTEGER ,       INTENT(IN)  :: DataHandle
2284   CHARACTER*(*) , INTENT(IN)  :: Element
2285   CHARACTER*(*) , INTENT(IN)  :: DateStr
2286   CHARACTER*(*) , INTENT(IN)  :: VarName
2287   real*8 ,            INTENT(IN) :: Data(*)
2288   INTEGER ,       INTENT(IN)  :: Count
2289   INTEGER ,       INTENT(OUT) :: Status
2290   CHARACTER(len=1000) :: tmpstr(1000)
2291   INTEGER             :: idx
2292
2293   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_double')
2294
2295
2296   if (fileinfo(DataHandle)%committed) then
2297
2298      do idx = 1,Count
2299         write(tmpstr(idx),'(G17.10)')Data(idx)
2300      enddo
2301
2302      CALL gr2_build_string (td_output(DataHandle), &
2303           trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2304           tmpstr, Count, Status)
2305
2306   endif
2307
2308 RETURN
2309 END SUBROUTINE ext_gr2_put_var_td_double
2310
2311 !*****************************************************************************
2312
2313 SUBROUTINE ext_gr2_put_var_td_integer ( DataHandle,Element,  DateStr, &
2314      Varname, Data, Count,  Status )
2315
2316   USE gr2_data_info
2317   IMPLICIT NONE
2318 #include "wrf_status_codes.h"
2319   INTEGER ,       INTENT(IN)  :: DataHandle
2320   CHARACTER*(*) :: Element
2321   CHARACTER*(*) :: DateStr
2322   CHARACTER*(*) :: VarName
2323   integer ,       INTENT(IN)  :: Data(*)
2324   INTEGER ,       INTENT(IN)  :: Count
2325   INTEGER ,       INTENT(OUT) :: Status
2326   CHARACTER(len=1000) :: tmpstr(1000)
2327   INTEGER             :: idx
2328
2329   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_integer')
2330
2331   if (fileinfo(DataHandle)%committed) then
2332
2333      do idx = 1,Count
2334         write(tmpstr(idx),'(G17.10)')Data(idx)
2335      enddo
2336
2337      CALL gr2_build_string (td_output(DataHandle), &
2338           trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2339           tmpstr, Count, Status)
2340
2341   endif
2342
2343 RETURN
2344 END SUBROUTINE ext_gr2_put_var_td_integer
2345
2346 !*****************************************************************************
2347
2348 SUBROUTINE ext_gr2_put_var_td_real ( DataHandle,Element,  DateStr,Varname, &
2349      Data, Count,  Status )
2350
2351   USE gr2_data_info
2352   IMPLICIT NONE
2353 #include "wrf_status_codes.h"
2354   INTEGER ,       INTENT(IN)  :: DataHandle
2355   CHARACTER*(*) :: Element
2356   CHARACTER*(*) :: DateStr
2357   CHARACTER*(*) :: VarName
2358   real ,          INTENT(IN)  :: Data(*)
2359   INTEGER ,       INTENT(IN)  :: Count
2360   INTEGER ,       INTENT(OUT) :: Status
2361   CHARACTER(len=1000) :: tmpstr(1000)
2362   INTEGER             :: idx
2363
2364   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_real')
2365
2366   if (fileinfo(DataHandle)%committed) then
2367
2368      do idx = 1,Count
2369         write(tmpstr(idx),'(G17.10)')Data(idx)
2370      enddo
2371
2372      CALL gr2_build_string (td_output(DataHandle), &
2373           trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2374           tmpstr, Count, Status)
2375
2376   endif
2377
2378   RETURN
2379 END SUBROUTINE ext_gr2_put_var_td_real
2380
2381 !*****************************************************************************
2382
2383 SUBROUTINE ext_gr2_put_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
2384      Data, Count,  Status )
2385
2386   USE gr2_data_info
2387   IMPLICIT NONE
2388 #include "wrf_status_codes.h"
2389   INTEGER ,       INTENT(IN)  :: DataHandle
2390   CHARACTER*(*) :: Element
2391   CHARACTER*(*) :: DateStr
2392   CHARACTER*(*) :: VarName
2393   real*8 ,        INTENT(IN)  :: Data(*)
2394   INTEGER ,       INTENT(IN)  :: Count
2395   INTEGER ,       INTENT(OUT) :: Status
2396   CHARACTER(len=1000) :: tmpstr(1000)
2397   INTEGER             :: idx
2398
2399   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_real8')
2400
2401   if (fileinfo(DataHandle)%committed) then
2402      do idx = 1,Count
2403         write(tmpstr(idx),'(G17.10)')Data(idx)
2404      enddo
2405
2406      CALL gr2_build_string (td_output(DataHandle), &
2407           trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2408           tmpstr, Count, Status)
2409   endif
2410
2411   RETURN
2412 END SUBROUTINE ext_gr2_put_var_td_real8
2413
2414 !*****************************************************************************
2415
2416 SUBROUTINE ext_gr2_put_var_td_logical ( DataHandle,Element,  DateStr, &
2417      Varname, Data, Count,  Status )
2418
2419   USE gr2_data_info
2420   IMPLICIT NONE
2421 #include "wrf_status_codes.h"
2422   INTEGER ,       INTENT(IN)  :: DataHandle
2423   CHARACTER*(*) :: Element
2424   CHARACTER*(*) :: DateStr
2425   CHARACTER*(*) :: VarName
2426   logical ,       INTENT(IN)  :: Data(*)
2427   INTEGER ,       INTENT(IN)  :: Count
2428   INTEGER ,       INTENT(OUT) :: Status
2429   CHARACTER(len=1000) :: tmpstr(1000)
2430   INTEGER             :: idx
2431
2432   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_logical')
2433
2434   if (fileinfo(DataHandle)%committed) then
2435
2436      do idx = 1,Count
2437         write(tmpstr(idx),'(G17.10)')Data(idx)
2438      enddo
2439
2440      CALL gr2_build_string (td_output(DataHandle), &
2441           trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2442           tmpstr, Count, Status)
2443
2444   endif
2445
2446   RETURN
2447 END SUBROUTINE ext_gr2_put_var_td_logical
2448
2449 !*****************************************************************************
2450
2451 SUBROUTINE ext_gr2_put_var_td_char ( DataHandle,Element,  DateStr,Varname, &
2452      Data,  Status )
2453
2454   USE gr2_data_info
2455   IMPLICIT NONE
2456 #include "wrf_status_codes.h"
2457   INTEGER ,       INTENT(IN)  :: DataHandle
2458   CHARACTER*(*) :: Element
2459   CHARACTER*(*) :: DateStr
2460   CHARACTER*(*) :: VarName
2461   CHARACTER*(*) :: Data
2462   INTEGER ,       INTENT(OUT) :: Status
2463   CHARACTER(len=1000) :: tmpstr(1)
2464   INTEGER             :: idx
2465
2466   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_char')
2467
2468   if (fileinfo(DataHandle)%committed) then
2469
2470      write(tmpstr(idx),*)Data
2471
2472      CALL gr2_build_string (td_output(DataHandle), &
2473           trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2474           tmpstr, 1, Status)
2475
2476   endif
2477
2478   RETURN
2479 END SUBROUTINE ext_gr2_put_var_td_char
2480
2481 !******************************************************************************
2482 !* End of put_var_td_* routines
2483 !******************************************************************************
2484
2485
2486 !******************************************************************************
2487 !* Start of get_dom_ti_* routines
2488 !******************************************************************************
2489
2490 SUBROUTINE ext_gr2_get_dom_ti_real ( DataHandle,Element,   Data, Count, &
2491      Outcount, Status )
2492
2493   USE gr2_data_info
2494   IMPLICIT NONE
2495 #include "wrf_status_codes.h"
2496   INTEGER ,       INTENT(IN)  :: DataHandle
2497   CHARACTER*(*) :: Element
2498   real ,          INTENT(OUT) :: Data(*)
2499   INTEGER ,       INTENT(IN)  :: Count
2500   INTEGER ,       INTENT(OUT) :: Outcount
2501   INTEGER ,       INTENT(OUT) :: Status
2502   INTEGER          :: idx
2503   INTEGER          :: stat
2504   CHARACTER*(1000) :: VALUE
2505
2506   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_real')
2507
2508   Status = WRF_NO_ERR
2509
2510   CALL gr2_get_metadata_value(global_input(DataHandle), &
2511        trim(Element), Value, stat)
2512   if (stat /= 0) then
2513      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2514      Status = WRF_WARN_VAR_NF
2515      RETURN
2516   endif
2517
2518   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2519   if (stat .ne. 0) then
2520      CALL wrf_message("Reading data from"//Value//"failed")
2521      Status = WRF_WARN_COUNT_TOO_LONG
2522      RETURN
2523   endif
2524   Outcount = idx
2525
2526   RETURN
2527 END SUBROUTINE ext_gr2_get_dom_ti_real
2528
2529 !*****************************************************************************
2530
2531 SUBROUTINE ext_gr2_get_dom_ti_real8 ( DataHandle,Element,   Data, Count, &
2532      Outcount, Status )
2533
2534   USE gr2_data_info
2535   IMPLICIT NONE
2536 #include "wrf_status_codes.h"
2537   INTEGER ,       INTENT(IN)  :: DataHandle
2538   CHARACTER*(*) :: Element
2539   real*8 ,        INTENT(OUT) :: Data(*)
2540   INTEGER ,       INTENT(IN)  :: Count
2541   INTEGER ,       INTENT(OUT) :: OutCount
2542   INTEGER ,       INTENT(OUT) :: Status
2543   INTEGER          :: idx
2544   INTEGER          :: stat
2545   CHARACTER*(1000) :: VALUE
2546
2547   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_real8')
2548
2549   Status = WRF_NO_ERR
2550
2551   CALL gr2_get_metadata_value(global_input(DataHandle), &
2552        trim(Element), Value, stat)
2553   if (stat /= 0) then
2554      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2555      Status = WRF_WARN_VAR_NF
2556      RETURN
2557   endif
2558
2559   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2560   if (stat .ne. 0) then
2561      CALL wrf_message("Reading data from"//Value//"failed")
2562      Status = WRF_WARN_COUNT_TOO_LONG
2563      RETURN
2564   endif
2565   Outcount = idx
2566
2567   RETURN
2568 END SUBROUTINE ext_gr2_get_dom_ti_real8
2569
2570 !*****************************************************************************
2571
2572 SUBROUTINE ext_gr2_get_dom_ti_integer ( DataHandle,Element,   Data, Count, &
2573      Outcount, Status )
2574
2575   USE gr2_data_info
2576   IMPLICIT NONE
2577 #include "wrf_status_codes.h"
2578   INTEGER ,       INTENT(IN)  :: DataHandle
2579   CHARACTER*(*) :: Element
2580   integer ,       INTENT(OUT) :: Data(*)
2581   INTEGER ,       INTENT(IN)  :: Count
2582   INTEGER ,       INTENT(OUT) :: OutCount
2583   INTEGER ,       INTENT(OUT) :: Status
2584   INTEGER          :: idx
2585   INTEGER          :: stat
2586   CHARACTER*(1000) :: VALUE
2587
2588   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_integer Element: '//Element)
2589
2590   CALL gr2_get_metadata_value(global_input(DataHandle), &
2591        trim(Element), Value, stat)
2592   if (stat /= 0) then
2593      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2594      Status = WRF_WARN_VAR_NF
2595      RETURN
2596   endif
2597
2598   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2599   if (stat .ne. 0) then
2600      CALL wrf_message("Reading data from"//Value//"failed")
2601      Status = WRF_WARN_COUNT_TOO_LONG
2602      RETURN
2603   endif
2604   Outcount = Count
2605
2606   RETURN
2607 END SUBROUTINE ext_gr2_get_dom_ti_integer
2608
2609 !*****************************************************************************
2610
2611 SUBROUTINE ext_gr2_get_dom_ti_logical ( DataHandle,Element,   Data, Count, &
2612      Outcount, Status )
2613
2614   USE gr2_data_info
2615   IMPLICIT NONE
2616 #include "wrf_status_codes.h"
2617   INTEGER ,       INTENT(IN)  :: DataHandle
2618   CHARACTER*(*) :: Element
2619   logical ,       INTENT(OUT) :: Data(*)
2620   INTEGER ,       INTENT(IN)  :: Count
2621   INTEGER ,       INTENT(OUT) :: OutCount
2622   INTEGER ,       INTENT(OUT) :: Status
2623   INTEGER          :: idx
2624   INTEGER          :: stat
2625   CHARACTER*(1000) :: VALUE
2626
2627   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_logical')
2628
2629   Status = WRF_NO_ERR
2630
2631   CALL gr2_get_metadata_value(global_input(DataHandle), &
2632        trim(Element), Value, stat)
2633   if (stat /= 0) then
2634      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2635      Status = WRF_WARN_VAR_NF
2636      RETURN
2637   endif
2638
2639   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2640   if (stat .ne. 0) then
2641      CALL wrf_message("Reading data from"//Value//"failed")
2642      Status = WRF_WARN_COUNT_TOO_LONG
2643      RETURN
2644   endif
2645   Outcount = idx
2646
2647   RETURN
2648 END SUBROUTINE ext_gr2_get_dom_ti_logical
2649
2650 !*****************************************************************************
2651
2652 SUBROUTINE ext_gr2_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
2653
2654   USE gr2_data_info
2655   IMPLICIT NONE
2656 #include "wrf_status_codes.h"
2657   INTEGER ,       INTENT(IN)  :: DataHandle
2658   CHARACTER*(*) :: Element
2659   CHARACTER*(*) :: Data
2660   INTEGER ,       INTENT(OUT) :: Status
2661   INTEGER       :: stat
2662   INTEGER       :: endchar
2663
2664   Status = WRF_NO_ERR
2665
2666   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_char')
2667
2668   CALL gr2_get_metadata_value(global_input(DataHandle), &
2669        trim(Element), Data, stat)
2670   if (stat /= 0) then
2671      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2672      Status = WRF_WARN_VAR_NF
2673      RETURN
2674   endif
2675
2676   RETURN
2677 END SUBROUTINE ext_gr2_get_dom_ti_char
2678
2679 !*****************************************************************************
2680
2681 SUBROUTINE ext_gr2_get_dom_ti_double ( DataHandle,Element,   Data, Count, &
2682      Outcount, Status )
2683   USE gr2_data_info
2684   IMPLICIT NONE
2685 #include "wrf_status_codes.h"
2686   INTEGER ,       INTENT(IN)  :: DataHandle
2687   CHARACTER*(*) , INTENT(IN)  :: Element
2688   real*8 ,            INTENT(OUT) :: Data(*)
2689   INTEGER ,       INTENT(IN)  :: Count
2690   INTEGER ,       INTENT(OUT)  :: OutCount
2691   INTEGER ,       INTENT(OUT) :: Status
2692   INTEGER          :: idx
2693   INTEGER          :: stat
2694   CHARACTER*(1000) :: VALUE
2695
2696   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_double')
2697
2698   Status = WRF_NO_ERR
2699
2700   CALL gr2_get_metadata_value(global_input(DataHandle), &
2701        trim(Element), Value, stat)
2702   if (stat /= 0) then
2703      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2704      Status = WRF_WARN_VAR_NF
2705      RETURN
2706   endif
2707
2708   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2709   if (stat .ne. 0) then
2710      CALL wrf_message("Reading data from"//Value//"failed")
2711      Status = WRF_WARN_COUNT_TOO_LONG
2712      RETURN
2713   endif
2714   Outcount = idx
2715
2716 RETURN
2717 END SUBROUTINE ext_gr2_get_dom_ti_double
2718
2719 !******************************************************************************
2720 !* End of get_dom_ti_* routines
2721 !******************************************************************************
2722
2723
2724 !******************************************************************************
2725 !* Start of put_dom_ti_* routines
2726 !******************************************************************************
2727
2728 SUBROUTINE ext_gr2_put_dom_ti_real ( DataHandle,Element,   Data, Count,  &
2729      Status )
2730
2731   USE gr2_data_info
2732   IMPLICIT NONE
2733 #include "wrf_status_codes.h"
2734   INTEGER ,       INTENT(IN)  :: DataHandle
2735   CHARACTER*(*) :: Element
2736   real ,          INTENT(IN)  :: Data(*)
2737   INTEGER ,       INTENT(IN)  :: Count
2738   INTEGER ,       INTENT(OUT) :: Status
2739   REAL dummy
2740   CHARACTER(len=1000) :: tmpstr(1000)
2741   character(len=2)    :: lf
2742   integer             :: idx
2743
2744   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_real')
2745
2746   if (Element .eq. 'DX') then
2747      dx = Data(1)/1000.
2748   endif
2749   if (Element .eq. 'DY') then
2750      dy = Data(1)/1000.
2751   endif
2752   if (Element .eq. 'CEN_LAT') then
2753      center_lat = Data(1)
2754   endif
2755   if (Element .eq. 'CEN_LON') then
2756      center_lon = Data(1)
2757   endif
2758   if (Element .eq. 'TRUELAT1') then
2759      truelat1 = Data(1)
2760   endif
2761   if (Element .eq. 'TRUELAT2') then
2762      truelat2 = Data(1)
2763   endif
2764   if (Element == 'STAND_LON') then
2765      proj_central_lon = Data(1)
2766   endif
2767   if (Element == 'DT') then
2768      timestep = Data(1)
2769   endif
2770
2771   if (fileinfo(DataHandle)%committed) then
2772
2773      do idx = 1,Count
2774         write(tmpstr(idx),'(G17.10)')Data(idx)
2775      enddo
2776
2777      CALL gr2_build_string (ti_output(DataHandle), Element, &
2778           tmpstr, Count, Status)
2779
2780   endif
2781
2782   RETURN
2783 END SUBROUTINE ext_gr2_put_dom_ti_real
2784
2785 !*****************************************************************************
2786
2787 SUBROUTINE ext_gr2_put_dom_ti_real8 ( DataHandle,Element,   Data, Count,  &
2788      Status )
2789
2790   USE gr2_data_info
2791   IMPLICIT NONE
2792 #include "wrf_status_codes.h"
2793   INTEGER ,       INTENT(IN)  :: DataHandle
2794   CHARACTER*(*) :: Element
2795   real*8 ,        INTENT(IN)  :: Data(*)
2796   INTEGER ,       INTENT(IN)  :: Count
2797   INTEGER ,       INTENT(OUT) :: Status
2798   CHARACTER(len=1000) :: tmpstr(1000)
2799   INTEGER             :: idx
2800
2801   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_real8')
2802
2803   if (fileinfo(DataHandle)%committed) then
2804
2805      do idx = 1,Count
2806         write(tmpstr(idx),'(G17.10)')Data(idx)
2807      enddo
2808
2809      CALL gr2_build_string (ti_output(DataHandle), Element, &
2810           tmpstr, Count, Status)
2811
2812   endif
2813
2814   RETURN
2815 END SUBROUTINE ext_gr2_put_dom_ti_real8
2816
2817 !*****************************************************************************
2818
2819 SUBROUTINE ext_gr2_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  &
2820      Status )
2821
2822   USE gr2_data_info
2823   IMPLICIT NONE
2824 #include "wrf_status_codes.h"
2825   INTEGER ,       INTENT(IN)  :: DataHandle
2826   CHARACTER*(*) :: Element
2827   INTEGER ,       INTENT(IN)  :: Data(*)
2828   INTEGER ,       INTENT(IN)  :: Count
2829   INTEGER ,       INTENT(OUT) :: Status
2830   REAL dummy
2831   CHARACTER(len=1000) :: tmpstr(1000)
2832   INTEGER             :: idx
2833
2834
2835   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_integer')
2836
2837   if (Element == 'WEST-EAST_GRID_DIMENSION') then
2838      full_xsize = Data(1)
2839   else if (Element == 'SOUTH-NORTH_GRID_DIMENSION') then
2840      full_ysize = Data(1)
2841   else if (Element == 'MAP_PROJ') then
2842      wrf_projection = Data(1)
2843   else if (Element == 'BACKGROUND_PROC_ID') then
2844      background_proc_id = Data(1)
2845   else if (Element == 'FORECAST_PROC_ID') then
2846      forecast_proc_id = Data(1)
2847   else if (Element == 'PRODUCTION_STATUS') then
2848      production_status = Data(1)
2849   else if (Element == 'COMPRESSION') then
2850      compression = Data(1)
2851   endif
2852
2853   if (fileinfo(DataHandle)%committed) then
2854
2855      do idx = 1,Count
2856         write(tmpstr(idx),'(G17.10)')Data(idx)
2857      enddo
2858
2859      CALL gr2_build_string (ti_output(DataHandle), Element, &
2860           tmpstr, Count, Status)
2861
2862   endif
2863
2864   call wrf_debug ( DEBUG , 'Leaving ext_gr2_put_dom_ti_integer')
2865
2866   RETURN
2867 END SUBROUTINE ext_gr2_put_dom_ti_integer
2868
2869 !*****************************************************************************
2870
2871 SUBROUTINE ext_gr2_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  &
2872      Status )
2873
2874   USE gr2_data_info
2875   IMPLICIT NONE
2876 #include "wrf_status_codes.h"
2877   INTEGER ,       INTENT(IN)  :: DataHandle
2878   CHARACTER*(*) :: Element
2879   logical ,       INTENT(IN)  :: Data(*)
2880   INTEGER ,       INTENT(IN)  :: Count
2881   INTEGER ,       INTENT(OUT) :: Status
2882   CHARACTER(len=1000) :: tmpstr(1000)
2883   INTEGER             :: idx
2884
2885   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_logical')
2886
2887   if (fileinfo(DataHandle)%committed) then
2888
2889      do idx = 1,Count
2890         write(tmpstr(idx),'(G17.10)')Data(idx)
2891      enddo
2892
2893      CALL gr2_build_string (ti_output(DataHandle), Element, &
2894           tmpstr, Count, Status)
2895
2896   endif
2897
2898   RETURN
2899 END SUBROUTINE ext_gr2_put_dom_ti_logical
2900
2901 !*****************************************************************************
2902
2903 SUBROUTINE ext_gr2_put_dom_ti_char ( DataHandle,Element,   Data,  &
2904      Status )
2905
2906   USE gr2_data_info
2907   IMPLICIT NONE
2908 #include "wrf_status_codes.h"
2909   INTEGER ,       INTENT(IN)  :: DataHandle
2910   CHARACTER*(*) :: Element
2911   CHARACTER*(*),     INTENT(IN)  :: Data
2912   INTEGER ,       INTENT(OUT) :: Status
2913   REAL dummy
2914   CHARACTER(len=1000) :: tmpstr
2915
2916   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_char')
2917
2918   if (Element .eq. 'START_DATE') then
2919
2920      !
2921      ! This is just a hack to fix a problem when outputting restart.  WRF
2922      !   outputs both the initialization time and the time of the restart
2923      !   as the StartDate.  So, we ll just take the earliest.
2924      !
2925      if ((StartDate .eq. '') .or. (Data .le. StartDate)) then
2926         StartDate = Data
2927      endif
2928
2929   endif
2930
2931   if (fileinfo(DataHandle)%committed) then
2932
2933      write(tmpstr,*)trim(Data)
2934
2935      CALL gr2_build_string (ti_output(DataHandle), Element, &
2936           tmpstr, 1, Status)
2937
2938   endif
2939
2940   RETURN
2941 END SUBROUTINE ext_gr2_put_dom_ti_char
2942
2943 !*****************************************************************************
2944
2945 SUBROUTINE ext_gr2_put_dom_ti_double ( DataHandle,Element, Data, Count, &
2946      Status )
2947   USE gr2_data_info
2948   IMPLICIT NONE
2949 #include "wrf_status_codes.h"
2950   INTEGER ,       INTENT(IN)  :: DataHandle
2951   CHARACTER*(*) , INTENT(IN)  :: Element
2952   real*8 ,            INTENT(IN) :: Data(*)
2953   INTEGER ,       INTENT(IN)  :: Count
2954   INTEGER ,       INTENT(OUT) :: Status
2955   CHARACTER(len=1000) :: tmpstr(1000)
2956   INTEGER             :: idx
2957
2958   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_double')
2959
2960   if (fileinfo(DataHandle)%committed) then
2961
2962      do idx = 1,Count
2963         write(tmpstr(idx),'(G17.10)')Data(idx)
2964      enddo
2965
2966      CALL gr2_build_string (ti_output(DataHandle), Element, &
2967           tmpstr, Count, Status)
2968
2969   endif
2970
2971   RETURN
2972 END SUBROUTINE ext_gr2_put_dom_ti_double
2973
2974 !******************************************************************************
2975 !* End of put_dom_ti_* routines
2976 !******************************************************************************
2977
2978
2979 !******************************************************************************
2980 !* Start of get_dom_td_* routines
2981 !******************************************************************************
2982
2983 SUBROUTINE ext_gr2_get_dom_td_real ( DataHandle,Element, DateStr,  Data, &
2984      Count, Outcount, Status )
2985
2986   USE gr2_data_info
2987   IMPLICIT NONE
2988 #include "wrf_status_codes.h"
2989   INTEGER ,       INTENT(IN)  :: DataHandle
2990   CHARACTER*(*) :: Element
2991   CHARACTER*(*) :: DateStr
2992   real ,          INTENT(OUT) :: Data(*)
2993   INTEGER ,       INTENT(IN)  :: Count
2994   INTEGER ,       INTENT(OUT) :: OutCount
2995   INTEGER ,       INTENT(OUT) :: Status
2996   INTEGER          :: idx
2997   INTEGER          :: stat
2998   CHARACTER*(1000) :: VALUE
2999
3000   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_real')
3001
3002   Status = WRF_NO_ERR
3003
3004   CALL gr2_get_metadata_value(global_input(DataHandle), &
3005        trim(DateStr)//';'//trim(Element), Value, stat)
3006   if (stat /= 0) then
3007      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3008      Status = WRF_WARN_VAR_NF
3009      RETURN
3010   endif
3011
3012   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3013   if (stat .ne. 0) then
3014      CALL wrf_message("Reading data from"//Value//"failed")
3015      Status = WRF_WARN_COUNT_TOO_LONG
3016      RETURN
3017   endif
3018   Outcount = idx
3019
3020   RETURN
3021 END SUBROUTINE ext_gr2_get_dom_td_real
3022
3023 !*****************************************************************************
3024
3025 SUBROUTINE ext_gr2_get_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
3026      Count, Outcount, Status )
3027
3028   USE gr2_data_info
3029   IMPLICIT NONE
3030 #include "wrf_status_codes.h"
3031   INTEGER ,       INTENT(IN)  :: DataHandle
3032   CHARACTER*(*) :: Element
3033   CHARACTER*(*) :: DateStr
3034   real*8 ,        INTENT(OUT) :: Data(*)
3035   INTEGER ,       INTENT(IN)  :: Count
3036   INTEGER ,       INTENT(OUT) :: OutCount
3037   INTEGER ,       INTENT(OUT) :: Status
3038   INTEGER          :: idx
3039   INTEGER          :: stat
3040   CHARACTER*(1000) :: VALUE
3041
3042   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_real8')
3043
3044   Status = WRF_NO_ERR
3045
3046   CALL gr2_get_metadata_value(global_input(DataHandle), &
3047        trim(DateStr)//';'//trim(Element), Value, stat)
3048   if (stat /= 0) then
3049      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3050      Status = WRF_WARN_VAR_NF
3051      RETURN
3052   endif
3053
3054   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3055   if (stat .ne. 0) then
3056      CALL wrf_message("Reading data from"//Value//"failed")
3057      Status = WRF_WARN_COUNT_TOO_LONG
3058      RETURN
3059   endif
3060   Outcount = idx
3061
3062   RETURN
3063 END SUBROUTINE ext_gr2_get_dom_td_real8
3064
3065 !*****************************************************************************
3066
3067 SUBROUTINE ext_gr2_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
3068      Count, Outcount, Status )
3069
3070   USE gr2_data_info
3071   IMPLICIT NONE
3072 #include "wrf_status_codes.h"
3073   INTEGER ,       INTENT(IN)  :: DataHandle
3074   CHARACTER*(*) :: Element
3075   CHARACTER*(*) :: DateStr
3076   integer ,       INTENT(OUT) :: Data(*)
3077   INTEGER ,       INTENT(IN)  :: Count
3078   INTEGER ,       INTENT(OUT) :: OutCount
3079   INTEGER ,       INTENT(OUT) :: Status
3080   INTEGER          :: idx
3081   INTEGER          :: stat
3082   CHARACTER*(1000) :: VALUE
3083
3084   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_integer')
3085
3086   Status = WRF_NO_ERR
3087
3088   CALL gr2_get_metadata_value(global_input(DataHandle), &
3089        trim(DateStr)//';'//trim(Element), Value, stat)
3090   if (stat /= 0) then
3091      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3092      Status = WRF_WARN_VAR_NF
3093      RETURN
3094   endif
3095
3096   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3097   if (stat .ne. 0) then
3098      CALL wrf_message("Reading data from"//Value//"failed")
3099      Status = WRF_WARN_COUNT_TOO_LONG
3100      RETURN
3101   endif
3102   Outcount = idx
3103
3104   RETURN
3105 END SUBROUTINE ext_gr2_get_dom_td_integer
3106
3107 !*****************************************************************************
3108
3109 SUBROUTINE ext_gr2_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
3110      Count, Outcount, Status )
3111
3112   USE gr2_data_info
3113   IMPLICIT NONE
3114 #include "wrf_status_codes.h"
3115   INTEGER ,       INTENT(IN)  :: DataHandle
3116   CHARACTER*(*) :: Element
3117   CHARACTER*(*) :: DateStr
3118   logical ,       INTENT(OUT) :: Data(*)
3119   INTEGER ,       INTENT(IN)  :: Count
3120   INTEGER ,       INTENT(OUT) :: OutCount
3121   INTEGER ,       INTENT(OUT) :: Status
3122   INTEGER          :: idx
3123   INTEGER          :: stat
3124   CHARACTER*(1000) :: VALUE
3125
3126   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_logical')
3127
3128   Status = WRF_NO_ERR
3129
3130   CALL gr2_get_metadata_value(global_input(DataHandle), &
3131        trim(DateStr)//';'//trim(Element), Value, stat)
3132   if (stat /= 0) then
3133      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3134      Status = WRF_WARN_VAR_NF
3135      RETURN
3136   endif
3137
3138   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3139   if (stat .ne. 0) then
3140      CALL wrf_message("Reading data from"//Value//"failed")
3141      Status = WRF_WARN_COUNT_TOO_LONG
3142      RETURN
3143   endif
3144   Outcount = idx
3145
3146   RETURN
3147 END SUBROUTINE ext_gr2_get_dom_td_logical
3148
3149 !*****************************************************************************
3150
3151 SUBROUTINE ext_gr2_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  &
3152      Status )
3153
3154   USE gr2_data_info
3155   IMPLICIT NONE
3156 #include "wrf_status_codes.h"
3157   INTEGER ,       INTENT(IN)  :: DataHandle
3158   CHARACTER*(*) :: Element
3159   CHARACTER*(*) :: DateStr
3160   CHARACTER*(*) :: Data
3161   INTEGER ,       INTENT(OUT) :: Status
3162   INTEGER       :: stat
3163
3164   Status = WRF_NO_ERR
3165
3166   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_char')
3167
3168   CALL gr2_get_metadata_value(global_input(DataHandle), &
3169        trim(DateStr)//';'//trim(Element), Data, stat)
3170   if (stat /= 0) then
3171      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3172      Status = WRF_WARN_VAR_NF
3173      RETURN
3174   endif
3175
3176   RETURN
3177 END SUBROUTINE ext_gr2_get_dom_td_char
3178
3179 !*****************************************************************************
3180
3181 SUBROUTINE ext_gr2_get_dom_td_double ( DataHandle,Element, DateStr,  Data, &
3182      Count, Outcount, Status )
3183   USE gr2_data_info
3184   IMPLICIT NONE
3185 #include "wrf_status_codes.h"
3186   INTEGER ,       INTENT(IN)  :: DataHandle
3187   CHARACTER*(*) , INTENT(IN)  :: Element
3188   CHARACTER*(*) , INTENT(IN)  :: DateStr
3189   real*8 ,            INTENT(OUT) :: Data(*)
3190   INTEGER ,       INTENT(IN)  :: Count
3191   INTEGER ,       INTENT(OUT)  :: OutCount
3192   INTEGER ,       INTENT(OUT) :: Status
3193   INTEGER          :: idx
3194   INTEGER          :: stat
3195   CHARACTER*(1000) :: VALUE
3196
3197   call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_double')
3198
3199   Status = WRF_NO_ERR
3200
3201   CALL gr2_get_metadata_value(global_input(DataHandle), &
3202        trim(DateStr)//';'//trim(Element), Value, stat)
3203   if (stat /= 0) then
3204      CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3205      Status = WRF_WARN_VAR_NF
3206      RETURN
3207   endif
3208
3209   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3210   if (stat .ne. 0) then
3211      CALL wrf_message("Reading data from"//Value//"failed")
3212      Status = WRF_WARN_COUNT_TOO_LONG
3213      RETURN
3214   endif
3215   Outcount = idx
3216
3217 RETURN
3218 END SUBROUTINE ext_gr2_get_dom_td_double
3219
3220 !******************************************************************************
3221 !* End of get_dom_td_* routines
3222 !******************************************************************************
3223
3224
3225 !******************************************************************************
3226 !* Start of put_dom_td_* routines
3227 !******************************************************************************
3228
3229
3230 SUBROUTINE ext_gr2_put_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
3231      Count,  Status )
3232
3233   USE gr2_data_info
3234   IMPLICIT NONE
3235 #include "wrf_status_codes.h"
3236   INTEGER ,       INTENT(IN)  :: DataHandle
3237   CHARACTER*(*) :: Element
3238   CHARACTER*(*) :: DateStr
3239   real*8 ,        INTENT(IN)  :: Data(*)
3240   INTEGER ,       INTENT(IN)  :: Count
3241   INTEGER ,       INTENT(OUT) :: Status
3242   CHARACTER(len=1000) :: tmpstr(1000)
3243   INTEGER             :: idx
3244
3245   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_real8')
3246
3247   if (fileinfo(DataHandle)%committed) then
3248
3249      do idx = 1,Count
3250         write(tmpstr(idx),'(G17.10)')Data(idx)
3251      enddo
3252
3253      CALL gr2_build_string (td_output(DataHandle), &
3254           trim(DateStr)//';'//trim(Element), tmpstr, &
3255           Count, Status)
3256
3257   endif
3258
3259   RETURN
3260 END SUBROUTINE ext_gr2_put_dom_td_real8
3261
3262 !*****************************************************************************
3263
3264 SUBROUTINE ext_gr2_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
3265      Count,  Status )
3266
3267   USE gr2_data_info
3268   IMPLICIT NONE
3269 #include "wrf_status_codes.h"
3270   INTEGER ,       INTENT(IN)  :: DataHandle
3271   CHARACTER*(*) :: Element
3272   CHARACTER*(*) :: DateStr
3273   integer ,       INTENT(IN)  :: Data(*)
3274   INTEGER ,       INTENT(IN)  :: Count
3275   INTEGER ,       INTENT(OUT) :: Status
3276   CHARACTER(len=1000) :: tmpstr(1000)
3277   INTEGER             :: idx
3278
3279   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_integer')
3280
3281   if (fileinfo(DataHandle)%committed) then
3282
3283      do idx = 1,Count
3284         write(tmpstr(idx),'(G17.10)')Data(idx)
3285      enddo
3286
3287      CALL gr2_build_string (td_output(DataHandle), &
3288           trim(DateStr)//';'//trim(Element), tmpstr, &
3289           Count, Status)
3290
3291   endif
3292
3293   RETURN
3294 END SUBROUTINE ext_gr2_put_dom_td_integer
3295
3296 !*****************************************************************************
3297
3298 SUBROUTINE ext_gr2_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
3299      Count,  Status )
3300
3301   USE gr2_data_info
3302   IMPLICIT NONE
3303 #include "wrf_status_codes.h"
3304   INTEGER ,       INTENT(IN)  :: DataHandle
3305   CHARACTER*(*) :: Element
3306   CHARACTER*(*) :: DateStr
3307   logical ,       INTENT(IN)  :: Data(*)
3308   INTEGER ,       INTENT(IN)  :: Count
3309   INTEGER ,       INTENT(OUT) :: Status
3310   CHARACTER(len=1000) :: tmpstr(1000)
3311   INTEGER             :: idx
3312
3313   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_logical')
3314
3315   if (fileinfo(DataHandle)%committed) then
3316
3317      do idx = 1,Count
3318         write(tmpstr(idx),'(G17.10)')Data(idx)
3319      enddo
3320
3321      CALL gr2_build_string (td_output(DataHandle), &
3322           trim(DateStr)//';'//trim(Element), tmpstr, &
3323           Count, Status)
3324
3325   endif
3326
3327   RETURN
3328 END SUBROUTINE ext_gr2_put_dom_td_logical
3329
3330 !*****************************************************************************
3331
3332 SUBROUTINE ext_gr2_put_dom_td_char ( DataHandle,Element, DateStr,  Data, &
3333      Status )
3334
3335   USE gr2_data_info
3336   IMPLICIT NONE
3337 #include "wrf_status_codes.h"
3338   INTEGER ,       INTENT(IN)  :: DataHandle
3339   CHARACTER*(*) :: Element
3340   CHARACTER*(*) :: DateStr
3341   CHARACTER(len=*), INTENT(IN)  :: Data
3342   INTEGER ,       INTENT(OUT) :: Status
3343   CHARACTER(len=1000) :: tmpstr(1)
3344
3345   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_char')
3346
3347   if (fileinfo(DataHandle)%committed) then
3348
3349      write(tmpstr(1),*)Data
3350
3351      CALL gr2_build_string (td_output(DataHandle), &
3352           trim(DateStr)//';'//trim(Element), tmpstr, &
3353           1, Status)
3354
3355   endif
3356
3357   RETURN
3358 END SUBROUTINE ext_gr2_put_dom_td_char
3359
3360 !*****************************************************************************
3361
3362 SUBROUTINE ext_gr2_put_dom_td_double ( DataHandle,Element, DateStr,  Data, &
3363      Count,  Status )
3364   USE gr2_data_info
3365   IMPLICIT NONE
3366 #include "wrf_status_codes.h"
3367   INTEGER ,       INTENT(IN)  :: DataHandle
3368   CHARACTER*(*) , INTENT(IN)  :: Element
3369   CHARACTER*(*) , INTENT(IN)  :: DateStr
3370   real*8 ,            INTENT(IN) :: Data(*)
3371   INTEGER ,       INTENT(IN)  :: Count
3372   INTEGER ,       INTENT(OUT) :: Status
3373   CHARACTER(len=1000) :: tmpstr(1000)
3374   INTEGER             :: idx
3375
3376   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_double')
3377
3378   if (fileinfo(DataHandle)%committed) then
3379
3380      do idx = 1,Count
3381         write(tmpstr(idx),'(G17.10)')Data(idx)
3382      enddo
3383
3384      CALL gr2_build_string (td_output(DataHandle), &
3385           trim(DateStr)//';'//trim(Element), tmpstr, &
3386           Count, Status)
3387
3388   endif
3389
3390 RETURN
3391 END SUBROUTINE ext_gr2_put_dom_td_double
3392
3393 !*****************************************************************************
3394
3395 SUBROUTINE ext_gr2_put_dom_td_real ( DataHandle,Element, DateStr,  Data, &
3396      Count,  Status )
3397
3398   USE gr2_data_info
3399   IMPLICIT NONE
3400 #include "wrf_status_codes.h"
3401   INTEGER ,       INTENT(IN)  :: DataHandle
3402   CHARACTER*(*) :: Element
3403   CHARACTER*(*) :: DateStr
3404   real ,          INTENT(IN)  :: Data(*)
3405   INTEGER ,       INTENT(IN)  :: Count
3406   INTEGER ,       INTENT(OUT) :: Status
3407   CHARACTER(len=1000) :: tmpstr(1000)
3408   INTEGER             :: idx
3409
3410   call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_real')
3411
3412   if (fileinfo(DataHandle)%committed) then
3413
3414      do idx = 1,Count
3415         write(tmpstr(idx),'(G17.10)')Data(idx)
3416      enddo
3417
3418      CALL gr2_build_string (td_output(DataHandle), &
3419           trim(DateStr)//';'//trim(Element), tmpstr, &
3420           Count, Status)
3421
3422   endif
3423
3424   RETURN
3425 END SUBROUTINE ext_gr2_put_dom_td_real
3426
3427
3428 !******************************************************************************
3429 !* End of put_dom_td_* routines
3430 !******************************************************************************
3431
3432
3433 SUBROUTINE gr2_get_new_handle(DataHandle)
3434   USE gr2_data_info
3435   IMPLICIT NONE
3436
3437   INTEGER ,       INTENT(OUT)  :: DataHandle
3438   INTEGER :: i
3439
3440   DataHandle = -1
3441   do i=firstFileHandle, maxFileHandles
3442      if (.NOT. fileinfo(i)%used) then
3443         DataHandle = i
3444         fileinfo(i)%used = .true.
3445         exit
3446      endif
3447   enddo
3448
3449   RETURN
3450 END SUBROUTINE gr2_get_new_handle
3451
3452 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3453
3454
3455 !*****************************************************************************
3456
3457 SUBROUTINE gr2_retrieve_data (MemoryOrder, MemoryStart, MemoryEnd, xsize, ysize, &
3458      zsize, z, FieldType, Field, data)
3459
3460   IMPLICIT NONE
3461
3462 #include "wrf_io_flags.h"
3463
3464   character*(*)                 ,intent(in)    :: MemoryOrder
3465   integer                       ,intent(in)    :: xsize, ysize, zsize
3466   integer                       ,intent(in)    :: z
3467   integer,dimension(*)          ,intent(in)    :: MemoryStart, MemoryEnd
3468   integer                       ,intent(in)    :: FieldType
3469   real                          ,intent(in),       &
3470        dimension( 1:1,MemoryStart(1):MemoryEnd(1), &
3471        MemoryStart(2):MemoryEnd(2), &
3472        MemoryStart(3):MemoryEnd(3) )           :: Field
3473   real   ,dimension(1:xsize,1:ysize),intent(inout) :: data
3474
3475   integer                                      :: x, y, idx
3476   integer, dimension(:,:),   pointer           :: mold
3477   integer                                      :: istat
3478   integer                                      :: dim1
3479
3480   ALLOCATE(mold(1:xsize,1:ysize), STAT=istat)
3481   if (istat .ne. 0) then
3482      print *,'Could not allocate space for mold, returning'
3483      return
3484   endif
3485
3486   !
3487   ! Set the size of the first dimension of the data array (dim1) to xsize.
3488   !    If the MemoryOrder is Z or z, dim1 is overridden below.
3489   !
3490   dim1 = xsize
3491
3492   SELECT CASE (MemoryOrder)
3493   CASE ('XYZ')
3494      data = Field(1,1:xsize,1:ysize,z)
3495   CASE ('C')
3496      data = Field(1,1:xsize,1:ysize,z)
3497   CASE ('XZY')
3498      data = Field(1,1:xsize,z,1:ysize)
3499   CASE ('YXZ')
3500      do x = 1,xsize
3501         do y = 1,ysize
3502            data(x,y) = Field(1,y,x,z)
3503         enddo
3504      enddo
3505   CASE ('YZX')
3506      do x = 1,xsize
3507         do y = 1,ysize
3508            data(x,y) = Field(1,y,z,x)
3509         enddo
3510      enddo
3511   CASE ('ZXY')
3512      data = Field(1,z,1:xsize,1:ysize)
3513   CASE ('ZYX')
3514      do x = 1,xsize
3515         do y = 1,ysize
3516            data(x,y) = Field(1,z,y,x)
3517         enddo
3518      enddo
3519   CASE ('XY')
3520      data = Field(1,1:xsize,1:ysize,1)
3521   CASE ('YX')
3522      do x = 1,xsize
3523         do y = 1,ysize
3524            data(x,y) = Field(1,y,x,1)
3525         enddo
3526      enddo
3527
3528   CASE ('XSZ')
3529      do x = 1,xsize
3530         do y = 1,ysize
3531            data(x,y) = Field(1,y,z,x)
3532         enddo
3533      enddo
3534   CASE ('XEZ')
3535      do x = 1,xsize
3536         do y = 1,ysize
3537            data(x,y) = Field(1,y,z,x)
3538         enddo
3539      enddo
3540   CASE ('YSZ')
3541      do x = 1,xsize
3542         do y = 1,ysize
3543            data(x,y) = Field(1,x,z,y)
3544         enddo
3545      enddo
3546   CASE ('YEZ')
3547      do x = 1,xsize
3548         do y = 1,ysize
3549            data(x,y) = Field(1,x,z,y)
3550         enddo
3551      enddo
3552
3553   CASE ('XS')
3554      do x = 1,xsize
3555         do y = 1,ysize
3556            data(x,y) = Field(1,y,x,1)
3557         enddo
3558      enddo
3559   CASE ('XE')
3560      do x = 1,xsize
3561         do y = 1,ysize
3562            data(x,y) = Field(1,y,x,1)
3563         enddo
3564      enddo
3565   CASE ('YS')
3566      do x = 1,xsize
3567         do y = 1,ysize
3568            data(x,y) = Field(1,x,y,1)
3569         enddo
3570      enddo
3571   CASE ('YE')
3572      do x = 1,xsize
3573         do y = 1,ysize
3574            data(x,y) = Field(1,x,y,1)
3575         enddo
3576      enddo
3577   CASE ('Z')
3578      data(1:zsize,1) = Field(1,1:zsize,1,1)
3579      dim1 = zsize
3580   CASE ('z')
3581      data(1:zsize,1) = Field(1,zsize:1,1,1)
3582      dim1 = zsize
3583   CASE ('0')
3584      data(1,1) = Field(1,1,1,1)
3585   END SELECT
3586
3587   !
3588   ! Here, we convert any integer fields to real
3589   !
3590   if (FieldType == WRF_INTEGER) then
3591      mold = 0
3592      do idx=1,dim1
3593         !
3594         ! The parentheses around data(idx,:) are needed in order
3595         !   to fix a bug with transfer with the xlf compiler on NCARs
3596         !   IBM (bluesky).
3597         !
3598         data(idx,:)=transfer((data(idx,:)),mold)
3599      enddo
3600   endif
3601
3602   deallocate(mold)
3603
3604   return
3605
3606 end subroutine gr2_retrieve_data
3607
3608 !*****************************************************************************
3609
3610 SUBROUTINE gr2_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, &
3611      fraction, vert_unit1, vert_unit2, vert_sclFctr1, vert_sclFctr2, &
3612      level1, level2)
3613
3614   use gr2_data_info
3615   IMPLICIT NONE
3616
3617   integer :: zidx
3618   integer :: zsize
3619   logical :: soil_layers
3620   logical :: vert_stag
3621   logical :: fraction
3622   integer :: vert_unit1, vert_unit2
3623   integer :: vert_sclFctr1, vert_sclFctr2
3624   integer :: level1
3625   integer :: level2
3626   character (LEN=*) :: VarName
3627
3628   ! Setup vert_unit, and vertical levels in grib units
3629
3630   if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCTOP') &
3631        .or. (VarName .eq. 'SOILCBOT')) then
3632      vert_unit1 = 105;
3633      vert_unit2 = 255;
3634      vert_sclFctr1 = 0
3635      vert_sclFctr2 = 0
3636      level1 = zidx
3637      level2 = 0
3638   else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction)) &
3639        then
3640      vert_unit1 = 111;
3641      vert_unit2 = 255;
3642      vert_sclFctr1 = 4
3643      vert_sclFctr2 = 4
3644      if (vert_stag) then
3645         level1 = (10000*full_eta(zidx)+0.5)
3646      else
3647         level1 = (10000*half_eta(zidx)+0.5)
3648      endif
3649      level2 = 0
3650   else
3651      ! Set the vertical coordinate and level for soil and 2D fields
3652      if (fraction) then
3653         vert_unit1 = 105
3654         vert_unit2 = 255
3655         level1 = zidx
3656         level2 = 0
3657         vert_sclFctr1 = 0
3658         vert_sclFctr2 = 0
3659      else if (soil_layers) then
3660         vert_unit1 = 106
3661         vert_unit2 = 106
3662         level1 = 100*(soil_depth(zidx) - 0.5*soil_thickness(zidx))+0.5
3663         level2 = 100*(soil_depth(zidx) + 0.5*soil_thickness(zidx))+0.5
3664         vert_sclFctr1 = 2
3665         vert_sclFctr2 = 2
3666      else if (VarName .eq. 'mu') then
3667         vert_unit1 = 105
3668         vert_unit2 = 255
3669         level1 = 0
3670         level2 = 0
3671         vert_sclFctr1 = 0
3672         vert_sclFctr2 = 0
3673      else if ((VarName .eq. 'Q2') .or. (VarName .eq. 'TH2') .or. &
3674         (VarName .eq. 'T2')) then
3675         vert_unit1 = 103
3676         vert_unit2 = 255
3677         level1 = 2
3678         level2 = 0
3679         vert_sclFctr1 = 0
3680         vert_sclFctr2 = 0
3681      else if ((VarName .eq. 'Q10') .or. (VarName .eq. 'TH10') .or. &
3682           (VarName .eq. 'U10') .or. (VarName .eq. 'V10')) then
3683         vert_unit1 = 103
3684         vert_unit2 = 255
3685         level1 = 10
3686         level2 = 0
3687         vert_sclFctr1 = 0
3688         vert_sclFctr2 = 0
3689      else
3690         vert_unit1 = 1
3691         vert_unit2 = 255
3692         level1 = 0
3693         level2 = 0
3694         vert_sclFctr1 = 0
3695         vert_sclFctr2 = 0
3696      endif
3697   endif
3698
3699 end SUBROUTINE gr2_get_levels
3700
3701 !*****************************************************************************
3702
3703 subroutine gr2_create_w(StartDate, cgrib, lcgrib, production_status, Disc, &
3704      center, subcenter, MasterTblV, LocalTblV, ierr, msg)
3705
3706   implicit none
3707
3708   character*24 ,intent(in)     :: StartDate
3709   character*(*),intent(inout)  :: cgrib
3710   integer      ,intent(in)     :: lcgrib
3711   integer      ,intent(in)     :: production_status
3712   integer      ,intent(out)    :: ierr
3713   character*(*),intent(out)    :: msg
3714   integer , dimension(13)      :: listsec1
3715   integer , dimension(2)       :: listsec0
3716   integer                      :: slen
3717   integer , intent(in)         :: Disc, center, subcenter, MasterTblV, LocalTblV
3718
3719   !
3720   ! Create the grib message
3721   !
3722   listsec0(1) = Disc       ! Discipline (Table 0.0)
3723   listsec0(2) = 2          ! Grib edition number
3724
3725   listsec1(1) = center     ! Id of Originating Center (255 for missing)
3726   listsec1(2) = subcenter  ! Id of originating sub-center (255 for missing)
3727   listsec1(3) = MasterTblV ! Master Table Version #
3728   listsec1(4) = LocalTblV  ! Local table version #
3729   listsec1(5) = 1          ! Significance of reference time, 1 indicates start of forecast
3730
3731   READ(StartDate(1:4),  '(I4)') listsec1(6) ! Year of reference
3732
3733   READ(StartDate(6:7),  '(I2)') listsec1(7) ! Month of reference
3734
3735   READ(StartDate(9:10), '(I2)') listsec1(8) ! Day of reference
3736
3737   slen = LEN(StartDate)
3738
3739   if (slen.GE.13) then
3740      read(StartDate(12:13),'(I2)') listsec1(9)
3741   else
3742      listsec1(9) = 0
3743   endif
3744
3745   if (slen.GE.16) then
3746      read(StartDate(15:16),'(I2)') listsec1(10)
3747   else
3748      listsec1(10) = 0
3749   endif
3750
3751   if (slen.GE.19) then
3752      read(StartDate(18:19),'(I2)') listsec1(11)
3753   else
3754      listsec1(11) = 0
3755   end if
3756
3757   listsec1(12) = production_status  ! Production status of data
3758   listsec1(13) = 1     ! Type of data (1 indicates forecast products)
3759
3760   call gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
3761
3762   if (ierr .ne. 0) then
3763      write(msg,*) 'gribcreate failed with ierr: ',ierr
3764   else
3765      msg = ''
3766   endif
3767
3768 end SUBROUTINE gr2_create_w
3769
3770
3771 !*****************************************************************************
3772 subroutine gr2_addgrid_w(cgrib, lcgrib, central_lat, central_lon, wrf_projection, &
3773      latin1, latin2, nx, ny, dx, dy, center_lat, center_lon, ierr,msg)
3774
3775   implicit none
3776
3777   character*(*)            ,intent(inout)   :: cgrib
3778   integer                  ,intent(in)      :: lcgrib
3779   real                     ,intent(in)      :: central_lat
3780   real                     ,intent(in)      :: central_lon
3781   integer                  ,intent(in)      :: wrf_projection
3782   real                     ,intent(in)      :: latin1
3783   real                     ,intent(in)      :: latin2
3784   integer                  ,intent(in)      :: nx
3785   integer                  ,intent(in)      :: ny
3786   real                     ,intent(in)      :: dx
3787   real                     ,intent(in)      :: dy
3788   real                     ,intent(in)      :: center_lat
3789   real                     ,intent(in)      :: center_lon
3790   integer                  ,intent(out)     :: ierr
3791   character*(*)            ,intent(out)     :: msg
3792   integer, dimension(5)                     :: igds
3793   integer, parameter                        :: igdstmplen = 25
3794   integer, dimension(igdstmplen)            :: igdstmpl
3795   integer, parameter                        :: idefnum = 0
3796   integer, dimension(idefnum)               :: ideflist
3797   real                                      :: LLLa, LLLo, URLa, URLo
3798   real                                      :: incrx, incry
3799   real, parameter                           :: deg_to_microdeg = 1e6
3800   real, parameter                           :: km_to_mm = 1e6
3801   real, parameter                           :: km_to_m = 1e3
3802   real, parameter                           :: DEG_TO_RAD = PI/180
3803   real, parameter                           :: RAD_TO_DEG = 180/PI
3804   real, parameter                           :: ERADIUS = 6370.0
3805
3806   igds(1) = 0      ! Source of grid definition
3807   igds(2) = nx*ny  ! Number of points in grid
3808   igds(3) = 0      !
3809   igds(4) = 0
3810
3811   ! Here, setup the parameters that are common to all WRF projections
3812
3813   igdstmpl(1) = 1       ! Shape of earth (1 for spherical with specified radius)
3814   igdstmpl(2) = 0       ! Scale factor for earth radius
3815   igdstmpl(3) = ERADIUS*km_to_m ! Radius of earth
3816   igdstmpl(4) = 0       ! Scale factor for major axis
3817   igdstmpl(5) = 0       ! Major axis
3818   igdstmpl(6) = 0       ! Scale factor for minor axis
3819   igdstmpl(7) = 0       ! Minor axis
3820   igdstmpl(8) = nx      ! Number of points along x axis
3821   igdstmpl(9) = ny      ! Number of points along y axis
3822
3823   !
3824   ! Setup increments in "x" and "y" direction.  For LATLON projection
3825   !   increments need to be in degrees.  For all other projections,
3826   !   increments are in km.
3827   !
3828   if ((wrf_projection .eq. WRF_LATLON) &
3829        .or. (wrf_projection .eq. WRF_CASSINI)) then
3830      incrx = (dx/ERADIUS) * RAD_TO_DEG
3831      incry = (dy/ERADIUS) * RAD_TO_DEG
3832   else
3833      incrx = dx
3834      incry = dy
3835   endif
3836
3837   ! Latitude and longitude of first (i.e., lower left) grid point
3838   call get_ll_latlon(central_lat, central_lon, wrf_projection, &
3839        latin1, latin2, nx, ny, incrx, incry, center_lat, center_lon, &
3840        LLLa, LLLo, URLa, URLo, ierr);
3841
3842   select case (wrf_projection)
3843
3844   case(WRF_LATLON,WRF_CASSINI)
3845      igds(5) = 0
3846      igdstmpl(10) = 0    ! Basic Angle of init projection (not important to us)
3847      igdstmpl(11) = 0    ! Subdivision of basic angle
3848      igdstmpl(12) = LLLa*deg_to_microdeg
3849      igdstmpl(13) = LLLo*deg_to_microdeg
3850      call gr2_convert_lon(igdstmpl(13))
3851      igdstmpl(14) = 128  ! Resolution and component flags
3852      igdstmpl(15) = URLa*deg_to_microdeg
3853      igdstmpl(16) = URLo*deg_to_microdeg
3854      call gr2_convert_lon(igdstmpl(16))
3855
3856      ! Warning, the following assumes that dx and dy are valid at the equator.
3857      !    It is not clear in WRF where dx and dy are valid for latlon projections
3858      igdstmpl(17) = incrx*deg_to_microdeg ! i-direction increment in micro degs
3859      igdstmpl(18) = incry*deg_to_microdeg ! j-direction increment in micro degs
3860
3861      igdstmpl(19) = 64   ! Scanning mode
3862   case(WRF_MERCATOR)
3863      igds(5) = 10
3864      igdstmpl(10) = LLLa*deg_to_microdeg
3865      igdstmpl(11) = LLLo*deg_to_microdeg
3866      call gr2_convert_lon(igdstmpl(11))
3867      igdstmpl(12) = 128  ! Resolution and component flags
3868      igdstmpl(13) = latin1*deg_to_microdeg  ! "True" latitude
3869      igdstmpl(14) = URLa*deg_to_microdeg
3870      igdstmpl(15) = URLo*deg_to_microdeg
3871      call gr2_convert_lon(igdstmpl(15))
3872      igdstmpl(16) = 64   ! Scanning mode
3873      igdstmpl(17) = 0    ! Orientation of grid between i-direction and equator
3874      igdstmpl(18) = dx*km_to_mm   ! i-direction increment
3875      igdstmpl(19) = dy*km_to_mm   ! j-direction increment
3876   case(WRF_LAMBERT)
3877      igds(5) = 30
3878
3879      igdstmpl(10) = LLLa*deg_to_microdeg
3880      igdstmpl(11) = LLLo*deg_to_microdeg
3881      call gr2_convert_lon(igdstmpl(11))
3882      igdstmpl(12) = 128 ! Resolution and component flag
3883      igdstmpl(13) = latin1*deg_to_microdeg ! Latitude where Dx and Dy are specified
3884      igdstmpl(14) = central_lon*deg_to_microdeg
3885      call gr2_convert_lon(igdstmpl(14))
3886      igdstmpl(15) = dx*km_to_mm  ! x-dimension grid-spacing  in units of m^-3
3887      igdstmpl(16) = dy*km_to_mm
3888      if (center_lat .lt. 0) then
3889         igdstmpl(17) = 1
3890      else
3891         igdstmpl(17) = 0
3892      endif
3893      igdstmpl(18) = 64   ! Scanning mode
3894      igdstmpl(19) = latin1*deg_to_microdeg
3895      igdstmpl(20) = latin2*deg_to_microdeg
3896      igdstmpl(21) = -90*deg_to_microdeg
3897      igdstmpl(22) = central_lon*deg_to_microdeg
3898      call gr2_convert_lon(igdstmpl(22))
3899
3900   case(WRF_POLAR_STEREO)
3901      igds(5) = 20
3902      igdstmpl(10) = LLLa*deg_to_microdeg
3903      igdstmpl(11) = LLLo*deg_to_microdeg
3904      call gr2_convert_lon(igdstmpl(11))
3905      igdstmpl(12) = 128 ! Resolution and component flag
3906      igdstmpl(13) = latin1*deg_to_microdeg ! Latitude where Dx and Dy are specified
3907      igdstmpl(14) = central_lon*deg_to_microdeg
3908      call gr2_convert_lon(igdstmpl(14))
3909      igdstmpl(15) = dx*km_to_mm  ! x-dimension grid-spacing  in units of m^-3
3910      igdstmpl(16) = dy*km_to_mm
3911      if (center_lat .lt. 0) then
3912         igdstmpl(17) = 1
3913      else
3914         igdstmpl(17) = 0
3915      endif
3916      igdstmpl(18) = 64   ! Scanning mode
3917
3918   case default
3919      write(msg,*) 'invalid WRF projection: ',wrf_projection
3920      ierr = -1
3921      return
3922   end select
3923
3924
3925   call addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,ideflist,idefnum,ierr)
3926   if (ierr .ne. 0) then
3927      write(msg,*) 'addgrid failed with ierr: ',ierr
3928   else
3929      msg = ''
3930   endif
3931
3932 end subroutine gr2_addgrid_w
3933
3934 !*****************************************************************************
3935
3936 subroutine gr2_addfield_w(cgrib, lcgrib, VarName, parmcat, parmnum, DecScl, &
3937      BinScl, fcst_secs, vert_unit1, vert_unit2, vert_sclFctr1, vert_sclFctr2, &
3938      numlevels, levels, ngrdpts, background_proc_id, forecast_proc_id, &
3939      compression, fld, ierr, msg)
3940
3941   implicit none
3942
3943   character*(*)            ,intent(inout)   :: cgrib
3944   integer                  ,intent(in)      :: lcgrib
3945   character (LEN=*)        ,intent(in)      :: VarName
3946   integer                  ,intent(in)      :: parmcat,parmnum,DecScl,BinScl
3947   real                     ,intent(in)      :: fcst_secs
3948   integer                  ,intent(in)      :: vert_unit1, vert_unit2
3949   integer                  ,intent(in)      :: vert_sclFctr1, vert_sclFctr2
3950   integer                  ,intent(in)      :: numlevels
3951   integer, dimension(*)    ,intent(in)      :: levels
3952   integer                  ,intent(in)      :: ngrdpts
3953   real                     ,intent(in)      :: fld(ngrdpts)
3954   integer                  ,intent(in)      :: background_proc_id
3955   integer                  ,intent(in)      :: forecast_proc_id
3956   integer                  ,intent(in)      :: compression
3957   integer                  ,intent(out)     :: ierr
3958   character*(*)            ,intent(out)     :: msg
3959   integer                                   :: ipdsnum
3960   integer, parameter                        :: ipdstmplen = 15
3961   integer, dimension(ipdstmplen)            :: ipdstmpl
3962   integer                                   :: numcoord
3963   integer, dimension(numlevels)             :: coordlist
3964   integer                                   :: idrsnum
3965   integer, parameter                        :: idrstmplen = 7
3966   integer, dimension(idrstmplen)            :: idrstmpl
3967   integer                                   :: ibmap
3968   integer, dimension(1)                     :: bmap
3969
3970   if (numlevels .gt. 2) then
3971      ipdsnum = 1000           ! Product definition tmplate (1000 for cross-sxn)
3972   else
3973      ipdsnum = 0              ! Product definition template (0 for horiz grid)
3974   endif
3975
3976   ipdstmpl(1) = parmcat    ! Parameter category
3977   ipdstmpl(2) = parmnum    ! Parameter number
3978   ipdstmpl(3) = 2          ! Type of generating process (2 for forecast)
3979   ipdstmpl(4) = background_proc_id ! Background generating process id
3980   ipdstmpl(5) = forecast_proc_id   ! Analysis or forecast generating process id
3981   ipdstmpl(6) = 0          ! Data cutoff period (Hours)
3982   ipdstmpl(7) = 0          ! Data cutoff period (minutes)
3983   ipdstmpl(8) = 13         ! Time range indicator (13 for seconds)
3984   ipdstmpl(9) = NINT(fcst_secs) ! Forecast time
3985
3986   if (ipdsnum .eq. 1000) then
3987      numcoord = numlevels
3988      coordlist = levels(1:numlevels)
3989
3990      !
3991      ! Set Data Representation templ (Use 0 for vertical cross sections,
3992      !    since there seems to be a bug in g2lib for JPEG2000 and PNG)
3993      !
3994      idrsnum = 0
3995
3996   else if (ipdsnum .eq. 0) then
3997      ipdstmpl(10) = vert_unit1    ! Type of first surface (111 for Eta level)
3998      ipdstmpl(11) = vert_sclFctr1 ! Scale factor for 1st surface
3999      ipdstmpl(12) = levels(1)     ! First fixed surface
4000      ipdstmpl(13) = vert_unit2    ! Type of second fixed surface
4001      ipdstmpl(14) = vert_sclFctr2 ! Scale factor for 2nd surface
4002      if (numlevels .eq. 2) then
4003         ipdstmpl(15) = levels(2)
4004      else
4005         ipdstmpl(15) = 0
4006      endif
4007      numcoord = 0
4008      coordlist(1) = 0
4009
4010      ! Set Data Representation templ (40 for JPEG2000, 41 for PNG)
4011      idrsnum = compression
4012
4013   endif
4014
4015
4016   if (idrsnum == 40) then    ! JPEG 2000
4017
4018      idrstmpl(1) = 255       ! Reference value - ignored on input
4019      idrstmpl(2) = BinScl    ! Binary scale factor
4020      idrstmpl(3) = DecScl    ! Decimal scale factor
4021      idrstmpl(4) = 0         ! number of bits for each data value - ignored on input
4022      idrstmpl(5) = 0         ! Original field type - ignored on input
4023      idrstmpl(6) = 0         ! 0 for lossless compression
4024      idrstmpl(7) = 255       ! Desired compression ratio if idrstmpl(6) != 0
4025
4026   else if (idrsnum == 41) then ! PNG
4027
4028      idrstmpl(1) = 255       ! Reference value - ignored on input
4029      idrstmpl(2) = BinScl    ! Binary scale factor
4030      idrstmpl(3) = DecScl    ! Decimal scale factor
4031      idrstmpl(4) = 0         ! number of bits for each data value - ignored on input
4032      idrstmpl(5) = 0         ! Original field type - ignored on input
4033
4034   else if (idrsnum == 0) then! Simple packing
4035
4036      idrstmpl(1) = 255       ! Reference value - ignored on input
4037      idrstmpl(2) = BinScl    ! Binary scale factor
4038      idrstmpl(3) = DecScl    ! Decimal scale factor
4039      idrstmpl(4) = 0         ! number of bits for each data value - ignored on input
4040      idrstmpl(5) = 0         ! Original field type - ignored on input
4041
4042   else
4043
4044      write (msg,*) 'addfield failed because Data Representation template',&
4045           idrsnum,' is invalid'
4046      ierr = 1
4047      return
4048
4049   endif
4050
4051   ibmap = 255                ! Flag for bitmap
4052
4053   call addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, coordlist,      &
4054        numcoord, idrsnum, idrstmpl, idrstmplen, fld, ngrdpts, ibmap,          &
4055        bmap, ierr)
4056
4057   if (ierr .ne. 0) then
4058      write(msg,*) 'addfield failed with ierr: ',ierr
4059   else
4060      msg = ''
4061   endif
4062
4063 end subroutine gr2_addfield_w
4064
4065 !*****************************************************************************
4066
4067 subroutine gr2_fill_local_use(DataHandle,string,VarName,fcsts,msg,status)
4068
4069   use gr2_data_info
4070   IMPLICIT NONE
4071 #include "wrf_status_codes.h"
4072
4073   integer,         intent(in)    :: DataHandle
4074   character*(*)   ,intent(inout) :: string
4075   character*(*)   ,intent(in)    :: VarName
4076   integer                        :: center, subcenter, MasterTblV, LocalTblV, &
4077        Disc, Category, ParmNum, DecScl, BinScl
4078   integer         ,intent(out)   :: status
4079   character*(*)   ,intent(out)   :: msg
4080   integer , parameter            :: lcgrib = 1000000
4081   character (lcgrib)             :: cgrib
4082   real, dimension(1,1)           :: data
4083   integer                        :: lengrib
4084   integer                        :: lcsec2
4085   integer                        :: fcsts
4086   integer                        :: bytes_written
4087
4088   !
4089   ! Set data to a default dummy value.
4090   !
4091   data = 1.0
4092
4093   !
4094   ! This statement prevents problems when calling addlocal in the grib2
4095   !   library.  Basically, if addlocal is called with an empty string, it
4096   !   will be encoded correctly by the grib2 routine, but the grib2 routines
4097   !   that read the data (i.e., getgb2) will segfault.  This prevents that
4098   !   segfault.
4099   !
4100
4101   if (string .eq. '') string = 'none'
4102
4103   CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
4104        LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
4105   if (status .ne. 0) then
4106      write(msg,*) 'Could not find parameter for '//   &
4107           trim(VarName)//'   Skipping output of '//trim(VarName)
4108      call wrf_message(trim(msg))
4109      Status =  WRF_GRIB2_ERR_GRIB2MAP
4110      return
4111   endif
4112
4113   !
4114   ! Create the indicator and identification sections (sections 0 and 1)
4115   !
4116   CALL gr2_create_w(StartDate, cgrib, lcgrib, production_status, Disc, &
4117              center, subcenter, MasterTblV, LocalTblV, status, msg)
4118   if (status .ne. 0) then
4119      call wrf_message(trim(msg))
4120      Status = WRF_GRIB2_ERR_GRIBCREATE
4121      return
4122   endif
4123
4124   !
4125   ! Add the local use section
4126   !
4127   lcsec2 = len_trim(string)
4128   call addlocal(cgrib,lcgrib,string,lcsec2,status)
4129   if (status .ne. 0) then
4130      call wrf_message(trim(msg))
4131      Status = WRF_GRIB2_ERR_ADDLOCAL
4132      return
4133   endif
4134
4135   !
4136   ! Add the grid definition section (section 3) using a 1x1 grid
4137   !
4138   call gr2_addgrid_w(cgrib, lcgrib, center_lat, proj_central_lon,  &
4139        wrf_projection, truelat1, truelat2, 1, 1, dx, dy,       &
4140        center_lat, center_lon, status, msg)
4141   if (status .ne. 0) then
4142      call wrf_message(trim(msg))
4143      Status = WRF_GRIB2_ERR_ADDGRIB
4144      return
4145   endif
4146
4147   !
4148   ! Add the Product Definition, Data representation, bitmap
4149   !      and data sections (sections 4-7)
4150   !
4151   call gr2_addfield_w(cgrib, lcgrib, VarName, Category, ParmNum, DecScl, &
4152        BinScl, fcsts, 1, 255, 0, 0, 1, 0, 1, &
4153        background_proc_id, forecast_proc_id, compression, data, status, msg)
4154   if (status .ne. 0) then
4155      call wrf_message(trim(msg))
4156      Status = WRF_GRIB2_ERR_ADDFIELD
4157      return
4158   endif
4159
4160   !
4161   ! Close out the message
4162   !
4163
4164   call gribend(cgrib,lcgrib,lengrib,status)
4165   if (status .ne. 0) then
4166      write(msg,*) 'gribend failed with status: ',status
4167      call wrf_message(trim(msg))
4168      Status = WRF_GRIB2_ERR_GRIBEND
4169      return
4170   endif
4171
4172   !
4173   ! Write the data to the file
4174   !
4175
4176   call bawrite(DataHandle, -1, lengrib, bytes_written, cgrib)
4177 !!  call write_file_n(fileinfo(DataHandle)%FileFd, cgrib, lengrib, status)
4178   if (bytes_written .ne. lengrib) then
4179      write(msg,*) '2 Error writing cgrib to file, wrote: ', &
4180           bytes_written, ' bytes.  Tried to write ', lengrib, ' bytes'
4181      call wrf_message(trim(msg))
4182      Status = WRF_GRIB2_ERR_WRITE
4183      return
4184   endif
4185
4186   ! Set string back to the original blank value
4187   if (string .eq. '') string = ''
4188
4189   return
4190
4191 end subroutine gr2_fill_local_use
4192
4193 !*****************************************************************************
4194 !
4195 ! Set longitude to be in the range of 0-360 degrees.
4196 !
4197 !*****************************************************************************
4198
4199 subroutine gr2_convert_lon(value)
4200
4201   IMPLICIT NONE
4202
4203   integer, intent(inout) :: value
4204   real, parameter                           :: deg_to_microdeg = 1e6
4205
4206   do while (value .lt. 0)
4207      value = value + 360*deg_to_microdeg
4208   enddo
4209
4210   do while (value .gt. 360*deg_to_microdeg)
4211      value = value - 360*deg_to_microdeg
4212   enddo
4213
4214 end subroutine gr2_convert_lon
4215
4216
4217 !*****************************************************************************
4218 !
4219 ! Add a time to the list of times
4220 !
4221 !*****************************************************************************
4222
4223 subroutine gr2_add_time(DataHandle,addTime)
4224
4225   USE gr2_data_info
4226   IMPLICIT NONE
4227
4228   integer           :: DataHandle
4229   character (len=*) :: addTime
4230   integer           :: idx
4231   logical           :: already_have = .false.
4232   logical           :: swap
4233   character (len=len(addTime)) :: tmp
4234   character (DateStrLen), dimension(:),pointer  :: tmpTimes(:)
4235   integer,parameter :: allsize = 50
4236   integer           :: ierr
4237
4238   already_have = .false.
4239   do idx = 1,fileinfo(DataHandle)%NumberTimes
4240      if (addTime .eq. fileinfo(DataHandle)%Times(idx)) then
4241         already_have = .true.
4242      endif
4243   enddo
4244
4245   if (.not. already_have) then
4246      fileinfo(DataHandle)%NumberTimes = fileinfo(DataHandle)%NumberTimes + 1
4247
4248      if (fileinfo(DataHandle)%NumberTimes .gt. &
4249           fileinfo(DataHandle)%sizeAllocated) then
4250
4251         if (fileinfo(DataHandle)%NumberTimes .eq. 1) then
4252
4253            if (allocated(fileinfo(DataHandle)%Times)) &
4254                 deallocate(fileinfo(DataHandle)%Times)
4255
4256            allocate(fileinfo(DataHandle)%Times(allsize), stat = ierr)
4257            if (ierr .ne. 0) then
4258               call wrf_message('Could not allocate space for Times 1, exiting')
4259               stop
4260            endif
4261
4262            fileinfo(DataHandle)%sizeAllocated = allsize
4263
4264         else
4265
4266            allocate(tmpTimes(fileinfo(DataHandle)%NumberTimes), stat=ierr)
4267
4268            tmpTimes = &
4269                 fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes)
4270
4271            deallocate(fileinfo(DataHandle)%Times)
4272
4273            allocate(&
4274                 fileinfo(DataHandle)%Times(fileinfo(DataHandle)%sizeAllocated+allsize), stat=ierr)
4275
4276            if (ierr .ne. 0) then
4277               call wrf_message('Could not allocate space for Times 2, exiting')
4278               stop
4279            endif
4280
4281            fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes) = &
4282                 tmpTimes
4283
4284            deallocate(tmpTimes)
4285
4286         endif
4287
4288      endif
4289
4290      fileinfo(DataHandle)%Times(fileinfo(DataHandle)%NumberTimes) = addTime
4291
4292      ! Sort the Times array
4293
4294      swap = .true.
4295      do while (swap)
4296         swap = .false.
4297         do idx = 1,fileinfo(DataHandle)%NumberTimes - 1
4298            if (fileinfo(DataHandle)%Times(idx) .gt. fileinfo(DataHandle)%Times(idx+1)) then
4299               tmp = fileinfo(DataHandle)%Times(idx)
4300               fileinfo(DataHandle)%Times(idx) = fileinfo(DataHandle)%Times(idx+1)
4301               fileinfo(DataHandle)%Times(idx+1) = tmp
4302               swap = .true.
4303            endif
4304         enddo
4305      enddo
4306
4307   endif
4308
4309   return
4310
4311 end subroutine gr2_add_time
4312
4313
4314 !*****************************************************************************
4315 !
4316 ! Fill an array of levels
4317 !
4318 !*****************************************************************************
4319
4320 subroutine gr2_fill_levels(DataHandle,VarName,levels,ierr)
4321
4322   USE gr2_data_info
4323   USE grib_mod
4324   IMPLICIT NONE
4325
4326 #include "wrf_status_codes.h"
4327
4328
4329   integer            :: DataHandle
4330   character (len=*)  :: VarName
4331   REAL,DIMENSION(*)  :: levels
4332   integer            :: ierr
4333   integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
4334        JGDT(JGDTSIZE)
4335   type(gribfield)    :: gfld
4336   integer            :: status, fields_to_skip
4337   logical            :: unpack
4338   integer            :: center, subcenter, MasterTblV, LocalTblV, &
4339        Disc, Category, ParmNum, DecScl, BinScl
4340   CHARACTER (LEN=maxMsgSize) :: msg
4341
4342
4343   CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
4344        LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
4345   if (status .ne. 0) then
4346      write(msg,*) 'Could not find parameter for '//   &
4347           trim(VarName)//'   Skipping output of '//trim(VarName)
4348      call wrf_message(trim(msg))
4349      ierr = -1
4350      return
4351   endif
4352
4353
4354   !
4355   ! First, set all values to wild, then specify necessary values
4356   !
4357   call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
4358
4359   JIDS(1) = center
4360   JIDS(2) = subcenter
4361   JIDS(3) = MasterTblV
4362   JIDS(4) = LocalTblV
4363   JIDS(5) = 1           ! Indicates that time is "Start of Forecast"
4364   JIDS(13) = 1          ! Type of processed data (1 for forecast products)
4365
4366   JPDTN = 1000          ! Product definition template number
4367   JPDT(1) = Category
4368   JPDT(2) = ParmNum
4369   JPDT(3) = 2           ! Generating process id
4370
4371   JGDTN    = -1         ! Indicates that any Grid Display Template is a match
4372
4373   UNPACK   = .TRUE.     ! Unpack bitmap and data values
4374
4375
4376   fields_to_skip = 0
4377
4378   CALL GETGB2(DataHandle, 0, fields_to_skip, -1, Disc, JIDS, JPDTN, &
4379        JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, &
4380        gfld, status)
4381   if (status .eq. 99) then
4382      write(msg,*)'Could not find field '//trim(VarName)//&
4383           ' continuing.'
4384      call wrf_message(trim(msg))
4385      ierr = -1
4386      return
4387   else if (status .ne. 0) then
4388      write(msg,*)'Retrieving scalar data field '//trim(VarName)//&
4389           ' failed, continuing.'
4390      call wrf_message(trim(msg))
4391      ierr = -1
4392      return
4393   endif
4394
4395   levels(1:gfld%ndpts) = gfld%fld(1:gfld%ndpts)
4396   ierr = 0
4397
4398 end subroutine gr2_fill_levels
4399
4400
4401 !*****************************************************************************
4402 !
4403 ! Set values for search array arguments for getgb2 to missing.
4404 !
4405 !*****************************************************************************
4406
4407 subroutine gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
4408
4409   USE gr2_data_info
4410   integer :: JIDS(*), JPDT(*), JGDT(*)
4411
4412   do idx = 1,JIDSSIZE
4413      JIDS(idx) = -9999
4414   enddo
4415
4416   do idx=1,JPDTSIZE
4417      JPDT(idx) = -9999
4418   enddo
4419
4420   do idx = 1,JGDTSIZE
4421      JGDT(idx) = -9999
4422   enddo
4423
4424   return
4425
4426 end subroutine gr2_g2lib_wildcard
4427 !*****************************************************************************
4428 !
4429 ! Retrieve a metadata value from the input string
4430 !
4431 !*****************************************************************************
4432
4433 subroutine gr2_get_metadata_value(instring, Key, Value, stat)
4434   character(len=*),intent(in)  :: instring
4435   character(len=*),intent(in)  :: Key
4436   character(len=*),intent(out) :: Value
4437   integer         ,intent(out) :: stat
4438   integer :: Key_pos, equals_pos, line_end
4439   character :: lf
4440
4441   lf=char(10)
4442
4443   Value = 'abc'
4444
4445   !
4446   ! Find Starting position of Key
4447   !
4448   Key_pos = index(instring, lf//' '//Key//' =')
4449   if (Key_pos .eq. 0) then
4450      stat = -1
4451      return
4452   endif
4453
4454   !
4455   ! Find position of the "=" after the Key
4456   !
4457   equals_pos = index(instring(Key_pos:len(instring)), "=") + Key_pos
4458   if (equals_pos .eq. Key_pos) then
4459      stat = -1
4460      return
4461   endif
4462
4463   !
4464   ! Find end of line
4465   !
4466   line_end = index(instring(equals_pos:len(instring)), lf) + equals_pos
4467
4468   !
4469   ! Handle the case for the last line in the string
4470   !
4471   if (line_end .eq. equals_pos) then
4472      line_end = len(trim(instring))
4473   endif
4474
4475   !
4476   ! Set value
4477   !
4478   if ( (equals_pos + 1) .le. (line_end - 2) ) then
4479      Value = trim(adjustl(instring(equals_pos+1:line_end-2)))
4480   else
4481      Value = ""
4482   endif
4483
4484   stat = 0
4485
4486
4487 end subroutine gr2_get_metadata_value
4488
4489 !*****************************************************************************
4490 !
4491 ! Build onto a metadata string with the input value
4492 !
4493 !*****************************************************************************
4494
4495 SUBROUTINE gr2_build_string (string, Element, Value, Count, Status)
4496
4497   IMPLICIT NONE
4498 #include "wrf_status_codes.h"
4499
4500   CHARACTER (LEN=*) , INTENT(INOUT) :: string
4501   CHARACTER (LEN=*) , INTENT(IN)    :: Element
4502   CHARACTER (LEN=*) , INTENT(IN)    :: Value(*)
4503   INTEGER ,           INTENT(IN)    :: Count
4504   INTEGER ,           INTENT(OUT)   :: Status
4505
4506   CHARACTER (LEN=2)                 :: lf
4507   INTEGER                           :: IDX
4508
4509   lf=char(10)//' '
4510
4511   if (index(string,lf//Element//' =') .gt. 0) then
4512      ! We do nothing, since we dont want to add the same variable twice.
4513   else
4514      if (len_trim(string) == 0) then
4515         string = lf//Element//' = '
4516      else
4517         string = trim(string)//lf//Element//' = '
4518      endif
4519      do idx = 1,Count
4520         if (idx > 1) then
4521            string = trim(string)//','
4522         endif
4523         string = trim(string)//' '//trim(adjustl(Value(idx)))
4524      enddo
4525   endif
4526
4527   Status = WRF_NO_ERR
4528
4529 END SUBROUTINE gr2_build_string
4530