source: lmdz_wrf/trunk/WRFV3/external/io_grib1/io_grib1.F @ 1544

Last change on this file since 1544 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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