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