Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

read_grib2map.F @ 2759

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

Rev	Line
[2759]	1	!*****************************************************************************
	2	!
	3	! Routine to fill a grib2map structure (linked list).
	4	!
	5	!*****************************************************************************
	6
	7	subroutine load_grib2map(filename, msg, ierr)
	8
	9	USE grib2tbls_types
	10	Implicit None
	11
	12	character(), intent(in) :: filename
	13	character(), intent(inout) :: msg
	14	integer , intent(out) :: ierr
	15	integer :: status = 0
	16	integer :: fileunit
	17	logical :: foundunit
	18	character*(maxLineSize) :: line
	19	integer :: firstval
	20	integer :: numtables = 0
	21	character*(1) :: delim
	22	integer :: lastpos
	23	integer :: pos
	24	integer :: idx
	25	integer :: end
	26	logical :: lerr
	27
	28	! Open the file
	29
	30	! First pass:
	31	! Scan the file to determine how many tables are included, and how many
	32	! entries are in each table.
	33	!
	34
	35	! Find an open fileunit
	36	foundunit = .false.
	37	do fileunit = 10,100
	38	inquire(unit=fileunit,opened=lerr)
	39	if (lerr .eqv. .false.) then
	40	foundunit = .true.
	41	exit
	42	endif
	43	enddo
	44	if (foundunit .neqv. .true.) then
	45	write(msg, *)'Could not find unit to open ',filename
	46	ierr = -1
	47	return
	48	endif
	49
	50	! Open the file
	51	open ( unit = fileunit, file=filename, status = 'old', iostat = status)
	52	if (status .ne. 0) then
	53	write(msg, *)'Could not open file ',filename
	54	ierr = -1
	55	return
	56	endif
	57
	58	! Loop through each line to count the number of tables and entries in
	59	! each table.
	60
	61	READLINE: do
	62	!
	63	! Read the line, skip line if line is comment, blank or invalid
	64	!
	65	read(fileunit,'(A)',iostat=status) line
	66	line = adjustl(line)
	67	if (status .lt. 0) then
	68	exit
	69	endif
	70	if (len_trim(line) .eq. 0) then
	71	cycle READLINE
	72	endif
	73	if (line(1:1) .eq. '#') then
	74	cycle READLINE
	75	endif
	76
	77	!
	78	! Read the first value in the line
	79	!
	80	read(line,*,iostat=status) firstval
	81	if (status .ne. 0) then
	82	print *,'Skipping Invalid line in',trim(filename),':'
	83	print *,'''',trim(line),''''
	84	cycle READLINE
	85	endif
	86
	87
	88	!
	89	! If the first value is -1, weve found a new table. Allocate
	90	! a new member in the linked list, and add the information
	91	! to that member
	92	!
	93	if (firstval .eq. -1) then
	94	numtables = numtables + 1
	95
	96	!
	97	! Create and allocate the next member of the linked list
	98	!
	99	if (.NOT. ASSOCIATED(TblHead)) THEN
	100	ALLOCATE (TblHead, stat=status)
	101	if (status .ne. 0) then
	102	print *,'Could not allocate space for TblHead'
	103	exit READLINE
	104	endif
	105	TblTail => TblHead
	106	else
	107	ALLOCATE (TblTail%next, STAT=status)
	108	if (status .ne. 0) then
	109	print *,'Could not allocate space for TblTail%next, continuing'
	110	cycle READLINE
	111	endif
	112	TblTail%previous => TblTail
	113	TblTail => TblTail%next
	114	endif
	115	nullify(TblTail%next)
	116	nullify(TblTail%ParmHead)
	117
	118	!
	119	! Parse the header line
	120	!
	121	lastpos = 0
	122	do idx = 1,5
	123	pos = index(line(lastpos+1:maxLineSize), "\|")
	124
	125	if (pos .lt. 0) then
	126	print *,'Found invalid header line: '
	127	print *,'''',trim(line),''''
	128	if (associated(TblTail%previous)) then
	129	TblTail => TblTail%previous
	130	else
	131	nullify(TblTail)
	132	endif
	133	cycle READLINE
	134	endif
	135
	136	SELECT CASE (idx)
	137	CASE (1)
	138	! Do nothing, since this is just the indicator value
	139	CASE (2)
	140	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%center
	141	if (status .ne. 0) then
	142	print *,'Found invalid header line: '
	143	print *,'''',trim(line),''''
	144	cycle READLINE
	145	endif
	146	CASE (3)
	147	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%subcenter
	148	if (status .ne. 0) then
	149	print *,'Found invalid header line: '
	150	print *,'''',trim(line),''''
	151	cycle READLINE
	152	endif
	153	CASE (4)
	154	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%MasterTblV
	155	if (status .ne. 0) then
	156	print *,'Found invalid header line: '
	157	print *,'''',trim(line),''''
	158	cycle READLINE
	159	endif
	160	CASE (5)
	161	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%LocalTblV
	162	if (status .ne. 0) then
	163	print *,'Found invalid header line: '
	164	print *,'''',trim(line),''''
	165	cycle READLINE
	166	endif
	167	END SELECT
	168
	169	lastpos = lastpos+pos
	170
	171	enddo
	172
	173	#ifdef TEST
	174	! Test
	175	print *,'Header Line: '
	176	print *,TblTail%center, TblTail%subcenter, TblTail%MasterTblV, &
	177	TblTail%LocalTblV
	178	#endif
	179
	180
	181	!
	182	! We found the header, cycle so that the header is not interpereted
	183	! as a parameter line.
	184	!
	185	cycle READLINE
	186
	187	endif
	188
	189	if (.NOT. ASSOCIATED(TblTail%ParmHead)) then
	190	ALLOCATE (TblTail%ParmHead, stat=status)
	191	if (status .ne. 0) then
	192	print *,'Could not allocate space for TblTail%ParmHead, continuing'
	193	cycle READLINE
	194	endif
	195	TblTail%ParmTail => TblTail%ParmHead
	196	else
	197	ALLOCATE (TblTail%ParmTail%next, STAT=status)
	198	if (status .ne. 0) then
	199	print *,'Could not allocate space for TblTail%ParmTail%next, continuing'
	200	cycle READLINE
	201	endif
	202	TblTail%ParmTail%previous => TblTail%ParmTail
	203	TblTail%ParmTail => TblTail%ParmTail%next
	204	endif
	205	nullify(TblTail%ParmTail%next)
	206
	207	!
	208	! Parse the Parameter line
	209	!
	210	lastpos = 0
	211	do idx = 1,7
	212	pos = index(line(lastpos+1:maxLineSize), "\|")
	213
	214	if (pos .lt. 0) then
	215	print *,'Found invalid header line: '
	216	print *,'''',trim(line),''''
	217	if (associated(TblTail%previous)) then
	218	TblTail => TblTail%previous
	219	else
	220	nullify(TblTail)
	221	endif
	222	cycle READLINE
	223	endif
	224
	225	SELECT CASE (idx)
	226	CASE (1)
	227	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Disc
	228	if (status .ne. 0) then
	229	print *,'Found invalid line: '
	230	print *,'''',trim(line),''''
	231	cycle READLINE
	232	endif
	233	CASE (2)
	234	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Category
	235	if (status .ne. 0) then
	236	print *,'Found invalid line: '
	237	print *,'''',trim(line),''''
	238	cycle READLINE
	239	endif
	240	CASE (3)
	241	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%ParmNum
	242	if (status .ne. 0) then
	243	print *,'Found invalid line: '
	244	print *,'''',trim(line),''''
	245	cycle READLINE
	246	endif
	247	CASE (4)
	248	TblTail%ParmTail%WRFNameString = &
	249	trim(adjustl(line(lastpos+1:lastpos+pos-1)))
	250	CASE (5)
	251	TblTail%ParmTail%Description = &
	252	trim(adjustl(line(lastpos+1:lastpos+pos-1)))
	253	CASE (6)
	254	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%DecScl
	255	if (status .ne. 0) then
	256	print *,'Found invalid line: '
	257	print *,'''',trim(line),''''
	258	cycle READLINE
	259	endif
	260	CASE (7)
	261	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%BinScl
	262	if (status .ne. 0) then
	263	print *,'Found invalid line: '
	264	print *,'''',trim(line),''''
	265	cycle READLINE
	266	endif
	267	END SELECT
	268
	269	lastpos = lastpos+pos
	270
	271	enddo
	272
	273	#ifdef TEST
	274	! Test Code
	275	delim = '\|'
	276	write(6,'(I4,A1,I4,A1,I4,A1,A12,A1,A42,A1,I4,A1,I4,A1)') &
	277	TblTail%ParmTail%Disc, delim, &
	278	TblTail%ParmTail%Category, delim, &
	279	TblTail%ParmTail%ParmNum, delim, &
	280	trim(TblTail%ParmTail%WRFNameString), delim, &
	281	trim(TblTail%ParmTail%Description), delim, &
	282	TblTail%ParmTail%DecScl, delim, &
	283	TblTail%ParmTail%BinScl, delim
	284	#endif
	285
	286	!
	287	! Parse the WRFNameString
	288	!
	289	status = 0
	290	lastpos = 0
	291	idx = 1
	292	do while (pos .gt. 0)
	293	pos = index(TblTail%ParmTail%WRFNameString(lastpos+1:maxLineSize), ",")
	294	if (pos .le. 0) then
	295	end = lastpos+maxLineSize
	296	else
	297	end = lastpos+pos-1
	298	endif
	299	read(TblTail%ParmTail%WRFNameString(lastpos+1:end),*) &
	300	TblTail%ParmTail%WRFNames(idx)
	301	lastpos = lastpos + pos
	302	idx = idx + 1
	303	enddo
	304	TblTail%ParmTail%numWRFNames = idx-1
	305
	306	#ifdef TEST
	307	write(6,*)'WRFNames: ',&
	308	(trim(TblTail%ParmTail%WRFNames(idx)),' ', &
	309	idx=1,TblTail%ParmTail%numWRFNames)
	310	#endif
	311
	312	enddo READLINE
	313
	314	close ( unit = fileunit)
	315
	316	end subroutine load_grib2map
	317
	318	!*****************************************************************************
	319	!
	320	! Routine to find and return the grib2 information associated with a WRF
	321	! parameter.
	322	!
	323	!*****************************************************************************
	324
	325	subroutine get_parminfo(parmname, center, subcenter, MasterTblV, &
	326	LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, ierr)
	327
	328	USE grib2tbls_types
	329	Implicit None
	330
	331	character(),intent(in) :: parmname
	332	integer ,intent(out) :: center, subcenter, MasterTblV, LocalTblV, &
	333	Disc, Category, ParmNum, DecScl, BinScl
	334	TYPE (grib2Entries_type), pointer :: ParmPtr
	335	TYPE (grib2tbls_type) , pointer :: TblPtr
	336	integer :: idx
	337	logical :: found
	338	integer :: ierr
	339
	340
	341	!
	342	! Loop through tables
	343	!
	344
	345	found = .false.
	346	TblPtr => TblHead
	347	TABLE : DO
	348
	349	if ( .not. associated(TblPtr)) then
	350	exit TABLE
	351	endif
	352
	353	!
	354	! Loop through parameters
	355	!
	356	ParmPtr => TblPtr%ParmHead
	357
	358	PARAMETER : DO
	359
	360	if ( .not. associated(ParmPtr)) then
	361	exit PARAMETER
	362	endif
	363
	364	!
	365	! Loop through WRF parameter names for the table parameter entry
	366	!
	367	WRFNAME : do idx = 1,ParmPtr%numWRFNames
	368	if (parmname .eq. ParmPtr%WRFNames(idx)) then
	369	found = .true.
	370	exit TABLE
	371	endif
	372	enddo WRFNAME
	373
	374	ParmPtr => ParmPtr%next
	375
	376	ENDDO PARAMETER
	377
	378	TblPtr => TblPtr%next
	379	ENDDO TABLE
	380
	381	if (found) then
	382	center = TblPtr%center
	383	subcenter = TblPtr%subcenter
	384	MasterTblV = TblPtr%MasterTblV
	385	LocalTblV = TblPtr%LocalTblV
	386	Disc = ParmPtr%Disc
	387	Category = ParmPtr%Category
	388	ParmNum = ParmPtr%ParmNum
	389	DecScl = ParmPtr%DecScl
	390	BinScl = ParmPtr%BinScl
	391	ierr = 0
	392	else
	393	ierr = 1
	394	endif
	395
	396	end subroutine get_parminfo
	397
	398	!*****************************************************************************
	399	!
	400	! Routine to free the lists.
	401	!
	402	!*****************************************************************************
	403
	404	subroutine free_grib2map()
	405	USE grib2tbls_types
	406	Implicit None
	407
	408	TYPE (grib2Entries_type), pointer :: ParmPtr
	409	TYPE (grib2Entries_type), pointer :: ParmSave
	410	TYPE (grib2tbls_type) , pointer :: TblPtr
	411	TYPE (grib2tbls_type) , pointer :: TblSave
	412
	413	TblPtr => TblHead
	414	TABLE : DO
	415
	416	if ( .not. associated(TblPtr)) then
	417	exit TABLE
	418	endif
	419
	420	!
	421	! Loop through parameters
	422	!
	423	ParmPtr => TblPtr%ParmHead
	424
	425	PARAMETER : DO
	426
	427	if ( .not. associated(ParmPtr)) then
	428	exit PARAMETER
	429	endif
	430
	431	ParmSave => ParmPtr%next
	432	deallocate(ParmPtr)
	433	ParmPtr => ParmSave
	434
	435	ENDDO PARAMETER
	436
	437
	438	TblSave => TblPtr%next
	439	deallocate(TblPtr)
	440	TblPtr => TblSave
	441
	442	ENDDO TABLE
	443
	444	end subroutine free_grib2map

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

Download in other formats:

Original Format