Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

io_grib2.F @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 135.5 KB

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

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

Download in other formats:

Original Format