Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

io_grib1.F @ 1

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

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 104.3 KB

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

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

Download in other formats:

Original Format