Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

io_grib2.F @ 2756

Last change on this file since 2756 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 135.7 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(MemoryOrder, di, FieldType, Field, &
1354	MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
1355	MemoryStart(3), MemoryEnd(3), &
1356	gfld%fld, zsize)
1357	else
1358	CALL Transpose(MemoryOrder, di, FieldType, Field, &
1359	MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
1360	MemoryStart(3), MemoryEnd(3), &
1361	gfld%fld, dim3, ysize,xsize)
1362	endif
1363	! CALL Transpose_new(MemoryOrder, di, FieldType, Field, &
1364	! MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
1365	! MemoryStart(3), MemoryEnd(3), &
1366	! gfld%fld, dim1size,dim2size,dim3)
1367
1368	call gf_free(gfld)
1369
1370	enddo VERTDIM
1371	endif
1372
1373	Status = WRF_NO_ERR
1374
1375
1376	call wrf_debug ( DEBUG , 'Leaving ext_gr2_read_field')
1377
1378	RETURN
1379	END SUBROUTINE ext_gr2_read_field
1380
1381	!*****************************************************************************
1382
1383	SUBROUTINE ext_gr2_get_next_var ( DataHandle, VarName, Status )
1384
1385	USE gr2_data_info
1386	IMPLICIT NONE
1387	#include "wrf_status_codes.h"
1388	INTEGER , INTENT(IN) :: DataHandle
1389	CHARACTER() :: VarName
1390	INTEGER , INTENT(OUT) :: Status
1391
1392	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_var')
1393
1394	Status = WRF_WARN_NOOP
1395
1396	RETURN
1397	END SUBROUTINE ext_gr2_get_next_var
1398
1399	!*****************************************************************************
1400
1401	subroutine ext_gr2_end_of_frame(DataHandle, Status)
1402
1403	USE gr2_data_info
1404	implicit none
1405	#include "wrf_status_codes.h"
1406	integer ,intent(in) :: DataHandle
1407	integer ,intent(out) :: Status
1408
1409	call wrf_debug ( DEBUG , 'Entering ext_gr2_end_of_frame')
1410
1411	Status = WRF_WARN_NOOP
1412
1413	return
1414	end subroutine ext_gr2_end_of_frame
1415
1416	!*****************************************************************************
1417
1418	SUBROUTINE ext_gr2_iosync ( DataHandle, Status )
1419
1420	USE gr2_data_info
1421	IMPLICIT NONE
1422	#include "wrf_status_codes.h"
1423	INTEGER , INTENT(IN) :: DataHandle
1424	INTEGER , INTENT(OUT) :: Status
1425	integer :: ierror
1426
1427	call wrf_debug ( DEBUG , 'Entering ext_gr2_iosync')
1428
1429	Status = WRF_NO_ERR
1430	if (DataHandle .GT. 0) then
1431	CALL flush_file(fileinfo(DataHandle)%FileFd)
1432	else
1433	Status = WRF_WARN_TOO_MANY_FILES
1434	endif
1435
1436	RETURN
1437	END SUBROUTINE ext_gr2_iosync
1438
1439	!*****************************************************************************
1440
1441	SUBROUTINE ext_gr2_inquire_filename ( DataHandle, FileName , FileStat, &
1442	Status )
1443
1444	USE gr2_data_info
1445	IMPLICIT NONE
1446	#include "wrf_status_codes.h"
1447	#include "wrf_io_flags.h"
1448	INTEGER , INTENT(IN) :: DataHandle
1449	CHARACTER() :: FileName
1450	INTEGER , INTENT(OUT) :: FileStat
1451	INTEGER , INTENT(OUT) :: Status
1452	CHARACTER *80 SysDepInfo
1453
1454	call wrf_debug ( DEBUG , 'Entering ext_gr2_inquire_filename')
1455
1456	FileName = fileinfo(DataHandle)%DataFile
1457
1458	if ((DataHandle .ge. firstFileHandle) .and. &
1459	(DataHandle .le. maxFileHandles)) then
1460	FileStat = fileinfo(DataHandle)%FileStatus
1461	else
1462	FileStat = WRF_FILE_NOT_OPENED
1463	endif
1464	Status = WRF_NO_ERR
1465
1466	RETURN
1467	END SUBROUTINE ext_gr2_inquire_filename
1468
1469	!*****************************************************************************
1470
1471	SUBROUTINE ext_gr2_get_var_info ( DataHandle , VarName , NDim , &
1472	MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status )
1473
1474	USE gr2_data_info
1475	IMPLICIT NONE
1476	#include "wrf_status_codes.h"
1477	integer ,intent(in) :: DataHandle
1478	character() ,intent(in) :: VarName
1479	integer ,intent(out) :: NDim
1480	character() ,intent(out) :: MemoryOrder
1481	character() ,intent(out) :: Stagger
1482	integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd
1483	integer ,intent(out) :: WrfType
1484	integer ,intent(out) :: Status
1485
1486	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_info')
1487
1488	MemoryOrder = ""
1489	Stagger = ""
1490	DomainStart(1) = 0
1491	DomainEnd(1) = 0
1492	WrfType = 0
1493	NDim = 0
1494
1495	CALL wrf_message('ext_gr2_get_var_info not supported for grib version2 data')
1496	Status = WRF_NO_ERR
1497
1498	RETURN
1499	END SUBROUTINE ext_gr2_get_var_info
1500
1501	!*****************************************************************************
1502
1503	SUBROUTINE ext_gr2_set_time ( DataHandle, DateStr, Status )
1504
1505	USE gr2_data_info
1506	IMPLICIT NONE
1507	#include "wrf_status_codes.h"
1508	INTEGER , INTENT(IN) :: DataHandle
1509	CHARACTER() :: DateStr
1510	INTEGER , INTENT(OUT) :: Status
1511	integer :: found_time
1512	integer :: idx
1513
1514	call wrf_debug ( DEBUG , 'Entering ext_gr2_set_time')
1515
1516	found_time = 0
1517	do idx = 1,fileinfo(DataHandle)%NumberTimes
1518	if (fileinfo(DataHandle)%Times(idx) == DateStr) then
1519	found_time = 1
1520	fileinfo(DataHandle)%CurrentTime = idx
1521	endif
1522	enddo
1523	if (found_time == 0) then
1524	Status = WRF_WARN_TIME_NF
1525	else
1526	Status = WRF_NO_ERR
1527	endif
1528
1529	RETURN
1530	END SUBROUTINE ext_gr2_set_time
1531
1532	!*****************************************************************************
1533
1534	SUBROUTINE ext_gr2_get_next_time ( DataHandle, DateStr, Status )
1535
1536	USE gr2_data_info
1537	IMPLICIT NONE
1538	#include "wrf_status_codes.h"
1539	INTEGER , INTENT(IN) :: DataHandle
1540	CHARACTER() , INTENT(OUT) :: DateStr
1541	INTEGER , INTENT(OUT) :: Status
1542
1543	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_next_time')
1544
1545	if (fileinfo(DataHandle)%CurrentTime == fileinfo(DataHandle)%NumberTimes) then
1546	Status = WRF_WARN_TIME_EOF
1547	else
1548	fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime + 1
1549	DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
1550	Status = WRF_NO_ERR
1551	endif
1552
1553	call wrf_debug ( DEBUG , 'Leaving ext_gr2_get_next_time, got time '//DateStr)
1554
1555	RETURN
1556	END SUBROUTINE ext_gr2_get_next_time
1557
1558	!*****************************************************************************
1559
1560	SUBROUTINE ext_gr2_get_previous_time ( DataHandle, DateStr, Status )
1561
1562	USE gr2_data_info
1563	IMPLICIT NONE
1564	#include "wrf_status_codes.h"
1565	INTEGER , INTENT(IN) :: DataHandle
1566	CHARACTER() :: DateStr
1567	INTEGER , INTENT(OUT) :: Status
1568
1569	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_previous_time')
1570
1571	if (fileinfo(DataHandle)%CurrentTime <= 0) then
1572	Status = WRF_WARN_TIME_EOF
1573	else
1574	fileinfo(DataHandle)%CurrentTime = fileinfo(DataHandle)%CurrentTime - 1
1575	DateStr = fileinfo(DataHandle)%Times(fileinfo(DataHandle)%CurrentTime)
1576	Status = WRF_NO_ERR
1577	endif
1578
1579	RETURN
1580	END SUBROUTINE ext_gr2_get_previous_time
1581
1582	!******************************************************************************
1583	!* Start of get_var_ti_* routines
1584	!******************************************************************************
1585
1586	SUBROUTINE ext_gr2_get_var_ti_real ( DataHandle,Element, Varname, Data, &
1587	Count, Outcount, Status )
1588
1589	USE gr2_data_info
1590	IMPLICIT NONE
1591	#include "wrf_status_codes.h"
1592	INTEGER , INTENT(IN) :: DataHandle
1593	CHARACTER() :: Element
1594	CHARACTER() :: VarName
1595	real , INTENT(OUT) :: Data(*)
1596	INTEGER , INTENT(IN) :: Count
1597	INTEGER , INTENT(OUT) :: OutCount
1598	INTEGER , INTENT(OUT) :: Status
1599	INTEGER :: idx
1600	INTEGER :: stat
1601	CHARACTER(len=100) :: Value
1602
1603	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_real')
1604
1605	Status = WRF_NO_ERR
1606
1607	CALL gr2_get_metadata_value(global_input(DataHandle), &
1608	trim(VarName)//';'//trim(Element), Value, stat)
1609	if (stat /= 0) then
1610	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1611	Status = WRF_WARN_VAR_NF
1612	RETURN
1613	endif
1614
1615	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1616	if (stat .ne. 0) then
1617	CALL wrf_message("Reading data from"//Value//"failed")
1618	Status = WRF_WARN_COUNT_TOO_LONG
1619	RETURN
1620	endif
1621	Outcount = idx
1622
1623	RETURN
1624	END SUBROUTINE ext_gr2_get_var_ti_real
1625
1626	!*****************************************************************************
1627
1628	SUBROUTINE ext_gr2_get_var_ti_real8 ( DataHandle,Element, Varname, Data, &
1629	Count, Outcount, Status )
1630
1631	USE gr2_data_info
1632	IMPLICIT NONE
1633	#include "wrf_status_codes.h"
1634	INTEGER , INTENT(IN) :: DataHandle
1635	CHARACTER() :: Element
1636	CHARACTER() :: VarName
1637	real8 , INTENT(OUT) :: Data()
1638	INTEGER , INTENT(IN) :: Count
1639	INTEGER , INTENT(OUT) :: OutCount
1640	INTEGER , INTENT(OUT) :: Status
1641	INTEGER :: idx
1642	INTEGER :: stat
1643	CHARACTER*(100) :: VALUE
1644
1645	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_real8')
1646
1647	Status = WRF_NO_ERR
1648
1649	CALL gr2_get_metadata_value(global_input(DataHandle), &
1650	trim(VarName)//';'//trim(Element), Value, stat)
1651	if (stat /= 0) then
1652	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1653	Status = WRF_WARN_VAR_NF
1654	RETURN
1655	endif
1656
1657	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1658	if (stat .ne. 0) then
1659	CALL wrf_message("Reading data from"//Value//"failed")
1660	Status = WRF_WARN_COUNT_TOO_LONG
1661	RETURN
1662	endif
1663	Outcount = idx
1664
1665	RETURN
1666	END SUBROUTINE ext_gr2_get_var_ti_real8
1667
1668	!*****************************************************************************
1669
1670	SUBROUTINE ext_gr2_get_var_ti_double ( DataHandle,Element, Varname, Data, &
1671	Count, Outcount, Status )
1672	USE gr2_data_info
1673	IMPLICIT NONE
1674	#include "wrf_status_codes.h"
1675	INTEGER , INTENT(IN) :: DataHandle
1676	CHARACTER() , INTENT(IN) :: Element
1677	CHARACTER() , INTENT(IN) :: VarName
1678	real8 , INTENT(OUT) :: Data()
1679	INTEGER , INTENT(IN) :: Count
1680	INTEGER , INTENT(OUT) :: OutCount
1681	INTEGER , INTENT(OUT) :: Status
1682	INTEGER :: idx
1683	INTEGER :: stat
1684	CHARACTER*(100) :: VALUE
1685
1686	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_double')
1687
1688	Status = WRF_NO_ERR
1689
1690	CALL gr2_get_metadata_value(global_input(DataHandle), &
1691	trim(VarName)//';'//trim(Element), Value, stat)
1692	if (stat /= 0) then
1693	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1694	Status = WRF_WARN_VAR_NF
1695	RETURN
1696	endif
1697
1698	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1699	if (stat .ne. 0) then
1700	CALL wrf_message("Reading data from"//Value//"failed")
1701	Status = WRF_WARN_COUNT_TOO_LONG
1702	RETURN
1703	endif
1704	Outcount = idx
1705
1706	RETURN
1707	END SUBROUTINE ext_gr2_get_var_ti_double
1708
1709	!*****************************************************************************
1710
1711	SUBROUTINE ext_gr2_get_var_ti_integer ( DataHandle,Element, Varname, Data, &
1712	Count, Outcount, Status )
1713
1714	USE gr2_data_info
1715	IMPLICIT NONE
1716	#include "wrf_status_codes.h"
1717	INTEGER , INTENT(IN) :: DataHandle
1718	CHARACTER() :: Element
1719	CHARACTER() :: VarName
1720	integer , INTENT(OUT) :: Data(*)
1721	INTEGER , INTENT(IN) :: Count
1722	INTEGER , INTENT(OUT) :: OutCount
1723	INTEGER , INTENT(OUT) :: Status
1724	INTEGER :: idx
1725	INTEGER :: stat
1726	CHARACTER*(1000) :: VALUE
1727
1728	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_integer')
1729
1730	Status = WRF_NO_ERR
1731
1732	CALL gr2_get_metadata_value(global_input(DataHandle), &
1733	trim(VarName)//';'//trim(Element), Value, stat)
1734	if (stat /= 0) then
1735	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1736	Status = WRF_WARN_VAR_NF
1737	RETURN
1738	endif
1739
1740	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1741	if (stat .ne. 0) then
1742	CALL wrf_message("Reading data from"//Value//"failed")
1743	Status = WRF_WARN_COUNT_TOO_LONG
1744	RETURN
1745	endif
1746	Outcount = idx
1747
1748	RETURN
1749	END SUBROUTINE ext_gr2_get_var_ti_integer
1750
1751	!*****************************************************************************
1752
1753	SUBROUTINE ext_gr2_get_var_ti_logical ( DataHandle,Element, Varname, Data, &
1754	Count, Outcount, Status )
1755
1756	USE gr2_data_info
1757	IMPLICIT NONE
1758	#include "wrf_status_codes.h"
1759	INTEGER , INTENT(IN) :: DataHandle
1760	CHARACTER() :: Element
1761	CHARACTER() :: VarName
1762	logical , INTENT(OUT) :: Data(*)
1763	INTEGER , INTENT(IN) :: Count
1764	INTEGER , INTENT(OUT) :: OutCount
1765	INTEGER , INTENT(OUT) :: Status
1766	INTEGER :: idx
1767	INTEGER :: stat
1768	CHARACTER*(100) :: VALUE
1769
1770	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_logical')
1771
1772	Status = WRF_NO_ERR
1773
1774	CALL gr2_get_metadata_value(global_input(DataHandle), &
1775	trim(VarName)//';'//trim(Element), Value, stat)
1776	if (stat /= 0) then
1777	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1778	Status = WRF_WARN_VAR_NF
1779	RETURN
1780	endif
1781
1782	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
1783	if (stat .ne. 0) then
1784	CALL wrf_message("Reading data from"//Value//"failed")
1785	Status = WRF_WARN_COUNT_TOO_LONG
1786	RETURN
1787	endif
1788	Outcount = idx
1789
1790	RETURN
1791	END SUBROUTINE ext_gr2_get_var_ti_logical
1792
1793	!*****************************************************************************
1794
1795	SUBROUTINE ext_gr2_get_var_ti_char ( DataHandle,Element, Varname, Data, &
1796	Status )
1797
1798	USE gr2_data_info
1799	IMPLICIT NONE
1800	#include "wrf_status_codes.h"
1801	INTEGER , INTENT(IN) :: DataHandle
1802	CHARACTER() :: Element
1803	CHARACTER() :: VarName
1804	CHARACTER() :: Data
1805	INTEGER , INTENT(OUT) :: Status
1806	INTEGER :: stat
1807
1808	Status = WRF_NO_ERR
1809
1810	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_ti_char')
1811
1812	CALL gr2_get_metadata_value(global_input(DataHandle), &
1813	trim(VarName)//';'//trim(Element), Data, stat)
1814	if (stat /= 0) then
1815	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(Element))
1816	Status = WRF_WARN_VAR_NF
1817	RETURN
1818	endif
1819
1820	RETURN
1821	END SUBROUTINE ext_gr2_get_var_ti_char
1822
1823	!******************************************************************************
1824	!* End of get_var_ti_* routines
1825	!******************************************************************************
1826
1827
1828	!******************************************************************************
1829	!* Start of put_var_ti_* routines
1830	!******************************************************************************
1831
1832	SUBROUTINE ext_gr2_put_var_ti_real ( DataHandle,Element, Varname, Data, &
1833	Count, Status )
1834
1835	USE gr2_data_info
1836	IMPLICIT NONE
1837	#include "wrf_status_codes.h"
1838	INTEGER , INTENT(IN) :: DataHandle
1839	CHARACTER() :: Element
1840	CHARACTER() :: VarName
1841	real , INTENT(IN) :: Data(*)
1842	INTEGER , INTENT(IN) :: Count
1843	INTEGER , INTENT(OUT) :: Status
1844	CHARACTER(len=1000) :: tmpstr(1000)
1845	INTEGER :: idx
1846
1847	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_real')
1848
1849	if (fileinfo(DataHandle)%committed) then
1850
1851	do idx = 1,Count
1852	write(tmpstr(idx),'(G17.10)')Data(idx)
1853	enddo
1854
1855	CALL gr2_build_string (ti_output(DataHandle), &
1856	trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1857
1858	endif
1859
1860	RETURN
1861	END SUBROUTINE ext_gr2_put_var_ti_real
1862
1863	!*****************************************************************************
1864
1865	SUBROUTINE ext_gr2_put_var_ti_double ( DataHandle,Element, Varname, Data, &
1866	Count, Status )
1867	USE gr2_data_info
1868	IMPLICIT NONE
1869	#include "wrf_status_codes.h"
1870	INTEGER , INTENT(IN) :: DataHandle
1871	CHARACTER() , INTENT(IN) :: Element
1872	CHARACTER() , INTENT(IN) :: VarName
1873	real8 , INTENT(IN) :: Data()
1874	INTEGER , INTENT(IN) :: Count
1875	INTEGER , INTENT(OUT) :: Status
1876	CHARACTER(len=1000) :: tmpstr(1000)
1877	INTEGER :: idx
1878
1879	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_double')
1880
1881	if (fileinfo(DataHandle)%committed) then
1882
1883	do idx = 1,Count
1884	write(tmpstr(idx),'(G17.10)')Data(idx)
1885	enddo
1886
1887	CALL gr2_build_string (ti_output(DataHandle), &
1888	trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1889	endif
1890
1891	RETURN
1892	END SUBROUTINE ext_gr2_put_var_ti_double
1893
1894	!*****************************************************************************
1895
1896	SUBROUTINE ext_gr2_put_var_ti_real8 ( DataHandle,Element, Varname, Data, &
1897	Count, Status )
1898
1899	USE gr2_data_info
1900	IMPLICIT NONE
1901	#include "wrf_status_codes.h"
1902	INTEGER , INTENT(IN) :: DataHandle
1903	CHARACTER() :: Element
1904	CHARACTER() :: VarName
1905	real8 , INTENT(IN) :: Data()
1906	INTEGER , INTENT(IN) :: Count
1907	INTEGER , INTENT(OUT) :: Status
1908	CHARACTER(len=1000) :: tmpstr(1000)
1909	INTEGER :: idx
1910
1911	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_real8')
1912
1913	if (fileinfo(DataHandle)%committed) then
1914
1915	do idx = 1,Count
1916	write(tmpstr(idx),'(G17.10)')Data(idx)
1917	enddo
1918
1919	CALL gr2_build_string (ti_output(DataHandle), &
1920	trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1921	endif
1922
1923	RETURN
1924	END SUBROUTINE ext_gr2_put_var_ti_real8
1925
1926	!*****************************************************************************
1927
1928	SUBROUTINE ext_gr2_put_var_ti_integer ( DataHandle,Element, Varname, Data, &
1929	Count, Status )
1930
1931	USE gr2_data_info
1932	IMPLICIT NONE
1933	#include "wrf_status_codes.h"
1934	INTEGER , INTENT(IN) :: DataHandle
1935	CHARACTER() :: Element
1936	CHARACTER() :: VarName
1937	integer , INTENT(IN) :: Data(*)
1938	INTEGER , INTENT(IN) :: Count
1939	INTEGER , INTENT(OUT) :: Status
1940	CHARACTER(len=1000) :: tmpstr(1000)
1941	INTEGER :: idx
1942
1943	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_integer')
1944
1945	if (fileinfo(DataHandle)%committed) then
1946
1947	do idx = 1,Count
1948	write(tmpstr(idx),'(G17.10)')Data(idx)
1949	enddo
1950
1951	CALL gr2_build_string (ti_output(DataHandle), &
1952	trim(VarName)//';'//trim(Element), tmpstr, Count, Status)
1953	endif
1954
1955	RETURN
1956	END SUBROUTINE ext_gr2_put_var_ti_integer
1957
1958	!*****************************************************************************
1959
1960	SUBROUTINE ext_gr2_put_var_ti_logical ( DataHandle,Element, Varname, Data, &
1961	Count, Status )
1962
1963	USE gr2_data_info
1964	IMPLICIT NONE
1965	#include "wrf_status_codes.h"
1966	INTEGER , INTENT(IN) :: DataHandle
1967	CHARACTER() :: Element
1968	CHARACTER() :: VarName
1969	logical , INTENT(IN) :: Data(*)
1970	INTEGER , INTENT(IN) :: Count
1971	INTEGER , INTENT(OUT) :: Status
1972	CHARACTER(len=1000) :: tmpstr(1000)
1973	INTEGER :: idx
1974
1975	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_logical')
1976
1977	if (fileinfo(DataHandle)%committed) then
1978
1979	do idx = 1,Count
1980	write(tmpstr(idx),'(G17.10)')Data(idx)
1981	enddo
1982
1983	CALL gr2_build_string (ti_output(DataHandle), &
1984	trim(Varname)//';'//trim(Element), tmpstr, Count, Status)
1985
1986	endif
1987
1988	RETURN
1989	END SUBROUTINE ext_gr2_put_var_ti_logical
1990
1991	!*****************************************************************************
1992
1993	SUBROUTINE ext_gr2_put_var_ti_char ( DataHandle,Element, Varname, Data, &
1994	Status )
1995
1996	USE gr2_data_info
1997	IMPLICIT NONE
1998	#include "wrf_status_codes.h"
1999	INTEGER , INTENT(IN) :: DataHandle
2000	CHARACTER(len=*) :: Element
2001	CHARACTER(len=*) :: VarName
2002	CHARACTER(len=*) :: Data
2003	INTEGER , INTENT(OUT) :: Status
2004	REAL dummy
2005	INTEGER :: Count
2006	CHARACTER(len=1000) :: tmpstr(1)
2007	INTEGER :: idx
2008
2009	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_ti_char')
2010
2011	if (fileinfo(DataHandle)%committed) then
2012
2013	write(tmpstr(1),*)trim(Data)
2014
2015	CALL gr2_build_string (ti_output(DataHandle), &
2016	trim(VarName)//';'//trim(Element), tmpstr, 1, Status)
2017
2018	endif
2019
2020	RETURN
2021	END SUBROUTINE ext_gr2_put_var_ti_char
2022
2023	!******************************************************************************
2024	!* End of put_var_ti_* routines
2025	!******************************************************************************
2026
2027	!******************************************************************************
2028	!* Start of get_var_td_* routines
2029	!******************************************************************************
2030
2031	SUBROUTINE ext_gr2_get_var_td_double ( DataHandle,Element, DateStr, &
2032	Varname, Data, Count, Outcount, Status )
2033	USE gr2_data_info
2034	IMPLICIT NONE
2035	#include "wrf_status_codes.h"
2036	INTEGER , INTENT(IN) :: DataHandle
2037	CHARACTER() , INTENT(IN) :: Element
2038	CHARACTER() , INTENT(IN) :: DateStr
2039	CHARACTER() , INTENT(IN) :: VarName
2040	real8 , INTENT(OUT) :: Data()
2041	INTEGER , INTENT(IN) :: Count
2042	INTEGER , INTENT(OUT) :: OutCount
2043	INTEGER , INTENT(OUT) :: Status
2044	INTEGER :: idx
2045	INTEGER :: stat
2046	CHARACTER*(1000) :: VALUE
2047
2048	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_double')
2049
2050	Status = WRF_NO_ERR
2051
2052	CALL gr2_get_metadata_value(global_input(DataHandle), &
2053	trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2054	if (stat /= 0) then
2055	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2056	Status = WRF_WARN_VAR_NF
2057	RETURN
2058	endif
2059
2060	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2061	if (stat .ne. 0) then
2062	CALL wrf_message("Reading data from"//Value//"failed")
2063	Status = WRF_WARN_COUNT_TOO_LONG
2064	RETURN
2065	endif
2066	Outcount = idx
2067
2068	RETURN
2069	END SUBROUTINE ext_gr2_get_var_td_double
2070
2071	!*****************************************************************************
2072
2073	SUBROUTINE ext_gr2_get_var_td_real ( DataHandle,Element, DateStr,Varname, &
2074	Data, Count, Outcount, Status )
2075
2076	USE gr2_data_info
2077	IMPLICIT NONE
2078	#include "wrf_status_codes.h"
2079	INTEGER , INTENT(IN) :: DataHandle
2080	CHARACTER() :: Element
2081	CHARACTER() :: DateStr
2082	CHARACTER() :: VarName
2083	real , INTENT(OUT) :: Data(*)
2084	INTEGER , INTENT(IN) :: Count
2085	INTEGER , INTENT(OUT) :: OutCount
2086	INTEGER , INTENT(OUT) :: Status
2087	INTEGER :: idx
2088	INTEGER :: stat
2089	CHARACTER*(1000) :: VALUE
2090
2091	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_real')
2092
2093	Status = WRF_NO_ERR
2094
2095	CALL gr2_get_metadata_value(global_input(DataHandle), &
2096	trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2097	if (stat /= 0) then
2098	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2099	Status = WRF_WARN_VAR_NF
2100	RETURN
2101	endif
2102
2103	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2104	if (stat .ne. 0) then
2105	CALL wrf_message("Reading data from"//Value//"failed")
2106	Status = WRF_WARN_COUNT_TOO_LONG
2107	RETURN
2108	endif
2109	Outcount = idx
2110
2111	RETURN
2112	END SUBROUTINE ext_gr2_get_var_td_real
2113
2114	!*****************************************************************************
2115
2116	SUBROUTINE ext_gr2_get_var_td_real8 ( DataHandle,Element, DateStr,Varname, &
2117	Data, Count, Outcount, Status )
2118
2119	USE gr2_data_info
2120	IMPLICIT NONE
2121	#include "wrf_status_codes.h"
2122	INTEGER , INTENT(IN) :: DataHandle
2123	CHARACTER() :: Element
2124	CHARACTER() :: DateStr
2125	CHARACTER() :: VarName
2126	real8 , INTENT(OUT) :: Data()
2127	INTEGER , INTENT(IN) :: Count
2128	INTEGER , INTENT(OUT) :: OutCount
2129	INTEGER , INTENT(OUT) :: Status
2130	INTEGER :: idx
2131	INTEGER :: stat
2132	CHARACTER*(1000) :: VALUE
2133
2134	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_real8')
2135
2136	Status = WRF_NO_ERR
2137
2138	CALL gr2_get_metadata_value(global_input(DataHandle), &
2139	trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2140	if (stat /= 0) then
2141	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2142	Status = WRF_WARN_VAR_NF
2143	RETURN
2144	endif
2145
2146	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2147	if (stat .ne. 0) then
2148	CALL wrf_message("Reading data from"//Value//"failed")
2149	Status = WRF_WARN_COUNT_TOO_LONG
2150	RETURN
2151	endif
2152	Outcount = idx
2153
2154	RETURN
2155	END SUBROUTINE ext_gr2_get_var_td_real8
2156
2157	!*****************************************************************************
2158
2159	SUBROUTINE ext_gr2_get_var_td_integer ( DataHandle,Element, DateStr,Varname, &
2160	Data, Count, Outcount, Status )
2161
2162	USE gr2_data_info
2163	IMPLICIT NONE
2164	#include "wrf_status_codes.h"
2165	INTEGER , INTENT(IN) :: DataHandle
2166	CHARACTER() :: Element
2167	CHARACTER() :: DateStr
2168	CHARACTER() :: VarName
2169	integer , INTENT(OUT) :: Data(*)
2170	INTEGER , INTENT(IN) :: Count
2171	INTEGER , INTENT(OUT) :: OutCount
2172	INTEGER , INTENT(OUT) :: Status
2173	INTEGER :: idx
2174	INTEGER :: stat
2175	CHARACTER*(1000) :: VALUE
2176
2177	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_integer')
2178
2179	Status = WRF_NO_ERR
2180
2181	CALL gr2_get_metadata_value(global_input(DataHandle), &
2182	trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2183	if (stat /= 0) then
2184	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2185	Status = WRF_WARN_VAR_NF
2186	RETURN
2187	endif
2188
2189	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2190	if (stat .ne. 0) then
2191	CALL wrf_message("Reading data from"//Value//"failed")
2192	Status = WRF_WARN_COUNT_TOO_LONG
2193	RETURN
2194	endif
2195	Outcount = idx
2196
2197	RETURN
2198	END SUBROUTINE ext_gr2_get_var_td_integer
2199
2200	!*****************************************************************************
2201
2202	SUBROUTINE ext_gr2_get_var_td_logical ( DataHandle,Element, DateStr,Varname, &
2203	Data, Count, Outcount, Status )
2204
2205	USE gr2_data_info
2206	IMPLICIT NONE
2207	#include "wrf_status_codes.h"
2208	INTEGER , INTENT(IN) :: DataHandle
2209	CHARACTER() :: Element
2210	CHARACTER() :: DateStr
2211	CHARACTER() :: VarName
2212	logical , INTENT(OUT) :: Data(*)
2213	INTEGER , INTENT(IN) :: Count
2214	INTEGER , INTENT(OUT) :: OutCount
2215	INTEGER , INTENT(OUT) :: Status
2216	INTEGER :: idx
2217	INTEGER :: stat
2218	CHARACTER*(1000) :: VALUE
2219
2220	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_logical')
2221
2222	Status = WRF_NO_ERR
2223
2224	CALL gr2_get_metadata_value(global_input(DataHandle), &
2225	trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Value, stat)
2226	if (stat /= 0) then
2227	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2228	Status = WRF_WARN_VAR_NF
2229	RETURN
2230	endif
2231
2232	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2233	if (stat .ne. 0) then
2234	CALL wrf_message("Reading data from"//Value//"failed")
2235	Status = WRF_WARN_COUNT_TOO_LONG
2236	RETURN
2237	endif
2238	Outcount = idx
2239
2240	RETURN
2241	END SUBROUTINE ext_gr2_get_var_td_logical
2242
2243	!*****************************************************************************
2244
2245	SUBROUTINE ext_gr2_get_var_td_char ( DataHandle,Element, DateStr,Varname, &
2246	Data, Status )
2247
2248	USE gr2_data_info
2249	IMPLICIT NONE
2250	#include "wrf_status_codes.h"
2251	INTEGER , INTENT(IN) :: DataHandle
2252	CHARACTER() :: Element
2253	CHARACTER() :: DateStr
2254	CHARACTER() :: VarName
2255	CHARACTER() :: Data
2256	INTEGER , INTENT(OUT) :: Status
2257	INTEGER :: stat
2258
2259	Status = WRF_NO_ERR
2260
2261	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_var_td_char')
2262
2263	CALL gr2_get_metadata_value(global_input(DataHandle), &
2264	trim(VarName)//';'//trim(DateStr)//';'//trim(Element), Data, stat)
2265	if (stat /= 0) then
2266	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(VarName)//';'//trim(DateStr)//';'//trim(Element))
2267	Status = WRF_WARN_VAR_NF
2268	RETURN
2269	endif
2270
2271	RETURN
2272	END SUBROUTINE ext_gr2_get_var_td_char
2273
2274	!******************************************************************************
2275	!* End of get_var_td_* routines
2276	!******************************************************************************
2277
2278	!******************************************************************************
2279	!* Start of put_var_td_* routines
2280	!******************************************************************************
2281
2282	SUBROUTINE ext_gr2_put_var_td_double ( DataHandle, Element, DateStr, Varname, &
2283	Data, Count, Status )
2284	USE gr2_data_info
2285	IMPLICIT NONE
2286	#include "wrf_status_codes.h"
2287	INTEGER , INTENT(IN) :: DataHandle
2288	CHARACTER() , INTENT(IN) :: Element
2289	CHARACTER() , INTENT(IN) :: DateStr
2290	CHARACTER() , INTENT(IN) :: VarName
2291	real8 , INTENT(IN) :: Data()
2292	INTEGER , INTENT(IN) :: Count
2293	INTEGER , INTENT(OUT) :: Status
2294	CHARACTER(len=1000) :: tmpstr(1000)
2295	INTEGER :: idx
2296
2297	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_double')
2298
2299
2300	if (fileinfo(DataHandle)%committed) then
2301
2302	do idx = 1,Count
2303	write(tmpstr(idx),'(G17.10)')Data(idx)
2304	enddo
2305
2306	CALL gr2_build_string (td_output(DataHandle), &
2307	trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2308	tmpstr, Count, Status)
2309
2310	endif
2311
2312	RETURN
2313	END SUBROUTINE ext_gr2_put_var_td_double
2314
2315	!*****************************************************************************
2316
2317	SUBROUTINE ext_gr2_put_var_td_integer ( DataHandle,Element, DateStr, &
2318	Varname, Data, Count, Status )
2319
2320	USE gr2_data_info
2321	IMPLICIT NONE
2322	#include "wrf_status_codes.h"
2323	INTEGER , INTENT(IN) :: DataHandle
2324	CHARACTER() :: Element
2325	CHARACTER() :: DateStr
2326	CHARACTER() :: VarName
2327	integer , INTENT(IN) :: Data(*)
2328	INTEGER , INTENT(IN) :: Count
2329	INTEGER , INTENT(OUT) :: Status
2330	CHARACTER(len=1000) :: tmpstr(1000)
2331	INTEGER :: idx
2332
2333	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_integer')
2334
2335	if (fileinfo(DataHandle)%committed) then
2336
2337	do idx = 1,Count
2338	write(tmpstr(idx),'(G17.10)')Data(idx)
2339	enddo
2340
2341	CALL gr2_build_string (td_output(DataHandle), &
2342	trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2343	tmpstr, Count, Status)
2344
2345	endif
2346
2347	RETURN
2348	END SUBROUTINE ext_gr2_put_var_td_integer
2349
2350	!*****************************************************************************
2351
2352	SUBROUTINE ext_gr2_put_var_td_real ( DataHandle,Element, DateStr,Varname, &
2353	Data, Count, Status )
2354
2355	USE gr2_data_info
2356	IMPLICIT NONE
2357	#include "wrf_status_codes.h"
2358	INTEGER , INTENT(IN) :: DataHandle
2359	CHARACTER() :: Element
2360	CHARACTER() :: DateStr
2361	CHARACTER() :: VarName
2362	real , INTENT(IN) :: Data(*)
2363	INTEGER , INTENT(IN) :: Count
2364	INTEGER , INTENT(OUT) :: Status
2365	CHARACTER(len=1000) :: tmpstr(1000)
2366	INTEGER :: idx
2367
2368	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_real')
2369
2370	if (fileinfo(DataHandle)%committed) then
2371
2372	do idx = 1,Count
2373	write(tmpstr(idx),'(G17.10)')Data(idx)
2374	enddo
2375
2376	CALL gr2_build_string (td_output(DataHandle), &
2377	trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2378	tmpstr, Count, Status)
2379
2380	endif
2381
2382	RETURN
2383	END SUBROUTINE ext_gr2_put_var_td_real
2384
2385	!*****************************************************************************
2386
2387	SUBROUTINE ext_gr2_put_var_td_real8 ( DataHandle,Element, DateStr,Varname, &
2388	Data, Count, Status )
2389
2390	USE gr2_data_info
2391	IMPLICIT NONE
2392	#include "wrf_status_codes.h"
2393	INTEGER , INTENT(IN) :: DataHandle
2394	CHARACTER() :: Element
2395	CHARACTER() :: DateStr
2396	CHARACTER() :: VarName
2397	real8 , INTENT(IN) :: Data()
2398	INTEGER , INTENT(IN) :: Count
2399	INTEGER , INTENT(OUT) :: Status
2400	CHARACTER(len=1000) :: tmpstr(1000)
2401	INTEGER :: idx
2402
2403	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_real8')
2404
2405	if (fileinfo(DataHandle)%committed) then
2406	do idx = 1,Count
2407	write(tmpstr(idx),'(G17.10)')Data(idx)
2408	enddo
2409
2410	CALL gr2_build_string (td_output(DataHandle), &
2411	trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2412	tmpstr, Count, Status)
2413	endif
2414
2415	RETURN
2416	END SUBROUTINE ext_gr2_put_var_td_real8
2417
2418	!*****************************************************************************
2419
2420	SUBROUTINE ext_gr2_put_var_td_logical ( DataHandle,Element, DateStr, &
2421	Varname, Data, Count, Status )
2422
2423	USE gr2_data_info
2424	IMPLICIT NONE
2425	#include "wrf_status_codes.h"
2426	INTEGER , INTENT(IN) :: DataHandle
2427	CHARACTER() :: Element
2428	CHARACTER() :: DateStr
2429	CHARACTER() :: VarName
2430	logical , INTENT(IN) :: Data(*)
2431	INTEGER , INTENT(IN) :: Count
2432	INTEGER , INTENT(OUT) :: Status
2433	CHARACTER(len=1000) :: tmpstr(1000)
2434	INTEGER :: idx
2435
2436	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_logical')
2437
2438	if (fileinfo(DataHandle)%committed) then
2439
2440	do idx = 1,Count
2441	write(tmpstr(idx),'(G17.10)')Data(idx)
2442	enddo
2443
2444	CALL gr2_build_string (td_output(DataHandle), &
2445	trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2446	tmpstr, Count, Status)
2447
2448	endif
2449
2450	RETURN
2451	END SUBROUTINE ext_gr2_put_var_td_logical
2452
2453	!*****************************************************************************
2454
2455	SUBROUTINE ext_gr2_put_var_td_char ( DataHandle,Element, DateStr,Varname, &
2456	Data, Status )
2457
2458	USE gr2_data_info
2459	IMPLICIT NONE
2460	#include "wrf_status_codes.h"
2461	INTEGER , INTENT(IN) :: DataHandle
2462	CHARACTER() :: Element
2463	CHARACTER() :: DateStr
2464	CHARACTER() :: VarName
2465	CHARACTER() :: Data
2466	INTEGER , INTENT(OUT) :: Status
2467	CHARACTER(len=1000) :: tmpstr(1)
2468	INTEGER :: idx
2469
2470	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_var_td_char')
2471
2472	if (fileinfo(DataHandle)%committed) then
2473
2474	write(tmpstr(idx),*)Data
2475
2476	CALL gr2_build_string (td_output(DataHandle), &
2477	trim(Varname)//';'//trim(DateStr)//';'//trim(Element), &
2478	tmpstr, 1, Status)
2479
2480	endif
2481
2482	RETURN
2483	END SUBROUTINE ext_gr2_put_var_td_char
2484
2485	!******************************************************************************
2486	!* End of put_var_td_* routines
2487	!******************************************************************************
2488
2489
2490	!******************************************************************************
2491	!* Start of get_dom_ti_* routines
2492	!******************************************************************************
2493
2494	SUBROUTINE ext_gr2_get_dom_ti_real ( DataHandle,Element, Data, Count, &
2495	Outcount, Status )
2496
2497	USE gr2_data_info
2498	IMPLICIT NONE
2499	#include "wrf_status_codes.h"
2500	INTEGER , INTENT(IN) :: DataHandle
2501	CHARACTER() :: Element
2502	real , INTENT(OUT) :: Data(*)
2503	INTEGER , INTENT(IN) :: Count
2504	INTEGER , INTENT(OUT) :: Outcount
2505	INTEGER , INTENT(OUT) :: Status
2506	INTEGER :: idx
2507	INTEGER :: stat
2508	CHARACTER*(1000) :: VALUE
2509
2510	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_real')
2511
2512	Status = WRF_NO_ERR
2513
2514	CALL gr2_get_metadata_value(global_input(DataHandle), &
2515	trim(Element), Value, stat)
2516	if (stat /= 0) then
2517	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2518	Status = WRF_WARN_VAR_NF
2519	RETURN
2520	endif
2521
2522	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2523	if (stat .ne. 0) then
2524	CALL wrf_message("Reading data from"//Value//"failed")
2525	Status = WRF_WARN_COUNT_TOO_LONG
2526	RETURN
2527	endif
2528	Outcount = idx
2529
2530	RETURN
2531	END SUBROUTINE ext_gr2_get_dom_ti_real
2532
2533	!*****************************************************************************
2534
2535	SUBROUTINE ext_gr2_get_dom_ti_real8 ( DataHandle,Element, Data, Count, &
2536	Outcount, Status )
2537
2538	USE gr2_data_info
2539	IMPLICIT NONE
2540	#include "wrf_status_codes.h"
2541	INTEGER , INTENT(IN) :: DataHandle
2542	CHARACTER() :: Element
2543	real8 , INTENT(OUT) :: Data()
2544	INTEGER , INTENT(IN) :: Count
2545	INTEGER , INTENT(OUT) :: OutCount
2546	INTEGER , INTENT(OUT) :: Status
2547	INTEGER :: idx
2548	INTEGER :: stat
2549	CHARACTER*(1000) :: VALUE
2550
2551	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_real8')
2552
2553	Status = WRF_NO_ERR
2554
2555	CALL gr2_get_metadata_value(global_input(DataHandle), &
2556	trim(Element), Value, stat)
2557	if (stat /= 0) then
2558	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2559	Status = WRF_WARN_VAR_NF
2560	RETURN
2561	endif
2562
2563	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2564	if (stat .ne. 0) then
2565	CALL wrf_message("Reading data from"//Value//"failed")
2566	Status = WRF_WARN_COUNT_TOO_LONG
2567	RETURN
2568	endif
2569	Outcount = idx
2570
2571	RETURN
2572	END SUBROUTINE ext_gr2_get_dom_ti_real8
2573
2574	!*****************************************************************************
2575
2576	SUBROUTINE ext_gr2_get_dom_ti_integer ( DataHandle,Element, Data, Count, &
2577	Outcount, Status )
2578
2579	USE gr2_data_info
2580	IMPLICIT NONE
2581	#include "wrf_status_codes.h"
2582	INTEGER , INTENT(IN) :: DataHandle
2583	CHARACTER() :: Element
2584	integer , INTENT(OUT) :: Data(*)
2585	INTEGER , INTENT(IN) :: Count
2586	INTEGER , INTENT(OUT) :: OutCount
2587	INTEGER , INTENT(OUT) :: Status
2588	INTEGER :: idx
2589	INTEGER :: stat
2590	CHARACTER*(1000) :: VALUE
2591
2592	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_integer Element: '//Element)
2593
2594	CALL gr2_get_metadata_value(global_input(DataHandle), &
2595	trim(Element), Value, stat)
2596	if (stat /= 0) then
2597	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2598	Status = WRF_WARN_VAR_NF
2599	RETURN
2600	endif
2601
2602	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2603	if (stat .ne. 0) then
2604	CALL wrf_message("Reading data from"//Value//"failed")
2605	Status = WRF_WARN_COUNT_TOO_LONG
2606	RETURN
2607	endif
2608	Outcount = Count
2609
2610	RETURN
2611	END SUBROUTINE ext_gr2_get_dom_ti_integer
2612
2613	!*****************************************************************************
2614
2615	SUBROUTINE ext_gr2_get_dom_ti_logical ( DataHandle,Element, Data, Count, &
2616	Outcount, Status )
2617
2618	USE gr2_data_info
2619	IMPLICIT NONE
2620	#include "wrf_status_codes.h"
2621	INTEGER , INTENT(IN) :: DataHandle
2622	CHARACTER() :: Element
2623	logical , INTENT(OUT) :: Data(*)
2624	INTEGER , INTENT(IN) :: Count
2625	INTEGER , INTENT(OUT) :: OutCount
2626	INTEGER , INTENT(OUT) :: Status
2627	INTEGER :: idx
2628	INTEGER :: stat
2629	CHARACTER*(1000) :: VALUE
2630
2631	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_logical')
2632
2633	Status = WRF_NO_ERR
2634
2635	CALL gr2_get_metadata_value(global_input(DataHandle), &
2636	trim(Element), Value, stat)
2637	if (stat /= 0) then
2638	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2639	Status = WRF_WARN_VAR_NF
2640	RETURN
2641	endif
2642
2643	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2644	if (stat .ne. 0) then
2645	CALL wrf_message("Reading data from"//Value//"failed")
2646	Status = WRF_WARN_COUNT_TOO_LONG
2647	RETURN
2648	endif
2649	Outcount = idx
2650
2651	RETURN
2652	END SUBROUTINE ext_gr2_get_dom_ti_logical
2653
2654	!*****************************************************************************
2655
2656	SUBROUTINE ext_gr2_get_dom_ti_char ( DataHandle,Element, Data, Status )
2657
2658	USE gr2_data_info
2659	IMPLICIT NONE
2660	#include "wrf_status_codes.h"
2661	INTEGER , INTENT(IN) :: DataHandle
2662	CHARACTER() :: Element
2663	CHARACTER() :: Data
2664	INTEGER , INTENT(OUT) :: Status
2665	INTEGER :: stat
2666	INTEGER :: endchar
2667
2668	Status = WRF_NO_ERR
2669
2670	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_char')
2671
2672	CALL gr2_get_metadata_value(global_input(DataHandle), &
2673	trim(Element), Data, stat)
2674	if (stat /= 0) then
2675	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2676	Status = WRF_WARN_VAR_NF
2677	RETURN
2678	endif
2679
2680	RETURN
2681	END SUBROUTINE ext_gr2_get_dom_ti_char
2682
2683	!*****************************************************************************
2684
2685	SUBROUTINE ext_gr2_get_dom_ti_double ( DataHandle,Element, Data, Count, &
2686	Outcount, Status )
2687	USE gr2_data_info
2688	IMPLICIT NONE
2689	#include "wrf_status_codes.h"
2690	INTEGER , INTENT(IN) :: DataHandle
2691	CHARACTER() , INTENT(IN) :: Element
2692	real8 , INTENT(OUT) :: Data()
2693	INTEGER , INTENT(IN) :: Count
2694	INTEGER , INTENT(OUT) :: OutCount
2695	INTEGER , INTENT(OUT) :: Status
2696	INTEGER :: idx
2697	INTEGER :: stat
2698	CHARACTER*(1000) :: VALUE
2699
2700	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_ti_double')
2701
2702	Status = WRF_NO_ERR
2703
2704	CALL gr2_get_metadata_value(global_input(DataHandle), &
2705	trim(Element), Value, stat)
2706	if (stat /= 0) then
2707	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(Element))
2708	Status = WRF_WARN_VAR_NF
2709	RETURN
2710	endif
2711
2712	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
2713	if (stat .ne. 0) then
2714	CALL wrf_message("Reading data from"//Value//"failed")
2715	Status = WRF_WARN_COUNT_TOO_LONG
2716	RETURN
2717	endif
2718	Outcount = idx
2719
2720	RETURN
2721	END SUBROUTINE ext_gr2_get_dom_ti_double
2722
2723	!******************************************************************************
2724	!* End of get_dom_ti_* routines
2725	!******************************************************************************
2726
2727
2728	!******************************************************************************
2729	!* Start of put_dom_ti_* routines
2730	!******************************************************************************
2731
2732	SUBROUTINE ext_gr2_put_dom_ti_real ( DataHandle,Element, Data, Count, &
2733	Status )
2734
2735	USE gr2_data_info
2736	IMPLICIT NONE
2737	#include "wrf_status_codes.h"
2738	INTEGER , INTENT(IN) :: DataHandle
2739	CHARACTER() :: Element
2740	real , INTENT(IN) :: Data(*)
2741	INTEGER , INTENT(IN) :: Count
2742	INTEGER , INTENT(OUT) :: Status
2743	REAL dummy
2744	CHARACTER(len=1000) :: tmpstr(1000)
2745	character(len=2) :: lf
2746	integer :: idx
2747
2748	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_real')
2749
2750	if (Element .eq. 'DX') then
2751	dx = Data(1)/1000.
2752	endif
2753	if (Element .eq. 'DY') then
2754	dy = Data(1)/1000.
2755	endif
2756	if (Element .eq. 'CEN_LAT') then
2757	center_lat = Data(1)
2758	endif
2759	if (Element .eq. 'CEN_LON') then
2760	center_lon = Data(1)
2761	endif
2762	if (Element .eq. 'TRUELAT1') then
2763	truelat1 = Data(1)
2764	endif
2765	if (Element .eq. 'TRUELAT2') then
2766	truelat2 = Data(1)
2767	endif
2768	if (Element == 'STAND_LON') then
2769	proj_central_lon = Data(1)
2770	endif
2771	if (Element == 'DT') then
2772	timestep = Data(1)
2773	endif
2774
2775	if (fileinfo(DataHandle)%committed) then
2776
2777	do idx = 1,Count
2778	write(tmpstr(idx),'(G17.10)')Data(idx)
2779	enddo
2780
2781	CALL gr2_build_string (ti_output(DataHandle), Element, &
2782	tmpstr, Count, Status)
2783
2784	endif
2785
2786	RETURN
2787	END SUBROUTINE ext_gr2_put_dom_ti_real
2788
2789	!*****************************************************************************
2790
2791	SUBROUTINE ext_gr2_put_dom_ti_real8 ( DataHandle,Element, Data, Count, &
2792	Status )
2793
2794	USE gr2_data_info
2795	IMPLICIT NONE
2796	#include "wrf_status_codes.h"
2797	INTEGER , INTENT(IN) :: DataHandle
2798	CHARACTER() :: Element
2799	real8 , INTENT(IN) :: Data()
2800	INTEGER , INTENT(IN) :: Count
2801	INTEGER , INTENT(OUT) :: Status
2802	CHARACTER(len=1000) :: tmpstr(1000)
2803	INTEGER :: idx
2804
2805	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_real8')
2806
2807	if (fileinfo(DataHandle)%committed) then
2808
2809	do idx = 1,Count
2810	write(tmpstr(idx),'(G17.10)')Data(idx)
2811	enddo
2812
2813	CALL gr2_build_string (ti_output(DataHandle), Element, &
2814	tmpstr, Count, Status)
2815
2816	endif
2817
2818	RETURN
2819	END SUBROUTINE ext_gr2_put_dom_ti_real8
2820
2821	!*****************************************************************************
2822
2823	SUBROUTINE ext_gr2_put_dom_ti_integer ( DataHandle,Element, Data, Count, &
2824	Status )
2825
2826	USE gr2_data_info
2827	IMPLICIT NONE
2828	#include "wrf_status_codes.h"
2829	INTEGER , INTENT(IN) :: DataHandle
2830	CHARACTER() :: Element
2831	INTEGER , INTENT(IN) :: Data(*)
2832	INTEGER , INTENT(IN) :: Count
2833	INTEGER , INTENT(OUT) :: Status
2834	REAL dummy
2835	CHARACTER(len=1000) :: tmpstr(1000)
2836	INTEGER :: idx
2837
2838
2839	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_integer')
2840
2841	if (Element == 'WEST-EAST_GRID_DIMENSION') then
2842	full_xsize = Data(1)
2843	else if (Element == 'SOUTH-NORTH_GRID_DIMENSION') then
2844	full_ysize = Data(1)
2845	else if (Element == 'MAP_PROJ') then
2846	wrf_projection = Data(1)
2847	else if (Element == 'BACKGROUND_PROC_ID') then
2848	background_proc_id = Data(1)
2849	else if (Element == 'FORECAST_PROC_ID') then
2850	forecast_proc_id = Data(1)
2851	else if (Element == 'PRODUCTION_STATUS') then
2852	production_status = Data(1)
2853	else if (Element == 'COMPRESSION') then
2854	compression = Data(1)
2855	endif
2856
2857	if (fileinfo(DataHandle)%committed) then
2858
2859	do idx = 1,Count
2860	write(tmpstr(idx),'(G17.10)')Data(idx)
2861	enddo
2862
2863	CALL gr2_build_string (ti_output(DataHandle), Element, &
2864	tmpstr, Count, Status)
2865
2866	endif
2867
2868	call wrf_debug ( DEBUG , 'Leaving ext_gr2_put_dom_ti_integer')
2869
2870	RETURN
2871	END SUBROUTINE ext_gr2_put_dom_ti_integer
2872
2873	!*****************************************************************************
2874
2875	SUBROUTINE ext_gr2_put_dom_ti_logical ( DataHandle,Element, Data, Count, &
2876	Status )
2877
2878	USE gr2_data_info
2879	IMPLICIT NONE
2880	#include "wrf_status_codes.h"
2881	INTEGER , INTENT(IN) :: DataHandle
2882	CHARACTER() :: Element
2883	logical , INTENT(IN) :: Data(*)
2884	INTEGER , INTENT(IN) :: Count
2885	INTEGER , INTENT(OUT) :: Status
2886	CHARACTER(len=1000) :: tmpstr(1000)
2887	INTEGER :: idx
2888
2889	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_logical')
2890
2891	if (fileinfo(DataHandle)%committed) then
2892
2893	do idx = 1,Count
2894	write(tmpstr(idx),'(G17.10)')Data(idx)
2895	enddo
2896
2897	CALL gr2_build_string (ti_output(DataHandle), Element, &
2898	tmpstr, Count, Status)
2899
2900	endif
2901
2902	RETURN
2903	END SUBROUTINE ext_gr2_put_dom_ti_logical
2904
2905	!*****************************************************************************
2906
2907	SUBROUTINE ext_gr2_put_dom_ti_char ( DataHandle,Element, Data, &
2908	Status )
2909
2910	USE gr2_data_info
2911	IMPLICIT NONE
2912	#include "wrf_status_codes.h"
2913	INTEGER , INTENT(IN) :: DataHandle
2914	CHARACTER() :: Element
2915	CHARACTER(), INTENT(IN) :: Data
2916	INTEGER , INTENT(OUT) :: Status
2917	REAL dummy
2918	CHARACTER(len=1000) :: tmpstr
2919
2920	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_char')
2921
2922	if (Element .eq. 'START_DATE') then
2923
2924	!
2925	! This is just a hack to fix a problem when outputting restart. WRF
2926	! outputs both the initialization time and the time of the restart
2927	! as the StartDate. So, we ll just take the earliest.
2928	!
2929	if ((StartDate .eq. '') .or. (Data .le. StartDate)) then
2930	StartDate = Data
2931	endif
2932
2933	endif
2934
2935	if (fileinfo(DataHandle)%committed) then
2936
2937	write(tmpstr,*)trim(Data)
2938
2939	CALL gr2_build_string (ti_output(DataHandle), Element, &
2940	tmpstr, 1, Status)
2941
2942	endif
2943
2944	RETURN
2945	END SUBROUTINE ext_gr2_put_dom_ti_char
2946
2947	!*****************************************************************************
2948
2949	SUBROUTINE ext_gr2_put_dom_ti_double ( DataHandle,Element, Data, Count, &
2950	Status )
2951	USE gr2_data_info
2952	IMPLICIT NONE
2953	#include "wrf_status_codes.h"
2954	INTEGER , INTENT(IN) :: DataHandle
2955	CHARACTER() , INTENT(IN) :: Element
2956	real8 , INTENT(IN) :: Data()
2957	INTEGER , INTENT(IN) :: Count
2958	INTEGER , INTENT(OUT) :: Status
2959	CHARACTER(len=1000) :: tmpstr(1000)
2960	INTEGER :: idx
2961
2962	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_ti_double')
2963
2964	if (fileinfo(DataHandle)%committed) then
2965
2966	do idx = 1,Count
2967	write(tmpstr(idx),'(G17.10)')Data(idx)
2968	enddo
2969
2970	CALL gr2_build_string (ti_output(DataHandle), Element, &
2971	tmpstr, Count, Status)
2972
2973	endif
2974
2975	RETURN
2976	END SUBROUTINE ext_gr2_put_dom_ti_double
2977
2978	!******************************************************************************
2979	!* End of put_dom_ti_* routines
2980	!******************************************************************************
2981
2982
2983	!******************************************************************************
2984	!* Start of get_dom_td_* routines
2985	!******************************************************************************
2986
2987	SUBROUTINE ext_gr2_get_dom_td_real ( DataHandle,Element, DateStr, Data, &
2988	Count, Outcount, Status )
2989
2990	USE gr2_data_info
2991	IMPLICIT NONE
2992	#include "wrf_status_codes.h"
2993	INTEGER , INTENT(IN) :: DataHandle
2994	CHARACTER() :: Element
2995	CHARACTER() :: DateStr
2996	real , INTENT(OUT) :: Data(*)
2997	INTEGER , INTENT(IN) :: Count
2998	INTEGER , INTENT(OUT) :: OutCount
2999	INTEGER , INTENT(OUT) :: Status
3000	INTEGER :: idx
3001	INTEGER :: stat
3002	CHARACTER*(1000) :: VALUE
3003
3004	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_real')
3005
3006	Status = WRF_NO_ERR
3007
3008	CALL gr2_get_metadata_value(global_input(DataHandle), &
3009	trim(DateStr)//';'//trim(Element), Value, stat)
3010	if (stat /= 0) then
3011	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3012	Status = WRF_WARN_VAR_NF
3013	RETURN
3014	endif
3015
3016	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3017	if (stat .ne. 0) then
3018	CALL wrf_message("Reading data from"//Value//"failed")
3019	Status = WRF_WARN_COUNT_TOO_LONG
3020	RETURN
3021	endif
3022	Outcount = idx
3023
3024	RETURN
3025	END SUBROUTINE ext_gr2_get_dom_td_real
3026
3027	!*****************************************************************************
3028
3029	SUBROUTINE ext_gr2_get_dom_td_real8 ( DataHandle,Element, DateStr, Data, &
3030	Count, Outcount, Status )
3031
3032	USE gr2_data_info
3033	IMPLICIT NONE
3034	#include "wrf_status_codes.h"
3035	INTEGER , INTENT(IN) :: DataHandle
3036	CHARACTER() :: Element
3037	CHARACTER() :: DateStr
3038	real8 , INTENT(OUT) :: Data()
3039	INTEGER , INTENT(IN) :: Count
3040	INTEGER , INTENT(OUT) :: OutCount
3041	INTEGER , INTENT(OUT) :: Status
3042	INTEGER :: idx
3043	INTEGER :: stat
3044	CHARACTER*(1000) :: VALUE
3045
3046	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_real8')
3047
3048	Status = WRF_NO_ERR
3049
3050	CALL gr2_get_metadata_value(global_input(DataHandle), &
3051	trim(DateStr)//';'//trim(Element), Value, stat)
3052	if (stat /= 0) then
3053	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3054	Status = WRF_WARN_VAR_NF
3055	RETURN
3056	endif
3057
3058	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3059	if (stat .ne. 0) then
3060	CALL wrf_message("Reading data from"//Value//"failed")
3061	Status = WRF_WARN_COUNT_TOO_LONG
3062	RETURN
3063	endif
3064	Outcount = idx
3065
3066	RETURN
3067	END SUBROUTINE ext_gr2_get_dom_td_real8
3068
3069	!*****************************************************************************
3070
3071	SUBROUTINE ext_gr2_get_dom_td_integer ( DataHandle,Element, DateStr, Data, &
3072	Count, Outcount, Status )
3073
3074	USE gr2_data_info
3075	IMPLICIT NONE
3076	#include "wrf_status_codes.h"
3077	INTEGER , INTENT(IN) :: DataHandle
3078	CHARACTER() :: Element
3079	CHARACTER() :: DateStr
3080	integer , INTENT(OUT) :: Data(*)
3081	INTEGER , INTENT(IN) :: Count
3082	INTEGER , INTENT(OUT) :: OutCount
3083	INTEGER , INTENT(OUT) :: Status
3084	INTEGER :: idx
3085	INTEGER :: stat
3086	CHARACTER*(1000) :: VALUE
3087
3088	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_integer')
3089
3090	Status = WRF_NO_ERR
3091
3092	CALL gr2_get_metadata_value(global_input(DataHandle), &
3093	trim(DateStr)//';'//trim(Element), Value, stat)
3094	if (stat /= 0) then
3095	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3096	Status = WRF_WARN_VAR_NF
3097	RETURN
3098	endif
3099
3100	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3101	if (stat .ne. 0) then
3102	CALL wrf_message("Reading data from"//Value//"failed")
3103	Status = WRF_WARN_COUNT_TOO_LONG
3104	RETURN
3105	endif
3106	Outcount = idx
3107
3108	RETURN
3109	END SUBROUTINE ext_gr2_get_dom_td_integer
3110
3111	!*****************************************************************************
3112
3113	SUBROUTINE ext_gr2_get_dom_td_logical ( DataHandle,Element, DateStr, Data, &
3114	Count, Outcount, Status )
3115
3116	USE gr2_data_info
3117	IMPLICIT NONE
3118	#include "wrf_status_codes.h"
3119	INTEGER , INTENT(IN) :: DataHandle
3120	CHARACTER() :: Element
3121	CHARACTER() :: DateStr
3122	logical , INTENT(OUT) :: Data(*)
3123	INTEGER , INTENT(IN) :: Count
3124	INTEGER , INTENT(OUT) :: OutCount
3125	INTEGER , INTENT(OUT) :: Status
3126	INTEGER :: idx
3127	INTEGER :: stat
3128	CHARACTER*(1000) :: VALUE
3129
3130	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_logical')
3131
3132	Status = WRF_NO_ERR
3133
3134	CALL gr2_get_metadata_value(global_input(DataHandle), &
3135	trim(DateStr)//';'//trim(Element), Value, stat)
3136	if (stat /= 0) then
3137	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3138	Status = WRF_WARN_VAR_NF
3139	RETURN
3140	endif
3141
3142	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3143	if (stat .ne. 0) then
3144	CALL wrf_message("Reading data from"//Value//"failed")
3145	Status = WRF_WARN_COUNT_TOO_LONG
3146	RETURN
3147	endif
3148	Outcount = idx
3149
3150	RETURN
3151	END SUBROUTINE ext_gr2_get_dom_td_logical
3152
3153	!*****************************************************************************
3154
3155	SUBROUTINE ext_gr2_get_dom_td_char ( DataHandle,Element, DateStr, Data, &
3156	Status )
3157
3158	USE gr2_data_info
3159	IMPLICIT NONE
3160	#include "wrf_status_codes.h"
3161	INTEGER , INTENT(IN) :: DataHandle
3162	CHARACTER() :: Element
3163	CHARACTER() :: DateStr
3164	CHARACTER() :: Data
3165	INTEGER , INTENT(OUT) :: Status
3166	INTEGER :: stat
3167
3168	Status = WRF_NO_ERR
3169
3170	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_char')
3171
3172	CALL gr2_get_metadata_value(global_input(DataHandle), &
3173	trim(DateStr)//';'//trim(Element), Data, stat)
3174	if (stat /= 0) then
3175	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3176	Status = WRF_WARN_VAR_NF
3177	RETURN
3178	endif
3179
3180	RETURN
3181	END SUBROUTINE ext_gr2_get_dom_td_char
3182
3183	!*****************************************************************************
3184
3185	SUBROUTINE ext_gr2_get_dom_td_double ( DataHandle,Element, DateStr, Data, &
3186	Count, Outcount, Status )
3187	USE gr2_data_info
3188	IMPLICIT NONE
3189	#include "wrf_status_codes.h"
3190	INTEGER , INTENT(IN) :: DataHandle
3191	CHARACTER() , INTENT(IN) :: Element
3192	CHARACTER() , INTENT(IN) :: DateStr
3193	real8 , INTENT(OUT) :: Data()
3194	INTEGER , INTENT(IN) :: Count
3195	INTEGER , INTENT(OUT) :: OutCount
3196	INTEGER , INTENT(OUT) :: Status
3197	INTEGER :: idx
3198	INTEGER :: stat
3199	CHARACTER*(1000) :: VALUE
3200
3201	call wrf_debug ( DEBUG , 'Entering ext_gr2_get_dom_td_double')
3202
3203	Status = WRF_NO_ERR
3204
3205	CALL gr2_get_metadata_value(global_input(DataHandle), &
3206	trim(DateStr)//';'//trim(Element), Value, stat)
3207	if (stat /= 0) then
3208	CALL wrf_debug ( DEBUG , "gr2_get_metadata_value failed for "//trim(DateStr)//';'//trim(Element))
3209	Status = WRF_WARN_VAR_NF
3210	RETURN
3211	endif
3212
3213	READ(Value,*,IOSTAT=stat)(Data(idx),idx=1,Count)
3214	if (stat .ne. 0) then
3215	CALL wrf_message("Reading data from"//Value//"failed")
3216	Status = WRF_WARN_COUNT_TOO_LONG
3217	RETURN
3218	endif
3219	Outcount = idx
3220
3221	RETURN
3222	END SUBROUTINE ext_gr2_get_dom_td_double
3223
3224	!******************************************************************************
3225	!* End of get_dom_td_* routines
3226	!******************************************************************************
3227
3228
3229	!******************************************************************************
3230	!* Start of put_dom_td_* routines
3231	!******************************************************************************
3232
3233
3234	SUBROUTINE ext_gr2_put_dom_td_real8 ( DataHandle,Element, DateStr, Data, &
3235	Count, Status )
3236
3237	USE gr2_data_info
3238	IMPLICIT NONE
3239	#include "wrf_status_codes.h"
3240	INTEGER , INTENT(IN) :: DataHandle
3241	CHARACTER() :: Element
3242	CHARACTER() :: DateStr
3243	real8 , INTENT(IN) :: Data()
3244	INTEGER , INTENT(IN) :: Count
3245	INTEGER , INTENT(OUT) :: Status
3246	CHARACTER(len=1000) :: tmpstr(1000)
3247	INTEGER :: idx
3248
3249	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_real8')
3250
3251	if (fileinfo(DataHandle)%committed) then
3252
3253	do idx = 1,Count
3254	write(tmpstr(idx),'(G17.10)')Data(idx)
3255	enddo
3256
3257	CALL gr2_build_string (td_output(DataHandle), &
3258	trim(DateStr)//';'//trim(Element), tmpstr, &
3259	Count, Status)
3260
3261	endif
3262
3263	RETURN
3264	END SUBROUTINE ext_gr2_put_dom_td_real8
3265
3266	!*****************************************************************************
3267
3268	SUBROUTINE ext_gr2_put_dom_td_integer ( DataHandle,Element, DateStr, Data, &
3269	Count, Status )
3270
3271	USE gr2_data_info
3272	IMPLICIT NONE
3273	#include "wrf_status_codes.h"
3274	INTEGER , INTENT(IN) :: DataHandle
3275	CHARACTER() :: Element
3276	CHARACTER() :: DateStr
3277	integer , INTENT(IN) :: Data(*)
3278	INTEGER , INTENT(IN) :: Count
3279	INTEGER , INTENT(OUT) :: Status
3280	CHARACTER(len=1000) :: tmpstr(1000)
3281	INTEGER :: idx
3282
3283	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_integer')
3284
3285	if (fileinfo(DataHandle)%committed) then
3286
3287	do idx = 1,Count
3288	write(tmpstr(idx),'(G17.10)')Data(idx)
3289	enddo
3290
3291	CALL gr2_build_string (td_output(DataHandle), &
3292	trim(DateStr)//';'//trim(Element), tmpstr, &
3293	Count, Status)
3294
3295	endif
3296
3297	RETURN
3298	END SUBROUTINE ext_gr2_put_dom_td_integer
3299
3300	!*****************************************************************************
3301
3302	SUBROUTINE ext_gr2_put_dom_td_logical ( DataHandle,Element, DateStr, Data, &
3303	Count, Status )
3304
3305	USE gr2_data_info
3306	IMPLICIT NONE
3307	#include "wrf_status_codes.h"
3308	INTEGER , INTENT(IN) :: DataHandle
3309	CHARACTER() :: Element
3310	CHARACTER() :: DateStr
3311	logical , INTENT(IN) :: Data(*)
3312	INTEGER , INTENT(IN) :: Count
3313	INTEGER , INTENT(OUT) :: Status
3314	CHARACTER(len=1000) :: tmpstr(1000)
3315	INTEGER :: idx
3316
3317	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_logical')
3318
3319	if (fileinfo(DataHandle)%committed) then
3320
3321	do idx = 1,Count
3322	write(tmpstr(idx),'(G17.10)')Data(idx)
3323	enddo
3324
3325	CALL gr2_build_string (td_output(DataHandle), &
3326	trim(DateStr)//';'//trim(Element), tmpstr, &
3327	Count, Status)
3328
3329	endif
3330
3331	RETURN
3332	END SUBROUTINE ext_gr2_put_dom_td_logical
3333
3334	!*****************************************************************************
3335
3336	SUBROUTINE ext_gr2_put_dom_td_char ( DataHandle,Element, DateStr, Data, &
3337	Status )
3338
3339	USE gr2_data_info
3340	IMPLICIT NONE
3341	#include "wrf_status_codes.h"
3342	INTEGER , INTENT(IN) :: DataHandle
3343	CHARACTER() :: Element
3344	CHARACTER() :: DateStr
3345	CHARACTER(len=*), INTENT(IN) :: Data
3346	INTEGER , INTENT(OUT) :: Status
3347	CHARACTER(len=1000) :: tmpstr(1)
3348
3349	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_char')
3350
3351	if (fileinfo(DataHandle)%committed) then
3352
3353	write(tmpstr(1),*)Data
3354
3355	CALL gr2_build_string (td_output(DataHandle), &
3356	trim(DateStr)//';'//trim(Element), tmpstr, &
3357	1, Status)
3358
3359	endif
3360
3361	RETURN
3362	END SUBROUTINE ext_gr2_put_dom_td_char
3363
3364	!*****************************************************************************
3365
3366	SUBROUTINE ext_gr2_put_dom_td_double ( DataHandle,Element, DateStr, Data, &
3367	Count, Status )
3368	USE gr2_data_info
3369	IMPLICIT NONE
3370	#include "wrf_status_codes.h"
3371	INTEGER , INTENT(IN) :: DataHandle
3372	CHARACTER() , INTENT(IN) :: Element
3373	CHARACTER() , INTENT(IN) :: DateStr
3374	real8 , INTENT(IN) :: Data()
3375	INTEGER , INTENT(IN) :: Count
3376	INTEGER , INTENT(OUT) :: Status
3377	CHARACTER(len=1000) :: tmpstr(1000)
3378	INTEGER :: idx
3379
3380	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_double')
3381
3382	if (fileinfo(DataHandle)%committed) then
3383
3384	do idx = 1,Count
3385	write(tmpstr(idx),'(G17.10)')Data(idx)
3386	enddo
3387
3388	CALL gr2_build_string (td_output(DataHandle), &
3389	trim(DateStr)//';'//trim(Element), tmpstr, &
3390	Count, Status)
3391
3392	endif
3393
3394	RETURN
3395	END SUBROUTINE ext_gr2_put_dom_td_double
3396
3397	!*****************************************************************************
3398
3399	SUBROUTINE ext_gr2_put_dom_td_real ( DataHandle,Element, DateStr, Data, &
3400	Count, Status )
3401
3402	USE gr2_data_info
3403	IMPLICIT NONE
3404	#include "wrf_status_codes.h"
3405	INTEGER , INTENT(IN) :: DataHandle
3406	CHARACTER() :: Element
3407	CHARACTER() :: DateStr
3408	real , INTENT(IN) :: Data(*)
3409	INTEGER , INTENT(IN) :: Count
3410	INTEGER , INTENT(OUT) :: Status
3411	CHARACTER(len=1000) :: tmpstr(1000)
3412	INTEGER :: idx
3413
3414	call wrf_debug ( DEBUG , 'Entering ext_gr2_put_dom_td_real')
3415
3416	if (fileinfo(DataHandle)%committed) then
3417
3418	do idx = 1,Count
3419	write(tmpstr(idx),'(G17.10)')Data(idx)
3420	enddo
3421
3422	CALL gr2_build_string (td_output(DataHandle), &
3423	trim(DateStr)//';'//trim(Element), tmpstr, &
3424	Count, Status)
3425
3426	endif
3427
3428	RETURN
3429	END SUBROUTINE ext_gr2_put_dom_td_real
3430
3431
3432	!******************************************************************************
3433	!* End of put_dom_td_* routines
3434	!******************************************************************************
3435
3436
3437	SUBROUTINE gr2_get_new_handle(DataHandle)
3438	USE gr2_data_info
3439	IMPLICIT NONE
3440
3441	INTEGER , INTENT(OUT) :: DataHandle
3442	INTEGER :: i
3443
3444	DataHandle = -1
3445	do i=firstFileHandle, maxFileHandles
3446	if (.NOT. fileinfo(i)%used) then
3447	DataHandle = i
3448	fileinfo(i)%used = .true.
3449	exit
3450	endif
3451	enddo
3452
3453	RETURN
3454	END SUBROUTINE gr2_get_new_handle
3455
3456	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3457
3458
3459	!*****************************************************************************
3460
3461	SUBROUTINE gr2_retrieve_data (MemoryOrder, MemoryStart, MemoryEnd, xsize, ysize, &
3462	zsize, z, FieldType, Field, data)
3463
3464	IMPLICIT NONE
3465
3466	#include "wrf_io_flags.h"
3467
3468	character() ,intent(in) :: MemoryOrder
3469	integer ,intent(in) :: xsize, ysize, zsize
3470	integer ,intent(in) :: z
3471	integer,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
3472	integer ,intent(in) :: FieldType
3473	real ,intent(in), &
3474	dimension( 1:1,MemoryStart(1):MemoryEnd(1), &
3475	MemoryStart(2):MemoryEnd(2), &
3476	MemoryStart(3):MemoryEnd(3) ) :: Field
3477	real ,dimension(1:xsize,1:ysize),intent(inout) :: data
3478
3479	integer :: x, y, idx
3480	integer, dimension(:,:), pointer :: mold
3481	integer :: istat
3482	integer :: dim1
3483
3484	ALLOCATE(mold(1:xsize,1:ysize), STAT=istat)
3485	if (istat .ne. 0) then
3486	print *,'Could not allocate space for mold, returning'
3487	return
3488	endif
3489
3490	!
3491	! Set the size of the first dimension of the data array (dim1) to xsize.
3492	! If the MemoryOrder is Z or z, dim1 is overridden below.
3493	!
3494	dim1 = xsize
3495
3496	SELECT CASE (MemoryOrder)
3497	CASE ('XYZ')
3498	data = Field(1,1:xsize,1:ysize,z)
3499	CASE ('C')
3500	data = Field(1,1:xsize,1:ysize,z)
3501	CASE ('XZY')
3502	data = Field(1,1:xsize,z,1:ysize)
3503	CASE ('YXZ')
3504	do x = 1,xsize
3505	do y = 1,ysize
3506	data(x,y) = Field(1,y,x,z)
3507	enddo
3508	enddo
3509	CASE ('YZX')
3510	do x = 1,xsize
3511	do y = 1,ysize
3512	data(x,y) = Field(1,y,z,x)
3513	enddo
3514	enddo
3515	CASE ('ZXY')
3516	data = Field(1,z,1:xsize,1:ysize)
3517	CASE ('ZYX')
3518	do x = 1,xsize
3519	do y = 1,ysize
3520	data(x,y) = Field(1,z,y,x)
3521	enddo
3522	enddo
3523	CASE ('XY')
3524	data = Field(1,1:xsize,1:ysize,1)
3525	CASE ('YX')
3526	do x = 1,xsize
3527	do y = 1,ysize
3528	data(x,y) = Field(1,y,x,1)
3529	enddo
3530	enddo
3531
3532	CASE ('XSZ')
3533	do x = 1,xsize
3534	do y = 1,ysize
3535	data(x,y) = Field(1,y,z,x)
3536	enddo
3537	enddo
3538	CASE ('XEZ')
3539	do x = 1,xsize
3540	do y = 1,ysize
3541	data(x,y) = Field(1,y,z,x)
3542	enddo
3543	enddo
3544	CASE ('YSZ')
3545	do x = 1,xsize
3546	do y = 1,ysize
3547	data(x,y) = Field(1,x,z,y)
3548	enddo
3549	enddo
3550	CASE ('YEZ')
3551	do x = 1,xsize
3552	do y = 1,ysize
3553	data(x,y) = Field(1,x,z,y)
3554	enddo
3555	enddo
3556
3557	CASE ('XS')
3558	do x = 1,xsize
3559	do y = 1,ysize
3560	data(x,y) = Field(1,y,x,1)
3561	enddo
3562	enddo
3563	CASE ('XE')
3564	do x = 1,xsize
3565	do y = 1,ysize
3566	data(x,y) = Field(1,y,x,1)
3567	enddo
3568	enddo
3569	CASE ('YS')
3570	do x = 1,xsize
3571	do y = 1,ysize
3572	data(x,y) = Field(1,x,y,1)
3573	enddo
3574	enddo
3575	CASE ('YE')
3576	do x = 1,xsize
3577	do y = 1,ysize
3578	data(x,y) = Field(1,x,y,1)
3579	enddo
3580	enddo
3581	CASE ('Z')
3582	data(1:zsize,1) = Field(1,1:zsize,1,1)
3583	dim1 = zsize
3584	CASE ('z')
3585	data(1:zsize,1) = Field(1,zsize:1,1,1)
3586	dim1 = zsize
3587	CASE ('0')
3588	data(1,1) = Field(1,1,1,1)
3589	END SELECT
3590
3591	!
3592	! Here, we convert any integer fields to real
3593	!
3594	if (FieldType == WRF_INTEGER) then
3595	mold = 0
3596	do idx=1,dim1
3597	!
3598	! The parentheses around data(idx,:) are needed in order
3599	! to fix a bug with transfer with the xlf compiler on NCARs
3600	! IBM (bluesky).
3601	!
3602	data(idx,:)=transfer((data(idx,:)),mold)
3603	enddo
3604	endif
3605
3606	deallocate(mold)
3607
3608	return
3609
3610	end subroutine gr2_retrieve_data
3611
3612	!*****************************************************************************
3613
3614	SUBROUTINE gr2_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, &
3615	fraction, vert_unit1, vert_unit2, vert_sclFctr1, vert_sclFctr2, &
3616	level1, level2)
3617
3618	use gr2_data_info
3619	IMPLICIT NONE
3620
3621	integer :: zidx
3622	integer :: zsize
3623	logical :: soil_layers
3624	logical :: vert_stag
3625	logical :: fraction
3626	integer :: vert_unit1, vert_unit2
3627	integer :: vert_sclFctr1, vert_sclFctr2
3628	integer :: level1
3629	integer :: level2
3630	character (LEN=*) :: VarName
3631
3632	! Setup vert_unit, and vertical levels in grib units
3633
3634	if ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCTOP') &
3635	.or. (VarName .eq. 'SOILCBOT')) then
3636	vert_unit1 = 105;
3637	vert_unit2 = 255;
3638	vert_sclFctr1 = 0
3639	vert_sclFctr2 = 0
3640	level1 = zidx
3641	level2 = 0
3642	else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction)) &
3643	then
3644	vert_unit1 = 111;
3645	vert_unit2 = 255;
3646	vert_sclFctr1 = 4
3647	vert_sclFctr2 = 4
3648	if (vert_stag) then
3649	level1 = (10000*full_eta(zidx)+0.5)
3650	else
3651	level1 = (10000*half_eta(zidx)+0.5)
3652	endif
3653	level2 = 0
3654	else
3655	! Set the vertical coordinate and level for soil and 2D fields
3656	if (fraction) then
3657	vert_unit1 = 105
3658	vert_unit2 = 255
3659	level1 = zidx
3660	level2 = 0
3661	vert_sclFctr1 = 0
3662	vert_sclFctr2 = 0
3663	else if (soil_layers) then
3664	vert_unit1 = 106
3665	vert_unit2 = 106
3666	level1 = 100(soil_depth(zidx) - 0.5soil_thickness(zidx))+0.5
3667	level2 = 100(soil_depth(zidx) + 0.5soil_thickness(zidx))+0.5
3668	vert_sclFctr1 = 2
3669	vert_sclFctr2 = 2
3670	else if (VarName .eq. 'mu') then
3671	vert_unit1 = 105
3672	vert_unit2 = 255
3673	level1 = 0
3674	level2 = 0
3675	vert_sclFctr1 = 0
3676	vert_sclFctr2 = 0
3677	else if ((VarName .eq. 'Q2') .or. (VarName .eq. 'TH2') .or. &
3678	(VarName .eq. 'T2')) then
3679	vert_unit1 = 103
3680	vert_unit2 = 255
3681	level1 = 2
3682	level2 = 0
3683	vert_sclFctr1 = 0
3684	vert_sclFctr2 = 0
3685	else if ((VarName .eq. 'Q10') .or. (VarName .eq. 'TH10') .or. &
3686	(VarName .eq. 'U10') .or. (VarName .eq. 'V10')) then
3687	vert_unit1 = 103
3688	vert_unit2 = 255
3689	level1 = 10
3690	level2 = 0
3691	vert_sclFctr1 = 0
3692	vert_sclFctr2 = 0
3693	else
3694	vert_unit1 = 1
3695	vert_unit2 = 255
3696	level1 = 0
3697	level2 = 0
3698	vert_sclFctr1 = 0
3699	vert_sclFctr2 = 0
3700	endif
3701	endif
3702
3703	end SUBROUTINE gr2_get_levels
3704
3705	!*****************************************************************************
3706
3707	subroutine gr2_create_w(StartDate, cgrib, lcgrib, production_status, Disc, &
3708	center, subcenter, MasterTblV, LocalTblV, ierr, msg)
3709
3710	implicit none
3711
3712	character*24 ,intent(in) :: StartDate
3713	character(),intent(inout) :: cgrib
3714	integer ,intent(in) :: lcgrib
3715	integer ,intent(in) :: production_status
3716	integer ,intent(out) :: ierr
3717	character(),intent(out) :: msg
3718	integer , dimension(13) :: listsec1
3719	integer , dimension(2) :: listsec0
3720	integer :: slen
3721	integer , intent(in) :: Disc, center, subcenter, MasterTblV, LocalTblV
3722
3723	!
3724	! Create the grib message
3725	!
3726	listsec0(1) = Disc ! Discipline (Table 0.0)
3727	listsec0(2) = 2 ! Grib edition number
3728
3729	listsec1(1) = center ! Id of Originating Center (255 for missing)
3730	listsec1(2) = subcenter ! Id of originating sub-center (255 for missing)
3731	listsec1(3) = MasterTblV ! Master Table Version #
3732	listsec1(4) = LocalTblV ! Local table version #
3733	listsec1(5) = 1 ! Significance of reference time, 1 indicates start of forecast
3734
3735	READ(StartDate(1:4), '(I4)') listsec1(6) ! Year of reference
3736
3737	READ(StartDate(6:7), '(I2)') listsec1(7) ! Month of reference
3738
3739	READ(StartDate(9:10), '(I2)') listsec1(8) ! Day of reference
3740
3741	slen = LEN(StartDate)
3742
3743	if (slen.GE.13) then
3744	read(StartDate(12:13),'(I2)') listsec1(9)
3745	else
3746	listsec1(9) = 0
3747	endif
3748
3749	if (slen.GE.16) then
3750	read(StartDate(15:16),'(I2)') listsec1(10)
3751	else
3752	listsec1(10) = 0
3753	endif
3754
3755	if (slen.GE.19) then
3756	read(StartDate(18:19),'(I2)') listsec1(11)
3757	else
3758	listsec1(11) = 0
3759	end if
3760
3761	listsec1(12) = production_status ! Production status of data
3762	listsec1(13) = 1 ! Type of data (1 indicates forecast products)
3763
3764	call gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr)
3765
3766	if (ierr .ne. 0) then
3767	write(msg,*) 'gribcreate failed with ierr: ',ierr
3768	else
3769	msg = ''
3770	endif
3771
3772	end SUBROUTINE gr2_create_w
3773
3774
3775	!*****************************************************************************
3776	subroutine gr2_addgrid_w(cgrib, lcgrib, central_lat, central_lon, wrf_projection, &
3777	latin1, latin2, nx, ny, dx, dy, center_lat, center_lon, ierr,msg)
3778
3779	implicit none
3780
3781	character() ,intent(inout) :: cgrib
3782	integer ,intent(in) :: lcgrib
3783	real ,intent(in) :: central_lat
3784	real ,intent(in) :: central_lon
3785	integer ,intent(in) :: wrf_projection
3786	real ,intent(in) :: latin1
3787	real ,intent(in) :: latin2
3788	integer ,intent(in) :: nx
3789	integer ,intent(in) :: ny
3790	real ,intent(in) :: dx
3791	real ,intent(in) :: dy
3792	real ,intent(in) :: center_lat
3793	real ,intent(in) :: center_lon
3794	integer ,intent(out) :: ierr
3795	character() ,intent(out) :: msg
3796	integer, dimension(5) :: igds
3797	integer, parameter :: igdstmplen = 25
3798	integer, dimension(igdstmplen) :: igdstmpl
3799	integer, parameter :: idefnum = 0
3800	integer, dimension(idefnum) :: ideflist
3801	real :: LLLa, LLLo, URLa, URLo
3802	real :: incrx, incry
3803	real, parameter :: deg_to_microdeg = 1e6
3804	real, parameter :: km_to_mm = 1e6
3805	real, parameter :: km_to_m = 1e3
3806	real, parameter :: PI = 3.141593
3807	real, parameter :: DEG_TO_RAD = PI/180
3808	real, parameter :: RAD_TO_DEG = 180/PI
3809	real, parameter :: ERADIUS = 6370.0
3810
3811	igds(1) = 0 ! Source of grid definition
3812	igds(2) = nx*ny ! Number of points in grid
3813	igds(3) = 0 !
3814	igds(4) = 0
3815
3816	! Here, setup the parameters that are common to all WRF projections
3817
3818	igdstmpl(1) = 1 ! Shape of earth (1 for spherical with specified radius)
3819	igdstmpl(2) = 1 ! Scale factor for earth radius
3820	igdstmpl(3) = ERADIUS*km_to_m ! Radius of earth
3821	igdstmpl(4) = 0 ! Scale factor for major axis
3822	igdstmpl(5) = 0 ! Major axis
3823	igdstmpl(6) = 0 ! Scale factor for minor axis
3824	igdstmpl(7) = 0 ! Minor axis
3825	igdstmpl(8) = nx ! Number of points along x axis
3826	igdstmpl(9) = ny ! Number of points along y axis
3827
3828	!
3829	! Setup increments in "x" and "y" direction. For LATLON projection
3830	! increments need to be in degrees. For all other projections,
3831	! increments are in km.
3832	!
3833
3834	if (wrf_projection .eq. WRF_LATLON) then
3835	incrx = RAD_TO_DEG(dx/(ERADIUScos(latin1*DEG_TO_RAD)))
3836	incry = RAD_TO_DEG*(dy/ERADIUS)
3837	else
3838	incrx = dx
3839	incry = dy
3840	endif
3841
3842	! Latitude and longitude of first (i.e., lower left) grid point
3843	call get_ll_latlon(central_lat, central_lon, wrf_projection, &
3844	latin1, latin2, nx, ny, incrx, incry, center_lat, center_lon, &
3845	LLLa, LLLo, URLa, URLo, ierr);
3846
3847	select case (wrf_projection)
3848
3849	case(WRF_LATLON)
3850	igds(5) = 0
3851	igdstmpl(10) = 0 ! Basic Angle of init projection (not important to us)
3852	igdstmpl(11) = 0 ! Subdivision of basic angle
3853	igdstmpl(12) = LLLa*deg_to_microdeg
3854	igdstmpl(13) = LLLo*deg_to_microdeg
3855	call gr2_convert_lon(igdstmpl(13))
3856	igdstmpl(14) = 128 ! Resolution and component flags
3857	igdstmpl(15) = URLa*deg_to_microdeg
3858	igdstmpl(16) = URLo*deg_to_microdeg
3859	call gr2_convert_lon(igdstmpl(16))
3860
3861	! Warning, the following assumes that dx and dy are valid at the equator.
3862	! It is not clear in WRF where dx and dy are valid for latlon projections
3863	igdstmpl(17) = incrx*deg_to_microdeg ! i-direction increment in micro degs
3864	igdstmpl(18) = incry*deg_to_microdeg ! j-direction increment in micro degs
3865
3866	igdstmpl(19) = 64 ! Scanning mode
3867	case(WRF_MERCATOR)
3868	igds(5) = 10
3869	igdstmpl(10) = LLLa*deg_to_microdeg
3870	igdstmpl(11) = LLLo*deg_to_microdeg
3871	call gr2_convert_lon(igdstmpl(11))
3872	igdstmpl(12) = 128 ! Resolution and component flags
3873	igdstmpl(13) = latin1*deg_to_microdeg ! "True" latitude
3874	igdstmpl(14) = URLa*deg_to_microdeg
3875	igdstmpl(15) = URLo*deg_to_microdeg
3876	call gr2_convert_lon(igdstmpl(15))
3877	igdstmpl(16) = 64 ! Scanning mode
3878	igdstmpl(17) = 0 ! Orientation of grid between i-direction and equator
3879	igdstmpl(18) = dx*km_to_mm ! i-direction increment
3880	igdstmpl(19) = dy*km_to_mm ! j-direction increment
3881	case(WRF_LAMBERT)
3882	igds(5) = 30
3883
3884	igdstmpl(10) = LLLa*deg_to_microdeg
3885	igdstmpl(11) = LLLo*deg_to_microdeg
3886	call gr2_convert_lon(igdstmpl(11))
3887	igdstmpl(12) = 128 ! Resolution and component flag
3888	igdstmpl(13) = latin1*deg_to_microdeg ! Latitude where Dx and Dy are specified
3889	igdstmpl(14) = central_lon*deg_to_microdeg
3890	call gr2_convert_lon(igdstmpl(14))
3891	igdstmpl(15) = dx*km_to_mm ! x-dimension grid-spacing in units of m^-3
3892	igdstmpl(16) = dy*km_to_mm
3893	if (center_lat .lt. 0) then
3894	igdstmpl(17) = 1
3895	else
3896	igdstmpl(17) = 0
3897	endif
3898	igdstmpl(18) = 64 ! Scanning mode
3899	igdstmpl(19) = latin1*deg_to_microdeg
3900	igdstmpl(20) = latin2*deg_to_microdeg
3901	igdstmpl(21) = -90*deg_to_microdeg
3902	igdstmpl(22) = central_lon*deg_to_microdeg
3903	call gr2_convert_lon(igdstmpl(22))
3904
3905	case(WRF_POLAR_STEREO)
3906	igds(5) = 20
3907	igdstmpl(10) = LLLa*deg_to_microdeg
3908	igdstmpl(11) = LLLo*deg_to_microdeg
3909	call gr2_convert_lon(igdstmpl(11))
3910	igdstmpl(12) = 128 ! Resolution and component flag
3911	igdstmpl(13) = latin1*deg_to_microdeg ! Latitude where Dx and Dy are specified
3912	igdstmpl(14) = central_lon*deg_to_microdeg
3913	call gr2_convert_lon(igdstmpl(14))
3914	igdstmpl(15) = dx*km_to_mm ! x-dimension grid-spacing in units of m^-3
3915	igdstmpl(16) = dy*km_to_mm
3916	if (center_lat .lt. 0) then
3917	igdstmpl(17) = 1
3918	else
3919	igdstmpl(17) = 0
3920	endif
3921	igdstmpl(18) = 64 ! Scanning mode
3922
3923	case default
3924	write(msg,*) 'invalid WRF projection: ',wrf_projection
3925	ierr = -1
3926	return
3927	end select
3928
3929
3930	call addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen,ideflist,idefnum,ierr)
3931	if (ierr .ne. 0) then
3932	write(msg,*) 'addgrid failed with ierr: ',ierr
3933	else
3934	msg = ''
3935	endif
3936
3937	end subroutine gr2_addgrid_w
3938
3939	!*****************************************************************************
3940
3941	subroutine gr2_addfield_w(cgrib, lcgrib, VarName, parmcat, parmnum, DecScl, &
3942	BinScl, fcst_secs, vert_unit1, vert_unit2, vert_sclFctr1, vert_sclFctr2, &
3943	numlevels, levels, ngrdpts, background_proc_id, forecast_proc_id, &
3944	compression, fld, ierr, msg)
3945
3946	implicit none
3947
3948	character() ,intent(inout) :: cgrib
3949	integer ,intent(in) :: lcgrib
3950	character (LEN=*) ,intent(in) :: VarName
3951	integer ,intent(in) :: parmcat,parmnum,DecScl,BinScl
3952	real ,intent(in) :: fcst_secs
3953	integer ,intent(in) :: vert_unit1, vert_unit2
3954	integer ,intent(in) :: vert_sclFctr1, vert_sclFctr2
3955	integer ,intent(in) :: numlevels
3956	integer, dimension(*) ,intent(in) :: levels
3957	integer ,intent(in) :: ngrdpts
3958	real ,intent(in) :: fld(ngrdpts)
3959	integer ,intent(in) :: background_proc_id
3960	integer ,intent(in) :: forecast_proc_id
3961	integer ,intent(in) :: compression
3962	integer ,intent(out) :: ierr
3963	character() ,intent(out) :: msg
3964	integer :: ipdsnum
3965	integer, parameter :: ipdstmplen = 15
3966	integer, dimension(ipdstmplen) :: ipdstmpl
3967	integer :: numcoord
3968	integer, dimension(numlevels) :: coordlist
3969	integer :: idrsnum
3970	integer, parameter :: idrstmplen = 7
3971	integer, dimension(idrstmplen) :: idrstmpl
3972	integer :: ibmap
3973	integer, dimension(1) :: bmap
3974
3975	if (numlevels .gt. 2) then
3976	ipdsnum = 1000 ! Product definition tmplate (1000 for cross-sxn)
3977	else
3978	ipdsnum = 0 ! Product definition template (0 for horiz grid)
3979	endif
3980
3981	ipdstmpl(1) = parmcat ! Parameter category
3982	ipdstmpl(2) = parmnum ! Parameter number
3983	ipdstmpl(3) = 2 ! Type of generating process (2 for forecast)
3984	ipdstmpl(4) = background_proc_id ! Background generating process id
3985	ipdstmpl(5) = forecast_proc_id ! Analysis or forecast generating process id
3986	ipdstmpl(6) = 0 ! Data cutoff period (Hours)
3987	ipdstmpl(7) = 0 ! Data cutoff period (minutes)
3988	ipdstmpl(8) = 13 ! Time range indicator (13 for seconds)
3989	ipdstmpl(9) = NINT(fcst_secs) ! Forecast time
3990
3991	if (ipdsnum .eq. 1000) then
3992	numcoord = numlevels
3993	coordlist = levels(1:numlevels)
3994
3995	!
3996	! Set Data Representation templ (Use 0 for vertical cross sections,
3997	! since there seems to be a bug in g2lib for JPEG2000 and PNG)
3998	!
3999	idrsnum = 0
4000
4001	else if (ipdsnum .eq. 0) then
4002	ipdstmpl(10) = vert_unit1 ! Type of first surface (111 for Eta level)
4003	ipdstmpl(11) = vert_sclFctr1 ! Scale factor for 1st surface
4004	ipdstmpl(12) = levels(1) ! First fixed surface
4005	ipdstmpl(13) = vert_unit2 ! Type of second fixed surface
4006	ipdstmpl(14) = vert_sclFctr2 ! Scale factor for 2nd surface
4007	if (numlevels .eq. 2) then
4008	ipdstmpl(15) = levels(2)
4009	else
4010	ipdstmpl(15) = 0
4011	endif
4012	numcoord = 0
4013	coordlist(1) = 0
4014
4015	! Set Data Representation templ (40 for JPEG2000, 41 for PNG)
4016	idrsnum = compression
4017
4018	endif
4019
4020
4021	if (idrsnum == 40) then ! JPEG 2000
4022
4023	idrstmpl(1) = 255 ! Reference value - ignored on input
4024	idrstmpl(2) = BinScl ! Binary scale factor
4025	idrstmpl(3) = DecScl ! Decimal scale factor
4026	idrstmpl(4) = 0 ! number of bits for each data value - ignored on input
4027	idrstmpl(5) = 0 ! Original field type - ignored on input
4028	idrstmpl(6) = 0 ! 0 for lossless compression
4029	idrstmpl(7) = 255 ! Desired compression ratio if idrstmpl(6) != 0
4030
4031	else if (idrsnum == 41) then ! PNG
4032
4033	idrstmpl(1) = 255 ! Reference value - ignored on input
4034	idrstmpl(2) = BinScl ! Binary scale factor
4035	idrstmpl(3) = DecScl ! Decimal scale factor
4036	idrstmpl(4) = 0 ! number of bits for each data value - ignored on input
4037	idrstmpl(5) = 0 ! Original field type - ignored on input
4038
4039	else if (idrsnum == 0) then! Simple packing
4040
4041	idrstmpl(1) = 255 ! Reference value - ignored on input
4042	idrstmpl(2) = BinScl ! Binary scale factor
4043	idrstmpl(3) = DecScl ! Decimal scale factor
4044	idrstmpl(4) = 0 ! number of bits for each data value - ignored on input
4045	idrstmpl(5) = 0 ! Original field type - ignored on input
4046
4047	else
4048
4049	write (msg,*) 'addfield failed because Data Representation template',&
4050	idrsnum,' is invalid'
4051	ierr = 1
4052	return
4053
4054	endif
4055
4056	ibmap = 255 ! Flag for bitmap
4057
4058	call addfield(cgrib, lcgrib, ipdsnum, ipdstmpl, ipdstmplen, coordlist, &
4059	numcoord, idrsnum, idrstmpl, idrstmplen, fld, ngrdpts, ibmap, &
4060	bmap, ierr)
4061
4062	if (ierr .ne. 0) then
4063	write(msg,*) 'addfield failed with ierr: ',ierr
4064	else
4065	msg = ''
4066	endif
4067
4068	end subroutine gr2_addfield_w
4069
4070	!*****************************************************************************
4071
4072	subroutine gr2_fill_local_use(DataHandle,string,VarName,fcsts,msg,status)
4073
4074	use gr2_data_info
4075	IMPLICIT NONE
4076	#include "wrf_status_codes.h"
4077
4078	integer, intent(in) :: DataHandle
4079	character() ,intent(inout) :: string
4080	character() ,intent(in) :: VarName
4081	integer :: center, subcenter, MasterTblV, LocalTblV, &
4082	Disc, Category, ParmNum, DecScl, BinScl
4083	integer ,intent(out) :: status
4084	character() ,intent(out) :: msg
4085	integer , parameter :: lcgrib = 1000000
4086	character (lcgrib) :: cgrib
4087	real, dimension(1,1) :: data
4088	integer :: lengrib
4089	integer :: lcsec2
4090	integer :: fcsts
4091	integer :: bytes_written
4092
4093	!
4094	! Set data to a default dummy value.
4095	!
4096	data = 1.0
4097
4098	!
4099	! This statement prevents problems when calling addlocal in the grib2
4100	! library. Basically, if addlocal is called with an empty string, it
4101	! will be encoded correctly by the grib2 routine, but the grib2 routines
4102	! that read the data (i.e., getgb2) will segfault. This prevents that
4103	! segfault.
4104	!
4105
4106	if (string .eq. '') string = 'none'
4107
4108	CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
4109	LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
4110	if (status .ne. 0) then
4111	write(msg,*) 'Could not find parameter for '// &
4112	trim(VarName)//' Skipping output of '//trim(VarName)
4113	call wrf_message(trim(msg))
4114	Status = WRF_GRIB2_ERR_GRIB2MAP
4115	return
4116	endif
4117
4118	!
4119	! Create the indicator and identification sections (sections 0 and 1)
4120	!
4121	CALL gr2_create_w(StartDate, cgrib, lcgrib, production_status, Disc, &
4122	center, subcenter, MasterTblV, LocalTblV, status, msg)
4123	if (status .ne. 0) then
4124	call wrf_message(trim(msg))
4125	Status = WRF_GRIB2_ERR_GRIBCREATE
4126	return
4127	endif
4128
4129	!
4130	! Add the local use section
4131	!
4132	lcsec2 = len_trim(string)
4133	call addlocal(cgrib,lcgrib,string,lcsec2,status)
4134	if (status .ne. 0) then
4135	call wrf_message(trim(msg))
4136	Status = WRF_GRIB2_ERR_ADDLOCAL
4137	return
4138	endif
4139
4140	!
4141	! Add the grid definition section (section 3) using a 1x1 grid
4142	!
4143	call gr2_addgrid_w(cgrib, lcgrib, center_lat, proj_central_lon, &
4144	wrf_projection, truelat1, truelat2, 1, 1, dx, dy, &
4145	center_lat, center_lon, status, msg)
4146	if (status .ne. 0) then
4147	call wrf_message(trim(msg))
4148	Status = WRF_GRIB2_ERR_ADDGRIB
4149	return
4150	endif
4151
4152	!
4153	! Add the Product Definition, Data representation, bitmap
4154	! and data sections (sections 4-7)
4155	!
4156	call gr2_addfield_w(cgrib, lcgrib, VarName, Category, ParmNum, DecScl, &
4157	BinScl, fcsts, 1, 255, 0, 0, 1, 0, 1, &
4158	background_proc_id, forecast_proc_id, compression, data, status, msg)
4159	if (status .ne. 0) then
4160	call wrf_message(trim(msg))
4161	Status = WRF_GRIB2_ERR_ADDFIELD
4162	return
4163	endif
4164
4165	!
4166	! Close out the message
4167	!
4168
4169	call gribend(cgrib,lcgrib,lengrib,status)
4170	if (status .ne. 0) then
4171	write(msg,*) 'gribend failed with status: ',status
4172	call wrf_message(trim(msg))
4173	Status = WRF_GRIB2_ERR_GRIBEND
4174	return
4175	endif
4176
4177	!
4178	! Write the data to the file
4179	!
4180
4181	call bawrite(DataHandle, -1, lengrib, bytes_written, cgrib)
4182	!! call write_file_n(fileinfo(DataHandle)%FileFd, cgrib, lengrib, status)
4183	if (bytes_written .ne. lengrib) then
4184	write(msg,*) '2 Error writing cgrib to file, wrote: ', &
4185	bytes_written, ' bytes. Tried to write ', lengrib, ' bytes'
4186	call wrf_message(trim(msg))
4187	Status = WRF_GRIB2_ERR_WRITE
4188	return
4189	endif
4190
4191	! Set string back to the original blank value
4192	if (string .eq. '') string = ''
4193
4194	return
4195
4196	end subroutine gr2_fill_local_use
4197
4198	!*****************************************************************************
4199	!
4200	! Set longitude to be in the range of 0-360 degrees.
4201	!
4202	!*****************************************************************************
4203
4204	subroutine gr2_convert_lon(value)
4205
4206	IMPLICIT NONE
4207
4208	integer, intent(inout) :: value
4209	real, parameter :: deg_to_microdeg = 1e6
4210
4211	do while (value .lt. 0)
4212	value = value + 360*deg_to_microdeg
4213	enddo
4214
4215	do while (value .gt. 360*deg_to_microdeg)
4216	value = value - 360*deg_to_microdeg
4217	enddo
4218
4219	end subroutine gr2_convert_lon
4220
4221
4222	!*****************************************************************************
4223	!
4224	! Add a time to the list of times
4225	!
4226	!*****************************************************************************
4227
4228	subroutine gr2_add_time(DataHandle,addTime)
4229
4230	USE gr2_data_info
4231	IMPLICIT NONE
4232
4233	integer :: DataHandle
4234	character (len=*) :: addTime
4235	integer :: idx
4236	logical :: already_have = .false.
4237	logical :: swap
4238	character (len=len(addTime)) :: tmp
4239	character (DateStrLen), dimension(:),pointer :: tmpTimes(:)
4240	integer,parameter :: allsize = 50
4241	integer :: ierr
4242
4243	already_have = .false.
4244	do idx = 1,fileinfo(DataHandle)%NumberTimes
4245	if (addTime .eq. fileinfo(DataHandle)%Times(idx)) then
4246	already_have = .true.
4247	endif
4248	enddo
4249
4250	if (.not. already_have) then
4251	fileinfo(DataHandle)%NumberTimes = fileinfo(DataHandle)%NumberTimes + 1
4252
4253	if (fileinfo(DataHandle)%NumberTimes .gt. &
4254	fileinfo(DataHandle)%sizeAllocated) then
4255
4256	if (fileinfo(DataHandle)%NumberTimes .eq. 1) then
4257
4258	if (allocated(fileinfo(DataHandle)%Times)) &
4259	deallocate(fileinfo(DataHandle)%Times)
4260
4261	allocate(fileinfo(DataHandle)%Times(allsize), stat = ierr)
4262	if (ierr .ne. 0) then
4263	call wrf_message('Could not allocate space for Times 1, exiting')
4264	stop
4265	endif
4266
4267	fileinfo(DataHandle)%sizeAllocated = allsize
4268
4269	else
4270
4271	allocate(tmpTimes(fileinfo(DataHandle)%NumberTimes), stat=ierr)
4272
4273	tmpTimes = &
4274	fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes)
4275
4276	deallocate(fileinfo(DataHandle)%Times)
4277
4278	allocate(&
4279	fileinfo(DataHandle)%Times(fileinfo(DataHandle)%sizeAllocated+allsize), stat=ierr)
4280
4281	if (ierr .ne. 0) then
4282	call wrf_message('Could not allocate space for Times 2, exiting')
4283	stop
4284	endif
4285
4286	fileinfo(DataHandle)%Times(1:fileinfo(DataHandle)%NumberTimes) = &
4287	tmpTimes
4288
4289	deallocate(tmpTimes)
4290
4291	endif
4292
4293	endif
4294
4295	fileinfo(DataHandle)%Times(fileinfo(DataHandle)%NumberTimes) = addTime
4296
4297	! Sort the Times array
4298
4299	swap = .true.
4300	do while (swap)
4301	swap = .false.
4302	do idx = 1,fileinfo(DataHandle)%NumberTimes - 1
4303	if (fileinfo(DataHandle)%Times(idx) .gt. fileinfo(DataHandle)%Times(idx+1)) then
4304	tmp = fileinfo(DataHandle)%Times(idx)
4305	fileinfo(DataHandle)%Times(idx) = fileinfo(DataHandle)%Times(idx+1)
4306	fileinfo(DataHandle)%Times(idx+1) = tmp
4307	swap = .true.
4308	endif
4309	enddo
4310	enddo
4311
4312	endif
4313
4314	return
4315
4316	end subroutine gr2_add_time
4317
4318
4319	!*****************************************************************************
4320	!
4321	! Fill an array of levels
4322	!
4323	!*****************************************************************************
4324
4325	subroutine gr2_fill_levels(DataHandle,VarName,levels,ierr)
4326
4327	USE gr2_data_info
4328	USE grib_mod
4329	IMPLICIT NONE
4330
4331	#include "wrf_status_codes.h"
4332
4333
4334	integer :: DataHandle
4335	character (len=*) :: VarName
4336	REAL,DIMENSION(*) :: levels
4337	integer :: ierr
4338	integer :: JIDS(JIDSSIZE), JPDTN, JPDT(JPDTSIZE), JGDTN, &
4339	JGDT(JGDTSIZE)
4340	type(gribfield) :: gfld
4341	integer :: status, fields_to_skip
4342	logical :: unpack
4343	integer :: center, subcenter, MasterTblV, LocalTblV, &
4344	Disc, Category, ParmNum, DecScl, BinScl
4345	CHARACTER (LEN=maxMsgSize) :: msg
4346
4347
4348	CALL get_parminfo(VarName, center, subcenter, MasterTblV, &
4349	LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, status)
4350	if (status .ne. 0) then
4351	write(msg,*) 'Could not find parameter for '// &
4352	trim(VarName)//' Skipping output of '//trim(VarName)
4353	call wrf_message(trim(msg))
4354	ierr = -1
4355	return
4356	endif
4357
4358
4359	!
4360	! First, set all values to wild, then specify necessary values
4361	!
4362	call gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
4363
4364	JIDS(1) = center
4365	JIDS(2) = subcenter
4366	JIDS(3) = MasterTblV
4367	JIDS(4) = LocalTblV
4368	JIDS(5) = 1 ! Indicates that time is "Start of Forecast"
4369	JIDS(13) = 1 ! Type of processed data (1 for forecast products)
4370
4371	JPDTN = 1000 ! Product definition template number
4372	JPDT(1) = Category
4373	JPDT(2) = ParmNum
4374	JPDT(3) = 2 ! Generating process id
4375
4376	JGDTN = -1 ! Indicates that any Grid Display Template is a match
4377
4378	UNPACK = .TRUE. ! Unpack bitmap and data values
4379
4380
4381	fields_to_skip = 0
4382
4383	CALL GETGB2(DataHandle, 0, fields_to_skip, -1, Disc, JIDS, JPDTN, &
4384	JPDT, JGDTN, JGDT, UNPACK, fileinfo(DataHandle)%recnum, &
4385	gfld, status)
4386	if (status .eq. 99) then
4387	write(msg,*)'Could not find field '//trim(VarName)//&
4388	' continuing.'
4389	call wrf_message(trim(msg))
4390	ierr = -1
4391	return
4392	else if (status .ne. 0) then
4393	write(msg,*)'Retrieving scalar data field '//trim(VarName)//&
4394	' failed, continuing.'
4395	call wrf_message(trim(msg))
4396	ierr = -1
4397	return
4398	endif
4399
4400	levels(1:gfld%ndpts) = gfld%fld(1:gfld%ndpts)
4401	ierr = 0
4402
4403	end subroutine gr2_fill_levels
4404
4405
4406	!*****************************************************************************
4407	!
4408	! Set values for search array arguments for getgb2 to missing.
4409	!
4410	!*****************************************************************************
4411
4412	subroutine gr2_g2lib_wildcard(JIDS, JPDT, JGDT)
4413
4414	USE gr2_data_info
4415	integer :: JIDS(), JPDT(), JGDT(*)
4416
4417	do idx = 1,JIDSSIZE
4418	JIDS(idx) = -9999
4419	enddo
4420
4421	do idx=1,JPDTSIZE
4422	JPDT(idx) = -9999
4423	enddo
4424
4425	do idx = 1,JGDTSIZE
4426	JGDT(idx) = -9999
4427	enddo
4428
4429	return
4430
4431	end subroutine gr2_g2lib_wildcard
4432	!*****************************************************************************
4433	!
4434	! Retrieve a metadata value from the input string
4435	!
4436	!*****************************************************************************
4437
4438	subroutine gr2_get_metadata_value(instring, Key, Value, stat)
4439	character(len=*),intent(in) :: instring
4440	character(len=*),intent(in) :: Key
4441	character(len=*),intent(out) :: Value
4442	integer ,intent(out) :: stat
4443	integer :: Key_pos, equals_pos, line_end
4444	character :: lf
4445
4446	lf=char(10)
4447
4448	Value = 'abc'
4449
4450	!
4451	! Find Starting position of Key
4452	!
4453	Key_pos = index(instring, lf//' '//Key//' =')
4454	if (Key_pos .eq. 0) then
4455	stat = -1
4456	return
4457	endif
4458
4459	!
4460	! Find position of the "=" after the Key
4461	!
4462	equals_pos = index(instring(Key_pos:len(instring)), "=") + Key_pos
4463	if (equals_pos .eq. Key_pos) then
4464	stat = -1
4465	return
4466	endif
4467
4468	!
4469	! Find end of line
4470	!
4471	line_end = index(instring(equals_pos:len(instring)), lf) + equals_pos
4472
4473	!
4474	! Handle the case for the last line in the string
4475	!
4476	if (line_end .eq. equals_pos) then
4477	line_end = len(trim(instring))
4478	endif
4479
4480	!
4481	! Set value
4482	!
4483	if ( (equals_pos + 1) .le. (line_end - 2) ) then
4484	Value = trim(adjustl(instring(equals_pos+1:line_end-2)))
4485	else
4486	Value = ""
4487	endif
4488
4489	stat = 0
4490
4491
4492	end subroutine gr2_get_metadata_value
4493
4494	!*****************************************************************************
4495	!
4496	! Build onto a metadata string with the input value
4497	!
4498	!*****************************************************************************
4499
4500	SUBROUTINE gr2_build_string (string, Element, Value, Count, Status)
4501
4502	IMPLICIT NONE
4503	#include "wrf_status_codes.h"
4504
4505	CHARACTER (LEN=*) , INTENT(INOUT) :: string
4506	CHARACTER (LEN=*) , INTENT(IN) :: Element
4507	CHARACTER (LEN=) , INTENT(IN) :: Value()
4508	INTEGER , INTENT(IN) :: Count
4509	INTEGER , INTENT(OUT) :: Status
4510
4511	CHARACTER (LEN=2) :: lf
4512	INTEGER :: IDX
4513
4514	lf=char(10)//' '
4515
4516	if (index(string,lf//Element//' =') .gt. 0) then
4517	! We do nothing, since we dont want to add the same variable twice.
4518	else
4519	if (len_trim(string) == 0) then
4520	string = lf//Element//' = '
4521	else
4522	string = trim(string)//lf//Element//' = '
4523	endif
4524	do idx = 1,Count
4525	if (idx > 1) then
4526	string = trim(string)//','
4527	endif
4528	string = trim(string)//' '//trim(adjustl(Value(idx)))
4529	enddo
4530	endif
4531
4532	Status = WRF_NO_ERR
4533
4534	END SUBROUTINE gr2_build_string
4535

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

Download in other formats:

Original Format