Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

io_grib2.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 135.5 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format