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