wrfv2_fire/external/io_grib1/io_grib1.F

   1 !*-----------------------------------------------------------------------------
   2 !*
   3 !*  Todd Hutchinson
   4 !*  WSI
   5 !*  400 Minuteman Road
   6 !*  Andover, MA     01810
   7 !*  thutchinson@wsi.com
   8 !*
   9 !*-----------------------------------------------------------------------------
  10
  11 !*
  12 !* This io_grib1 API is designed to read WRF input and write WRF output data
  13 !*   in grib version 1 format.
  14 !*
  15
  16
  17 module gr1_data_info
  18
  19 !*
  20 !* This module will hold data internal to this I/O implementation.
  21 !*   The variables will be accessible by all functions (provided they have a
  22 !*   "USE gr1_data_info" line).
  23 !*
  24
  25   integer                , parameter       :: FATAL            = 1
  26   integer                , parameter       :: DEBUG            = 100
  27   integer                , parameter       :: DateStrLen       = 19
  28
  29   integer                , parameter       :: firstFileHandle  = 8
  30   integer                , parameter       :: maxFileHandles   = 30
  31   integer                , parameter       :: maxLevels        = 1000
  32   integer                , parameter       :: maxSoilLevels    = 100
  33   integer                , parameter       :: maxDomains       = 500
  34
  35   logical ,      dimension(maxFileHandles) :: committed, opened, used
  36   character*128, dimension(maxFileHandles) :: DataFile
  37   integer,       dimension(maxFileHandles) :: FileFd
  38   integer,       dimension(maxFileHandles) :: FileStatus
  39   REAL,          dimension(maxLevels)      :: half_eta, full_eta
  40   REAL,          dimension(maxSoilLevels)  :: soil_depth, soil_thickness
  41   character*24                             :: StartDate = ''
  42   character*24                             :: InputProgramName = ''
  43   integer                                  :: projection
  44   integer                                  :: wg_grid_id
  45   real                                     :: dx,dy
  46   real                                     :: truelat1, truelat2
  47   real                                     :: center_lat, center_lon
  48   real                                     :: proj_central_lon
  49   real                                     :: timestep
  50   character,     dimension(:), pointer     :: grib_tables
  51   logical                                  :: table_filled = .FALSE.
  52   character,     dimension(:), pointer     :: grid_info
  53   integer                                  :: full_xsize, full_ysize
  54   integer, dimension(maxDomains)           :: domains = -1
  55   integer                                  :: this_domain = 0
  56   integer                                  :: max_domain = 0
  57
  58   TYPE :: HandleVar
  59      character, dimension(:), pointer      :: fileindex(:)
  60      integer                               :: CurrentTime
  61      integer                               :: NumberTimes
  62      character (DateStrLen), dimension(:),pointer  :: Times(:)
  63   ENDTYPE
  64   TYPE (HandleVar), dimension(maxFileHandles) :: fileinfo
  65
  66   TYPE :: prevdata
  67      integer :: fcst_secs_rainc
  68      integer :: fcst_secs_rainnc
  69      real, dimension(:,:), pointer         :: rainc, rainnc
  70   END TYPE prevdata
  71   TYPE (prevdata), DIMENSION(500)          :: lastdata
  72
  73   TYPE :: initdata
  74      real,         dimension(:,:), pointer :: snod
  75   END TYPE initdata
  76
  77   TYPE (initdata), dimension(maxDomains)   :: firstdata
  78
  79   TYPE :: prestype
  80      real,         dimension(:,:,:), pointer :: vals
  81      logical                                :: newtime
  82      character*120                          :: lastDateStr
  83   END TYPE prestype
  84
  85   character*120, dimension(maxDomains)     :: lastDateStr
  86
  87   TYPE (prestype), dimension(maxDomains)   :: pressure
  88   TYPE (prestype), dimension(maxDomains)   :: geopotential
  89
  90   integer                                  :: center, subcenter, parmtbl
  91
  92   character(len=15000), dimension(firstFileHandle:maxFileHandles) :: td_output
  93   character(len=15000), dimension(firstFileHandle:maxFileHandles) :: ti_output
  94
  95   logical                                  :: WrfIOnotInitialized = .true.
  96
  97 end module gr1_data_info
  98
  99
 100 subroutine ext_gr1_ioinit(SysDepInfo,Status)
 101
 102   USE gr1_data_info
 103   implicit none
 104 #include "wrf_status_codes.h"
 105 #include "wrf_io_flags.h"
 106   CHARACTER*(*), INTENT(IN) :: SysDepInfo
 107   integer ,intent(out) :: Status
 108   integer :: i
 109   integer :: size, istat
 110   CHARACTER (LEN=300) :: wrf_err_message
 111
 112   call wrf_debug ( DEBUG , 'Entering ext_gr1_ioinit')
 113
 114   do i=firstFileHandle, maxFileHandles
 115         used(i) = .false.
 116         committed(i) = .false.
 117         opened(i) = .false.
 118         td_output(i) = ''
 119         ti_output(i) = ''
 120   enddo
 121   domains(:) = -1
 122
 123   do i = 1, maxDomains
 124     pressure(i)%newtime = .false.
 125     pressure(i)%lastDateStr = ''
 126     geopotential(i)%newtime = .false.
 127     geopotential(i)%lastDateStr = ''
 128     lastDateStr(i) = ''
 129   enddo
 130
 131   lastdata%fcst_secs_rainc = 0
 132   lastdata%fcst_secs_rainnc = 0
 133   FileStatus(1:maxFileHandles) = WRF_FILE_NOT_OPENED
 134   WrfIOnotInitialized = .false.
 135
 136   Status = WRF_NO_ERR
 137
 138   return
 139 end subroutine ext_gr1_ioinit
 140
 141 !*****************************************************************************
 142
 143 subroutine ext_gr1_ioexit(Status)
 144
 145   USE gr1_data_info
 146   implicit none
 147 #include "wrf_status_codes.h"
 148   integer istat
 149   integer ,intent(out) :: Status
 150
 151   call wrf_debug ( DEBUG , 'Entering ext_gr1_ioexit')
 152
 153   if (table_filled) then
 154      CALL free_gribmap(grib_tables)
 155      DEALLOCATE(grib_tables, stat=istat)
 156      table_filled = .FALSE.
 157   endif
 158   IF ( ASSOCIATED ( grid_info ) ) THEN
 159     DEALLOCATE(grid_info, stat=istat)
 160   ENDIF
 161   NULLIFY(grid_info)
 162
 163   Status = WRF_NO_ERR
 164
 165   return
 166 end subroutine ext_gr1_ioexit
 167
 168 !*****************************************************************************
 169
 170 SUBROUTINE ext_gr1_open_for_read_begin ( FileName , Comm_compute, Comm_io, &
 171      SysDepInfo, DataHandle , Status )
 172
 173   USE gr1_data_info
 174   IMPLICIT NONE
 175 #include "wrf_status_codes.h"
 176 #include "wrf_io_flags.h"
 177   CHARACTER*(*) :: FileName
 178   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
 179   CHARACTER*(*) :: SysDepInfo
 180   INTEGER ,       INTENT(OUT) :: DataHandle
 181   INTEGER ,       INTENT(OUT) :: Status
 182   integer                     :: ierr
 183   integer                     :: size
 184   integer                     :: idx
 185   integer                     :: parmid
 186   integer                     :: dpth_parmid
 187   integer                     :: thk_parmid
 188   integer                     :: leveltype
 189   integer , DIMENSION(1000)   :: indices
 190   integer                     :: numindices
 191   real , DIMENSION(1000)      :: levels
 192   real                        :: tmp
 193   integer                     :: swapped
 194   integer                     :: etaidx
 195   integer                     :: grb_index
 196   integer                     :: level1, level2
 197   integer   :: tablenum
 198   integer   :: stat
 199   integer   :: endchar
 200   integer   :: last_grb_index
 201   CHARACTER (LEN=300) :: wrf_err_message
 202
 203   call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_read_begin')
 204
 205   CALL gr1_get_new_handle(DataHandle)
 206
 207   if (DataHandle .GT. 0) then
 208      CALL open_file(TRIM(FileName), 'r', FileFd(DataHandle), ierr)
 209      if (ierr .ne. 0) then
 210         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 211      else
 212         opened(DataHandle) = .true.
 213         DataFile(DataHandle) = TRIM(FileName)
 214         FileStatus(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
 215      endif
 216   else
 217      Status = WRF_WARN_TOO_MANY_FILES
 218      return
 219   endif
 220
 221   ! Read the grib index file first
 222   if (.NOT. table_filled) then
 223      table_filled = .TRUE.
 224      CALL GET_GRIB1_TABLES_SIZE(size)
 225      ALLOCATE(grib_tables(1:size), STAT=ierr)
 226      CALL LOAD_GRIB1_TABLES ("gribmap.txt", grib_tables, ierr)
 227      if (ierr .ne. 0) then
 228         DEALLOCATE(grib_tables)
 229         WRITE( wrf_err_message , * ) &
 230              'Could not open file gribmap.txt '
 231         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
 232         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 233         return
 234      endif
 235   endif
 236
 237   ! Begin by indexing file and reading metadata into structure.
 238   CALL GET_FILEINDEX_SIZE(size)
 239   ALLOCATE(fileinfo(DataHandle)%fileindex(1:size), STAT=ierr)
 240
 241   CALL ALLOC_INDEX_FILE(fileinfo(DataHandle)%fileindex(:))
 242   CALL INDEX_FILE(FileFd(DataHandle),fileinfo(DataHandle)%fileindex(:))
 243
 244   ! Get times into Times variable
 245   CALL GET_NUM_TIMES(fileinfo(DataHandle)%fileindex(:), &
 246        fileinfo(DataHandle)%NumberTimes);
 247
 248   ALLOCATE(fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes), STAT=ierr)
 249   do idx = 1,fileinfo(DataHandle)%NumberTimes
 250      CALL GET_TIME(fileinfo(DataHandle)%fileindex(:),idx, &
 251           fileinfo(DataHandle)%Times(idx))
 252   enddo
 253
 254   ! CurrentTime starts as 0.  The first time in the file is 1.  So,
 255   !   until set_time or get_next_time is called, the current time
 256   !   is not set.
 257   fileinfo(DataHandle)%CurrentTime = 0
 258
 259   CALL gr1_fill_eta_levels(fileinfo(DataHandle)%fileindex(:), &
 260        FileFd(DataHandle), &
 261        grib_tables, "ZNW", full_eta)
 262   CALL gr1_fill_eta_levels(fileinfo(DataHandle)%fileindex(:), FileFd(DataHandle), &
 263        grib_tables, "ZNU", half_eta)
 264
 265   !
 266   ! Now, get the soil levels
 267   !
 268   CALL GET_GRIB_PARAM(grib_tables, "ZS", center, subcenter, parmtbl, &
 269        tablenum, dpth_parmid)
 270   CALL GET_GRIB_PARAM(grib_tables,"DZS", center, subcenter, parmtbl, &
 271        tablenum, thk_parmid)
 272   if (dpth_parmid == -1) then
 273      call wrf_message ('Error getting grib parameter')
 274   endif
 275
 276   leveltype = 112
 277
 278   CALL GET_GRIB_INDICES(fileinfo(DataHandle)%fileindex(:),center, subcenter, parmtbl, &
 279        dpth_parmid,"*",leveltype, &
 280        -HUGE(1),-HUGE(1), -HUGE(1),-HUGE(1),indices,numindices)
 281
 282   last_grb_index = -1;
 283   do idx = 1,numindices
 284      CALL READ_GRIB(fileinfo(DataHandle)%fileindex(:), FileFd(DataHandle), &
 285           indices(idx), soil_depth(idx))
 286      !
 287      ! Now read the soil thickenesses
 288      !
 289      CALL GET_LEVEL1(fileinfo(DataHandle)%fileindex(:),indices(idx),level1)
 290      CALL GET_LEVEL2(fileinfo(DataHandle)%fileindex(:),indices(idx),level2)
 291      CALL GET_GRIB_INDEX_GUESS(fileinfo(DataHandle)%fileindex(:), &
 292           center, subcenter, parmtbl, thk_parmid,"*",leveltype, &
 293           level1,level2,-HUGE(1),-HUGE(1), last_grb_index+1, grb_index)
 294      CALL READ_GRIB(fileinfo(DataHandle)%fileindex(:),FileFd(DataHandle),grb_index, &
 295           soil_thickness(idx))
 296
 297      last_grb_index = grb_index
 298   enddo
 299
 300
 301
 302   !
 303   ! Fill up any variables that need to be retrieved from Metadata
 304   !
 305   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), 'PROGRAM_NAME', "none", &
 306        "none", InputProgramName, stat)
 307   if (stat /= 0) then
 308      CALL wrf_debug (DEBUG , "PROGRAM_NAME not found in input METADATA")
 309   else
 310      endchar = SCAN(InputProgramName," ")
 311      InputProgramName = InputProgramName(1:endchar)
 312   endif
 313
 314   call wrf_debug ( DEBUG , 'Exiting ext_gr1_open_for_read_begin')
 315
 316   RETURN
 317 END SUBROUTINE ext_gr1_open_for_read_begin
 318
 319 !*****************************************************************************
 320
 321 SUBROUTINE ext_gr1_open_for_read_commit( DataHandle , Status )
 322
 323   USE gr1_data_info
 324   IMPLICIT NONE
 325 #include "wrf_status_codes.h"
 326 #include "wrf_io_flags.h"
 327   character(len=1000) :: msg
 328   INTEGER ,       INTENT(IN ) :: DataHandle
 329   INTEGER ,       INTENT(OUT) :: Status
 330
 331   call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_read_commit')
 332
 333   Status = WRF_NO_ERR
 334   if(WrfIOnotInitialized) then
 335     Status = WRF_IO_NOT_INITIALIZED
 336     write(msg,*) 'ext_gr1_ioinit was not called ',__FILE__,', line', __LINE__
 337     call wrf_debug ( FATAL , msg)
 338     return
 339   endif
 340   committed(DataHandle) = .true.
 341   FileStatus(DataHandle) = WRF_FILE_OPENED_FOR_READ
 342
 343   Status = WRF_NO_ERR
 344
 345   RETURN
 346 END SUBROUTINE ext_gr1_open_for_read_commit
 347
 348 !*****************************************************************************
 349
 350 SUBROUTINE ext_gr1_open_for_read ( FileName , Comm_compute, Comm_io, &
 351      SysDepInfo, DataHandle , Status )
 352
 353   USE gr1_data_info
 354   IMPLICIT NONE
 355 #include "wrf_status_codes.h"
 356 #include "wrf_io_flags.h"
 357   CHARACTER*(*) :: FileName
 358   INTEGER ,       INTENT(IN)  :: Comm_compute , Comm_io
 359   CHARACTER*(*) :: SysDepInfo
 360   INTEGER ,       INTENT(OUT) :: DataHandle
 361   INTEGER ,       INTENT(OUT) :: Status
 362
 363
 364   call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_read')
 365
 366   DataHandle = 0   ! dummy setting to quiet warning message
 367   CALL ext_gr1_open_for_read_begin( FileName, Comm_compute, Comm_io, &
 368        SysDepInfo, DataHandle, Status )
 369   IF ( Status .EQ. WRF_NO_ERR ) THEN
 370      FileStatus(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
 371      CALL ext_gr1_open_for_read_commit( DataHandle, Status )
 372   ENDIF
 373   return
 374
 375   RETURN
 376 END SUBROUTINE ext_gr1_open_for_read
 377
 378 !*****************************************************************************
 379
 380 SUBROUTINE ext_gr1_open_for_write_begin(FileName, Comm, IOComm, SysDepInfo, &
 381      DataHandle, Status)
 382
 383   USE gr1_data_info
 384   implicit none
 385 #include "wrf_status_codes.h"
 386 #include "wrf_io_flags.h"
 387
 388   character*(*)        ,intent(in)  :: FileName
 389   integer              ,intent(in)  :: Comm
 390   integer              ,intent(in)  :: IOComm
 391   character*(*)        ,intent(in)  :: SysDepInfo
 392   integer              ,intent(out) :: DataHandle
 393   integer              ,intent(out) :: Status
 394   integer :: ierr
 395   CHARACTER (LEN=300) :: wrf_err_message
 396   integer             :: size
 397
 398   call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_write_begin')
 399
 400   if (.NOT. table_filled) then
 401      table_filled = .TRUE.
 402      CALL GET_GRIB1_TABLES_SIZE(size)
 403      ALLOCATE(grib_tables(1:size), STAT=ierr)
 404      CALL LOAD_GRIB1_TABLES ("gribmap.txt", grib_tables, ierr)
 405      if (ierr .ne. 0) then
 406         DEALLOCATE(grib_tables)
 407         WRITE( wrf_err_message , * ) &
 408              'Could not open file gribmap.txt '
 409         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
 410         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 411         return
 412      endif
 413   endif
 414
 415   Status = WRF_NO_ERR
 416   CALL gr1_get_new_handle(DataHandle)
 417   if (DataHandle .GT. 0) then
 418      CALL open_file(TRIM(FileName), 'w', FileFd(DataHandle), ierr)
 419      if (ierr .ne. 0) then
 420         Status = WRF_WARN_WRITE_RONLY_FILE
 421      else
 422         opened(DataHandle) = .true.
 423         DataFile(DataHandle) = TRIM(FileName)
 424         FileStatus(DataHandle) = WRF_FILE_OPENED_NOT_COMMITTED
 425      endif
 426      committed(DataHandle) = .false.
 427      td_output(DataHandle) = ''
 428   else
 429      Status = WRF_WARN_TOO_MANY_FILES
 430   endif
 431
 432   RETURN
 433 END SUBROUTINE ext_gr1_open_for_write_begin
 434
 435 !*****************************************************************************
 436
 437 SUBROUTINE ext_gr1_open_for_write_commit( DataHandle , Status )
 438
 439   USE gr1_data_info
 440   IMPLICIT NONE
 441 #include "wrf_status_codes.h"
 442 #include "wrf_io_flags.h"
 443   INTEGER ,       INTENT(IN ) :: DataHandle
 444   INTEGER ,       INTENT(OUT) :: Status
 445
 446   call wrf_debug ( DEBUG , 'Entering ext_gr1_open_for_write_commit')
 447
 448   IF ( opened( DataHandle ) ) THEN
 449     IF ( used( DataHandle ) ) THEN
 450       committed(DataHandle) = .true.
 451       FileStatus(DataHandle) = WRF_FILE_OPENED_FOR_WRITE
 452     ENDIF
 453   ENDIF
 454
 455   Status = WRF_NO_ERR
 456
 457   RETURN
 458 END SUBROUTINE ext_gr1_open_for_write_commit
 459
 460 !*****************************************************************************
 461
 462 subroutine ext_gr1_inquiry (Inquiry, Result, Status)
 463   use gr1_data_info
 464   implicit none
 465 #include "wrf_status_codes.h"
 466   character *(*), INTENT(IN)    :: Inquiry
 467   character *(*), INTENT(OUT)   :: Result
 468   integer        ,INTENT(INOUT) :: Status
 469   SELECT CASE (Inquiry)
 470   CASE ("RANDOM_WRITE","RANDOM_READ")
 471      Result='ALLOW'
 472   CASE ("SEQUENTIAL_WRITE","SEQUENTIAL_READ")
 473      Result='NO'
 474   CASE ("OPEN_READ", "OPEN_WRITE", "OPEN_COMMIT_WRITE")
 475      Result='REQUIRE'
 476   CASE ("OPEN_COMMIT_READ","PARALLEL_IO")
 477      Result='NO'
 478   CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS")
 479      Result='YES'
 480   CASE ("MEDIUM")
 481      Result ='FILE'
 482   CASE DEFAULT
 483      Result = 'No Result for that inquiry!'
 484   END SELECT
 485   Status=WRF_NO_ERR
 486   return
 487 end subroutine ext_gr1_inquiry
 488
 489 !*****************************************************************************
 490
 491 SUBROUTINE ext_gr1_inquire_opened ( DataHandle, FileName , FileStat, Status )
 492
 493   USE gr1_data_info
 494   IMPLICIT NONE
 495 #include "wrf_status_codes.h"
 496 #include "wrf_io_flags.h"
 497   INTEGER ,       INTENT(IN)  :: DataHandle
 498   CHARACTER*(*) :: FileName
 499   INTEGER ,       INTENT(OUT) :: FileStat
 500   INTEGER ,       INTENT(OUT) :: Status
 501
 502   call wrf_debug ( DEBUG , 'Entering ext_gr1_inquire_opened')
 503
 504   FileStat = WRF_NO_ERR
 505   if ((DataHandle .ge. firstFileHandle) .and. &
 506        (DataHandle .le. maxFileHandles)) then
 507      FileStat = FileStatus(DataHandle)
 508   else
 509      FileStat = WRF_FILE_NOT_OPENED
 510   endif
 511
 512   Status = FileStat
 513
 514   RETURN
 515 END SUBROUTINE ext_gr1_inquire_opened
 516
 517 !*****************************************************************************
 518
 519 SUBROUTINE ext_gr1_ioclose ( DataHandle, Status )
 520
 521   USE gr1_data_info
 522   IMPLICIT NONE
 523 #include "wrf_status_codes.h"
 524   INTEGER DataHandle, Status
 525   INTEGER istat
 526   INTEGER ierr
 527   character(len=1000) :: outstring
 528   character :: lf
 529   lf=char(10)
 530
 531   call wrf_debug ( DEBUG , 'Entering ext_gr1_ioclose')
 532
 533   Status = WRF_NO_ERR
 534
 535   CALL write_file(FileFd(DataHandle), lf//'<METADATA>'//lf,ierr)
 536   outstring = &
 537        '<!-- The following are fields that were supplied to the WRF I/O API.'//lf//&
 538        'Many variables (but not all) are redundant with the variables within '//lf//&
 539        'the grib headers.  They are stored here, as METADATA, so that the '//lf//&
 540        'WRF I/O API has simple access to these variables.-->'
 541   CALL write_file(FileFd(DataHandle), trim(outstring), ierr)
 542   if (trim(ti_output(DataHandle)) /= '') then
 543      CALL write_file(FileFd(DataHandle), trim(ti_output(DataHandle)), ierr)
 544      CALL write_file(FileFd(DataHandle), lf, ierr)
 545   endif
 546   if (trim(td_output(DataHandle)) /= '') then
 547      CALL write_file(FileFd(DataHandle), trim(td_output(DataHandle)), ierr)
 548      CALL write_file(FileFd(DataHandle), lf, ierr)
 549   endif
 550   CALL write_file(FileFd(DataHandle), '</METADATA>'//lf,ierr)
 551   ti_output(DataHandle) = ''
 552   td_output(DataHandle) = ''
 553   if (ierr .ne. 0) then
 554      Status = WRF_WARN_WRITE_RONLY_FILE
 555   endif
 556   CALL close_file(FileFd(DataHandle))
 557
 558   used(DataHandle) = .false.
 559
 560   RETURN
 561 END SUBROUTINE ext_gr1_ioclose
 562
 563 !*****************************************************************************
 564
 565 SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , &
 566      Field , FieldType , Comm , IOComm, &
 567      DomainDesc , MemoryOrder , Stagger , &
 568      DimNames , &
 569      DomainStart , DomainEnd , &
 570      MemoryStart , MemoryEnd , &
 571      PatchStart , PatchEnd , &
 572      Status )
 573
 574   USE gr1_data_info
 575   IMPLICIT NONE
 576 #include "wrf_status_codes.h"
 577 #include "wrf_io_flags.h"
 578 #include "wrf_projection.h"
 579   INTEGER ,       INTENT(IN)    :: DataHandle
 580   CHARACTER*(*) :: DateStrIn
 581   CHARACTER(DateStrLen) :: DateStr
 582   CHARACTER*(*) :: VarName
 583   CHARACTER*120 :: OutName
 584   CHARACTER(120) :: TmpVarName
 585   integer                       ,intent(in)    :: FieldType
 586   integer                       ,intent(inout) :: Comm
 587   integer                       ,intent(inout) :: IOComm
 588   integer                       ,intent(in)    :: DomainDesc
 589   character*(*)                 ,intent(in)    :: MemoryOrder
 590   character*(*)                 ,intent(in)    :: Stagger
 591   character*(*) , dimension (*) ,intent(in)    :: DimNames
 592   integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
 593   integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
 594   integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
 595   integer                       ,intent(out)   :: Status
 596   integer                                      :: ierror
 597   character (120)                         :: msg
 598   integer :: xsize, ysize, zsize
 599   integer :: x, y, z
 600   integer :: x_start,x_end,y_start,y_end,z_start,z_end,ndim
 601   integer :: idx
 602   integer :: proj_center_flag
 603   logical :: vert_stag = .false.
 604   integer :: levelnum
 605   real, DIMENSION(:,:), POINTER :: data,tmpdata
 606   integer, DIMENSION(:), POINTER :: mold
 607   integer :: istat
 608   integer :: accum_period
 609   integer :: size
 610   integer, dimension(1000) :: level1, level2
 611   real, DIMENSION( 1:1,MemoryStart(1):MemoryEnd(1), &
 612                    MemoryStart(2):MemoryEnd(2), &
 613                    MemoryStart(3):MemoryEnd(3) ) :: Field
 614   real    :: fcst_secs
 615   logical :: soil_layers, fraction
 616   integer :: vert_unit
 617   integer :: abc(2,2,2)
 618   integer :: def(8)
 619   logical :: output = .true.
 620   integer :: idx1, idx2, idx3
 621   logical :: new_domain
 622   real    :: region_center_lat, region_center_lon
 623   integer :: dom_xsize, dom_ysize;
 624   integer :: ierr
 625   logical :: already_have_domain
 626
 627   call wrf_debug ( DEBUG , 'Entering ext_gr1_write_field for parameter'//VarName)
 628
 629   !
 630   ! If DateStr is all 0's, we reset it to StartDate (if StartDate exists).
 631   !   For some reason,
 632   !   in idealized simulations, StartDate is 0001-01-01_00:00:00 while
 633   !   the first DateStr is 0000-00-00_00:00:00.
 634   !
 635   if (DateStrIn .eq. '0000-00-00_00:00:00') then
 636      if (StartDate .ne. '') then
 637         DateStr = TRIM(StartDate)
 638      else
 639         DateStr = '0001-01-01_00:00:00'
 640      endif
 641   else
 642      DateStr = DateStrIn
 643   endif
 644
 645   !
 646   ! Check if this is a domain that we haven't seen yet.  If so, add it to
 647   !   the list of domains.
 648   !
 649   new_domain = .false.
 650   already_have_domain = .false.
 651   do idx = 1, max_domain
 652      if (this_domain .eq. domains(idx)) then
 653         already_have_domain = .true.
 654      endif
 655   enddo
 656   if (.NOT. already_have_domain) then
 657      max_domain = max_domain + 1
 658      domains(max_domain) = this_domain
 659      new_domain = .true.
 660   endif
 661
 662   !
 663   ! If the time has changed, we open a new file.  This is a kludge to get
 664   !   around slowness in WRF that occurs when opening a new data file the
 665   !   standard way.
 666   !
 667 #ifdef GRIB_ONE_TIME_PER_FILE
 668   if (lastDateStr(this_domain) .ne. DateStr) then
 669      write(DataFile(DataHandle),'(A8,i2.2,A1,A19)') 'wrfout_d',this_domain,'_',DateStr
 670      call ext_gr1_ioclose ( DataHandle, Status )
 671      CALL open_file(TRIM(DataFile(DataHandle)), 'w', FileFd(DataHandle), ierr)
 672      if (ierr .ne. 0) then
 673         print *,'Could not open new file: ',DataFile(DataHandle)
 674         print *,'  Appending to old file.'
 675      else
 676         ! Just set used back to .true. here, since ioclose set it to false.
 677         used(DataHandle) = .true.
 678      endif
 679      td_output(DataHandle) = ''
 680   endif
 681   lastDateStr(this_domain) = DateStr
 682 #endif
 683
 684   output = .true.
 685   zsize = 1
 686   xsize = 1
 687   ysize = 1
 688   OutName = VarName
 689   soil_layers = .false.
 690   fraction = .false.
 691
 692   ! First, handle then special cases for the boundary data.
 693
 694   CALL get_dims(MemoryOrder, PatchStart, PatchEnd, ndim, x_start, x_end, &
 695        y_start, y_end,z_start,z_end)
 696   xsize = x_end - x_start + 1
 697   ysize = y_end - y_start + 1
 698   zsize = z_end - z_start + 1
 699
 700   do idx = 1, len(MemoryOrder)
 701      if ((MemoryOrder(idx:idx) .eq. 'Z') .and. &
 702           (DimNames(idx) .eq. 'soil_layers_stag')) then
 703         soil_layers = .true.
 704      else if ((OutName .eq. 'LANDUSEF') .or. (OutName .eq. 'SOILCBOT') .or. &
 705           (OutName .eq. 'SOILCTOP')) then
 706         fraction = .true.
 707      endif
 708   enddo
 709
 710   if (.not. ASSOCIATED(grid_info)) then
 711      CALL get_grid_info_size(size)
 712      ALLOCATE(grid_info(1:size), STAT=istat)
 713      if (istat .eq. -1) then
 714         DEALLOCATE(grid_info)
 715         Status = WRF_ERR_FATAL_BAD_FILE_STATUS
 716         return
 717      endif
 718   endif
 719
 720
 721   if (new_domain) then
 722      ALLOCATE(firstdata(this_domain)%snod(xsize,ysize))
 723      firstdata(this_domain)%snod(:,:) = 0.0
 724      ALLOCATE(lastdata(this_domain)%rainc(xsize,ysize))
 725      lastdata(this_domain)%rainc(:,:) = 0.0
 726      ALLOCATE(lastdata(this_domain)%rainnc(xsize,ysize))
 727      lastdata(this_domain)%rainnc(:,:) = 0.0
 728   endif
 729
 730   if (zsize .eq. 0) then
 731      zsize = 1
 732   endif
 733
 734   ALLOCATE(data(1:xsize,1:ysize), STAT=istat)
 735   ALLOCATE(mold(1:ysize), STAT=istat)
 736   ALLOCATE(tmpdata(1:xsize,1:ysize), STAT=istat)
 737
 738   if (OutName .eq. 'ZNU') then
 739      do idx = 1, zsize
 740         half_eta(idx) = Field(1,idx,1,1)
 741      enddo
 742   endif
 743
 744   if (OutName .eq. 'ZNW') then
 745      do idx = 1, zsize
 746         full_eta(idx) = Field(1,idx,1,1)
 747      enddo
 748   endif
 749
 750   if (OutName .eq. 'ZS') then
 751      do idx = 1, zsize
 752         soil_depth(idx) = Field(1,idx,1,1)
 753      enddo
 754   endif
 755
 756   if (OutName .eq. 'DZS') then
 757      do idx = 1, zsize
 758         soil_thickness(idx) = Field(1,idx,1,1)
 759      enddo
 760   endif
 761
 762
 763   if ((xsize .lt. 1) .or. (ysize .lt. 1)) then
 764      write(msg,*) 'Cannot output field with memory order: ', &
 765           MemoryOrder,Varname
 766      call wrf_message(msg)
 767      return
 768   endif
 769
 770   call get_vert_stag(OutName,Stagger,vert_stag)
 771
 772   do idx = 1, zsize
 773      call gr1_get_levels(OutName, idx, zsize, soil_layers, vert_stag, fraction, &
 774           vert_unit, level1(idx), level2(idx))
 775   enddo
 776
 777   !
 778   ! Get the center lat/lon for the area being output.  For some cases (such
 779   !    as for boundary areas, the center of the area is different from the
 780   !    center of the model grid.
 781   !
 782   if (index(Stagger,'X') .le. 0) then
 783      dom_xsize = full_xsize - 1
 784   else
 785      dom_xsize = full_xsize
 786   endif
 787   if (index(Stagger,'Y') .le. 0) then
 788      dom_ysize = full_ysize - 1
 789   else
 790      dom_ysize = full_ysize
 791   endif
 792
 793   !
 794   ! Handle case of polare stereographic centered on pole.  In that case,
 795   !   always set center lon to be the projection central longitude.
 796   !
 797   if ((projection .eq. WRF_POLAR_STEREO) .AND. &
 798        (abs(center_lat - 90.0) < 0.01)) then
 799      center_lon = proj_central_lon
 800   endif
 801
 802   CALL get_region_center(MemoryOrder, projection, center_lat, center_lon, &
 803        dom_xsize, dom_ysize, dx, dy, proj_central_lon, proj_center_flag, &
 804        truelat1, truelat2, xsize, ysize, region_center_lat, region_center_lon)
 805
 806   if ( .not. opened(DataHandle)) then
 807      Status = WRF_WARN_FILE_NOT_OPENED
 808      return
 809   endif
 810
 811
 812   if (opened(DataHandle) .and. committed(DataHandle)) then
 813
 814
 815 #ifdef OUTPUT_FULL_PRESSURE
 816
 817      !
 818      ! The following is a kludge to output full pressure instead of the two
 819      !  fields of base-state pressure and pressure perturbation.
 820      !
 821      ! This code can be turned on by adding -DOUTPUT_FULL_PRESSURE to the
 822      !  compile line
 823      !
 824
 825      if ((OutName .eq. 'P') .or. (OutName.eq.'PB')) then
 826         do idx = 1, len(MemoryOrder)
 827             if (MemoryOrder(idx:idx) .eq. 'X') then
 828               idx1=idx
 829            endif
 830            if (MemoryOrder(idx:idx) .eq. 'Y') then
 831               idx2=idx
 832            endif
 833            if (MemoryOrder(idx:idx) .eq. 'Z') then
 834               idx3=idx
 835            endif
 836         enddo
 837
 838         !
 839         ! Allocate space for pressure values (this variable holds
 840         !   base-state pressure or pressure perturbation to be used
 841         !   later to sum base-state and perturbation pressure to get full
 842         !   pressure).
 843         !
 844
 845         if (.not. ASSOCIATED(pressure(this_domain)%vals)) then
 846            ALLOCATE(pressure(this_domain)%vals(MemoryStart(1):MemoryEnd(1), &
 847                 MemoryStart(2):MemoryEnd(2),MemoryStart(3):MemoryEnd(3)))
 848         endif
 849         if (DateStr .NE. &
 850              pressure(this_domain)%lastDateStr) then
 851            pressure(this_domain)%newtime = .true.
 852         endif
 853         if (pressure(this_domain)%newtime) then
 854            pressure(this_domain)%vals = Field(1,:,:,:)
 855            pressure(this_domain)%newtime = .false.
 856            output = .false.
 857         else
 858            output = .true.
 859         endif
 860         pressure(this_domain)%lastDateStr=DateStr
 861      endif
 862 #endif
 863
 864 #ifdef OUTPUT_FULL_GEOPOTENTIAL
 865
 866      !
 867      ! The following is a kludge to output full geopotential height instead
 868      !  of the two fields of base-state geopotential and perturbation
 869      !  geopotential.
 870      !
 871      ! This code can be turned on by adding -DOUTPUT_FULL_GEOPOTENTIAL to the
 872      !  compile line
 873      !
 874
 875      if ((OutName .eq. 'PHB') .or. (OutName.eq.'PH')) then
 876         do idx = 1, len(MemoryOrder)
 877             if (MemoryOrder(idx:idx) .eq. 'X') then
 878               idx1=idx
 879            endif
 880            if (MemoryOrder(idx:idx) .eq. 'Y') then
 881               idx2=idx
 882            endif
 883            if (MemoryOrder(idx:idx) .eq. 'Z') then
 884               idx3=idx
 885            endif
 886         enddo
 887
 888         !
 889         ! Allocate space for geopotential values (this variable holds
 890         !   geopotential to be used
 891         !   later to sum base-state and perturbation to get full
 892         !   geopotential).
 893         !
 894
 895         if (.not. ASSOCIATED(geopotential(this_domain)%vals)) then
 896            ALLOCATE(geopotential(this_domain)%vals(MemoryStart(1):MemoryEnd(1), &
 897                 MemoryStart(2):MemoryEnd(2),MemoryStart(3):MemoryEnd(3)))
 898         endif
 899         if (DateStr .NE. &
 900              geopotential(this_domain)%lastDateStr) then
 901            geopotential(this_domain)%newtime = .true.
 902         endif
 903         if (geopotential(this_domain)%newtime) then
 904            geopotential(this_domain)%vals = Field(1,:,:,:)
 905            geopotential(this_domain)%newtime = .false.
 906            output = .false.
 907         else
 908            output = .true.
 909         endif
 910         geopotential(this_domain)%lastDateStr=DateStr
 911      endif
 912 #endif
 913
 914      if (output) then
 915         if (StartDate == '') then
 916            StartDate = DateStr
 917         endif
 918         CALL geth_idts(DateStr,StartDate,fcst_secs)
 919
 920         if (center_lat .lt. 0) then
 921            proj_center_flag = 2
 922         else
 923            proj_center_flag = 1
 924         endif
 925
 926         do z = 1, zsize
 927            SELECT CASE (MemoryOrder)
 928            CASE ('XYZ')
 929               data = Field(1,1:xsize,1:ysize,z)
 930            CASE ('XZY')
 931               data = Field(1,1:xsize,z,1:ysize)
 932            CASE ('YXZ')
 933               do x = 1,xsize
 934                  do y = 1,ysize
 935                     data(x,y) = Field(1,y,x,z)
 936                  enddo
 937               enddo
 938            CASE ('YZX')
 939               do x = 1,xsize
 940                  do y = 1,ysize
 941                     data(x,y) = Field(1,y,z,x)
 942                  enddo
 943               enddo
 944            CASE ('ZXY')
 945               data = Field(1,z,1:xsize,1:ysize)
 946            CASE ('ZYX')
 947               do x = 1,xsize
 948                  do y = 1,ysize
 949                     data(x,y) = Field(1,z,y,x)
 950                  enddo
 951               enddo
 952            CASE ('XY')
 953               data = Field(1,1:xsize,1:ysize,1)
 954            CASE ('YX')
 955               do x = 1,xsize
 956                  do y = 1,ysize
 957                     data(x,y) = Field(1,y,x,1)
 958                  enddo
 959               enddo
 960
 961            CASE ('XSZ')
 962               do x = 1,xsize
 963                  do y = 1,ysize
 964                     data(x,y) = Field(1,y,z,x)
 965                  enddo
 966               enddo
 967            CASE ('XEZ')
 968               do x = 1,xsize
 969                  do y = 1,ysize
 970                     data(x,y) = Field(1,y,z,x)
 971                  enddo
 972               enddo
 973            CASE ('YSZ')
 974               do x = 1,xsize
 975                  do y = 1,ysize
 976                     data(x,y) = Field(1,x,z,y)
 977                  enddo
 978               enddo
 979            CASE ('YEZ')
 980               do x = 1,xsize
 981                  do y = 1,ysize
 982                     data(x,y) = Field(1,x,z,y)
 983                  enddo
 984               enddo
 985
 986            CASE ('XS')
 987               do x = 1,xsize
 988                  do y = 1,ysize
 989                     data(x,y) = Field(1,y,x,1)
 990                  enddo
 991               enddo
 992            CASE ('XE')
 993               do x = 1,xsize
 994                  do y = 1,ysize
 995                     data(x,y) = Field(1,y,x,1)
 996                  enddo
 997               enddo
 998            CASE ('YS')
 999               do x = 1,xsize
1000                  do y = 1,ysize
1001                     data(x,y) = Field(1,x,y,1)
1002                  enddo
1003               enddo
1004            CASE ('YE')
1005               do x = 1,xsize
1006                  do y = 1,ysize
1007                     data(x,y) = Field(1,x,y,1)
1008                  enddo
1009               enddo
1010
1011            CASE ('Z')
1012               data(1,1) = Field(1,z,1,1)
1013            CASE ('z')
1014               data(1,1) = Field(1,z,1,1)
1015            CASE ('C')
1016               data = Field(1,1:xsize,1:ysize,z)
1017            CASE ('c')
1018               data = Field(1,1:xsize,1:ysize,z)
1019            CASE ('0')
1020               data(1,1) = Field(1,1,1,1)
1021            END SELECT
1022
1023            !
1024            ! Here, we convert any integer fields to real
1025            !
1026            if (FieldType == WRF_INTEGER) then
1027               mold = 0
1028               do idx=1,xsize
1029                  !
1030                  ! The parentheses around data(idx,:) are needed in order
1031                  !   to fix a bug with transfer with the xlf compiler on NCAR's
1032                  !   IBM (bluesky).
1033                  !
1034                  data(idx,:)=transfer((data(idx,:)),mold)
1035               enddo
1036            endif
1037            !
1038            ! Here, we do any necessary conversions to the data.
1039            !
1040
1041            ! Potential temperature is sometimes passed in as perturbation
1042            !   potential temperature (i.e., POT-300).  Other times (i.e., from
1043            !   WRF SI), it is passed in as full potential temperature.
1044            ! Here, we convert to full potential temperature by adding 300
1045            !   only if POT < 200 K.
1046            !
1047            if (OutName == 'T') then
1048               if (data(1,1) < 200) then
1049                  data = data + 300
1050               endif
1051            endif
1052
1053            !
1054            ! For precip, we setup the accumulation period, and output a precip
1055            !    rate for time-step precip.
1056            !
1057            if (OutName .eq. 'RAINNCV') then
1058               ! Convert time-step precip to precip rate.
1059               data = data/timestep
1060               accum_period = 0
1061            else
1062               accum_period = 0
1063            endif
1064
1065 #ifdef OUTPUT_FULL_PRESSURE
1066            !
1067            ! Computation of full-pressure off by default since there are
1068            !  uses for base-state and perturbation (i.e., restarts
1069            !
1070             if ((OutName .eq. 'P') .or. (OutName.eq.'PB')) then
1071                if (idx3 .eq. 1) then
1072                   data = data + &
1073                        pressure(this_domain)%vals(z, &
1074                        patchstart(2):patchend(2),patchstart(3):patchend(3))
1075                elseif (idx3 .eq. 2) then
1076                   data = data + &
1077                        pressure(this_domain)%vals(patchstart(1):patchend(1), &
1078                        z,patchstart(3):patchend(3))
1079                elseif (idx3 .eq. 3) then
1080                   data = data + &
1081                        pressure(this_domain)%vals(patchstart(1):patchend(1), &
1082                        patchstart(2):patchend(2),z)
1083                else
1084                   call wrf_message ('error in idx3, continuing')
1085                endif
1086
1087                OutName = 'P'
1088             endif
1089 #endif
1090
1091 #ifdef OUTPUT_FULL_GEOPOTENTIAL
1092            !
1093            ! Computation of full-geopotential off by default since there are
1094            !  uses for base-state and perturbation (i.e., restarts
1095            !
1096             if ((OutName .eq. 'PHB') .or. (OutName.eq.'PH')) then
1097                if (idx3 .eq. 1) then
1098                   data = data + &
1099                        geopotential(this_domain)%vals(z, &
1100                        patchstart(2):patchend(2),patchstart(3):patchend(3))
1101                elseif (idx3 .eq. 2) then
1102                   data = data + &
1103                        geopotential(this_domain)%vals(patchstart(1):patchend(1), &
1104                        z,patchstart(3):patchend(3))
1105                elseif (idx3 .eq. 3) then
1106                   data = data + &
1107                        geopotential(this_domain)%vals(patchstart(1):patchend(1), &
1108                        patchstart(2):patchend(2),z)
1109                else
1110                   call wrf_message ('error in idx3, continuing')
1111                endif
1112
1113                OutName = 'PHP'
1114             endif
1115 #endif
1116
1117            !
1118            !    Output current level
1119            !
1120            CALL load_grid_info(OutName, StartDate, vert_unit, level1(z), &
1121                 level2(z), fcst_secs, accum_period, wg_grid_id, projection, &
1122                 xsize, ysize, region_center_lat, region_center_lon, dx, dy, &
1123                 proj_central_lon, proj_center_flag, truelat1, truelat2, &
1124                 grib_tables, grid_info)
1125
1126            !
1127            ! Here, we copy data to a temporary array.  After write_grib,
1128            !    we copy back from the temporary array to the permanent
1129            !    array.  write_grib modifies data.  For certain fields that
1130            !    we use below, we want the original (unmodified) data
1131            !    values.  This kludge assures that we have the original
1132            !    values.
1133            !
1134
1135            if ((OutName .eq. 'RAINC') .or. (OutName .eq. 'RAINNC') .or. &
1136                 (OutName .eq. 'SNOWH')) then
1137               tmpdata(:,:) = data(:,:)
1138            endif
1139
1140            CALL write_grib(grid_info, FileFd(DataHandle), data)
1141
1142            if ((OutName .eq. 'RAINC') .or. (OutName .eq. 'RAINNC') .or. &
1143                 (OutName .eq. 'SNOWH')) then
1144               data(:,:) = tmpdata(:,:)
1145            endif
1146
1147            CALL free_grid_info(grid_info)
1148
1149            !
1150            ! If this is the total accumulated rain, call write_grib again
1151            !   to output the accumulation since the last output time as well.
1152            !   This is somewhat of a kludge to meet the requirements of PF.
1153            !
1154            if ((OutName .eq. 'RAINC') .or. (OutName .eq. 'RAINNC') .or. &
1155                 (OutName .eq. 'SNOWH')) then
1156               if (OutName .eq. 'RAINC') then
1157                  data(:,:) = data(:,:) - lastdata(this_domain)%rainc(:,:)
1158                  lastdata(this_domain)%rainc(:,:) = tmpdata(:,:)
1159                  accum_period = fcst_secs - &
1160                       lastdata(this_domain)%fcst_secs_rainc
1161                  lastdata(this_domain)%fcst_secs_rainc = fcst_secs
1162                  TmpVarName = 'ACPCP'
1163               else if (OutName .eq. 'RAINNC') then
1164                  tmpdata(:,:) = data(:,:)
1165                  data(:,:) = data(:,:) - lastdata(this_domain)%rainnc(:,:)
1166                  lastdata(this_domain)%rainnc(:,:) = tmpdata(:,:)
1167                  accum_period = fcst_secs - &
1168                       lastdata(this_domain)%fcst_secs_rainnc
1169                  lastdata(this_domain)%fcst_secs_rainnc = fcst_secs
1170                  TmpVarName = 'NCPCP'
1171               else if (OutName .eq. 'SNOWH') then
1172                  if (fcst_secs .eq. 0) then
1173                     firstdata(this_domain)%snod(:,:) = data(:,:)
1174                  endif
1175                  data(:,:) = data(:,:) - firstdata(this_domain)%snod(:,:)
1176                  TmpVarName = 'SNOWCU'
1177               endif
1178
1179               CALL load_grid_info(TmpVarName, StartDate, vert_unit, level1(z),&
1180                    level2(z), fcst_secs, accum_period, wg_grid_id, &
1181                    projection, xsize, ysize, region_center_lat, &
1182                    region_center_lon, dx, dy, proj_central_lon, &
1183                    proj_center_flag, truelat1, truelat2, grib_tables, &
1184                    grid_info)
1185
1186               CALL write_grib(grid_info, FileFd(DataHandle), data)
1187               CALL free_grid_info(grid_info)
1188            endif
1189
1190         enddo
1191      endif
1192   endif
1193
1194   deallocate(data, STAT = istat)
1195   deallocate(mold, STAT = istat)
1196   deallocate(tmpdata, STAT = istat)
1197
1198   Status = WRF_NO_ERR
1199
1200   call wrf_debug ( DEBUG , 'Leaving ext_gr1_write_field')
1201
1202   RETURN
1203 END SUBROUTINE ext_gr1_write_field
1204
1205 !*****************************************************************************
1206
1207 SUBROUTINE ext_gr1_read_field ( DataHandle , DateStr , VarName , Field , &
1208      FieldType , Comm , IOComm, DomainDesc , MemoryOrder , Stagger ,     &
1209      DimNames , DomainStart , DomainEnd , MemoryStart , MemoryEnd ,      &
1210      PatchStart , PatchEnd ,  Status )
1211
1212   USE gr1_data_info
1213   IMPLICIT NONE
1214 #include "wrf_status_codes.h"
1215 #include "wrf_io_flags.h"
1216   INTEGER ,       INTENT(IN)    :: DataHandle
1217   CHARACTER*(*) :: DateStr
1218   CHARACTER*(*) :: VarName
1219   CHARACTER (len=400) :: msg
1220   integer                       ,intent(inout)    :: FieldType
1221   integer                       ,intent(inout)    :: Comm
1222   integer                       ,intent(inout)    :: IOComm
1223   integer                       ,intent(inout)    :: DomainDesc
1224   character*(*)                 ,intent(inout)    :: MemoryOrder
1225   character*(*)                 ,intent(inout)    :: Stagger
1226   character*(*) , dimension (*) ,intent(inout)    :: DimNames
1227   integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
1228   integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
1229   integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
1230   integer                       ,intent(out)      :: Status
1231   INTEGER                       ,intent(out)      :: Field(*)
1232   integer   :: ndim,x_start,x_end,y_start,y_end,z_start,z_end
1233   integer   :: zidx
1234   REAL, DIMENSION(:,:), POINTER :: data
1235   logical                     :: vert_stag
1236   logical                     :: soil_layers
1237   integer                     :: level1,level2
1238
1239   integer                     :: parmid
1240   integer                     :: vert_unit
1241   integer                     :: grb_index
1242   integer                     :: numcols, numrows
1243   integer                     :: data_allocated
1244   integer                     :: istat
1245   integer                     :: tablenum
1246   integer                     :: di
1247   integer                     :: last_grb_index
1248
1249   call wrf_debug ( DEBUG , 'Entering ext_gr1_read_field')
1250
1251   !
1252   ! Get dimensions of data.
1253   ! Assume that the domain size in the input data is the same as the Domain
1254   !     Size from the input arguments.
1255   !
1256
1257   CALL get_dims(MemoryOrder,DomainStart,DomainEnd,ndim,x_start,x_end,y_start, &
1258        y_end,z_start,z_end)
1259
1260   !
1261   ! Get grib parameter id
1262   !
1263   CALL GET_GRIB_PARAM(grib_tables, VarName, center, subcenter, parmtbl, &
1264        tablenum, parmid)
1265
1266   !
1267   ! Setup the vertical unit and levels
1268   !
1269   CALL get_vert_stag(VarName,Stagger,vert_stag)
1270   CALL get_soil_layers(VarName,soil_layers)
1271
1272   !
1273   ! Loop over levels, grabbing data from each level, then assembling into a
1274   !   3D array.
1275   !
1276   data_allocated = 0
1277   last_grb_index = -1
1278   do zidx = z_start,z_end
1279
1280      CALL gr1_get_levels(VarName,zidx,z_end-z_start,soil_layers,vert_stag, &
1281           .false., vert_unit,level1,level2)
1282
1283      CALL GET_GRIB_INDEX_VALIDTIME_GUESS(fileinfo(DataHandle)%fileindex(:), center, &
1284           subcenter, parmtbl, parmid,DateStr,vert_unit,level1, &
1285           level2, last_grb_index + 1, grb_index)
1286      if (grb_index < 0) then
1287         write(msg,*)'Field not found: parmid: ',VarName,parmid,DateStr, &
1288              vert_unit,level1,level2
1289         call wrf_debug (DEBUG , msg)
1290         cycle
1291      endif
1292
1293      if (data_allocated .eq. 0) then
1294         CALL GET_SIZEOF_GRID(fileinfo(DataHandle)%fileindex(:),grb_index,numcols,numrows)
1295         allocate(data(z_start:z_end,1:numcols*numrows),stat=istat)
1296         data_allocated = 1
1297      endif
1298
1299      CALL READ_GRIB(fileinfo(DataHandle)%fileindex(:), FileFd(DataHandle), grb_index, &
1300           data(zidx,:))
1301
1302      !
1303      ! Transpose data into the order specified by MemoryOrder, setting only
1304      !   entries within the memory dimensions
1305      !
1306      CALL get_dims(MemoryOrder, MemoryStart, MemoryEnd, ndim, x_start, x_end, &
1307           y_start, y_end,z_start,z_end)
1308
1309      if(FieldType == WRF_DOUBLE) then
1310         di = 2
1311      else
1312         di = 1
1313      endif
1314
1315      !
1316      ! Here, we do any necessary conversions to the data.
1317      !
1318      ! The WRF executable (wrf.exe) expects perturbation potential
1319      !   temperature.  However, real.exe expects full potential T.
1320      ! So, if the program is WRF, subtract 300 from Potential Temperature
1321      !   to get perturbation potential temperature.
1322      !
1323      if (VarName == 'T') then
1324         if ( &
1325              (InputProgramName .eq. 'REAL_EM') .or. &
1326              (InputProgramName .eq. 'IDEAL') .or. &
1327              (InputProgramName .eq. 'NDOWN_EM')) then
1328            data(zidx,:) = data(zidx,:) - 300
1329         endif
1330      endif
1331
1332      CALL Transpose_grib(MemoryOrder, di, FieldType, Field, &
1333           MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
1334           MemoryStart(3), MemoryEnd(3), &
1335           data(zidx,:), zidx, numrows, numcols)
1336
1337      if (zidx .eq. z_end) then
1338         data_allocated = 0
1339         deallocate(data)
1340      endif
1341
1342      last_grb_index = grb_index
1343
1344   enddo
1345
1346   Status = WRF_NO_ERR
1347   if (grb_index < 0) Status = WRF_WARN_VAR_NF
1348   call wrf_debug ( DEBUG , 'Leaving ext_gr1_read_field')
1349
1350   RETURN
1351 END SUBROUTINE ext_gr1_read_field
1352
1353 !*****************************************************************************
1354
1355 SUBROUTINE ext_gr1_get_next_var ( DataHandle, VarName, Status )
1356
1357   USE gr1_data_info
1358   IMPLICIT NONE
1359 #include "wrf_status_codes.h"
1360   INTEGER ,       INTENT(IN)  :: DataHandle
1361   CHARACTER*(*) :: VarName
1362   INTEGER ,       INTENT(OUT) :: Status
1363
1364   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_next_var')
1365
1366   call wrf_message ( 'WARNING: ext_gr1_get_next_var is not supported.')
1367
1368   Status = WRF_WARN_NOOP
1369
1370   RETURN
1371 END SUBROUTINE ext_gr1_get_next_var
1372
1373 !*****************************************************************************
1374
1375 subroutine ext_gr1_end_of_frame(DataHandle, Status)
1376
1377   USE gr1_data_info
1378   implicit none
1379 #include "wrf_status_codes.h"
1380   integer               ,intent(in)     :: DataHandle
1381   integer               ,intent(out)    :: Status
1382
1383   call wrf_debug ( DEBUG , 'Entering ext_gr1_end_of_frame')
1384
1385   Status = WRF_WARN_NOOP
1386
1387   return
1388 end subroutine ext_gr1_end_of_frame
1389
1390 !*****************************************************************************
1391
1392 SUBROUTINE ext_gr1_iosync ( DataHandle, Status )
1393
1394   USE gr1_data_info
1395   IMPLICIT NONE
1396 #include "wrf_status_codes.h"
1397   INTEGER ,       INTENT(IN)  :: DataHandle
1398   INTEGER ,       INTENT(OUT) :: Status
1399
1400   call wrf_debug ( DEBUG , 'Entering ext_gr1_iosync')
1401
1402   Status = WRF_NO_ERR
1403   if (DataHandle .GT. 0) then
1404      CALL flush_file(FileFd(DataHandle))
1405   else
1406      Status = WRF_WARN_TOO_MANY_FILES
1407   endif
1408
1409   RETURN
1410 END SUBROUTINE ext_gr1_iosync
1411
1412 !*****************************************************************************
1413
1414 SUBROUTINE ext_gr1_inquire_filename ( DataHandle, FileName , FileStat, &
1415      Status )
1416
1417   USE gr1_data_info
1418   IMPLICIT NONE
1419 #include "wrf_status_codes.h"
1420 #include "wrf_io_flags.h"
1421   INTEGER ,       INTENT(IN)  :: DataHandle
1422   CHARACTER*(*) :: FileName
1423   INTEGER ,       INTENT(OUT) :: FileStat
1424   INTEGER ,       INTENT(OUT) :: Status
1425   CHARACTER *80   SysDepInfo
1426
1427   call wrf_debug ( DEBUG , 'Entering ext_gr1_inquire_filename')
1428
1429   FileName = DataFile(DataHandle)
1430
1431   if ((DataHandle .ge. firstFileHandle) .and. &
1432        (DataHandle .le. maxFileHandles)) then
1433      FileStat = FileStatus(DataHandle)
1434   else
1435      FileStat = WRF_FILE_NOT_OPENED
1436   endif
1437
1438   Status = WRF_NO_ERR
1439
1440   RETURN
1441 END SUBROUTINE ext_gr1_inquire_filename
1442
1443 !*****************************************************************************
1444
1445 SUBROUTINE ext_gr1_get_var_info ( DataHandle , VarName , NDim , &
1446      MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status )
1447
1448   USE gr1_data_info
1449   IMPLICIT NONE
1450 #include "wrf_status_codes.h"
1451   integer               ,intent(in)     :: DataHandle
1452   character*(*)         ,intent(in)     :: VarName
1453   integer               ,intent(out)    :: NDim
1454   character*(*)         ,intent(out)    :: MemoryOrder
1455   character*(*)         ,intent(out)    :: Stagger
1456   integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
1457   integer               ,intent(out)    :: WrfType
1458   integer               ,intent(out)    :: Status
1459
1460   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_info')
1461
1462   CALL wrf_message('ext_gr1_get_var_info not supported for grib version1 data')
1463   Status = WRF_NO_ERR
1464
1465   RETURN
1466 END SUBROUTINE ext_gr1_get_var_info
1467
1468 !*****************************************************************************
1469
1470 SUBROUTINE ext_gr1_set_time ( DataHandle, DateStr, Status )
1471
1472   USE gr1_data_info
1473   IMPLICIT NONE
1474 #include "wrf_status_codes.h"
1475   INTEGER ,       INTENT(IN)  :: DataHandle
1476   CHARACTER*(*) :: DateStr
1477   INTEGER ,       INTENT(OUT) :: Status
1478   integer       :: found_time
1479   integer       :: idx
1480
1481   call wrf_debug ( DEBUG , 'Entering ext_gr1_set_time')
1482
1483   found_time = 0
1484   do idx = 1,fileinfo(DataHandle)%NumberTimes
1485      if (fileinfo(DataHandle)%Times(idx) == DateStr) then
1486         found_time = 1
1487         fileinfo(DataHandle)%CurrentTime = idx
1488      endif
1489   enddo
1490   if (found_time == 0) then
1491      Status = WRF_WARN_TIME_NF
1492   else
1493      Status = WRF_NO_ERR
1494   endif
1495
1496   RETURN
1497 END SUBROUTINE ext_gr1_set_time
1498
1499 !*****************************************************************************
1500
1501 SUBROUTINE ext_gr1_get_next_time ( DataHandle, DateStr, Status )
1502
1503   USE gr1_data_info
1504   IMPLICIT NONE
1505 #include "wrf_status_codes.h"
1506   INTEGER ,       INTENT(IN)  :: DataHandle
1507   CHARACTER*(*) , INTENT(OUT) :: DateStr
1508   INTEGER ,       INTENT(OUT) :: Status
1509
1510   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_next_time')
1511
1512   if (fileinfo(DataHandle)%CurrentTime == fileinfo(DataHandle)%NumberTimes) then
1513      Status = WRF_WARN_TIME_EOF
1514   else
1515      fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime + 1
1516      DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
1517      Status = WRF_NO_ERR
1518   endif
1519
1520   RETURN
1521 END SUBROUTINE ext_gr1_get_next_time
1522
1523 !*****************************************************************************
1524
1525 SUBROUTINE ext_gr1_get_previous_time ( DataHandle, DateStr, Status )
1526
1527   USE gr1_data_info
1528   IMPLICIT NONE
1529 #include "wrf_status_codes.h"
1530   INTEGER ,       INTENT(IN)  :: DataHandle
1531   CHARACTER*(*) :: DateStr
1532   INTEGER ,       INTENT(OUT) :: Status
1533
1534   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_previous_time')
1535
1536   if (fileinfo(DataHandle)%CurrentTime <= 0) then
1537      Status = WRF_WARN_TIME_EOF
1538   else
1539      fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime - 1
1540      DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
1541      Status = WRF_NO_ERR
1542   endif
1543
1544   RETURN
1545 END SUBROUTINE ext_gr1_get_previous_time
1546
1547 !******************************************************************************
1548 !* Start of get_var_ti_* routines
1549 !******************************************************************************
1550
1551 SUBROUTINE ext_gr1_get_var_ti_real ( DataHandle,Element,  Varname, Data, &
1552      Count, Outcount, Status )
1553
1554   USE gr1_data_info
1555   IMPLICIT NONE
1556 #include "wrf_status_codes.h"
1557   INTEGER ,       INTENT(IN)    :: DataHandle
1558   CHARACTER*(*) :: Element
1559   CHARACTER*(*) :: VarName
1560   real ,          INTENT(OUT)   :: Data(*)
1561   INTEGER ,       INTENT(IN)    :: Count
1562   INTEGER ,       INTENT(OUT)   :: OutCount
1563   INTEGER ,       INTENT(OUT)   :: Status
1564   INTEGER          :: idx
1565   INTEGER          :: stat
1566   CHARACTER*(1000) :: VALUE
1567
1568   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_real')
1569
1570   Status = WRF_NO_ERR
1571
1572   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
1573        Varname, Value, stat)
1574   if (stat /= 0) then
1575      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
1576      Status = WRF_WARN_VAR_NF
1577      RETURN
1578   endif
1579
1580   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1581   if (stat .ne. 0) then
1582      CALL wrf_message("Reading data from"//Value//"failed")
1583      Status = WRF_WARN_COUNT_TOO_LONG
1584      RETURN
1585   endif
1586   Outcount = idx
1587
1588   RETURN
1589 END SUBROUTINE ext_gr1_get_var_ti_real
1590
1591 !*****************************************************************************
1592
1593 SUBROUTINE ext_gr1_get_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
1594      Count, Outcount, Status )
1595
1596   USE gr1_data_info
1597   IMPLICIT NONE
1598 #include "wrf_status_codes.h"
1599   INTEGER ,       INTENT(IN)      :: DataHandle
1600   CHARACTER*(*) :: Element
1601   CHARACTER*(*) :: VarName
1602   real*8 ,        INTENT(OUT)     :: Data(*)
1603   INTEGER ,       INTENT(IN)      :: Count
1604   INTEGER ,       INTENT(OUT)     :: OutCount
1605   INTEGER ,       INTENT(OUT)     :: Status
1606   INTEGER          :: idx
1607   INTEGER          :: stat
1608   CHARACTER*(1000) :: VALUE
1609
1610   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_real8')
1611
1612   Status = WRF_NO_ERR
1613
1614   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:),TRIM(Element),&
1615        "none",Varname,Value,stat)
1616   if (stat /= 0) then
1617      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
1618      Status = WRF_WARN_VAR_NF
1619      RETURN
1620   endif
1621
1622   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1623   if (stat .ne. 0) then
1624      CALL wrf_message("Reading data from"//Value//"failed")
1625      Status = WRF_WARN_COUNT_TOO_LONG
1626      RETURN
1627   endif
1628   Outcount = idx
1629
1630   RETURN
1631 END SUBROUTINE ext_gr1_get_var_ti_real8
1632
1633 !*****************************************************************************
1634
1635 SUBROUTINE ext_gr1_get_var_ti_double ( DataHandle,Element,  Varname, Data, &
1636      Count, Outcount, Status )
1637   USE gr1_data_info
1638   IMPLICIT NONE
1639 #include "wrf_status_codes.h"
1640   INTEGER ,       INTENT(IN)  :: DataHandle
1641   CHARACTER*(*) , INTENT(IN)  :: Element
1642   CHARACTER*(*) , INTENT(IN)  :: VarName
1643   real*8 ,            INTENT(OUT) :: Data(*)
1644   INTEGER ,       INTENT(IN)  :: Count
1645   INTEGER ,       INTENT(OUT)  :: OutCount
1646   INTEGER ,       INTENT(OUT) :: Status
1647   INTEGER          :: idx
1648   INTEGER          :: stat
1649   CHARACTER*(1000) :: VALUE
1650
1651   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_double')
1652
1653   Status = WRF_NO_ERR
1654
1655   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
1656        "none", Varname, &
1657        Value,stat)
1658   if (stat /= 0) then
1659      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
1660      Status = WRF_WARN_VAR_NF
1661      RETURN
1662   endif
1663
1664   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1665   if (stat .ne. 0) then
1666      CALL wrf_message("Reading data from"//Value//"failed")
1667      Status = WRF_WARN_COUNT_TOO_LONG
1668      RETURN
1669   endif
1670   Outcount = idx
1671
1672   RETURN
1673 END SUBROUTINE ext_gr1_get_var_ti_double
1674
1675 !*****************************************************************************
1676
1677 SUBROUTINE ext_gr1_get_var_ti_integer ( DataHandle,Element,  Varname, Data, &
1678      Count, Outcount, Status )
1679
1680   USE gr1_data_info
1681   IMPLICIT NONE
1682 #include "wrf_status_codes.h"
1683   INTEGER ,       INTENT(IN)       :: DataHandle
1684   CHARACTER*(*) :: Element
1685   CHARACTER*(*) :: VarName
1686   integer ,       INTENT(OUT)      :: Data(*)
1687   INTEGER ,       INTENT(IN)       :: Count
1688   INTEGER ,       INTENT(OUT)      :: OutCount
1689   INTEGER ,       INTENT(OUT)      :: Status
1690   INTEGER          :: idx
1691   INTEGER          :: stat
1692   CHARACTER*(1000) :: VALUE
1693
1694   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_integer')
1695
1696   Status = WRF_NO_ERR
1697
1698   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
1699        "none", Varname, Value, stat)
1700   if (stat /= 0) then
1701      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
1702      Status = WRF_WARN_VAR_NF
1703      RETURN
1704   endif
1705
1706   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1707   if (stat .ne. 0) then
1708      CALL wrf_message("Reading data from"//Value//"failed")
1709      Status = WRF_WARN_COUNT_TOO_LONG
1710      RETURN
1711   endif
1712   Outcount = idx
1713
1714   RETURN
1715 END SUBROUTINE ext_gr1_get_var_ti_integer
1716
1717 !*****************************************************************************
1718
1719 SUBROUTINE ext_gr1_get_var_ti_logical ( DataHandle,Element,  Varname, Data, &
1720      Count, Outcount, Status )
1721
1722   USE gr1_data_info
1723   IMPLICIT NONE
1724 #include "wrf_status_codes.h"
1725   INTEGER ,       INTENT(IN)       :: DataHandle
1726   CHARACTER*(*) :: Element
1727   CHARACTER*(*) :: VarName
1728   logical ,       INTENT(OUT)      :: Data(*)
1729   INTEGER ,       INTENT(IN)       :: Count
1730   INTEGER ,       INTENT(OUT)      :: OutCount
1731   INTEGER ,       INTENT(OUT)      :: Status
1732   INTEGER          :: idx
1733   INTEGER          :: stat
1734   CHARACTER*(1000) :: VALUE
1735
1736   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_logical')
1737
1738   Status = WRF_NO_ERR
1739
1740   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
1741        "none", Varname, Value,stat)
1742   if (stat /= 0) then
1743      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
1744      Status = WRF_WARN_VAR_NF
1745      RETURN
1746   endif
1747
1748   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1749   if (stat .ne. 0) then
1750      CALL wrf_message("Reading data from"//Value//"failed")
1751      Status = WRF_WARN_COUNT_TOO_LONG
1752      RETURN
1753   endif
1754   Outcount = idx
1755
1756   RETURN
1757 END SUBROUTINE ext_gr1_get_var_ti_logical
1758
1759 !*****************************************************************************
1760
1761 SUBROUTINE ext_gr1_get_var_ti_char ( DataHandle,Element,  Varname, Data,  &
1762      Status )
1763
1764   USE gr1_data_info
1765   IMPLICIT NONE
1766 #include "wrf_status_codes.h"
1767   INTEGER ,       INTENT(IN)  :: DataHandle
1768   CHARACTER*(*) :: Element
1769   CHARACTER*(*) :: VarName
1770   CHARACTER*(*) :: Data
1771   INTEGER ,       INTENT(OUT) :: Status
1772   INTEGER       :: stat
1773
1774   Status = WRF_NO_ERR
1775
1776   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_ti_char')
1777
1778   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), &
1779        "none", Varname, Data,stat)
1780   if (stat /= 0) then
1781      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
1782      Status = WRF_WARN_VAR_NF
1783      RETURN
1784   endif
1785
1786   RETURN
1787 END SUBROUTINE ext_gr1_get_var_ti_char
1788
1789 !******************************************************************************
1790 !* End of get_var_ti_* routines
1791 !******************************************************************************
1792
1793
1794 !******************************************************************************
1795 !* Start of put_var_ti_* routines
1796 !******************************************************************************
1797
1798 SUBROUTINE ext_gr1_put_var_ti_real ( DataHandle,Element,  Varname, Data, &
1799      Count,  Status )
1800
1801   USE gr1_data_info
1802   IMPLICIT NONE
1803 #include "wrf_status_codes.h"
1804   INTEGER ,       INTENT(IN)  :: DataHandle
1805   CHARACTER*(*) :: Element
1806   CHARACTER*(*) :: VarName
1807   real ,          INTENT(IN)  :: Data(*)
1808   INTEGER ,       INTENT(IN)  :: Count
1809   INTEGER ,       INTENT(OUT) :: Status
1810   CHARACTER(len=1000) :: tmpstr(1000)
1811   INTEGER             :: idx
1812
1813   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_real')
1814
1815   if (committed(DataHandle)) then
1816
1817      do idx = 1,Count
1818         write(tmpstr(idx),'(G17.10)')Data(idx)
1819      enddo
1820
1821      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
1822
1823   endif
1824
1825   RETURN
1826 END SUBROUTINE ext_gr1_put_var_ti_real
1827
1828 !*****************************************************************************
1829
1830 SUBROUTINE ext_gr1_put_var_ti_double ( DataHandle,Element,  Varname, Data, &
1831      Count,  Status )
1832   USE gr1_data_info
1833   IMPLICIT NONE
1834 #include "wrf_status_codes.h"
1835   INTEGER ,       INTENT(IN)  :: DataHandle
1836   CHARACTER*(*) , INTENT(IN)  :: Element
1837   CHARACTER*(*) , INTENT(IN)  :: VarName
1838   real*8 ,            INTENT(IN) :: Data(*)
1839   INTEGER ,       INTENT(IN)  :: Count
1840   INTEGER ,       INTENT(OUT) :: Status
1841   CHARACTER(len=1000) :: tmpstr(1000)
1842   INTEGER             :: idx
1843
1844   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_double')
1845
1846   if (committed(DataHandle)) then
1847
1848      do idx = 1,Count
1849         write(tmpstr(idx),'(G17.10)')Data(idx)
1850      enddo
1851
1852      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
1853   endif
1854
1855   RETURN
1856 END SUBROUTINE ext_gr1_put_var_ti_double
1857
1858 !*****************************************************************************
1859
1860 SUBROUTINE ext_gr1_put_var_ti_real8 ( DataHandle,Element,  Varname, Data, &
1861      Count,  Status )
1862
1863   USE gr1_data_info
1864   IMPLICIT NONE
1865 #include "wrf_status_codes.h"
1866   INTEGER ,       INTENT(IN)  :: DataHandle
1867   CHARACTER*(*) :: Element
1868   CHARACTER*(*) :: 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_gr1_put_var_ti_real8')
1876
1877   if (committed(DataHandle)) then
1878
1879      do idx = 1,Count
1880         write(tmpstr(idx),'(G17.10)')Data(idx)
1881      enddo
1882
1883      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
1884   endif
1885
1886   RETURN
1887 END SUBROUTINE ext_gr1_put_var_ti_real8
1888
1889 !*****************************************************************************
1890
1891 SUBROUTINE ext_gr1_put_var_ti_integer ( DataHandle,Element,  Varname, Data, &
1892      Count,  Status )
1893
1894   USE gr1_data_info
1895   IMPLICIT NONE
1896 #include "wrf_status_codes.h"
1897   INTEGER ,       INTENT(IN)  :: DataHandle
1898   CHARACTER*(*) :: Element
1899   CHARACTER*(*) :: VarName
1900   integer ,       INTENT(IN)  :: Data(*)
1901   INTEGER ,       INTENT(IN)  :: Count
1902   INTEGER ,       INTENT(OUT) :: Status
1903   CHARACTER(len=1000) :: tmpstr(1000)
1904   INTEGER             :: idx
1905
1906   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_integer')
1907
1908   if (committed(DataHandle)) then
1909
1910      do idx = 1,Count
1911         write(tmpstr(idx),'(G17.10)')Data(idx)
1912      enddo
1913
1914      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
1915   endif
1916
1917   RETURN
1918 END SUBROUTINE ext_gr1_put_var_ti_integer
1919
1920 !*****************************************************************************
1921
1922 SUBROUTINE ext_gr1_put_var_ti_logical ( DataHandle,Element,  Varname, Data, &
1923      Count,  Status )
1924
1925   USE gr1_data_info
1926   IMPLICIT NONE
1927 #include "wrf_status_codes.h"
1928   INTEGER ,       INTENT(IN)  :: DataHandle
1929   CHARACTER*(*) :: Element
1930   CHARACTER*(*) :: VarName
1931   logical ,       INTENT(IN)  :: Data(*)
1932   INTEGER ,       INTENT(IN)  :: Count
1933   INTEGER ,       INTENT(OUT) :: Status
1934   CHARACTER(len=1000) :: tmpstr(1000)
1935   INTEGER             :: idx
1936
1937   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_logical')
1938
1939   if (committed(DataHandle)) then
1940
1941      do idx = 1,Count
1942         write(tmpstr(idx),'(G17.10)')Data(idx)
1943      enddo
1944
1945      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
1946
1947   endif
1948
1949 RETURN
1950 END SUBROUTINE ext_gr1_put_var_ti_logical
1951
1952 !*****************************************************************************
1953
1954 SUBROUTINE ext_gr1_put_var_ti_char ( DataHandle,Element,  Varname, Data,  &
1955      Status )
1956
1957   USE gr1_data_info
1958   IMPLICIT NONE
1959 #include "wrf_status_codes.h"
1960   INTEGER ,       INTENT(IN)  :: DataHandle
1961   CHARACTER(len=*) :: Element
1962   CHARACTER(len=*) :: VarName
1963   CHARACTER(len=*) :: Data
1964   INTEGER ,       INTENT(OUT) :: Status
1965   REAL dummy
1966   INTEGER                     :: Count
1967   CHARACTER(len=1000) :: tmpstr(1)
1968   INTEGER             :: idx
1969
1970   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_ti_char')
1971
1972   if (committed(DataHandle)) then
1973
1974      write(tmpstr(1),*)trim(Data)
1975
1976      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, 1, Status)
1977
1978   endif
1979
1980   RETURN
1981 END SUBROUTINE ext_gr1_put_var_ti_char
1982
1983 !******************************************************************************
1984 !* End of put_var_ti_* routines
1985 !******************************************************************************
1986
1987 !******************************************************************************
1988 !* Start of get_var_td_* routines
1989 !******************************************************************************
1990
1991 SUBROUTINE ext_gr1_get_var_td_double ( DataHandle,Element,  DateStr, &
1992      Varname, Data, Count, Outcount, Status )
1993   USE gr1_data_info
1994   IMPLICIT NONE
1995 #include "wrf_status_codes.h"
1996   INTEGER ,       INTENT(IN)  :: DataHandle
1997   CHARACTER*(*) , INTENT(IN)  :: Element
1998   CHARACTER*(*) , INTENT(IN)  :: DateStr
1999   CHARACTER*(*) , INTENT(IN)  :: VarName
2000   real*8 ,            INTENT(OUT) :: Data(*)
2001   INTEGER ,       INTENT(IN)  :: Count
2002   INTEGER ,       INTENT(OUT)  :: OutCount
2003   INTEGER ,       INTENT(OUT) :: Status
2004   INTEGER          :: idx
2005   INTEGER          :: stat
2006   CHARACTER*(1000) :: VALUE
2007
2008   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_double')
2009
2010   Status = WRF_NO_ERR
2011
2012   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:),TRIM(Element),DateStr,&
2013        Varname,Value,stat)
2014   if (stat /= 0) then
2015      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2016      Status = WRF_WARN_VAR_NF
2017      RETURN
2018   endif
2019
2020   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2021   if (stat .ne. 0) then
2022      CALL wrf_message("Reading data from"//Value//"failed")
2023      Status = WRF_WARN_COUNT_TOO_LONG
2024      RETURN
2025   endif
2026   Outcount = idx
2027
2028 RETURN
2029 END SUBROUTINE ext_gr1_get_var_td_double
2030
2031 !*****************************************************************************
2032
2033 SUBROUTINE ext_gr1_get_var_td_real ( DataHandle,Element,  DateStr,Varname, &
2034      Data, Count, Outcount, Status )
2035
2036   USE gr1_data_info
2037   IMPLICIT NONE
2038 #include "wrf_status_codes.h"
2039   INTEGER ,       INTENT(IN)  :: DataHandle
2040   CHARACTER*(*) :: Element
2041   CHARACTER*(*) :: DateStr
2042   CHARACTER*(*) :: VarName
2043   real ,          INTENT(OUT) :: Data(*)
2044   INTEGER ,       INTENT(IN)  :: Count
2045   INTEGER ,       INTENT(OUT) :: OutCount
2046   INTEGER ,       INTENT(OUT) :: Status
2047   INTEGER          :: idx
2048   INTEGER          :: stat
2049   CHARACTER*(1000) :: VALUE
2050
2051   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_real')
2052
2053   Status = WRF_NO_ERR
2054
2055   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
2056        Varname, Value, stat)
2057   if (stat /= 0) then
2058      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2059      Status = WRF_WARN_VAR_NF
2060      RETURN
2061   endif
2062
2063   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2064   if (stat .ne. 0) then
2065      CALL wrf_message("Reading data from"//Value//"failed")
2066      Status = WRF_WARN_COUNT_TOO_LONG
2067      RETURN
2068   endif
2069   Outcount = idx
2070
2071   RETURN
2072 END SUBROUTINE ext_gr1_get_var_td_real
2073
2074 !*****************************************************************************
2075
2076 SUBROUTINE ext_gr1_get_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
2077      Data, Count, Outcount, Status )
2078
2079   USE gr1_data_info
2080   IMPLICIT NONE
2081 #include "wrf_status_codes.h"
2082   INTEGER ,       INTENT(IN)  :: DataHandle
2083   CHARACTER*(*) :: Element
2084   CHARACTER*(*) :: DateStr
2085   CHARACTER*(*) :: VarName
2086   real*8 ,        INTENT(OUT) :: Data(*)
2087   INTEGER ,       INTENT(IN)  :: Count
2088   INTEGER ,       INTENT(OUT) :: OutCount
2089   INTEGER ,       INTENT(OUT) :: Status
2090   INTEGER          :: idx
2091   INTEGER          :: stat
2092   CHARACTER*(1000) :: VALUE
2093
2094   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_real8')
2095
2096   Status = WRF_NO_ERR
2097
2098   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:),TRIM(Element),DateStr,&
2099        Varname,Value,stat)
2100   if (stat /= 0) then
2101      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2102      Status = WRF_WARN_VAR_NF
2103      RETURN
2104   endif
2105
2106   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2107   if (stat .ne. 0) then
2108      CALL wrf_message("Reading data from"//Value//"failed")
2109      Status = WRF_WARN_COUNT_TOO_LONG
2110      RETURN
2111   endif
2112   Outcount = idx
2113
2114   RETURN
2115 END SUBROUTINE ext_gr1_get_var_td_real8
2116
2117 !*****************************************************************************
2118
2119 SUBROUTINE ext_gr1_get_var_td_integer ( DataHandle,Element,  DateStr,Varname, &
2120      Data, Count, Outcount, Status )
2121
2122   USE gr1_data_info
2123   IMPLICIT NONE
2124 #include "wrf_status_codes.h"
2125   INTEGER ,       INTENT(IN)  :: DataHandle
2126   CHARACTER*(*) :: Element
2127   CHARACTER*(*) :: DateStr
2128   CHARACTER*(*) :: VarName
2129   integer ,       INTENT(OUT) :: Data(*)
2130   INTEGER ,       INTENT(IN)  :: Count
2131   INTEGER ,       INTENT(OUT) :: OutCount
2132   INTEGER ,       INTENT(OUT) :: Status
2133   INTEGER          :: idx
2134   INTEGER          :: stat
2135   CHARACTER*(1000) :: VALUE
2136
2137   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_integer')
2138
2139   Status = WRF_NO_ERR
2140
2141   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
2142        Varname, Value,stat)
2143   if (stat /= 0) then
2144      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2145      Status = WRF_WARN_VAR_NF
2146      RETURN
2147   endif
2148
2149   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2150   if (stat .ne. 0) then
2151      CALL wrf_message("Reading data from"//Value//"failed")
2152      Status = WRF_WARN_COUNT_TOO_LONG
2153      RETURN
2154   endif
2155   Outcount = idx
2156
2157   RETURN
2158 END SUBROUTINE ext_gr1_get_var_td_integer
2159
2160 !*****************************************************************************
2161
2162 SUBROUTINE ext_gr1_get_var_td_logical ( DataHandle,Element,  DateStr,Varname, &
2163      Data, Count, Outcount, Status )
2164
2165   USE gr1_data_info
2166   IMPLICIT NONE
2167 #include "wrf_status_codes.h"
2168   INTEGER ,       INTENT(IN)  :: DataHandle
2169   CHARACTER*(*) :: Element
2170   CHARACTER*(*) :: DateStr
2171   CHARACTER*(*) :: VarName
2172   logical ,       INTENT(OUT) :: Data(*)
2173   INTEGER ,       INTENT(IN)  :: Count
2174   INTEGER ,       INTENT(OUT) :: OutCount
2175   INTEGER ,       INTENT(OUT) :: Status
2176   INTEGER          :: idx
2177   INTEGER          :: stat
2178   CHARACTER*(1000) :: VALUE
2179
2180   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_logical')
2181
2182   Status = WRF_NO_ERR
2183
2184   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
2185        Varname, Value,stat)
2186   if (stat /= 0) then
2187      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2188      Status = WRF_WARN_VAR_NF
2189      RETURN
2190   endif
2191
2192   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2193   if (stat .ne. 0) then
2194      CALL wrf_message("Reading data from"//Value//"failed")
2195      Status = WRF_WARN_COUNT_TOO_LONG
2196      RETURN
2197   endif
2198   Outcount = idx
2199
2200   RETURN
2201 END SUBROUTINE ext_gr1_get_var_td_logical
2202
2203 !*****************************************************************************
2204
2205 SUBROUTINE ext_gr1_get_var_td_char ( DataHandle,Element,  DateStr,Varname, &
2206      Data,  Status )
2207
2208   USE gr1_data_info
2209   IMPLICIT NONE
2210 #include "wrf_status_codes.h"
2211   INTEGER ,       INTENT(IN)  :: DataHandle
2212   CHARACTER*(*) :: Element
2213   CHARACTER*(*) :: DateStr
2214   CHARACTER*(*) :: VarName
2215   CHARACTER*(*) :: Data
2216   INTEGER ,       INTENT(OUT) :: Status
2217   INTEGER       :: stat
2218
2219   Status = WRF_NO_ERR
2220
2221   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_td_char')
2222
2223   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
2224        Varname, Data,stat)
2225   if (stat /= 0) then
2226      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2227      Status = WRF_WARN_VAR_NF
2228      RETURN
2229   endif
2230
2231   RETURN
2232 END SUBROUTINE ext_gr1_get_var_td_char
2233
2234 !******************************************************************************
2235 !* End of get_var_td_* routines
2236 !******************************************************************************
2237
2238 !******************************************************************************
2239 !* Start of put_var_td_* routines
2240 !******************************************************************************
2241
2242 SUBROUTINE ext_gr1_put_var_td_double ( DataHandle, Element, DateStr, Varname, &
2243      Data, Count,  Status )
2244   USE gr1_data_info
2245   IMPLICIT NONE
2246 #include "wrf_status_codes.h"
2247   INTEGER ,       INTENT(IN)  :: DataHandle
2248   CHARACTER*(*) , INTENT(IN)  :: Element
2249   CHARACTER*(*) , INTENT(IN)  :: DateStr
2250   CHARACTER*(*) , INTENT(IN)  :: VarName
2251   real*8 ,            INTENT(IN) :: Data(*)
2252   INTEGER ,       INTENT(IN)  :: Count
2253   INTEGER ,       INTENT(OUT) :: Status
2254   CHARACTER(len=1000) :: tmpstr(1000)
2255   INTEGER             :: idx
2256
2257   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_double')
2258
2259
2260   if (committed(DataHandle)) then
2261
2262      do idx = 1,Count
2263         write(tmpstr(idx),'(G17.10)')Data(idx)
2264      enddo
2265
2266      CALL gr1_build_string (td_output(DataHandle), &
2267           Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
2268
2269   endif
2270
2271 RETURN
2272 END SUBROUTINE ext_gr1_put_var_td_double
2273
2274 !*****************************************************************************
2275
2276 SUBROUTINE ext_gr1_put_var_td_integer ( DataHandle,Element,  DateStr, &
2277      Varname, Data, Count,  Status )
2278
2279   USE gr1_data_info
2280   IMPLICIT NONE
2281 #include "wrf_status_codes.h"
2282   INTEGER ,       INTENT(IN)  :: DataHandle
2283   CHARACTER*(*) :: Element
2284   CHARACTER*(*) :: DateStr
2285   CHARACTER*(*) :: VarName
2286   integer ,       INTENT(IN)  :: Data(*)
2287   INTEGER ,       INTENT(IN)  :: Count
2288   INTEGER ,       INTENT(OUT) :: Status
2289   CHARACTER(len=1000) :: tmpstr(1000)
2290   INTEGER             :: idx
2291
2292   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_integer')
2293
2294   if (committed(DataHandle)) then
2295
2296      do idx = 1,Count
2297         write(tmpstr(idx),'(G17.10)')Data(idx)
2298      enddo
2299
2300      CALL gr1_build_string (td_output(DataHandle), &
2301           Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
2302
2303   endif
2304
2305 RETURN
2306 END SUBROUTINE ext_gr1_put_var_td_integer
2307
2308 !*****************************************************************************
2309
2310 SUBROUTINE ext_gr1_put_var_td_real ( DataHandle,Element,  DateStr,Varname, &
2311      Data, Count,  Status )
2312
2313   USE gr1_data_info
2314   IMPLICIT NONE
2315 #include "wrf_status_codes.h"
2316   INTEGER ,       INTENT(IN)  :: DataHandle
2317   CHARACTER*(*) :: Element
2318   CHARACTER*(*) :: DateStr
2319   CHARACTER*(*) :: VarName
2320   real ,          INTENT(IN)  :: Data(*)
2321   INTEGER ,       INTENT(IN)  :: Count
2322   INTEGER ,       INTENT(OUT) :: Status
2323   CHARACTER(len=1000) :: tmpstr(1000)
2324   INTEGER             :: idx
2325
2326   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_real')
2327
2328   if (committed(DataHandle)) then
2329
2330      do idx = 1,Count
2331         write(tmpstr(idx),'(G17.10)')Data(idx)
2332      enddo
2333
2334      CALL gr1_build_string (td_output(DataHandle), &
2335           Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
2336
2337   endif
2338
2339   RETURN
2340 END SUBROUTINE ext_gr1_put_var_td_real
2341
2342 !*****************************************************************************
2343
2344 SUBROUTINE ext_gr1_put_var_td_real8 ( DataHandle,Element,  DateStr,Varname, &
2345      Data, Count,  Status )
2346
2347   USE gr1_data_info
2348   IMPLICIT NONE
2349 #include "wrf_status_codes.h"
2350   INTEGER ,       INTENT(IN)  :: DataHandle
2351   CHARACTER*(*) :: Element
2352   CHARACTER*(*) :: DateStr
2353   CHARACTER*(*) :: VarName
2354   real*8 ,        INTENT(IN)  :: Data(*)
2355   INTEGER ,       INTENT(IN)  :: Count
2356   INTEGER ,       INTENT(OUT) :: Status
2357   CHARACTER(len=1000) :: tmpstr(1000)
2358   INTEGER             :: idx
2359
2360   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_real8')
2361
2362   if (committed(DataHandle)) then
2363      do idx = 1,Count
2364         write(tmpstr(idx),'(G17.10)')Data(idx)
2365      enddo
2366
2367      CALL gr1_build_string (td_output(DataHandle), &
2368           Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
2369   endif
2370
2371   RETURN
2372 END SUBROUTINE ext_gr1_put_var_td_real8
2373
2374 !*****************************************************************************
2375
2376 SUBROUTINE ext_gr1_put_var_td_logical ( DataHandle,Element,  DateStr, &
2377      Varname, Data, Count,  Status )
2378
2379   USE gr1_data_info
2380   IMPLICIT NONE
2381 #include "wrf_status_codes.h"
2382   INTEGER ,       INTENT(IN)  :: DataHandle
2383   CHARACTER*(*) :: Element
2384   CHARACTER*(*) :: DateStr
2385   CHARACTER*(*) :: VarName
2386   logical ,       INTENT(IN)  :: Data(*)
2387   INTEGER ,       INTENT(IN)  :: Count
2388   INTEGER ,       INTENT(OUT) :: Status
2389   CHARACTER(len=1000) :: tmpstr(1000)
2390   INTEGER             :: idx
2391
2392   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_logical')
2393
2394   if (committed(DataHandle)) then
2395
2396      do idx = 1,Count
2397         write(tmpstr(idx),'(G17.10)')Data(idx)
2398      enddo
2399
2400      CALL gr1_build_string (td_output(DataHandle), &
2401           Varname//';'//DateStr//';'//Element, tmpstr, Count, Status)
2402
2403   endif
2404
2405   RETURN
2406 END SUBROUTINE ext_gr1_put_var_td_logical
2407
2408 !*****************************************************************************
2409
2410 SUBROUTINE ext_gr1_put_var_td_char ( DataHandle,Element,  DateStr,Varname, &
2411      Data,  Status )
2412
2413   USE gr1_data_info
2414   IMPLICIT NONE
2415 #include "wrf_status_codes.h"
2416   INTEGER ,       INTENT(IN)  :: DataHandle
2417   CHARACTER*(*) :: Element
2418   CHARACTER*(*) :: DateStr
2419   CHARACTER*(*) :: VarName
2420   CHARACTER*(*) :: Data
2421   INTEGER ,       INTENT(OUT) :: Status
2422   CHARACTER(len=1000) :: tmpstr
2423   INTEGER             :: idx
2424
2425   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_var_td_char')
2426
2427   if (committed(DataHandle)) then
2428
2429
2430      DO idx=1,LEN(Data)
2431         tmpstr(idx:idx)=Data(idx:idx)
2432      END DO
2433      DO idx=LEN(Data)+1,1000
2434         tmpstr(idx:idx)=' '
2435      END DO
2436
2437      CALL gr1_build_string (td_output(DataHandle), &
2438           Varname//';'//DateStr//';'//Element, tmpstr, 1, Status)
2439
2440   endif
2441
2442   RETURN
2443 END SUBROUTINE ext_gr1_put_var_td_char
2444
2445 !******************************************************************************
2446 !* End of put_var_td_* routines
2447 !******************************************************************************
2448
2449
2450 !******************************************************************************
2451 !* Start of get_dom_ti_* routines
2452 !******************************************************************************
2453
2454 SUBROUTINE ext_gr1_get_dom_ti_real ( DataHandle,Element,   Data, Count, &
2455      Outcount, Status )
2456
2457   USE gr1_data_info
2458   IMPLICIT NONE
2459 #include "wrf_status_codes.h"
2460   INTEGER ,       INTENT(IN)  :: DataHandle
2461   CHARACTER*(*) :: Element
2462   real ,          INTENT(OUT) :: Data(*)
2463   INTEGER ,       INTENT(IN)  :: Count
2464   INTEGER ,       INTENT(OUT) :: Outcount
2465   INTEGER ,       INTENT(OUT) :: Status
2466   INTEGER          :: idx
2467   INTEGER          :: stat
2468   CHARACTER*(1000) :: VALUE
2469
2470   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_real')
2471
2472   Status = WRF_NO_ERR
2473
2474   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
2475        "none", Value,stat)
2476   if (stat /= 0) then
2477      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2478      Status = WRF_WARN_VAR_NF
2479      RETURN
2480   endif
2481
2482   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2483   if (stat .ne. 0) then
2484      CALL wrf_message("Reading data from"//Value//"failed")
2485      Status = WRF_WARN_COUNT_TOO_LONG
2486      RETURN
2487   endif
2488   Outcount = idx
2489
2490   RETURN
2491 END SUBROUTINE ext_gr1_get_dom_ti_real
2492
2493 !*****************************************************************************
2494
2495 SUBROUTINE ext_gr1_get_dom_ti_real8 ( DataHandle,Element,   Data, Count, &
2496      Outcount, Status )
2497
2498   USE gr1_data_info
2499   IMPLICIT NONE
2500 #include "wrf_status_codes.h"
2501   INTEGER ,       INTENT(IN)  :: DataHandle
2502   CHARACTER*(*) :: Element
2503   real*8 ,        INTENT(OUT) :: Data(*)
2504   INTEGER ,       INTENT(IN)  :: Count
2505   INTEGER ,       INTENT(OUT) :: OutCount
2506   INTEGER ,       INTENT(OUT) :: Status
2507   INTEGER          :: idx
2508   INTEGER          :: stat
2509   CHARACTER*(1000) :: VALUE
2510
2511   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_real8')
2512
2513   Status = WRF_NO_ERR
2514
2515   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
2516        "none", Value,stat)
2517   if (stat /= 0) then
2518      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2519      Status = WRF_WARN_VAR_NF
2520      RETURN
2521   endif
2522
2523   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2524   if (stat .ne. 0) then
2525      CALL wrf_message("Reading data from"//Value//"failed")
2526      Status = WRF_WARN_COUNT_TOO_LONG
2527      RETURN
2528   endif
2529   Outcount = idx
2530
2531   RETURN
2532 END SUBROUTINE ext_gr1_get_dom_ti_real8
2533
2534 !*****************************************************************************
2535
2536 SUBROUTINE ext_gr1_get_dom_ti_integer ( DataHandle,Element,   Data, Count, &
2537      Outcount, Status )
2538
2539   USE gr1_data_info
2540   IMPLICIT NONE
2541 #include "wrf_status_codes.h"
2542   INTEGER ,       INTENT(IN)  :: DataHandle
2543   CHARACTER*(*) :: Element
2544   integer ,       INTENT(OUT) :: Data(*)
2545   INTEGER ,       INTENT(IN)  :: Count
2546   INTEGER ,       INTENT(OUT) :: OutCount
2547   INTEGER ,       INTENT(OUT) :: Status
2548   INTEGER          :: idx
2549   INTEGER          :: stat
2550   CHARACTER*(1000) :: VALUE
2551
2552   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_integer Element: '//Element)
2553
2554   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
2555        "none", Value,stat)
2556   if (stat /= 0) then
2557      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2558      Status = WRF_WARN_VAR_NF
2559      RETURN
2560   endif
2561
2562   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2563   if (stat .ne. 0) then
2564      CALL wrf_message("Reading data from"//Value//"failed")
2565      Status = WRF_WARN_COUNT_TOO_LONG
2566      RETURN
2567   endif
2568   Outcount = Count
2569
2570   RETURN
2571 END SUBROUTINE ext_gr1_get_dom_ti_integer
2572
2573 !*****************************************************************************
2574
2575 SUBROUTINE ext_gr1_get_dom_ti_logical ( DataHandle,Element,   Data, Count, &
2576      Outcount, Status )
2577
2578   USE gr1_data_info
2579   IMPLICIT NONE
2580 #include "wrf_status_codes.h"
2581   INTEGER ,       INTENT(IN)  :: DataHandle
2582   CHARACTER*(*) :: Element
2583   logical ,       INTENT(OUT) :: Data(*)
2584   INTEGER ,       INTENT(IN)  :: Count
2585   INTEGER ,       INTENT(OUT) :: OutCount
2586   INTEGER ,       INTENT(OUT) :: Status
2587   INTEGER          :: idx
2588   INTEGER          :: stat
2589   CHARACTER*(1000) :: VALUE
2590
2591   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_logical')
2592
2593   Status = WRF_NO_ERR
2594
2595   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
2596        "none", Value,stat)
2597   if (stat /= 0) then
2598      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2599      Status = WRF_WARN_VAR_NF
2600      RETURN
2601   endif
2602
2603   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2604   if (stat .ne. 0) then
2605      CALL wrf_message("Reading data from"//Value//"failed")
2606      Status = WRF_WARN_COUNT_TOO_LONG
2607      RETURN
2608   endif
2609   Outcount = idx
2610
2611   RETURN
2612 END SUBROUTINE ext_gr1_get_dom_ti_logical
2613
2614 !*****************************************************************************
2615
2616 SUBROUTINE ext_gr1_get_dom_ti_char ( DataHandle,Element,   Data,  Status )
2617
2618   USE gr1_data_info
2619   IMPLICIT NONE
2620 #include "wrf_status_codes.h"
2621   INTEGER ,       INTENT(IN)  :: DataHandle
2622   CHARACTER*(*) :: Element
2623   CHARACTER*(*) :: Data
2624   INTEGER ,       INTENT(OUT) :: Status
2625   INTEGER       :: stat
2626   INTEGER       :: endchar
2627
2628   Status = WRF_NO_ERR
2629
2630   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_char')
2631
2632   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
2633        "none", Data, stat)
2634   if (stat /= 0) then
2635      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2636      Status = WRF_WARN_VAR_NF
2637      RETURN
2638   endif
2639
2640   RETURN
2641 END SUBROUTINE ext_gr1_get_dom_ti_char
2642
2643 !*****************************************************************************
2644
2645 SUBROUTINE ext_gr1_get_dom_ti_double ( DataHandle,Element,   Data, Count, &
2646      Outcount, Status )
2647   USE gr1_data_info
2648   IMPLICIT NONE
2649 #include "wrf_status_codes.h"
2650   INTEGER ,       INTENT(IN)  :: DataHandle
2651   CHARACTER*(*) , INTENT(IN)  :: Element
2652   real*8 ,            INTENT(OUT) :: Data(*)
2653   INTEGER ,       INTENT(IN)  :: Count
2654   INTEGER ,       INTENT(OUT)  :: OutCount
2655   INTEGER ,       INTENT(OUT) :: Status
2656   INTEGER          :: idx
2657   INTEGER          :: stat
2658   CHARACTER*(1000) :: VALUE
2659
2660   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_ti_double')
2661
2662   Status = WRF_NO_ERR
2663
2664   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), "none", &
2665        "none", Value, stat)
2666   if (stat /= 0) then
2667      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2668      Status = WRF_WARN_VAR_NF
2669      RETURN
2670   endif
2671
2672   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2673   if (stat .ne. 0) then
2674      CALL wrf_message("Reading data from"//Value//"failed")
2675      Status = WRF_WARN_COUNT_TOO_LONG
2676      RETURN
2677   endif
2678   Outcount = idx
2679
2680 RETURN
2681 END SUBROUTINE ext_gr1_get_dom_ti_double
2682
2683 !******************************************************************************
2684 !* End of get_dom_ti_* routines
2685 !******************************************************************************
2686
2687
2688 !******************************************************************************
2689 !* Start of put_dom_ti_* routines
2690 !******************************************************************************
2691
2692 SUBROUTINE ext_gr1_put_dom_ti_real ( DataHandle,Element,   Data, Count,  &
2693      Status )
2694
2695   USE gr1_data_info
2696   IMPLICIT NONE
2697 #include "wrf_status_codes.h"
2698   INTEGER ,       INTENT(IN)  :: DataHandle
2699   CHARACTER*(*) :: Element
2700   real ,          INTENT(IN)  :: Data(*)
2701   INTEGER ,       INTENT(IN)  :: Count
2702   INTEGER ,       INTENT(OUT) :: Status
2703   REAL dummy
2704   CHARACTER(len=1000) :: tmpstr(1000)
2705   character(len=2)    :: lf
2706   integer             :: idx
2707
2708   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_real')
2709
2710   if (Element .eq. 'DX') then
2711      dx = Data(1)/1000.
2712   endif
2713   if (Element .eq. 'DY') then
2714      dy = Data(1)/1000.
2715   endif
2716   if (Element .eq. 'CEN_LAT') then
2717      center_lat = Data(1)
2718   endif
2719   if (Element .eq. 'CEN_LON') then
2720      center_lon = Data(1)
2721   endif
2722   if (Element .eq. 'TRUELAT1') then
2723      truelat1 = Data(1)
2724   endif
2725   if (Element .eq. 'TRUELAT2') then
2726      truelat2 = Data(1)
2727   endif
2728   if (Element == 'STAND_LON') then
2729      proj_central_lon = Data(1)
2730   endif
2731   if (Element == 'DT') then
2732      timestep = Data(1)
2733   endif
2734
2735   if (committed(DataHandle)) then
2736
2737      do idx = 1,Count
2738         write(tmpstr(idx),'(G17.10)')Data(idx)
2739      enddo
2740
2741      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
2742
2743   endif
2744
2745   RETURN
2746 END SUBROUTINE ext_gr1_put_dom_ti_real
2747
2748 !*****************************************************************************
2749
2750 SUBROUTINE ext_gr1_put_dom_ti_real8 ( DataHandle,Element,   Data, Count,  &
2751      Status )
2752
2753   USE gr1_data_info
2754   IMPLICIT NONE
2755 #include "wrf_status_codes.h"
2756   INTEGER ,       INTENT(IN)  :: DataHandle
2757   CHARACTER*(*) :: Element
2758   real*8 ,        INTENT(IN)  :: Data(*)
2759   INTEGER ,       INTENT(IN)  :: Count
2760   INTEGER ,       INTENT(OUT) :: Status
2761   CHARACTER(len=1000) :: tmpstr(1000)
2762   INTEGER             :: idx
2763
2764   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_real8')
2765
2766   if (committed(DataHandle)) then
2767
2768      do idx = 1,Count
2769         write(tmpstr(idx),'(G17.10)')Data(idx)
2770      enddo
2771
2772      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
2773
2774   endif
2775
2776   RETURN
2777 END SUBROUTINE ext_gr1_put_dom_ti_real8
2778
2779 !*****************************************************************************
2780
2781 SUBROUTINE ext_gr1_put_dom_ti_integer ( DataHandle,Element,   Data, Count,  &
2782      Status )
2783
2784   USE gr1_data_info
2785   IMPLICIT NONE
2786 #include "wrf_status_codes.h"
2787   INTEGER ,       INTENT(IN)  :: DataHandle
2788   CHARACTER*(*) :: Element
2789   INTEGER ,       INTENT(IN)  :: Data(*)
2790   INTEGER ,       INTENT(IN)  :: Count
2791   INTEGER ,       INTENT(OUT) :: Status
2792   REAL dummy
2793   CHARACTER(len=1000) :: tmpstr(1000)
2794   INTEGER             :: idx
2795
2796
2797   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_integer')
2798
2799   if (Element == 'WEST-EAST_GRID_DIMENSION') then
2800      full_xsize = Data(1)
2801   else if (Element == 'SOUTH-NORTH_GRID_DIMENSION') then
2802      full_ysize = Data(1)
2803   else if (Element == 'MAP_PROJ') then
2804      projection = Data(1)
2805   else if (Element == 'WG_GRID_ID') then
2806      wg_grid_id = Data(1)
2807   else if (Element == 'GRID_ID') then
2808      this_domain = Data(1)
2809   endif
2810
2811   if (committed(DataHandle)) then
2812
2813      do idx = 1,Count
2814         write(tmpstr(idx),'(G17.10)')Data(idx)
2815      enddo
2816
2817      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
2818
2819   endif
2820
2821   call wrf_debug ( DEBUG , 'Leaving ext_gr1_put_dom_ti_integer')
2822
2823   RETURN
2824 END SUBROUTINE ext_gr1_put_dom_ti_integer
2825
2826 !*****************************************************************************
2827
2828 SUBROUTINE ext_gr1_put_dom_ti_logical ( DataHandle,Element,   Data, Count,  &
2829      Status )
2830
2831   USE gr1_data_info
2832   IMPLICIT NONE
2833 #include "wrf_status_codes.h"
2834   INTEGER ,       INTENT(IN)  :: DataHandle
2835   CHARACTER*(*) :: Element
2836   logical ,       INTENT(IN)  :: Data(*)
2837   INTEGER ,       INTENT(IN)  :: Count
2838   INTEGER ,       INTENT(OUT) :: Status
2839   CHARACTER(len=1000) :: tmpstr(1000)
2840   INTEGER             :: idx
2841
2842   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_logical')
2843
2844   if (committed(DataHandle)) then
2845
2846      do idx = 1,Count
2847         write(tmpstr(idx),'(G17.10)')Data(idx)
2848      enddo
2849
2850      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
2851
2852   endif
2853
2854   RETURN
2855 END SUBROUTINE ext_gr1_put_dom_ti_logical
2856
2857 !*****************************************************************************
2858
2859 SUBROUTINE ext_gr1_put_dom_ti_char ( DataHandle,Element,   Data,  &
2860      Status )
2861
2862   USE gr1_data_info
2863   IMPLICIT NONE
2864 #include "wrf_status_codes.h"
2865   INTEGER ,       INTENT(IN)  :: DataHandle
2866   CHARACTER*(*) :: Element
2867   CHARACTER*(*),     INTENT(IN)  :: Data
2868   INTEGER ,       INTENT(OUT) :: Status
2869   REAL dummy
2870   CHARACTER(len=1000) :: tmpstr(1000)
2871
2872   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_char')
2873
2874   if (Element .eq. 'START_DATE') then
2875      StartDate = Data
2876   endif
2877
2878   if (committed(DataHandle)) then
2879
2880      write(tmpstr(1),*)trim(Data)
2881
2882      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, 1, Status)
2883
2884   endif
2885
2886   RETURN
2887 END SUBROUTINE ext_gr1_put_dom_ti_char
2888
2889 !*****************************************************************************
2890
2891 SUBROUTINE ext_gr1_put_dom_ti_double ( DataHandle,Element, Data, Count, &
2892      Status )
2893   USE gr1_data_info
2894   IMPLICIT NONE
2895 #include "wrf_status_codes.h"
2896   INTEGER ,       INTENT(IN)  :: DataHandle
2897   CHARACTER*(*) , INTENT(IN)  :: Element
2898   real*8 ,            INTENT(IN) :: Data(*)
2899   INTEGER ,       INTENT(IN)  :: Count
2900   INTEGER ,       INTENT(OUT) :: Status
2901   CHARACTER(len=1000) :: tmpstr(1000)
2902   INTEGER             :: idx
2903
2904   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_ti_double')
2905
2906   if (committed(DataHandle)) then
2907
2908      do idx = 1,Count
2909         write(tmpstr(idx),'(G17.10)')Data(idx)
2910      enddo
2911
2912      CALL gr1_build_string (ti_output(DataHandle), Element, tmpstr, Count, Status)
2913
2914   endif
2915
2916   RETURN
2917 END SUBROUTINE ext_gr1_put_dom_ti_double
2918
2919 !******************************************************************************
2920 !* End of put_dom_ti_* routines
2921 !******************************************************************************
2922
2923
2924 !******************************************************************************
2925 !* Start of get_dom_td_* routines
2926 !******************************************************************************
2927
2928 SUBROUTINE ext_gr1_get_dom_td_real ( DataHandle,Element, DateStr,  Data, &
2929      Count, Outcount, Status )
2930
2931   USE gr1_data_info
2932   IMPLICIT NONE
2933 #include "wrf_status_codes.h"
2934   INTEGER ,       INTENT(IN)  :: DataHandle
2935   CHARACTER*(*) :: Element
2936   CHARACTER*(*) :: DateStr
2937   real ,          INTENT(OUT) :: Data(*)
2938   INTEGER ,       INTENT(IN)  :: Count
2939   INTEGER ,       INTENT(OUT) :: OutCount
2940   INTEGER ,       INTENT(OUT) :: Status
2941   INTEGER          :: idx
2942   INTEGER          :: stat
2943   CHARACTER*(1000) :: VALUE
2944
2945   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_real')
2946
2947   Status = WRF_NO_ERR
2948
2949   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
2950        "none", Value, stat)
2951   if (stat /= 0) then
2952      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2953      Status = WRF_WARN_VAR_NF
2954      RETURN
2955   endif
2956
2957   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2958   if (stat .ne. 0) then
2959      CALL wrf_message("Reading data from"//Value//"failed")
2960      Status = WRF_WARN_COUNT_TOO_LONG
2961      RETURN
2962   endif
2963   Outcount = idx
2964
2965   RETURN
2966 END SUBROUTINE ext_gr1_get_dom_td_real
2967
2968 !*****************************************************************************
2969
2970 SUBROUTINE ext_gr1_get_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
2971      Count, Outcount, Status )
2972
2973   USE gr1_data_info
2974   IMPLICIT NONE
2975 #include "wrf_status_codes.h"
2976   INTEGER ,       INTENT(IN)  :: DataHandle
2977   CHARACTER*(*) :: Element
2978   CHARACTER*(*) :: DateStr
2979   real*8 ,        INTENT(OUT) :: Data(*)
2980   INTEGER ,       INTENT(IN)  :: Count
2981   INTEGER ,       INTENT(OUT) :: OutCount
2982   INTEGER ,       INTENT(OUT) :: Status
2983   INTEGER          :: idx
2984   INTEGER          :: stat
2985   CHARACTER*(1000) :: VALUE
2986
2987   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_real8')
2988
2989   Status = WRF_NO_ERR
2990
2991   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
2992        "none", Value, stat)
2993   if (stat /= 0) then
2994      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
2995      Status = WRF_WARN_VAR_NF
2996      RETURN
2997   endif
2998
2999   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3000   if (stat .ne. 0) then
3001      CALL wrf_message("Reading data from"//Value//"failed")
3002      Status = WRF_WARN_COUNT_TOO_LONG
3003      RETURN
3004   endif
3005   Outcount = idx
3006
3007   RETURN
3008 END SUBROUTINE ext_gr1_get_dom_td_real8
3009
3010 !*****************************************************************************
3011
3012 SUBROUTINE ext_gr1_get_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
3013      Count, Outcount, Status )
3014
3015   USE gr1_data_info
3016   IMPLICIT NONE
3017 #include "wrf_status_codes.h"
3018   INTEGER ,       INTENT(IN)  :: DataHandle
3019   CHARACTER*(*) :: Element
3020   CHARACTER*(*) :: DateStr
3021   integer ,       INTENT(OUT) :: Data(*)
3022   INTEGER ,       INTENT(IN)  :: Count
3023   INTEGER ,       INTENT(OUT) :: OutCount
3024   INTEGER ,       INTENT(OUT) :: Status
3025   INTEGER          :: idx
3026   INTEGER          :: stat
3027   CHARACTER*(1000) :: VALUE
3028
3029   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_integer')
3030
3031   Status = WRF_NO_ERR
3032
3033   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
3034        "none", Value,stat)
3035   if (stat /= 0) then
3036      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
3037      Status = WRF_WARN_VAR_NF
3038      RETURN
3039   endif
3040
3041   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3042   if (stat .ne. 0) then
3043      CALL wrf_message("Reading data from"//Value//"failed")
3044      Status = WRF_WARN_COUNT_TOO_LONG
3045      RETURN
3046   endif
3047   Outcount = idx
3048
3049   RETURN
3050 END SUBROUTINE ext_gr1_get_dom_td_integer
3051
3052 !*****************************************************************************
3053
3054 SUBROUTINE ext_gr1_get_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
3055      Count, Outcount, Status )
3056
3057   USE gr1_data_info
3058   IMPLICIT NONE
3059 #include "wrf_status_codes.h"
3060   INTEGER ,       INTENT(IN)  :: DataHandle
3061   CHARACTER*(*) :: Element
3062   CHARACTER*(*) :: DateStr
3063   logical ,       INTENT(OUT) :: Data(*)
3064   INTEGER ,       INTENT(IN)  :: Count
3065   INTEGER ,       INTENT(OUT) :: OutCount
3066   INTEGER ,       INTENT(OUT) :: Status
3067   INTEGER          :: idx
3068   INTEGER          :: stat
3069   CHARACTER*(1000) :: VALUE
3070
3071   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_logical')
3072
3073   Status = WRF_NO_ERR
3074
3075   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
3076        "none", Value, stat)
3077   if (stat /= 0) then
3078      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
3079      Status = WRF_WARN_VAR_NF
3080      RETURN
3081   endif
3082
3083   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3084   if (stat .ne. 0) then
3085      CALL wrf_message("Reading data from"//Value//"failed")
3086      Status = WRF_WARN_COUNT_TOO_LONG
3087      RETURN
3088   endif
3089   Outcount = idx
3090
3091   RETURN
3092 END SUBROUTINE ext_gr1_get_dom_td_logical
3093
3094 !*****************************************************************************
3095
3096 SUBROUTINE ext_gr1_get_dom_td_char ( DataHandle,Element, DateStr,  Data,  &
3097      Status )
3098
3099   USE gr1_data_info
3100   IMPLICIT NONE
3101 #include "wrf_status_codes.h"
3102   INTEGER ,       INTENT(IN)  :: DataHandle
3103   CHARACTER*(*) :: Element
3104   CHARACTER*(*) :: DateStr
3105   CHARACTER*(*) :: Data
3106   INTEGER ,       INTENT(OUT) :: Status
3107   INTEGER       :: stat
3108
3109   Status = WRF_NO_ERR
3110
3111   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_char')
3112
3113   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
3114        "none", Data, stat)
3115   if (stat /= 0) then
3116      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
3117      Status = WRF_WARN_VAR_NF
3118      RETURN
3119   endif
3120
3121   RETURN
3122 END SUBROUTINE ext_gr1_get_dom_td_char
3123
3124 !*****************************************************************************
3125
3126 SUBROUTINE ext_gr1_get_dom_td_double ( DataHandle,Element, DateStr,  Data, &
3127      Count, Outcount, Status )
3128   USE gr1_data_info
3129   IMPLICIT NONE
3130 #include "wrf_status_codes.h"
3131   INTEGER ,       INTENT(IN)  :: DataHandle
3132   CHARACTER*(*) , INTENT(IN)  :: Element
3133   CHARACTER*(*) , INTENT(IN)  :: DateStr
3134   real*8 ,            INTENT(OUT) :: Data(*)
3135   INTEGER ,       INTENT(IN)  :: Count
3136   INTEGER ,       INTENT(OUT)  :: OutCount
3137   INTEGER ,       INTENT(OUT) :: Status
3138   INTEGER          :: idx
3139   INTEGER          :: stat
3140   CHARACTER*(1000) :: VALUE
3141
3142   call wrf_debug ( DEBUG , 'Entering ext_gr1_get_dom_td_double')
3143
3144   Status = WRF_NO_ERR
3145
3146   CALL GET_METADATA_VALUE(fileinfo(DataHandle)%fileindex(:), TRIM(Element), DateStr, &
3147        "none", Value, stat)
3148   if (stat /= 0) then
3149      CALL wrf_debug ( DEBUG , "GET_METADATA_VALUE failed for "//Element)
3150      Status = WRF_WARN_VAR_NF
3151      RETURN
3152   endif
3153
3154   READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3155   if (stat .ne. 0) then
3156      CALL wrf_message("Reading data from"//Value//"failed")
3157      Status = WRF_WARN_COUNT_TOO_LONG
3158      RETURN
3159   endif
3160   Outcount = idx
3161
3162 RETURN
3163 END SUBROUTINE ext_gr1_get_dom_td_double
3164
3165 !******************************************************************************
3166 !* End of get_dom_td_* routines
3167 !******************************************************************************
3168
3169
3170 !******************************************************************************
3171 !* Start of put_dom_td_* routines
3172 !******************************************************************************
3173
3174
3175 SUBROUTINE ext_gr1_put_dom_td_real8 ( DataHandle,Element, DateStr,  Data, &
3176      Count,  Status )
3177
3178   USE gr1_data_info
3179   IMPLICIT NONE
3180 #include "wrf_status_codes.h"
3181   INTEGER ,       INTENT(IN)  :: DataHandle
3182   CHARACTER*(*) :: Element
3183   CHARACTER*(*) :: DateStr
3184   real*8 ,        INTENT(IN)  :: Data(*)
3185   INTEGER ,       INTENT(IN)  :: Count
3186   INTEGER ,       INTENT(OUT) :: Status
3187   CHARACTER(len=1000) :: tmpstr(1000)
3188   INTEGER             :: idx
3189
3190   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_real8')
3191
3192   if (committed(DataHandle)) then
3193
3194      do idx = 1,Count
3195         write(tmpstr(idx),'(G17.10)')Data(idx)
3196      enddo
3197
3198      CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
3199           Count, Status)
3200
3201   endif
3202
3203   RETURN
3204 END SUBROUTINE ext_gr1_put_dom_td_real8
3205
3206 !*****************************************************************************
3207
3208 SUBROUTINE ext_gr1_put_dom_td_integer ( DataHandle,Element, DateStr,  Data, &
3209      Count,  Status )
3210
3211   USE gr1_data_info
3212   IMPLICIT NONE
3213 #include "wrf_status_codes.h"
3214   INTEGER ,       INTENT(IN)  :: DataHandle
3215   CHARACTER*(*) :: Element
3216   CHARACTER*(*) :: DateStr
3217   integer ,       INTENT(IN)  :: Data(*)
3218   INTEGER ,       INTENT(IN)  :: Count
3219   INTEGER ,       INTENT(OUT) :: Status
3220   CHARACTER(len=1000) :: tmpstr(1000)
3221   INTEGER             :: idx
3222
3223   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_integer')
3224
3225   if (committed(DataHandle)) then
3226
3227      do idx = 1,Count
3228         write(tmpstr(idx),'(G17.10)')Data(idx)
3229      enddo
3230
3231      CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
3232           Count, Status)
3233
3234   endif
3235
3236   RETURN
3237 END SUBROUTINE ext_gr1_put_dom_td_integer
3238
3239 !*****************************************************************************
3240
3241 SUBROUTINE ext_gr1_put_dom_td_logical ( DataHandle,Element, DateStr,  Data, &
3242      Count,  Status )
3243
3244   USE gr1_data_info
3245   IMPLICIT NONE
3246 #include "wrf_status_codes.h"
3247   INTEGER ,       INTENT(IN)  :: DataHandle
3248   CHARACTER*(*) :: Element
3249   CHARACTER*(*) :: DateStr
3250   logical ,       INTENT(IN)  :: Data(*)
3251   INTEGER ,       INTENT(IN)  :: Count
3252   INTEGER ,       INTENT(OUT) :: Status
3253   CHARACTER(len=1000) :: tmpstr(1000)
3254   INTEGER             :: idx
3255
3256   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_logical')
3257
3258   if (committed(DataHandle)) then
3259
3260      do idx = 1,Count
3261         write(tmpstr(idx),'(G17.10)')Data(idx)
3262      enddo
3263
3264      CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
3265           Count, Status)
3266
3267   endif
3268
3269   RETURN
3270 END SUBROUTINE ext_gr1_put_dom_td_logical
3271
3272 !*****************************************************************************
3273
3274 SUBROUTINE ext_gr1_put_dom_td_char ( DataHandle,Element, DateStr,  Data, &
3275      Status )
3276
3277   USE gr1_data_info
3278   IMPLICIT NONE
3279 #include "wrf_status_codes.h"
3280   INTEGER ,       INTENT(IN)  :: DataHandle
3281   CHARACTER*(*) :: Element
3282   CHARACTER*(*) :: DateStr
3283   CHARACTER(len=*), INTENT(IN)  :: Data
3284   INTEGER ,       INTENT(OUT) :: Status
3285   CHARACTER(len=1000) :: tmpstr(1)
3286
3287   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_char')
3288
3289   if (committed(DataHandle)) then
3290
3291      write(tmpstr(1),*)Data
3292
3293      CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
3294           1, Status)
3295
3296   endif
3297
3298   RETURN
3299 END SUBROUTINE ext_gr1_put_dom_td_char
3300
3301 !*****************************************************************************
3302
3303 SUBROUTINE ext_gr1_put_dom_td_double ( DataHandle,Element, DateStr,  Data, &
3304      Count,  Status )
3305   USE gr1_data_info
3306   IMPLICIT NONE
3307 #include "wrf_status_codes.h"
3308   INTEGER ,       INTENT(IN)  :: DataHandle
3309   CHARACTER*(*) , INTENT(IN)  :: Element
3310   CHARACTER*(*) , INTENT(IN)  :: DateStr
3311   real*8 ,            INTENT(IN) :: Data(*)
3312   INTEGER ,       INTENT(IN)  :: Count
3313   INTEGER ,       INTENT(OUT) :: Status
3314   CHARACTER(len=1000) :: tmpstr(1000)
3315   INTEGER             :: idx
3316
3317   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_double')
3318
3319   if (committed(DataHandle)) then
3320
3321      do idx = 1,Count
3322         write(tmpstr(idx),'(G17.10)')Data(idx)
3323      enddo
3324
3325      CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
3326           Count, Status)
3327
3328   endif
3329
3330 RETURN
3331 END SUBROUTINE ext_gr1_put_dom_td_double
3332
3333 !*****************************************************************************
3334
3335 SUBROUTINE ext_gr1_put_dom_td_real ( DataHandle,Element, DateStr,  Data, &
3336      Count,  Status )
3337
3338   USE gr1_data_info
3339   IMPLICIT NONE
3340 #include "wrf_status_codes.h"
3341   INTEGER ,       INTENT(IN)  :: DataHandle
3342   CHARACTER*(*) :: Element
3343   CHARACTER*(*) :: DateStr
3344   real ,          INTENT(IN)  :: Data(*)
3345   INTEGER ,       INTENT(IN)  :: Count
3346   INTEGER ,       INTENT(OUT) :: Status
3347   CHARACTER(len=1000) :: tmpstr(1000)
3348   INTEGER             :: idx
3349
3350   call wrf_debug ( DEBUG , 'Entering ext_gr1_put_dom_td_real')
3351
3352   if (committed(DataHandle)) then
3353
3354      do idx = 1,Count
3355         write(tmpstr(idx),'(G17.10)')Data(idx)
3356      enddo
3357
3358      CALL gr1_build_string (td_output(DataHandle), DateStr//';'//Element, tmpstr, &
3359           Count, Status)
3360
3361   endif
3362
3363   RETURN
3364 END SUBROUTINE ext_gr1_put_dom_td_real
3365
3366
3367 !******************************************************************************
3368 !* End of put_dom_td_* routines
3369 !******************************************************************************
3370
3371
3372 !*****************************************************************************
3373
3374 SUBROUTINE gr1_build_string (string, Element, Value, Count, Status)
3375
3376   IMPLICIT NONE
3377 #include "wrf_status_codes.h"
3378
3379   CHARACTER (LEN=*) , INTENT(INOUT) :: string
3380   CHARACTER (LEN=*) , INTENT(IN)    :: Element
3381   CHARACTER (LEN=*) , INTENT(IN)    :: Value(*)
3382   INTEGER ,           INTENT(IN)    :: Count
3383   INTEGER ,           INTENT(OUT)   :: Status
3384
3385   CHARACTER (LEN=2)                 :: lf
3386   INTEGER                           :: IDX
3387
3388   lf=char(10)//' '
3389   if (len_trim(string) == 0) then
3390      string = lf//Element//' = '
3391   else
3392      string = trim(string)//lf//Element//' = '
3393   endif
3394   do idx = 1,Count
3395      if (idx > 1) then
3396         string = trim(string)//','
3397      endif
3398      string = trim(string)//' '//trim(adjustl(Value(idx)))
3399   enddo
3400
3401   Status = WRF_NO_ERR
3402
3403 END SUBROUTINE gr1_build_string
3404
3405 !*****************************************************************************
3406
3407 SUBROUTINE gr1_get_new_handle(DataHandle)
3408   USE gr1_data_info
3409   IMPLICIT NONE
3410
3411   INTEGER ,       INTENT(OUT)  :: DataHandle
3412   INTEGER :: i
3413
3414   DataHandle = -1
3415   do i=firstFileHandle, maxFileHandles
3416      if (.NOT. used(i)) then
3417         DataHandle = i
3418         used(i) = .true.
3419         exit
3420      endif
3421   enddo
3422
3423   RETURN
3424 END SUBROUTINE gr1_get_new_handle
3425
3426
3427 !******************************************************************************
3428
3429
3430 SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction, &
3431      vert_unit, level1, level2)
3432
3433   use gr1_data_info
3434   IMPLICIT NONE
3435
3436   integer :: zidx
3437   integer :: zsize
3438   logical :: soil_layers
3439   logical :: vert_stag
3440   logical :: fraction
3441   integer :: vert_unit
3442   integer :: level1
3443   integer :: level2
3444   character (LEN=*) :: VarName
3445
3446   ! Setup vert_unit, and vertical levels in grib units
3447
3448   if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCTOP') &
3449        .or. (VarName .eq. 'SOILCBOT')) then
3450      vert_unit = 109;
3451      level1 = zidx
3452      level2 = 0
3453   else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction)) &
3454        then
3455      vert_unit = 119;
3456      if (vert_stag) then
3457         level1 = (10000*full_eta(zidx)+0.5)
3458      else
3459         level1 = (10000*half_eta(zidx)+0.5)
3460      endif
3461      level2 = 0
3462   else
3463      ! Set the vertical coordinate and level for soil and 2D fields
3464      if (fraction) then
3465         vert_unit = 109
3466         level1 = zidx
3467         level2 = 0
3468      else if (soil_layers) then
3469         vert_unit = 112
3470         level1 = 100*(soil_depth(zidx) - 0.5*soil_thickness(zidx))+0.5
3471         level2 = 100*(soil_depth(zidx) + 0.5*soil_thickness(zidx))+0.5
3472      else if (VarName .eq. 'mu') then
3473         vert_unit = 200
3474         level1 = 0
3475         level2 = 0
3476      else if ((VarName .eq. 'Q2') .or. (VarName .eq. 'TH2') .or. &
3477         (VarName .eq. 'T2')) then
3478         vert_unit = 105
3479         level1 = 2
3480         level2 = 0
3481      else if ((VarName .eq. 'Q10') .or. (VarName .eq. 'TH10') .or. &
3482           (VarName .eq. 'U10') .or. (VarName .eq. 'V10')) then
3483         vert_unit = 105
3484         level1 = 10
3485         level2 = 0
3486      else
3487         vert_unit = 1
3488         level1 = 0
3489         level2 = 0
3490      endif
3491   endif
3492
3493 end SUBROUTINE gr1_get_levels
3494
3495 !*****************************************************************************
3496
3497
3498 SUBROUTINE gr1_fill_eta_levels(fileindex, FileFd, grib_tables, VarName, eta_levels)
3499   IMPLICIT NONE
3500
3501   CHARACTER (len=*) :: fileindex
3502   INTEGER   :: FileFd
3503   CHARACTER (len=*) :: grib_tables
3504   character (len=*) :: VarName
3505   REAL,DIMENSION(*) :: eta_levels
3506
3507   INTEGER   :: center, subcenter, parmtbl
3508   INTEGER   :: swapped
3509   INTEGER   :: leveltype
3510   INTEGER   :: idx
3511   INTEGER   :: parmid
3512   INTEGER   :: tablenum
3513   REAL      :: tmp
3514   INTEGER   :: numindices
3515   integer , DIMENSION(1000)   :: indices
3516
3517   !
3518   ! Read the levels from the grib file
3519   !
3520   CALL GET_GRIB_PARAM(grib_tables, VarName, center, subcenter, parmtbl, &
3521        tablenum, parmid)
3522
3523   if (parmid == -1) then
3524      call wrf_message ('Error getting grib parameter')
3525   endif
3526
3527   leveltype = 119
3528
3529   CALL GET_GRIB_INDICES(fileindex(:), center, subcenter, parmtbl, &
3530        parmid, "*", leveltype, &
3531        -HUGE(1), -HUGE(1), -HUGE(1), -HUGE(1), indices, numindices)
3532
3533   do idx = 1,numindices
3534      CALL READ_GRIB(fileindex(:),FileFd,indices(idx),eta_levels(idx))
3535   enddo
3536
3537   !
3538   ! Sort the levels--from highest (bottom) to lowest (top)
3539   !
3540   swapped = 1
3541   sortloop : do
3542      if (swapped /= 1) exit sortloop
3543      swapped = 0
3544      do idx=2, numindices
3545         !
3546         ! Remove duplicate levels, caused by multiple time periods in a
3547         ! single file.
3548         !
3549         if (eta_levels(idx) == eta_levels(idx-1)) eta_levels(idx) = 0.0
3550         if (eta_levels(idx) > eta_levels(idx-1)) then
3551           tmp = eta_levels(idx)
3552           eta_levels(idx) = eta_levels(idx - 1)
3553           eta_levels(idx - 1) = tmp
3554           swapped = 1
3555         endif
3556      enddo
3557   enddo sortloop
3558
3559 end subroutine gr1_fill_eta_levels
3560