Context Navigation

module_internal_header_util.F

Last change on this file 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: 39.6 KB

Line
1	MODULE module_internal_header_util
2
3	!<DESCRIPTION>
4	!<PRE>
5	! Subroutines defined in this module are used to generate (put together) and get (take apart)
6	! data headers stored in the form of integer vectors.
7	!
8	! Data headers serve two purposes:
9	! - Provide a package-independent metadata storage and retrieval mechanism
10	! for I/O packages that do not support native metadata.
11	! - Provide a mechanism for communicating I/O commands from compute
12	! tasks to quilt tasks when I/O quilt servers are enabled.
13	!
14	! Within a data header, character strings are stored one character per integer.
15	! The number of characters is stored immediately before the first character of
16	! each string.
17	!
18	! In an I/O package that does not support native metadata, routines
19	! int_gen_*_header() are called to pack information into data headers that
20	! are then written to files. Routines int_get_*_header() are called to
21	! extract information from a data headers after they have been read from a
22	! file.
23	!
24	! When I/O quilt server tasks are used, routines int_gen_*_header()
25	! are called by compute tasks to pack information into data headers
26	! (commands) that are then sent to the I/O quilt servers. Routines
27	! int_get_*_header() are called by I/O quilt servers to extract
28	! information from data headers (commands) received from the compute
29	! tasks.
30	!
31	!</PRE>
32	!</DESCRIPTION>
33
34	INTERFACE int_get_ti_header
35	MODULE PROCEDURE int_get_ti_header_integer, int_get_ti_header_real
36	END INTERFACE
37	INTERFACE int_gen_ti_header
38	MODULE PROCEDURE int_gen_ti_header_integer, int_gen_ti_header_real
39	END INTERFACE
40	INTERFACE int_get_td_header
41	MODULE PROCEDURE int_get_td_header_integer, int_get_td_header_real
42	END INTERFACE
43	INTERFACE int_gen_td_header
44	MODULE PROCEDURE int_gen_td_header_integer, int_gen_td_header_real
45	END INTERFACE
46
47	PRIVATE :: int_pack_string, int_unpack_string
48
49	CONTAINS
50	!!!!!!!!!!!!! header manipulation routines !!!!!!!!!!!!!!!
51
52	INTEGER FUNCTION get_hdr_tag( hdrbuf )
53	IMPLICIT NONE
54	INTEGER, INTENT(IN) :: hdrbuf(*)
55	get_hdr_tag = hdrbuf(2)
56	RETURN
57	END FUNCTION get_hdr_tag
58
59	INTEGER FUNCTION get_hdr_rec_size( hdrbuf )
60	IMPLICIT NONE
61	INTEGER, INTENT(IN) :: hdrbuf(*)
62	get_hdr_rec_size = hdrbuf(1)
63	RETURN
64	END FUNCTION get_hdr_rec_size
65
66	SUBROUTINE int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize, &
67	DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
68	DomainDesc , MemoryOrder , Stagger , DimNames , &
69	DomainStart , DomainEnd , &
70	MemoryStart , MemoryEnd , &
71	PatchStart , PatchEnd )
72	!<DESCRIPTION>
73	!<PRE>
74	! Items and their starting locations within a "write field" data header.
75	! Assume that the data header is stored in integer vector "hdrbuf":
76	! hdrbuf(1) = hdrbufsize
77	! hdrbuf(2) = headerTag
78	! hdrbuf(3) = ftypesize
79	! hdrbuf(4) = DataHandle
80	! hdrbuf(5) = LEN(TRIM(DateStr))
81	! hdrbuf(6:5+n1) = DateStr ! n1 = LEN(TRIM(DateStr)) + 1
82	! hdrbuf(6+n1) = LEN(TRIM(VarName))
83	! hdrbuf(7+n1:6+n1+n2) = VarName ! n2 = LEN(TRIM(VarName)) + 1
84	! hdrbuf(7+n1+n2) = FieldType
85	! hdrbuf(8+n1+n2) = LEN(TRIM(MemoryOrder))
86	! hdrbuf(9+n1+n2:8+n1+n2+n3) = MemoryOrder ! n3 = LEN(TRIM(MemoryOrder)) + 1
87	! hdrbuf(9+n1+n2+n3) = LEN(TRIM(Stagger))
88	! hdrbuf(9+n1+n2+n3:8+n1+n2+n3+n4) = Stagger ! n4 = LEN(TRIM(Stagger)) + 1
89	! hdrbuf(9+n1+n2+n3+n4) = LEN(TRIM(DimNames(1)))
90	! hdrbuf(9+n1+n2+n3+n4:8+n1+n2+n3+n4+n5) = DimNames(1) ! n5 = LEN(TRIM(DimNames(1))) + 1
91	! hdrbuf(9+n1+n2+n3+n4+n5) = LEN(TRIM(DimNames(2)))
92	! hdrbuf(9+n1+n2+n3+n4+n5:8+n1+n2+n3+n4+n5+n6) = DimNames(2) ! n6 = LEN(TRIM(DimNames(2))) + 1
93	! hdrbuf(9+n1+n2+n3+n4+n5+n6) = LEN(TRIM(DimNames(3)))
94	! hdrbuf(9+n1+n2+n3+n4+n5+n6:8+n1+n2+n3+n4+n5+n6+n7) = DimNames(3) ! n7 = LEN(TRIM(DimNames(3))) + 1
95	! hdrbuf(9+n1+n2+n3+n4+n5+n6+n7) = DomainStart(1)
96	! hdrbuf(10+n1+n2+n3+n4+n5+n6+n7) = DomainStart(2)
97	! hdrbuf(11+n1+n2+n3+n4+n5+n6+n7) = DomainStart(3)
98	! hdrbuf(12+n1+n2+n3+n4+n5+n6+n7) = DomainEnd(1)
99	! hdrbuf(13+n1+n2+n3+n4+n5+n6+n7) = DomainEnd(2)
100	! hdrbuf(14+n1+n2+n3+n4+n5+n6+n7) = DomainEnd(3)
101	! hdrbuf(15+n1+n2+n3+n4+n5+n6+n7) = PatchStart(1)
102	! hdrbuf(16+n1+n2+n3+n4+n5+n6+n7) = PatchStart(2)
103	! hdrbuf(17+n1+n2+n3+n4+n5+n6+n7) = PatchStart(3)
104	! hdrbuf(18+n1+n2+n3+n4+n5+n6+n7) = PatchEnd(1)
105	! hdrbuf(19+n1+n2+n3+n4+n5+n6+n7) = PatchEnd(2)
106	! hdrbuf(20+n1+n2+n3+n4+n5+n6+n7) = PatchEnd(3)
107	! hdrbuf(21+n1+n2+n3+n4+n5+n6+n7) = DomainDesc
108	!
109	! Further details for some items:
110	! hdrbufsize: Size of this data header in bytes.
111	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
112	! header this is. For a "write field" header it must be set to
113	! int_field. See file intio_tags.h for a complete list of
114	! these tags.
115	! ftypesize: Size of field data type in bytes.
116	! DataHandle: Descriptor for an open data set.
117	! DomainDesc: Additional argument that may be used by some packages as a
118	! package-specific domain descriptor.
119	! Other items are described in detail in the "WRF I/O and Model Coupling API
120	! Specification".
121	!
122	!</PRE>
123	!</DESCRIPTION>
124	IMPLICIT NONE
125	#include "intio_tags.h"
126	INTEGER, INTENT(INOUT) :: hdrbuf(*)
127	INTEGER, INTENT(INOUT) :: hdrbufsize
128	INTEGER, INTENT(INOUT) :: itypesize, ftypesize
129	INTEGER , INTENT(IN) :: DataHandle
130	CHARACTER(), INTENT(IN) :: DateStr
131	CHARACTER(), INTENT(IN) :: VarName
132	REAL, DIMENSION(*) :: Dummy
133	INTEGER ,intent(in) :: FieldType
134	INTEGER ,intent(inout) :: Comm
135	INTEGER ,intent(inout) :: IOComm
136	INTEGER ,intent(in) :: DomainDesc
137	CHARACTER() ,intent(in) :: MemoryOrder
138	CHARACTER() ,intent(in) :: Stagger
139	CHARACTER() , dimension (*) ,intent(in) :: DimNames
140	INTEGER ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
141	INTEGER ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
142	INTEGER ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
143
144	INTEGER i, n
145
146
147	hdrbuf(1) = 0 ! deferred -- this will be length of header
148	hdrbuf(2) = int_field
149	hdrbuf(3) = ftypesize
150
151	i = 4
152	hdrbuf(i) = DataHandle ; i = i+1
153	call int_pack_string( DateStr, hdrbuf(i), n ) ; i = i + n
154	call int_pack_string( VarName, hdrbuf(i), n ) ; i = i + n
155	hdrbuf(i) = FieldType ; i = i+1
156	call int_pack_string( MemoryOrder, hdrbuf(i), n ) ; i = i + n
157	call int_pack_string( Stagger, hdrbuf(i), n ) ; i = i + n
158	call int_pack_string( DimNames(1), hdrbuf(i), n ) ; i = i + n
159	call int_pack_string( DimNames(2), hdrbuf(i), n ) ; i = i + n
160	call int_pack_string( DimNames(3), hdrbuf(i), n ) ; i = i + n
161	hdrbuf(i) = DomainStart(1) ; i = i+1
162	hdrbuf(i) = DomainStart(2) ; i = i+1
163	hdrbuf(i) = DomainStart(3) ; i = i+1
164	hdrbuf(i) = DomainEnd(1) ; i = i+1
165	hdrbuf(i) = DomainEnd(2) ; i = i+1
166	hdrbuf(i) = DomainEnd(3) ; i = i+1
167	hdrbuf(i) = PatchStart(1) ; i = i+1
168	hdrbuf(i) = PatchStart(2) ; i = i+1
169	hdrbuf(i) = PatchStart(3) ; i = i+1
170	hdrbuf(i) = PatchEnd(1) ; i = i+1
171	hdrbuf(i) = PatchEnd(2) ; i = i+1
172	hdrbuf(i) = PatchEnd(3) ; i = i+1
173	hdrbuf(i) = DomainDesc ; i = i+1
174
175	hdrbufsize = (i-1) * itypesize ! return the number in bytes
176	hdrbuf(1) = hdrbufsize
177
178	RETURN
179	END SUBROUTINE int_gen_write_field_header
180
181
182	SUBROUTINE int_get_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize, &
183	DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
184	DomainDesc , MemoryOrder , Stagger , DimNames , &
185	DomainStart , DomainEnd , &
186	MemoryStart , MemoryEnd , &
187	PatchStart , PatchEnd )
188	!<DESCRIPTION>
189	!<PRE>
190	! See documentation block in int_gen_write_field_header() for
191	! a description of a "write field" header.
192	!</PRE>
193	!</DESCRIPTION>
194	IMPLICIT NONE
195	#include "intio_tags.h"
196	INTEGER, INTENT(INOUT) :: hdrbuf(*)
197	INTEGER, INTENT(OUT) :: hdrbufsize
198	INTEGER, INTENT(INOUT) :: itypesize, ftypesize
199	INTEGER , INTENT(OUT) :: DataHandle
200	CHARACTER(), INTENT(INOUT) :: DateStr
201	CHARACTER(), INTENT(INOUT) :: VarName
202	REAL, DIMENSION(*) :: Dummy
203	INTEGER :: FieldType
204	INTEGER :: Comm
205	INTEGER :: IOComm
206	INTEGER :: DomainDesc
207	CHARACTER() :: MemoryOrder
208	CHARACTER() :: Stagger
209	CHARACTER() , dimension (*) :: DimNames
210	INTEGER ,dimension(*) :: DomainStart, DomainEnd
211	INTEGER ,dimension(*) :: MemoryStart, MemoryEnd
212	INTEGER ,dimension(*) :: PatchStart, PatchEnd
213	!Local
214	CHARACTER*132 mess
215	INTEGER i, n
216
217	hdrbufsize = hdrbuf(1)
218	IF ( hdrbuf(2) .NE. int_field ) THEN
219	write(mess,*)'int_get_write_field_header: hdrbuf(2) ne int_field ',hdrbuf(2),int_field
220	CALL wrf_error_fatal ( mess )
221	ENDIF
222	ftypesize = hdrbuf(3)
223
224	i = 4
225	DataHandle = hdrbuf(i) ; i = i+1
226	call int_unpack_string( DateStr, hdrbuf(i), n ) ; i = i+n
227	call int_unpack_string( VarName, hdrbuf(i), n ) ; i = i+n
228	FieldType = hdrbuf(i) ; i = i+1
229	call int_unpack_string( MemoryOrder, hdrbuf(i), n ) ; i = i+n
230	call int_unpack_string( Stagger, hdrbuf(i), n ) ; i = i+n
231	call int_unpack_string( DimNames(1), hdrbuf(i), n ) ; i = i+n
232	call int_unpack_string( DimNames(2), hdrbuf(i), n ) ; i = i+n
233	call int_unpack_string( DimNames(3), hdrbuf(i), n ) ; i = i+n
234	DomainStart(1) = hdrbuf(i) ; i = i+1
235	DomainStart(2) = hdrbuf(i) ; i = i+1
236	DomainStart(3) = hdrbuf(i) ; i = i+1
237	DomainEnd(1) = hdrbuf(i) ; i = i+1
238	DomainEnd(2) = hdrbuf(i) ; i = i+1
239	DomainEnd(3) = hdrbuf(i) ; i = i+1
240	PatchStart(1) = hdrbuf(i) ; i = i+1
241	PatchStart(2) = hdrbuf(i) ; i = i+1
242	PatchStart(3) = hdrbuf(i) ; i = i+1
243	PatchEnd(1) = hdrbuf(i) ; i = i+1
244	PatchEnd(2) = hdrbuf(i) ; i = i+1
245	PatchEnd(3) = hdrbuf(i) ; i = i+1
246	DomainDesc = hdrbuf(i) ; i = i+1
247
248	RETURN
249	END SUBROUTINE int_get_write_field_header
250
251	!!!!!!!!
252
253	!generate open for read header
254	SUBROUTINE int_gen_ofr_header( hdrbuf, hdrbufsize, itypesize, &
255	FileName, SysDepInfo, DataHandle )
256	!<DESCRIPTION>
257	!<PRE>
258	! Items and their starting locations within a "open for read" data header.
259	! Assume that the data header is stored in integer vector "hdrbuf":
260	! hdrbuf(1) = hdrbufsize
261	! hdrbuf(2) = headerTag
262	! hdrbuf(3) = DataHandle
263	! hdrbuf(4) = LEN(TRIM(FileName))
264	! hdrbuf(5:4+n1) = FileName ! n1 = LEN(TRIM(FileName)) + 1
265	! hdrbuf(5+n1) = LEN(TRIM(SysDepInfo))
266	! hdrbuf(6+n1:5+n1+n2) = SysDepInfo ! n2 = LEN(TRIM(SysDepInfo)) + 1
267	!
268	! Further details for some items:
269	! hdrbufsize: Size of this data header in bytes.
270	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
271	! header this is. For an "open for read" header it must be set to
272	! int_open_for_read. See file intio_tags.h for a complete list of
273	! these tags.
274	! DataHandle: Descriptor for an open data set.
275	! FileName: File name.
276	! SysDepInfo: System dependent information used for optional additional
277	! I/O control information.
278	! Other items are described in detail in the "WRF I/O and Model Coupling API
279	! Specification".
280	!
281	!</PRE>
282	!</DESCRIPTION>
283	IMPLICIT NONE
284	#include "intio_tags.h"
285	INTEGER, INTENT(INOUT) :: hdrbuf(*)
286	INTEGER, INTENT(OUT) :: hdrbufsize
287	INTEGER, INTENT(INOUT) :: itypesize
288	INTEGER , INTENT(IN) :: DataHandle
289	CHARACTER(), INTENT(INOUT) :: FileName
290	CHARACTER(), INTENT(INOUT) :: SysDepInfo
291	!Local
292	INTEGER i, n, i1
293	!
294	hdrbuf(1) = 0 !deferred
295	hdrbuf(2) = int_open_for_read
296	i = 3
297	hdrbuf(i) = DataHandle ; i = i+1
298
299	call int_pack_string( TRIM(FileName), hdrbuf(i), n ) ; i = i + n
300	call int_pack_string( TRIM(SysDepInfo), hdrbuf(i), n ) ; i = i + n
301	hdrbufsize = (i-1) * itypesize ! return the number in bytes
302	hdrbuf(1) = hdrbufsize
303	RETURN
304	END SUBROUTINE int_gen_ofr_header
305
306	!get open for read header
307	SUBROUTINE int_get_ofr_header( hdrbuf, hdrbufsize, itypesize, &
308	FileName, SysDepInfo, DataHandle )
309	!<DESCRIPTION>
310	!<PRE>
311	! See documentation block in int_gen_ofr_header() for
312	! a description of a "open for read" header.
313	!</PRE>
314	!</DESCRIPTION>
315	IMPLICIT NONE
316	#include "intio_tags.h"
317	INTEGER, INTENT(INOUT) :: hdrbuf(*)
318	INTEGER, INTENT(OUT) :: hdrbufsize
319	INTEGER, INTENT(INOUT) :: itypesize
320	INTEGER , INTENT(OUT) :: DataHandle
321	CHARACTER(), INTENT(INOUT) :: FileName
322	CHARACTER(), INTENT(INOUT) :: SysDepInfo
323	!Local
324	INTEGER i, n
325	!
326	hdrbufsize = hdrbuf(1)
327	! IF ( hdrbuf(2) .NE. int_open_for_read ) THEN
328	! CALL wrf_error_fatal ( "int_get_ofr_header: hdrbuf ne int_open_for_read")
329	! ENDIF
330	i = 3
331	DataHandle = hdrbuf(i) ; i = i+1
332	call int_unpack_string( FileName, hdrbuf(i), n ) ; i = i+n
333	call int_unpack_string( SysDepInfo, hdrbuf(i), n ) ; i = i+n
334	RETURN
335	END SUBROUTINE int_get_ofr_header
336
337	!!!!!!!!
338
339	!generate open for write begin header
340	SUBROUTINE int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
341	FileName, SysDepInfo, io_form, DataHandle )
342	!<DESCRIPTION>
343	!<PRE>
344	! Items and their starting locations within a "open for write begin" data
345	! header. Assume that the data header is stored in integer vector "hdrbuf":
346	! hdrbuf(1) = hdrbufsize
347	! hdrbuf(2) = headerTag
348	! hdrbuf(3) = DataHandle
349	! hdrbuf(4) = io_form
350	! hdrbuf(5) = LEN(TRIM(FileName))
351	! hdrbuf(6:5+n1) = FileName ! n1 = LEN(TRIM(FileName)) + 1
352	! hdrbuf(6+n1) = LEN(TRIM(SysDepInfo))
353	! hdrbuf(7+n1:6+n1+n2) = SysDepInfo ! n2 = LEN(TRIM(SysDepInfo)) + 1
354	!
355	! Further details for some items:
356	! hdrbufsize: Size of this data header in bytes.
357	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
358	! header this is. For an "open for write begin" header it must be set to
359	! int_open_for_write_begin. See file intio_tags.h for a complete list of
360	! these tags.
361	! DataHandle: Descriptor for an open data set.
362	! io_form: I/O format for this file (netCDF, etc.).
363	! FileName: File name.
364	! SysDepInfo: System dependent information used for optional additional
365	! I/O control information.
366	! Other items are described in detail in the "WRF I/O and Model Coupling API
367	! Specification".
368	!
369	!</PRE>
370	!</DESCRIPTION>
371	IMPLICIT NONE
372	#include "intio_tags.h"
373	INTEGER, INTENT(INOUT) :: hdrbuf(*)
374	INTEGER, INTENT(OUT) :: hdrbufsize
375	INTEGER, INTENT(INOUT) :: itypesize
376	INTEGER , INTENT(IN) :: io_form
377	INTEGER , INTENT(IN) :: DataHandle
378	CHARACTER(), INTENT(INOUT) :: FileName
379	CHARACTER(), INTENT(INOUT) :: SysDepInfo
380	!Local
381	INTEGER i, n, j
382	!
383	hdrbuf(1) = 0 !deferred
384	hdrbuf(2) = int_open_for_write_begin
385	i = 3
386	hdrbuf(i) = DataHandle ; i = i+1
387	hdrbuf(i) = io_form ; i = i+1
388	!j = i
389	call int_pack_string( FileName, hdrbuf(i), n ) ; i = i + n
390	!write(0,*)'int_gen_ofwb_header FileName ',TRIM(FileName),hdrbuf(j),n
391	!j = i
392	call int_pack_string( SysDepInfo, hdrbuf(i), n ) ; i = i + n
393	!write(0,*)'int_gen_ofwb_header SysDepInfo ',TRIM(SysDepInfo),hdrbuf(j),n
394	hdrbufsize = (i-1) * itypesize ! return the number in bytes
395	hdrbuf(1) = hdrbufsize
396	!write(0,*)'int_gen_ofwb_header hdrbuf(1) ',hdrbuf(1)
397	RETURN
398	END SUBROUTINE int_gen_ofwb_header
399
400	!get open for write begin header
401	SUBROUTINE int_get_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
402	FileName, SysDepInfo, io_form, DataHandle )
403	!<DESCRIPTION>
404	!<PRE>
405	! See documentation block in int_gen_ofwb_header() for
406	! a description of a "open for write begin" header.
407	!</PRE>
408	!</DESCRIPTION>
409	IMPLICIT NONE
410	#include "intio_tags.h"
411	INTEGER, INTENT(INOUT) :: hdrbuf(*)
412	INTEGER, INTENT(OUT) :: hdrbufsize
413	INTEGER, INTENT(INOUT) :: itypesize
414	INTEGER , INTENT(OUT) :: DataHandle
415	INTEGER , INTENT(OUT) :: io_form
416	CHARACTER(), INTENT (INOUT) :: FileName
417	CHARACTER(), INTENT (INOUT) :: SysDepInfo
418	!Local
419	INTEGER i, n, j
420	!
421	hdrbufsize = hdrbuf(1)
422	!write(0,*)' int_get_ofwb_header next rec start ',hdrbuf(hdrbufsize+1)
423	! IF ( hdrbuf(2) .NE. int_open_for_write_begin ) THEN
424	! CALL wrf_error_fatal ( "int_get_ofwb_header: hdrbuf ne int_open_for_write_begin")
425	! ENDIF
426	i = 3
427	DataHandle = hdrbuf(i) ; i = i+1
428	!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1)
429	io_form = hdrbuf(i) ; i = i+1
430	!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1)
431
432	!j = i
433	call int_unpack_string( FileName, hdrbuf(i), n ) ; i = i+n
434	!write(0,*)'int_get_ofwb_header FileName ',TRIM(FileName),hdrbuf(j),n
435	!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1)
436	!j = i
437	call int_unpack_string( SysDepInfo, hdrbuf(i), n ) ; i = i+n
438	!write(0,*)'int_get_ofwb_header SysDepInfo ',TRIM(SysDepInfo),hdrbuf(j),n
439	!write(0,*)' int_get_ofwb_header next rec',i, hdrbuf(hdrbufsize+1)
440	!write(0,*)'int_get_ofwb_header hdrbufsize ',hdrbufsize
441	RETURN
442	END SUBROUTINE int_get_ofwb_header
443
444	!!!!!!!!!!
445
446	SUBROUTINE int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
447	DataHandle , code )
448	!<DESCRIPTION>
449	!<PRE>
450	! Items and their starting locations within a "generic handle" data header.
451	! Several types of data headers contain only a DataHandle and a header tag
452	! (I/O command). This routine is used for all of them. Assume that
453	! the data header is stored in integer vector "hdrbuf":
454	! hdrbuf(1) = hdrbufsize
455	! hdrbuf(2) = headerTag
456	! hdrbuf(3) = DataHandle
457	!
458	! Further details for some items:
459	! hdrbufsize: Size of this data header in bytes.
460	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
461	! header this is. For a "generic handle" header there are
462	! several possible values. In this routine, dummy argument
463	! "code" is used as headerTag.
464	! DataHandle: Descriptor for an open data set.
465	!
466	!</PRE>
467	!</DESCRIPTION>
468	IMPLICIT NONE
469	#include "intio_tags.h"
470	INTEGER, INTENT(INOUT) :: hdrbuf(*)
471	INTEGER, INTENT(OUT) :: hdrbufsize
472	INTEGER, INTENT(INOUT) :: itypesize
473	INTEGER ,INTENT(IN) :: DataHandle, code
474	!Local
475	INTEGER i
476	!
477	hdrbuf(1) = 0 !deferred
478	hdrbuf(2) = code
479	i = 3
480	hdrbuf(i) = DataHandle ; i = i+1
481	hdrbufsize = (i-1) * itypesize ! return the number in bytes
482	hdrbuf(1) = hdrbufsize
483	RETURN
484	END SUBROUTINE int_gen_handle_header
485
486	SUBROUTINE int_get_handle_header( hdrbuf, hdrbufsize, itypesize, &
487	DataHandle , code )
488	!<DESCRIPTION>
489	!<PRE>
490	! See documentation block in int_gen_handle_header() for
491	! a description of a "generic handle" header.
492	!</PRE>
493	!</DESCRIPTION>
494	IMPLICIT NONE
495	#include "intio_tags.h"
496	INTEGER, INTENT(INOUT) :: hdrbuf(*)
497	INTEGER, INTENT(OUT) :: hdrbufsize
498	INTEGER, INTENT(INOUT) :: itypesize
499	INTEGER ,INTENT(OUT) :: DataHandle, code
500	!Local
501	INTEGER i
502	!
503	hdrbufsize = hdrbuf(1)
504	code = hdrbuf(2)
505	i = 3
506	DataHandle = hdrbuf(i) ; i = i+1
507	RETURN
508	END SUBROUTINE int_get_handle_header
509
510	!!!!!!!!!!!!
511
512	SUBROUTINE int_gen_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
513	DataHandle, Element, Data, Count, code )
514	!<DESCRIPTION>
515	!<PRE>
516	! Items and their starting locations within a "time-independent integer"
517	! data header. Assume that the data header is stored in integer vector
518	! "hdrbuf":
519	! hdrbuf(1) = hdrbufsize
520	! hdrbuf(2) = headerTag
521	! hdrbuf(3) = DataHandle
522	! hdrbuf(4) = typesize
523	! hdrbuf(5) = Count
524	! hdrbuf(6:6+n1) = Data ! n1 = (Count * typesize / itypesize) + 1
525	! hdrbuf(7+n1) = LEN(TRIM(Element))
526	! hdrbuf(8+n1:7+n1+n2) = Element ! n2 = LEN(TRIM(Element)) + 1
527	!
528	! Further details for some items:
529	! hdrbufsize: Size of this data header in bytes.
530	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
531	! header this is. For an "time-independent integer" header it must be
532	! set to int_dom_ti_integer. See file intio_tags.h for a complete
533	! list of these tags.
534	! DataHandle: Descriptor for an open data set.
535	! typesize: Size in bytes of each element of Data.
536	! Count: Number of elements in Data.
537	! Data: Data to write to file.
538	! Element: Name of the data.
539	! Other items are described in detail in the "WRF I/O and Model Coupling API
540	! Specification".
541	!
542	!</PRE>
543	!</DESCRIPTION>
544	IMPLICIT NONE
545	#include "intio_tags.h"
546	INTEGER, INTENT(INOUT) :: hdrbuf(*)
547	INTEGER, INTENT(OUT) :: hdrbufsize
548	INTEGER, INTENT(IN) :: itypesize, typesize
549	CHARACTER(), INTENT(INOUT) :: Element
550	INTEGER, INTENT(IN) :: Data(*)
551	INTEGER, INTENT(IN) :: DataHandle, Count, code
552	!Local
553	INTEGER i, n
554	!
555	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
556	DataHandle, Data, Count, code )
557	i = hdrbufsize/itypesize + 1 ;
558	!write(0,*)'int_gen_ti_header_integer ',TRIM(Element)
559	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
560	hdrbufsize = n * itypesize + hdrbufsize ! return the number in bytes
561	hdrbuf(1) = hdrbufsize
562	RETURN
563	END SUBROUTINE int_gen_ti_header_integer
564
565	SUBROUTINE int_gen_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
566	DataHandle, Element, Data, Count, code )
567	!<DESCRIPTION>
568	!<PRE>
569	! Same as int_gen_ti_header_integer except that Data has type REAL.
570	!</PRE>
571	!</DESCRIPTION>
572	IMPLICIT NONE
573	#include "intio_tags.h"
574	INTEGER, INTENT(INOUT) :: hdrbuf(*)
575	INTEGER, INTENT(OUT) :: hdrbufsize
576	INTEGER, INTENT(IN) :: itypesize, typesize
577	CHARACTER(), INTENT(INOUT) :: Element
578	REAL, INTENT(IN) :: Data(*)
579	INTEGER, INTENT(IN) :: DataHandle, Count, code
580	!Local
581	INTEGER i, n
582	!
583	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
584	DataHandle, Data, Count, code )
585	i = hdrbufsize/itypesize + 1 ;
586	!write(0,*)'int_gen_ti_header_real ',TRIM(Element)
587	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
588	hdrbufsize = n * itypesize + hdrbufsize ! return the number in bytes
589	hdrbuf(1) = hdrbufsize
590	RETURN
591	END SUBROUTINE int_gen_ti_header_real
592
593	SUBROUTINE int_get_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
594	DataHandle, Element, Data, Count, code )
595	!<DESCRIPTION>
596	!<PRE>
597	! Same as int_gen_ti_header_integer except that Data is read from
598	! the file.
599	!</PRE>
600	!</DESCRIPTION>
601	IMPLICIT NONE
602	#include "intio_tags.h"
603	INTEGER, INTENT(INOUT) :: hdrbuf(*)
604	INTEGER, INTENT(OUT) :: hdrbufsize
605	INTEGER, INTENT(IN) :: itypesize, typesize
606	CHARACTER(), INTENT(INOUT) :: Element
607	INTEGER, INTENT(OUT) :: Data(*)
608	INTEGER, INTENT(OUT) :: DataHandle, Count, code
609	!Local
610	INTEGER i, n
611	!
612
613	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
614	DataHandle, Data, Count, code )
615	i = 1
616	CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ;
617	!write(0,*)'int_get_ti_header_integer ',TRIM(Element), Data(1)
618	hdrbufsize = hdrbuf(1)
619	RETURN
620	END SUBROUTINE int_get_ti_header_integer
621
622	SUBROUTINE int_get_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
623	DataHandle, Element, Data, Count, code )
624	!<DESCRIPTION>
625	!<PRE>
626	! Same as int_gen_ti_header_real except that Data is read from
627	! the file.
628	!</PRE>
629	!</DESCRIPTION>
630	IMPLICIT NONE
631	#include "intio_tags.h"
632	INTEGER, INTENT(INOUT) :: hdrbuf(*)
633	INTEGER, INTENT(OUT) :: hdrbufsize
634	INTEGER, INTENT(IN) :: itypesize, typesize
635	CHARACTER(), INTENT(INOUT) :: Element
636	REAL, INTENT(OUT) :: Data(*)
637	INTEGER, INTENT(OUT) :: DataHandle, Count, code
638	!Local
639	INTEGER i, n
640	!
641
642	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
643	DataHandle, Data, Count, code )
644	i = 1
645	CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ;
646	!write(0,*)'int_get_ti_header_real ',TRIM(Element), Data(1)
647	hdrbufsize = hdrbuf(1)
648	RETURN
649	END SUBROUTINE int_get_ti_header_real
650
651	!!!!!!!!!!!!
652
653	SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
654	DataHandle, Element, VarName, Data, code )
655	!<DESCRIPTION>
656	!<PRE>
657	! Items and their starting locations within a "time-independent string"
658	! data header. Assume that the data header is stored in integer vector
659	! "hdrbuf":
660	! hdrbuf(1) = hdrbufsize
661	! hdrbuf(2) = headerTag
662	! hdrbuf(3) = DataHandle
663	! hdrbuf(4) = typesize
664	! hdrbuf(5) = LEN(TRIM(Element))
665	! hdrbuf(6:5+n1) = Element ! n1 = LEN(TRIM(Element)) + 1
666	! hdrbuf(6+n1) = LEN(TRIM(Data))
667	! hdrbuf(7+n1:6+n1+n2) = Data ! n2 = LEN(TRIM(Data)) + 1
668	! hdrbuf(7+n1+n2) = LEN(TRIM(VarName))
669	! hdrbuf(8+n1+n2:7+n1+n2+n3) = VarName ! n3 = LEN(TRIM(VarName)) + 1
670	!
671	! Further details for some items:
672	! hdrbufsize: Size of this data header in bytes.
673	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
674	! header this is. For an "time-independent string" header it must be
675	! set to int_dom_ti_char. See file intio_tags.h for a complete
676	! list of these tags.
677	! DataHandle: Descriptor for an open data set.
678	! typesize: 1 (size in bytes of a single CHARACTER).
679	! Element: Name of the data.
680	! Data: Data to write to file.
681	! VarName: Variable name. Used for *_<get\|put>_var_ti_char but not for
682	! *_<get\|put>_dom_ti_char.
683	! Other items are described in detail in the "WRF I/O and Model Coupling API
684	! Specification".
685	!
686	!</PRE>
687	!</DESCRIPTION>
688	IMPLICIT NONE
689	#include "intio_tags.h"
690	INTEGER, INTENT(INOUT) :: hdrbuf(*)
691	INTEGER, INTENT(OUT) :: hdrbufsize
692	INTEGER, INTENT(IN) :: itypesize
693	CHARACTER(), INTENT(IN) :: Element, Data, VarName
694	INTEGER, INTENT(IN) :: DataHandle, code
695	!Local
696	INTEGER :: DummyData
697	INTEGER i, n, Count, DummyCount
698	!
699	DummyCount = 0
700	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, &
701	DataHandle, DummyData, DummyCount, code )
702	i = hdrbufsize/itypesize+1 ;
703	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
704	CALL int_pack_string ( Data , hdrbuf( i ), n ) ; i = i + n
705	CALL int_pack_string ( VarName , hdrbuf( i ), n ) ; i = i + n
706	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
707	hdrbuf(1) = hdrbufsize
708	RETURN
709	END SUBROUTINE int_gen_ti_header_char
710
711	SUBROUTINE int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
712	DataHandle, Element, VarName, Data, code )
713	!<DESCRIPTION>
714	!<PRE>
715	! Same as int_gen_ti_header_char except that Data is read from
716	! the file.
717	!</PRE>
718	!</DESCRIPTION>
719	IMPLICIT NONE
720	#include "intio_tags.h"
721	INTEGER, INTENT(INOUT) :: hdrbuf(*)
722	INTEGER, INTENT(OUT) :: hdrbufsize
723	INTEGER, INTENT(IN) :: itypesize
724	CHARACTER(), INTENT(INOUT) :: Element, Data, VarName
725	INTEGER, INTENT(OUT) :: DataHandle, code
726	!Local
727	INTEGER i, n, DummyCount, typesize
728	CHARACTER * 132 dummyData
729	!
730	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
731	DataHandle, dummyData, DummyCount, code )
732	i = n/itypesize+1 ;
733	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n
734	CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n
735	CALL int_unpack_string ( VarName , hdrbuf( i ), n ) ; i = i + n
736	hdrbufsize = hdrbuf(1)
737
738	RETURN
739	END SUBROUTINE int_get_ti_header_char
740
741
742	!!!!!!!!!!!!
743
744	SUBROUTINE int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize, &
745	DataHandle, DateStr, Element, Data, code )
746	!<DESCRIPTION>
747	!<PRE>
748	! Items and their starting locations within a "time-dependent string"
749	! data header. Assume that the data header is stored in integer vector
750	! "hdrbuf":
751	! hdrbuf(1) = hdrbufsize
752	! hdrbuf(2) = headerTag
753	! hdrbuf(3) = DataHandle
754	! hdrbuf(4) = typesize
755	! hdrbuf(5) = LEN(TRIM(Element))
756	! hdrbuf(6:5+n1) = Element ! n1 = LEN(TRIM(Element)) + 1
757	! hdrbuf(6+n1) = LEN(TRIM(DateStr))
758	! hdrbuf(7+n1:6+n1+n2) = DateStr ! n2 = LEN(TRIM(DateStr)) + 1
759	! hdrbuf(7+n1+n2) = LEN(TRIM(Data))
760	! hdrbuf(8+n1+n2:7+n1+n2+n3) = Data ! n3 = LEN(TRIM(Data)) + 1
761	!
762	! Further details for some items:
763	! hdrbufsize: Size of this data header in bytes.
764	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
765	! header this is. For an "time-dependent string" header it must be
766	! set to int_dom_td_char. See file intio_tags.h for a complete
767	! list of these tags.
768	! DataHandle: Descriptor for an open data set.
769	! typesize: 1 (size in bytes of a single CHARACTER).
770	! Element: Name of the data.
771	! Data: Data to write to file.
772	! Other items are described in detail in the "WRF I/O and Model Coupling API
773	! Specification".
774	!
775	!</PRE>
776	!</DESCRIPTION>
777	IMPLICIT NONE
778	#include "intio_tags.h"
779	INTEGER, INTENT(INOUT) :: hdrbuf(*)
780	INTEGER, INTENT(OUT) :: hdrbufsize
781	INTEGER, INTENT(IN) :: itypesize
782	CHARACTER(), INTENT(INOUT) :: DateStr, Element, Data
783	INTEGER, INTENT(IN) :: DataHandle, code
784	!Local
785	INTEGER i, n, DummyCount, DummyData
786	!
787	DummyCount = 0
788
789	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, &
790	DataHandle, DummyData, DummyCount, code )
791	i = hdrbufsize/itypesize + 1 ;
792	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
793	CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
794	CALL int_pack_string ( Data , hdrbuf( i ), n ) ; i = i + n
795	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
796	hdrbuf(1) = hdrbufsize
797	RETURN
798	END SUBROUTINE int_gen_td_header_char
799
800	SUBROUTINE int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
801	DataHandle, DateStr, Element, Data, code )
802	!<DESCRIPTION>
803	!<PRE>
804	! Same as int_gen_td_header_char except that Data is read from
805	! the file.
806	!</PRE>
807	!</DESCRIPTION>
808	IMPLICIT NONE
809	#include "intio_tags.h"
810	INTEGER, INTENT(INOUT) :: hdrbuf(*)
811	INTEGER, INTENT(OUT) :: hdrbufsize
812	INTEGER, INTENT(IN) :: itypesize
813	CHARACTER(), INTENT(INOUT) :: DateStr, Element, Data
814	INTEGER, INTENT(OUT) :: DataHandle, code
815	!Local
816	INTEGER i, n, Count, typesize
817	!
818
819	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
820	DataHandle, Data, Count, code )
821	i = n/itypesize + 1 ;
822	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
823	CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
824	CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n ;
825	hdrbufsize = hdrbuf(1)
826	RETURN
827	END SUBROUTINE int_get_td_header_char
828
829	SUBROUTINE int_gen_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
830	DataHandle, DateStr, Element, Data, Count, code )
831	!<DESCRIPTION>
832	!<PRE>
833	! Items and their starting locations within a "time-dependent integer"
834	! data header. Assume that the data header is stored in integer vector
835	! "hdrbuf":
836	! hdrbuf(1) = hdrbufsize
837	! hdrbuf(2) = headerTag
838	! hdrbuf(3) = DataHandle
839	! hdrbuf(4) = typesize
840	! hdrbuf(5) = Count
841	! hdrbuf(6:6+n1) = Data ! n1 = (Count * typesize / itypesize) + 1
842	! hdrbuf(7+n1) = LEN(TRIM(DateStr))
843	! hdrbuf(8+n1:7+n1+n2) = DateStr ! n2 = LEN(TRIM(DateStr)) + 1
844	! hdrbuf(8+n1+n2) = LEN(TRIM(Element))
845	! hdrbuf(9+n1+n2:8+n1+n2+n3) = Element ! n3 = LEN(TRIM(Element)) + 1
846	!
847	! Further details for some items:
848	! hdrbufsize: Size of this data header in bytes.
849	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
850	! header this is. For an "time-dependent integer" header it must be
851	! set to int_dom_td_integer. See file intio_tags.h for a complete
852	! list of these tags.
853	! DataHandle: Descriptor for an open data set.
854	! typesize: 1 (size in bytes of a single CHARACTER).
855	! Element: Name of the data.
856	! Count: Number of elements in Data.
857	! Data: Data to write to file.
858	! Other items are described in detail in the "WRF I/O and Model Coupling API
859	! Specification".
860	!
861	!</PRE>
862	!</DESCRIPTION>
863	IMPLICIT NONE
864	#include "intio_tags.h"
865	INTEGER, INTENT(INOUT) :: hdrbuf(*)
866	INTEGER, INTENT(OUT) :: hdrbufsize
867	INTEGER, INTENT(IN) :: itypesize, typesize
868	CHARACTER(), INTENT(INOUT) :: DateStr, Element
869	INTEGER, INTENT(IN) :: Data(*)
870	INTEGER, INTENT(IN) :: DataHandle, Count, code
871	!Local
872	INTEGER i, n
873	!
874
875	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
876	DataHandle, Data, Count, code )
877	i = hdrbufsize/itypesize + 1 ;
878	CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
879	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
880	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
881	hdrbuf(1) = hdrbufsize
882	RETURN
883	END SUBROUTINE int_gen_td_header_integer
884
885	SUBROUTINE int_gen_td_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
886	DataHandle, DateStr, Element, Data, Count, code )
887	!<DESCRIPTION>
888	!<PRE>
889	! Same as int_gen_td_header_integer except that Data has type REAL.
890	!</PRE>
891	!</DESCRIPTION>
892	IMPLICIT NONE
893	#include "intio_tags.h"
894	INTEGER, INTENT(INOUT) :: hdrbuf(*)
895	INTEGER, INTENT(OUT) :: hdrbufsize
896	INTEGER, INTENT(IN) :: itypesize, typesize
897	CHARACTER(), INTENT(INOUT) :: DateStr, Element
898	REAL, INTENT(IN) :: Data(*)
899	INTEGER, INTENT(IN) :: DataHandle, Count, code
900	!Local
901	INTEGER i, n
902	!
903
904	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
905	DataHandle, Data, Count, code )
906	i = hdrbufsize/itypesize + 1 ;
907	CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
908	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
909	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
910	hdrbuf(1) = hdrbufsize
911	RETURN
912	END SUBROUTINE int_gen_td_header_real
913
914	SUBROUTINE int_get_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
915	DataHandle, DateStr, Element, Data, Count, code )
916	!<DESCRIPTION>
917	!<PRE>
918	! Same as int_gen_td_header_integer except that Data is read from
919	! the file.
920	!</PRE>
921	!</DESCRIPTION>
922	IMPLICIT NONE
923	#include "intio_tags.h"
924	INTEGER, INTENT(INOUT) :: hdrbuf(*)
925	INTEGER, INTENT(OUT) :: hdrbufsize
926	INTEGER, INTENT(IN) :: itypesize, typesize
927	CHARACTER(), INTENT(INOUT) :: DateStr, Element
928	INTEGER, INTENT(OUT) :: Data(*)
929	INTEGER, INTENT(OUT) :: DataHandle, Count, code
930	!Local
931	INTEGER i, n
932	!
933
934	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
935	DataHandle, Data, Count, code )
936	i = n/itypesize + 1 ;
937	CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
938	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
939	hdrbufsize = hdrbuf(1)
940	RETURN
941	END SUBROUTINE int_get_td_header_integer
942
943	SUBROUTINE int_get_td_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
944	DataHandle, DateStr, Element, Data, Count, code )
945	!<DESCRIPTION>
946	!<PRE>
947	! Same as int_gen_td_header_real except that Data is read from
948	! the file.
949	!</PRE>
950	!</DESCRIPTION>
951	IMPLICIT NONE
952	#include "intio_tags.h"
953	INTEGER, INTENT(INOUT) :: hdrbuf(*)
954	INTEGER, INTENT(OUT) :: hdrbufsize
955	INTEGER, INTENT(IN) :: itypesize, typesize
956	CHARACTER(), INTENT(INOUT) :: DateStr, Element
957	REAL , INTENT(OUT) :: Data(*)
958	INTEGER, INTENT(OUT) :: DataHandle, Count, code
959	!Local
960	INTEGER i, n
961	!
962
963	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
964	DataHandle, Data, Count, code )
965	i = n/itypesize + 1 ;
966	CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
967	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
968	hdrbufsize = hdrbuf(1)
969	RETURN
970	END SUBROUTINE int_get_td_header_real
971
972	!!!!!!!!!!!!!!
973
974	SUBROUTINE int_gen_noop_header ( hdrbuf, hdrbufsize, itypesize )
975	IMPLICIT NONE
976	!<DESCRIPTION>
977	!<PRE>
978	! Items and their starting locations within a "no-operation"
979	! data header. Assume that the data header is stored in integer vector
980	! "hdrbuf":
981	! hdrbuf(1) = hdrbufsize
982	! hdrbuf(2) = headerTag
983	!
984	! Further details for some items:
985	! hdrbufsize: Size of this data header in bytes.
986	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
987	! header this is. For an "no-operation" header it must be
988	! set to int_noop. See file intio_tags.h for a complete
989	! list of these tags.
990	!
991	!</PRE>
992	!</DESCRIPTION>
993	#include "intio_tags.h"
994	INTEGER, INTENT(INOUT) :: hdrbuf(*)
995	INTEGER, INTENT(OUT) :: hdrbufsize
996	INTEGER, INTENT(INOUT) :: itypesize
997	!Local
998	INTEGER i
999	!
1000	hdrbuf(1) = 0 !deferred
1001	hdrbuf(2) = int_noop
1002	i = 3
1003	hdrbufsize = (i-1) * itypesize ! return the number in bytes
1004	hdrbuf(1) = hdrbufsize
1005	RETURN
1006	END SUBROUTINE int_gen_noop_header
1007
1008	SUBROUTINE int_get_noop_header( hdrbuf, hdrbufsize, itypesize )
1009	!<DESCRIPTION>
1010	!<PRE>
1011	! See documentation block in int_gen_noop_header() for
1012	! a description of a "no-operation" header.
1013	!</PRE>
1014	!</DESCRIPTION>
1015	IMPLICIT NONE
1016	#include "intio_tags.h"
1017	INTEGER, INTENT(INOUT) :: hdrbuf(*)
1018	INTEGER, INTENT(OUT) :: hdrbufsize
1019	INTEGER, INTENT(INOUT) :: itypesize
1020	!Local
1021	INTEGER i
1022	!
1023	hdrbufsize = hdrbuf(1)
1024	IF ( hdrbuf(2) .NE. int_noop ) THEN
1025	CALL wrf_error_fatal ( "int_get_noop_header: hdrbuf ne int_noop")
1026	ENDIF
1027	i = 3
1028	RETURN
1029	END SUBROUTINE int_get_noop_header
1030
1031
1032	! first int is length of string to follow then string encodes as ints
1033	SUBROUTINE int_pack_string ( str, buf, n )
1034	IMPLICIT NONE
1035	!<DESCRIPTION>
1036	!<PRE>
1037	! This routine is used to store a string as a sequence of integers.
1038	! The first integer is the string length.
1039	!</PRE>
1040	!</DESCRIPTION>
1041	CHARACTER(), INTENT(IN) :: str
1042	INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints stored in buf
1043	INTEGER, INTENT(OUT), DIMENSION(*) :: buf
1044	!Local
1045	INTEGER i
1046	!
1047	n = 1
1048	buf(n) = LEN(TRIM(str))
1049	n = n+1
1050	DO i = 1, LEN(TRIM(str))
1051	buf(n) = ichar(str(i:i))
1052	n = n+1
1053	ENDDO
1054	n = n - 1
1055	END SUBROUTINE int_pack_string
1056
1057	SUBROUTINE int_unpack_string ( str, buf, n )
1058	IMPLICIT NONE
1059	!<DESCRIPTION>
1060	!<PRE>
1061	! This routine is used to extract a string from a sequence of integers.
1062	! The first integer is the string length.
1063	!</PRE>
1064	!</DESCRIPTION>
1065	CHARACTER(), INTENT(OUT) :: str
1066	INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints copied from buf
1067	INTEGER, INTENT(IN), DIMENSION(*) :: buf
1068	!Local
1069	INTEGER i
1070	INTEGER strlen
1071
1072	strlen = buf(1)
1073	str = ""
1074	DO i = 1, strlen
1075	str(i:i) = char(buf(i+1))
1076	ENDDO
1077	n = strlen + 1
1078	END SUBROUTINE int_unpack_string
1079
1080	END MODULE module_internal_header_util
1081

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

Download in other formats:

Original Format