module_internal_header_util.F
References to this file elsewhere.
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