Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

io_grib1.F @ 3567

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

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

Download in other formats:

Original Format