Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_internal_header_util.F @ 1

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

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 43.2 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_integer_varname( hdrbuf, hdrbufsize, itypesize, typesize, &
566	DataHandle, Element, VarName, Data, Count, code )
567	!<DESCRIPTION>
568	!<PRE>
569	! Items and their starting locations within a "time-independent integer"
570	! data header. Assume that the data header is stored in integer vector
571	! "hdrbuf":
572	! hdrbuf(1) = hdrbufsize
573	! hdrbuf(2) = headerTag
574	! hdrbuf(3) = DataHandle
575	! hdrbuf(4) = typesize
576	! hdrbuf(5) = Count
577	! hdrbuf(6:6+n1) = Data ! n1 = (Count * typesize / itypesize) + 1
578	! hdrbuf(7+n1) = LEN(TRIM(Element))
579	! hdrbuf(8+n1:7+n1+n2) = Element ! n2 = LEN(TRIM(Element)) + 1
580	! hdrbuf(8+n1+n2) = LEN(TRIM(VarName)) = n3
581	! hderbuf(9+n1+n2:8+n1+n2+n3) = TRIM(VarName)
582	!
583	! Further details for some items:
584	! hdrbufsize: Size of this data header in bytes.
585	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
586	! header this is. For an "time-independent integer" header it must be
587	! set to int_dom_ti_integer. See file intio_tags.h for a complete
588	! list of these tags.
589	! DataHandle: Descriptor for an open data set.
590	! typesize: Size in bytes of each element of Data.
591	! Count: Number of elements in Data.
592	! Data: Data to write to file.
593	! Element: Name of the data.
594	! VarName: Variable name. Used for *_<get\|put>_var_ti_char but not for
595	! *_<get\|put>_dom_ti_char.
596	! Other items are described in detail in the "WRF I/O and Model Coupling API
597	! Specification".
598	!
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(IN) :: Element, VarName
607	INTEGER, INTENT(IN) :: Data(*)
608	INTEGER, INTENT(IN) :: DataHandle, Count, code
609	!Local
610	INTEGER i, n
611	!
612	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
613	DataHandle, Data, Count, code )
614	i = hdrbufsize/itypesize + 1 ;
615	!write(0,*)'int_gen_ti_header_integer ',TRIM(Element)
616	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
617	CALL int_pack_string ( VarName, hdrbuf( i ), n ) ; i = i + n
618	hdrbufsize = i * itypesize + hdrbufsize ! return the number in bytes
619	hdrbuf(1) = hdrbufsize
620	RETURN
621	END SUBROUTINE int_gen_ti_header_integer_varname
622
623	SUBROUTINE int_gen_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
624	DataHandle, Element, Data, Count, code )
625	!<DESCRIPTION>
626	!<PRE>
627	! Same as int_gen_ti_header_integer except that Data has type REAL.
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(IN) :: Data(*)
637	INTEGER, INTENT(IN) :: DataHandle, Count, code
638	!Local
639	INTEGER i, n
640	!
641	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
642	DataHandle, Data, Count, code )
643	i = hdrbufsize/itypesize + 1 ;
644	!write(0,*)'int_gen_ti_header_real ',TRIM(Element)
645	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
646	hdrbufsize = n * itypesize + hdrbufsize ! return the number in bytes
647	hdrbuf(1) = hdrbufsize
648	RETURN
649	END SUBROUTINE int_gen_ti_header_real
650
651	SUBROUTINE int_get_ti_header_integer_varname( hdrbuf, hdrbufsize, itypesize, typesize, &
652	DataHandle, Element, VarName, Data, Count, code)
653	!<DESCRIPTION>
654	!<PRE>
655	! Same as int_gen_ti_header_integer except that Data is read from
656	! the file.
657	!</PRE>
658	!</DESCRIPTION>
659	IMPLICIT NONE
660	#include "intio_tags.h"
661	INTEGER, INTENT(INOUT) :: hdrbuf(*)
662	INTEGER, INTENT(OUT) :: hdrbufsize
663	INTEGER, INTENT(IN) :: itypesize, typesize
664	CHARACTER(), INTENT(INOUT) :: Element, VarName
665	INTEGER, INTENT(OUT) :: Data(*)
666	INTEGER, INTENT(OUT) :: DataHandle, Count, code
667	!Local
668	INTEGER i, n
669	!
670
671	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
672	DataHandle, Data, Count, code )
673	i = n/itypesize + 1
674	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i=i+n;
675	CALL int_unpack_string ( VarName, hdrbuf( i ), n ) ; i = i + n
676	! write(0,*)'int_get_ti_header_integer_varname "', &
677	! TRIM(Element),'" "', TRIM(VarName),'" data(1)=',Data(1)
678	hdrbufsize = hdrbuf(1)
679	RETURN
680	END SUBROUTINE int_get_ti_header_integer_varname
681
682	SUBROUTINE int_get_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
683	DataHandle, Element, Data, Count, code )
684	!<DESCRIPTION>
685	!<PRE>
686	! Same as int_gen_ti_header_integer except that Data is read from
687	! the file.
688	!</PRE>
689	!</DESCRIPTION>
690	IMPLICIT NONE
691	#include "intio_tags.h"
692	INTEGER, INTENT(INOUT) :: hdrbuf(*)
693	INTEGER, INTENT(OUT) :: hdrbufsize
694	INTEGER, INTENT(IN) :: itypesize, typesize
695	CHARACTER(), INTENT(INOUT) :: Element
696	INTEGER, INTENT(OUT) :: Data(*)
697	INTEGER, INTENT(OUT) :: DataHandle, Count, code
698	!Local
699	INTEGER i, n
700	!
701
702	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
703	DataHandle, Data, Count, code )
704	i = 1
705	CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ;
706	!write(0,*)'int_get_ti_header_integer ',TRIM(Element), Data(1)
707	hdrbufsize = hdrbuf(1)
708	RETURN
709	END SUBROUTINE int_get_ti_header_integer
710
711	SUBROUTINE int_get_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
712	DataHandle, Element, Data, Count, code )
713	!<DESCRIPTION>
714	!<PRE>
715	! Same as int_gen_ti_header_real 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, typesize
724	CHARACTER(), INTENT(INOUT) :: Element
725	REAL, INTENT(OUT) :: Data(*)
726	INTEGER, INTENT(OUT) :: DataHandle, Count, code
727	!Local
728	INTEGER i, n
729	!
730
731	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
732	DataHandle, Data, Count, code )
733	i = 1
734	CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ;
735	!write(0,*)'int_get_ti_header_real ',TRIM(Element), Data(1)
736	hdrbufsize = hdrbuf(1)
737	RETURN
738	END SUBROUTINE int_get_ti_header_real
739
740	!!!!!!!!!!!!
741
742	SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
743	DataHandle, Element, VarName, Data, code )
744	!<DESCRIPTION>
745	!<PRE>
746	! Items and their starting locations within a "time-independent string"
747	! data header. Assume that the data header is stored in integer vector
748	! "hdrbuf":
749	! hdrbuf(1) = hdrbufsize
750	! hdrbuf(2) = headerTag
751	! hdrbuf(3) = DataHandle
752	! hdrbuf(4) = typesize
753	! hdrbuf(5) = LEN(TRIM(Element))
754	! hdrbuf(6:5+n1) = Element ! n1 = LEN(TRIM(Element)) + 1
755	! hdrbuf(6+n1) = LEN(TRIM(Data))
756	! hdrbuf(7+n1:6+n1+n2) = Data ! n2 = LEN(TRIM(Data)) + 1
757	! hdrbuf(7+n1+n2) = LEN(TRIM(VarName))
758	! hdrbuf(8+n1+n2:7+n1+n2+n3) = VarName ! n3 = LEN(TRIM(VarName)) + 1
759	!
760	! Further details for some items:
761	! hdrbufsize: Size of this data header in bytes.
762	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
763	! header this is. For an "time-independent string" header it must be
764	! set to int_dom_ti_char. See file intio_tags.h for a complete
765	! list of these tags.
766	! DataHandle: Descriptor for an open data set.
767	! typesize: 1 (size in bytes of a single CHARACTER).
768	! Element: Name of the data.
769	! Data: Data to write to file.
770	! VarName: Variable name. Used for *_<get\|put>_var_ti_char but not for
771	! *_<get\|put>_dom_ti_char.
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(IN) :: Element, Data, VarName
783	INTEGER, INTENT(IN) :: DataHandle, code
784	!Local
785	INTEGER :: DummyData
786	INTEGER i, n, Count, DummyCount
787	!
788	DummyCount = 0
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 ( Data , hdrbuf( i ), n ) ; i = i + n
794	CALL int_pack_string ( VarName , 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_ti_header_char
799
800	SUBROUTINE int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
801	DataHandle, Element, VarName, Data, code )
802	!<DESCRIPTION>
803	!<PRE>
804	! Same as int_gen_ti_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) :: Element, Data, VarName
814	INTEGER, INTENT(OUT) :: DataHandle, code
815	!Local
816	INTEGER i, n, DummyCount, typesize
817	CHARACTER * 132 dummyData
818	!
819	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
820	DataHandle, dummyData, DummyCount, code )
821	i = n/itypesize+1 ;
822	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n
823	CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n
824	CALL int_unpack_string ( VarName , hdrbuf( i ), n ) ; i = i + n
825	hdrbufsize = hdrbuf(1)
826
827	RETURN
828	END SUBROUTINE int_get_ti_header_char
829
830
831	!!!!!!!!!!!!
832
833	SUBROUTINE int_gen_td_header_char( hdrbuf, hdrbufsize, itypesize, &
834	DataHandle, DateStr, Element, Data, code )
835	!<DESCRIPTION>
836	!<PRE>
837	! Items and their starting locations within a "time-dependent string"
838	! data header. Assume that the data header is stored in integer vector
839	! "hdrbuf":
840	! hdrbuf(1) = hdrbufsize
841	! hdrbuf(2) = headerTag
842	! hdrbuf(3) = DataHandle
843	! hdrbuf(4) = typesize
844	! hdrbuf(5) = LEN(TRIM(Element))
845	! hdrbuf(6:5+n1) = Element ! n1 = LEN(TRIM(Element)) + 1
846	! hdrbuf(6+n1) = LEN(TRIM(DateStr))
847	! hdrbuf(7+n1:6+n1+n2) = DateStr ! n2 = LEN(TRIM(DateStr)) + 1
848	! hdrbuf(7+n1+n2) = LEN(TRIM(Data))
849	! hdrbuf(8+n1+n2:7+n1+n2+n3) = Data ! n3 = LEN(TRIM(Data)) + 1
850	!
851	! Further details for some items:
852	! hdrbufsize: Size of this data header in bytes.
853	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
854	! header this is. For an "time-dependent string" header it must be
855	! set to int_dom_td_char. See file intio_tags.h for a complete
856	! list of these tags.
857	! DataHandle: Descriptor for an open data set.
858	! typesize: 1 (size in bytes of a single CHARACTER).
859	! Element: Name of the data.
860	! Data: Data to write to file.
861	! Other items are described in detail in the "WRF I/O and Model Coupling API
862	! Specification".
863	!
864	!</PRE>
865	!</DESCRIPTION>
866	IMPLICIT NONE
867	#include "intio_tags.h"
868	INTEGER, INTENT(INOUT) :: hdrbuf(*)
869	INTEGER, INTENT(OUT) :: hdrbufsize
870	INTEGER, INTENT(IN) :: itypesize
871	CHARACTER(), INTENT(INOUT) :: DateStr, Element, Data
872	INTEGER, INTENT(IN) :: DataHandle, code
873	!Local
874	INTEGER i, n, DummyCount, DummyData
875	!
876	DummyCount = 0
877
878	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, &
879	DataHandle, DummyData, DummyCount, code )
880	i = hdrbufsize/itypesize + 1 ;
881	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
882	CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
883	CALL int_pack_string ( Data , hdrbuf( i ), n ) ; i = i + n
884	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
885	hdrbuf(1) = hdrbufsize
886	RETURN
887	END SUBROUTINE int_gen_td_header_char
888
889	SUBROUTINE int_get_td_header_char( hdrbuf, hdrbufsize, itypesize, &
890	DataHandle, DateStr, Element, Data, code )
891	!<DESCRIPTION>
892	!<PRE>
893	! Same as int_gen_td_header_char except that Data is read from
894	! the file.
895	!</PRE>
896	!</DESCRIPTION>
897	IMPLICIT NONE
898	#include "intio_tags.h"
899	INTEGER, INTENT(INOUT) :: hdrbuf(*)
900	INTEGER, INTENT(OUT) :: hdrbufsize
901	INTEGER, INTENT(IN) :: itypesize
902	CHARACTER(), INTENT(INOUT) :: DateStr, Element, Data
903	INTEGER, INTENT(OUT) :: DataHandle, code
904	!Local
905	INTEGER i, n, Count, typesize
906	!
907
908	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
909	DataHandle, Data, Count, code )
910	i = n/itypesize + 1 ;
911	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
912	CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
913	CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n ;
914	hdrbufsize = hdrbuf(1)
915	RETURN
916	END SUBROUTINE int_get_td_header_char
917
918	SUBROUTINE int_gen_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
919	DataHandle, DateStr, Element, Data, Count, code )
920	!<DESCRIPTION>
921	!<PRE>
922	! Items and their starting locations within a "time-dependent integer"
923	! data header. Assume that the data header is stored in integer vector
924	! "hdrbuf":
925	! hdrbuf(1) = hdrbufsize
926	! hdrbuf(2) = headerTag
927	! hdrbuf(3) = DataHandle
928	! hdrbuf(4) = typesize
929	! hdrbuf(5) = Count
930	! hdrbuf(6:6+n1) = Data ! n1 = (Count * typesize / itypesize) + 1
931	! hdrbuf(7+n1) = LEN(TRIM(DateStr))
932	! hdrbuf(8+n1:7+n1+n2) = DateStr ! n2 = LEN(TRIM(DateStr)) + 1
933	! hdrbuf(8+n1+n2) = LEN(TRIM(Element))
934	! hdrbuf(9+n1+n2:8+n1+n2+n3) = Element ! n3 = LEN(TRIM(Element)) + 1
935	!
936	! Further details for some items:
937	! hdrbufsize: Size of this data header in bytes.
938	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
939	! header this is. For an "time-dependent integer" header it must be
940	! set to int_dom_td_integer. See file intio_tags.h for a complete
941	! list of these tags.
942	! DataHandle: Descriptor for an open data set.
943	! typesize: 1 (size in bytes of a single CHARACTER).
944	! Element: Name of the data.
945	! Count: Number of elements in Data.
946	! Data: Data to write to file.
947	! Other items are described in detail in the "WRF I/O and Model Coupling API
948	! Specification".
949	!
950	!</PRE>
951	!</DESCRIPTION>
952	IMPLICIT NONE
953	#include "intio_tags.h"
954	INTEGER, INTENT(INOUT) :: hdrbuf(*)
955	INTEGER, INTENT(OUT) :: hdrbufsize
956	INTEGER, INTENT(IN) :: itypesize, typesize
957	CHARACTER(), INTENT(INOUT) :: DateStr, Element
958	INTEGER, INTENT(IN) :: Data(*)
959	INTEGER, INTENT(IN) :: DataHandle, Count, code
960	!Local
961	INTEGER i, n
962	!
963
964	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
965	DataHandle, Data, Count, code )
966	i = hdrbufsize/itypesize + 1 ;
967	CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
968	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
969	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
970	hdrbuf(1) = hdrbufsize
971	RETURN
972	END SUBROUTINE int_gen_td_header_integer
973
974	SUBROUTINE int_gen_td_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
975	DataHandle, DateStr, Element, Data, Count, code )
976	!<DESCRIPTION>
977	!<PRE>
978	! Same as int_gen_td_header_integer except that Data has type REAL.
979	!</PRE>
980	!</DESCRIPTION>
981	IMPLICIT NONE
982	#include "intio_tags.h"
983	INTEGER, INTENT(INOUT) :: hdrbuf(*)
984	INTEGER, INTENT(OUT) :: hdrbufsize
985	INTEGER, INTENT(IN) :: itypesize, typesize
986	CHARACTER(), INTENT(INOUT) :: DateStr, Element
987	REAL, INTENT(IN) :: Data(*)
988	INTEGER, INTENT(IN) :: DataHandle, Count, code
989	!Local
990	INTEGER i, n
991	!
992
993	CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
994	DataHandle, Data, Count, code )
995	i = hdrbufsize/itypesize + 1 ;
996	CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
997	CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
998	hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
999	hdrbuf(1) = hdrbufsize
1000	RETURN
1001	END SUBROUTINE int_gen_td_header_real
1002
1003	SUBROUTINE int_get_td_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
1004	DataHandle, DateStr, Element, Data, Count, code )
1005	!<DESCRIPTION>
1006	!<PRE>
1007	! Same as int_gen_td_header_integer except that Data is read from
1008	! the file.
1009	!</PRE>
1010	!</DESCRIPTION>
1011	IMPLICIT NONE
1012	#include "intio_tags.h"
1013	INTEGER, INTENT(INOUT) :: hdrbuf(*)
1014	INTEGER, INTENT(OUT) :: hdrbufsize
1015	INTEGER, INTENT(IN) :: itypesize, typesize
1016	CHARACTER(), INTENT(INOUT) :: DateStr, Element
1017	INTEGER, INTENT(OUT) :: Data(*)
1018	INTEGER, INTENT(OUT) :: DataHandle, Count, code
1019	!Local
1020	INTEGER i, n
1021	!
1022
1023	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
1024	DataHandle, Data, Count, code )
1025	i = n/itypesize + 1 ;
1026	CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
1027	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
1028	hdrbufsize = hdrbuf(1)
1029	RETURN
1030	END SUBROUTINE int_get_td_header_integer
1031
1032	SUBROUTINE int_get_td_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
1033	DataHandle, DateStr, Element, Data, Count, code )
1034	!<DESCRIPTION>
1035	!<PRE>
1036	! Same as int_gen_td_header_real except that Data is read from
1037	! the file.
1038	!</PRE>
1039	!</DESCRIPTION>
1040	IMPLICIT NONE
1041	#include "intio_tags.h"
1042	INTEGER, INTENT(INOUT) :: hdrbuf(*)
1043	INTEGER, INTENT(OUT) :: hdrbufsize
1044	INTEGER, INTENT(IN) :: itypesize, typesize
1045	CHARACTER(), INTENT(INOUT) :: DateStr, Element
1046	REAL , INTENT(OUT) :: Data(*)
1047	INTEGER, INTENT(OUT) :: DataHandle, Count, code
1048	!Local
1049	INTEGER i, n
1050	!
1051
1052	CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
1053	DataHandle, Data, Count, code )
1054	i = n/itypesize + 1 ;
1055	CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
1056	CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
1057	hdrbufsize = hdrbuf(1)
1058	RETURN
1059	END SUBROUTINE int_get_td_header_real
1060
1061	!!!!!!!!!!!!!!
1062
1063	SUBROUTINE int_gen_noop_header ( hdrbuf, hdrbufsize, itypesize )
1064	IMPLICIT NONE
1065	!<DESCRIPTION>
1066	!<PRE>
1067	! Items and their starting locations within a "no-operation"
1068	! data header. Assume that the data header is stored in integer vector
1069	! "hdrbuf":
1070	! hdrbuf(1) = hdrbufsize
1071	! hdrbuf(2) = headerTag
1072	!
1073	! Further details for some items:
1074	! hdrbufsize: Size of this data header in bytes.
1075	! headerTag: "Header tag" that tells the I/O quilt servers what kind of
1076	! header this is. For an "no-operation" header it must be
1077	! set to int_noop. See file intio_tags.h for a complete
1078	! list of these tags.
1079	!
1080	!</PRE>
1081	!</DESCRIPTION>
1082	#include "intio_tags.h"
1083	INTEGER, INTENT(INOUT) :: hdrbuf(*)
1084	INTEGER, INTENT(OUT) :: hdrbufsize
1085	INTEGER, INTENT(INOUT) :: itypesize
1086	!Local
1087	INTEGER i
1088	!
1089	hdrbuf(1) = 0 !deferred
1090	hdrbuf(2) = int_noop
1091	i = 3
1092	hdrbufsize = (i-1) * itypesize ! return the number in bytes
1093	hdrbuf(1) = hdrbufsize
1094	RETURN
1095	END SUBROUTINE int_gen_noop_header
1096
1097	SUBROUTINE int_get_noop_header( hdrbuf, hdrbufsize, itypesize )
1098	!<DESCRIPTION>
1099	!<PRE>
1100	! See documentation block in int_gen_noop_header() for
1101	! a description of a "no-operation" header.
1102	!</PRE>
1103	!</DESCRIPTION>
1104	IMPLICIT NONE
1105	#include "intio_tags.h"
1106	INTEGER, INTENT(INOUT) :: hdrbuf(*)
1107	INTEGER, INTENT(OUT) :: hdrbufsize
1108	INTEGER, INTENT(INOUT) :: itypesize
1109	!Local
1110	INTEGER i
1111	!
1112	hdrbufsize = hdrbuf(1)
1113	IF ( hdrbuf(2) .NE. int_noop ) THEN
1114	CALL wrf_error_fatal ( "int_get_noop_header: hdrbuf ne int_noop")
1115	ENDIF
1116	i = 3
1117	RETURN
1118	END SUBROUTINE int_get_noop_header
1119
1120
1121	! first int is length of string to follow then string encodes as ints
1122	SUBROUTINE int_pack_string ( str, buf, n )
1123	IMPLICIT NONE
1124	!<DESCRIPTION>
1125	!<PRE>
1126	! This routine is used to store a string as a sequence of integers.
1127	! The first integer is the string length.
1128	!</PRE>
1129	!</DESCRIPTION>
1130	CHARACTER(), INTENT(IN) :: str
1131	INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints stored in buf
1132	INTEGER, INTENT(OUT), DIMENSION(*) :: buf
1133	!Local
1134	INTEGER i
1135	!
1136	n = 1
1137	buf(n) = LEN(TRIM(str))
1138	n = n+1
1139	DO i = 1, LEN(TRIM(str))
1140	buf(n) = ichar(str(i:i))
1141	n = n+1
1142	ENDDO
1143	n = n - 1
1144	END SUBROUTINE int_pack_string
1145
1146	SUBROUTINE int_unpack_string ( str, buf, n )
1147	IMPLICIT NONE
1148	!<DESCRIPTION>
1149	!<PRE>
1150	! This routine is used to extract a string from a sequence of integers.
1151	! The first integer is the string length.
1152	!</PRE>
1153	!</DESCRIPTION>
1154	CHARACTER(), INTENT(OUT) :: str
1155	INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints copied from buf
1156	INTEGER, INTENT(IN), DIMENSION(*) :: buf
1157	!Local
1158	INTEGER i
1159	INTEGER strlen
1160
1161	strlen = buf(1)
1162	str = ""
1163	DO i = 1, strlen
1164	str(i:i) = char(buf(i+1))
1165	ENDDO
1166	n = strlen + 1
1167	END SUBROUTINE int_unpack_string
1168
1169	END MODULE module_internal_header_util
1170

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

Download in other formats:

Original Format