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