internal_header_util.F
References to this file elsewhere.
1 !!!!!!!!!!!!! header manipulation routines !!!!!!!!!!!!!!!
2
3 INTEGER FUNCTION get_hdr_tag( hdrbuf )
4 IMPLICIT NONE
5 INTEGER, INTENT(IN) :: hdrbuf(*)
6 get_hdr_tag = hdrbuf(2)
7 RETURN
8 END FUNCTION get_hdr_tag
9
10 SUBROUTINE int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize, &
11 DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
12 DomainDesc , MemoryOrder , Stagger , DimNames , &
13 DomainStart , DomainEnd , &
14 MemoryStart , MemoryEnd , &
15 PatchStart , PatchEnd )
16 IMPLICIT NONE
17 #include "intio_tags.h"
18 INTEGER, INTENT(INOUT) :: hdrbuf(*)
19 INTEGER, INTENT(INOUT) :: hdrbufsize
20 INTEGER, INTENT(INOUT) :: itypesize, ftypesize
21
22 INTEGER , INTENT(IN) :: DataHandle
23 CHARACTER*(*) :: DateStr
24 CHARACTER*(*) :: VarName
25 integer :: dummy
26 integer ,intent(in) :: FieldType
27 integer ,intent(inout) :: Comm
28 integer ,intent(inout) :: IOComm
29 integer ,intent(in) :: DomainDesc
30 character*(*) ,intent(in) :: MemoryOrder
31 character*(*) ,intent(in) :: Stagger
32 character*(*) , dimension (*) ,intent(in) :: DimNames
33 integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
34 integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
35 integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
36
37 INTEGER i, n
38
39 hdrbuf(1) = 0 ! deferred -- this will be length of header
40 hdrbuf(2) = int_field
41 hdrbuf(3) = ftypesize
42
43 i = 4
44 hdrbuf(i) = DataHandle ; i = i+1
45 call int_pack_string( DateStr, hdrbuf(i), n ) ; i = i + n
46 call int_pack_string( VarName, hdrbuf(i), n ) ; i = i + n
47 hdrbuf(i) = FieldType ; i = i+1
48 call int_pack_string( MemoryOrder, hdrbuf(i), n ) ; i = i + n
49 call int_pack_string( Stagger, hdrbuf(i), n ) ; i = i + n
50 call int_pack_string( DimNames(1), hdrbuf(i), n ) ; i = i + n
51 call int_pack_string( DimNames(2), hdrbuf(i), n ) ; i = i + n
52 call int_pack_string( DimNames(3), hdrbuf(i), n ) ; i = i + n
53 hdrbuf(i) = DomainStart(1) ; i = i+1
54 hdrbuf(i) = DomainStart(2) ; i = i+1
55 hdrbuf(i) = DomainStart(3) ; i = i+1
56 hdrbuf(i) = DomainEnd(1) ; i = i+1
57 hdrbuf(i) = DomainEnd(2) ; i = i+1
58 hdrbuf(i) = DomainEnd(3) ; i = i+1
59 hdrbuf(i) = PatchStart(1) ; i = i+1
60 hdrbuf(i) = PatchStart(2) ; i = i+1
61 hdrbuf(i) = PatchStart(3) ; i = i+1
62 hdrbuf(i) = PatchEnd(1) ; i = i+1
63 hdrbuf(i) = PatchEnd(2) ; i = i+1
64 hdrbuf(i) = PatchEnd(3) ; i = i+1
65
66 hdrbufsize = (i-1) * itypesize ! return the number in bytes
67 hdrbuf(1) = hdrbufsize
68
69 RETURN
70 END SUBROUTINE int_gen_write_field_header
71
72
73 SUBROUTINE int_get_write_field_header ( hdrbuf, hdrbufsize, itypesize, ftypesize, &
74 DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
75 DomainDesc , MemoryOrder , Stagger , DimNames , &
76 DomainStart , DomainEnd , &
77 MemoryStart , MemoryEnd , &
78 PatchStart , PatchEnd )
79 IMPLICIT NONE
80 #include "intio_tags.h"
81 INTEGER, INTENT(INOUT) :: hdrbuf(*)
82 INTEGER, INTENT(OUT) :: hdrbufsize
83 INTEGER, INTENT(INOUT) :: itypesize, ftypesize
84
85 INTEGER , INTENT(OUT) :: DataHandle
86 CHARACTER*(*) :: DateStr
87 CHARACTER*(*) :: VarName
88 integer :: dummy
89 integer :: FieldType
90 integer :: Comm
91 integer :: IOComm
92 integer :: DomainDesc
93 character*(*) :: MemoryOrder
94 character*(*) :: Stagger
95 character*(*) , dimension (*) :: DimNames
96 integer ,dimension(*) :: DomainStart, DomainEnd
97 integer ,dimension(*) :: MemoryStart, MemoryEnd
98 integer ,dimension(*) :: PatchStart, PatchEnd
99 character*132 mess
100
101 INTEGER i, n
102
103 hdrbufsize = hdrbuf(1)
104 IF ( hdrbuf(2) .NE. int_field ) THEN
105 write(mess,*)'int_get_write_field_header: hdrbuf(2) ne int_field ',hdrbuf(2),int_field
106 CALL wrf_error_fatal ( mess )
107 ENDIF
108 ftypesize = hdrbuf(3)
109
110 i = 4
111 DataHandle = hdrbuf(i) ; i = i+1
112 call int_unpack_string( DateStr, hdrbuf(i), n ) ; i = i+n
113 call int_unpack_string( VarName, hdrbuf(i), n ) ; i = i+n
114 FieldType = hdrbuf(i) ; i = i+1
115 call int_unpack_string( MemoryOrder, hdrbuf(i), n ) ; i = i+n
116 call int_unpack_string( Stagger, hdrbuf(i), n ) ; i = i+n
117 call int_unpack_string( DimNames(1), hdrbuf(i), n ) ; i = i+n
118 call int_unpack_string( DimNames(2), hdrbuf(i), n ) ; i = i+n
119 call int_unpack_string( DimNames(3), hdrbuf(i), n ) ; i = i+n
120 DomainStart(1) = hdrbuf(i) ; i = i+1
121 DomainStart(2) = hdrbuf(i) ; i = i+1
122 DomainStart(3) = hdrbuf(i) ; i = i+1
123 DomainEnd(1) = hdrbuf(i) ; i = i+1
124 DomainEnd(2) = hdrbuf(i) ; i = i+1
125 DomainEnd(3) = hdrbuf(i) ; i = i+1
126 PatchStart(1) = hdrbuf(i) ; i = i+1
127 PatchStart(2) = hdrbuf(i) ; i = i+1
128 PatchStart(3) = hdrbuf(i) ; i = i+1
129 PatchEnd(1) = hdrbuf(i) ; i = i+1
130 PatchEnd(2) = hdrbuf(i) ; i = i+1
131 PatchEnd(3) = hdrbuf(i) ; i = i+1
132
133 RETURN
134 END SUBROUTINE int_get_write_field_header
135
136 !!!!!!!!
137
138 SUBROUTINE int_gen_ofr_header( hdrbuf, hdrbufsize, itypesize, &
139 FileName, SysDepInfo, DataHandle )
140 IMPLICIT NONE
141 #include "intio_tags.h"
142 INTEGER, INTENT(INOUT) :: hdrbuf(*)
143 INTEGER, INTENT(OUT) :: hdrbufsize
144 INTEGER, INTENT(INOUT) :: itypesize
145 !Local
146 INTEGER , INTENT(IN) :: DataHandle
147 CHARACTER*(*) :: FileName
148 CHARACTER*(*) :: SysDepInfo
149 INTEGER i, n
150 !
151 hdrbuf(1) = 0 !deferred
152 hdrbuf(2) = int_open_for_read
153 i = 3
154 hdrbuf(i) = DataHandle ; i = i+1
155 call int_pack_string( FileName, hdrbuf(i), n ) ; i = i + n
156 call int_pack_string( SysDepInfo, hdrbuf(i), n ) ; i = i + n
157 hdrbufsize = (i-1) * itypesize ! return the number in bytes
158 hdrbuf(1) = hdrbufsize
159 RETURN
160 END SUBROUTINE int_gen_ofr_header
161
162 SUBROUTINE int_get_ofr_header( hdrbuf, hdrbufsize, itypesize, &
163 FileName, SysDepInfo, DataHandle )
164 IMPLICIT NONE
165 #include "intio_tags.h"
166 INTEGER, INTENT(INOUT) :: hdrbuf(*)
167 INTEGER, INTENT(OUT) :: hdrbufsize
168 INTEGER, INTENT(INOUT) :: itypesize
169 !Local
170 INTEGER , INTENT(OUT) :: DataHandle
171 CHARACTER*(*) :: FileName
172 CHARACTER*(*) :: SysDepInfo
173 INTEGER i, n
174 integer ii
175 !
176 hdrbufsize = hdrbuf(1)
177 ! IF ( hdrbuf(2) .NE. int_open_for_read ) THEN
178 ! CALL wrf_error_fatal ( "int_get_ofr_header: hdrbuf ne int_open_for_read")
179 ! ENDIF
180 i = 3
181 DataHandle = hdrbuf(i) ; i = i+1
182 call int_unpack_string( FileName, hdrbuf(i), n ) ; i = i+n
183 call int_unpack_string( SysDepInfo, hdrbuf(i), n ) ; i = i+n
184 RETURN
185 END SUBROUTINE int_get_ofr_header
186
187 !!!!!!!!
188
189 SUBROUTINE int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
190 FileName, SysDepInfo, io_form, DataHandle )
191 IMPLICIT NONE
192 #include "intio_tags.h"
193 INTEGER, INTENT(INOUT) :: hdrbuf(*)
194 INTEGER, INTENT(OUT) :: hdrbufsize
195 INTEGER, INTENT(INOUT) :: itypesize
196 INTEGER , INTENT(IN) :: io_form
197 INTEGER , INTENT(IN) :: DataHandle
198 !Local
199 CHARACTER*(*) :: FileName
200 CHARACTER*(*) :: SysDepInfo
201 INTEGER i, n
202 !
203 hdrbuf(1) = 0 !deferred
204 hdrbuf(2) = int_open_for_write_begin
205 i = 3
206 hdrbuf(i) = DataHandle ; i = i+1
207 hdrbuf(i) = io_form ; i = i+1
208 call int_pack_string( FileName, hdrbuf(i), n ) ; i = i + n
209 call int_pack_string( SysDepInfo, hdrbuf(i), n ) ; i = i + n
210 hdrbufsize = (i-1) * itypesize ! return the number in bytes
211 hdrbuf(1) = hdrbufsize
212 RETURN
213 END SUBROUTINE int_gen_ofwb_header
214
215 SUBROUTINE int_get_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
216 FileName, SysDepInfo, io_form, DataHandle )
217 IMPLICIT NONE
218 #include "intio_tags.h"
219 INTEGER, INTENT(INOUT) :: hdrbuf(*)
220 INTEGER, INTENT(OUT) :: hdrbufsize
221 INTEGER, INTENT(INOUT) :: itypesize
222 INTEGER , INTENT(OUT) :: DataHandle
223 INTEGER , INTENT(OUT) :: io_form
224 !Local
225 CHARACTER*(*) :: FileName
226 CHARACTER*(*) :: SysDepInfo
227 INTEGER i, n
228 integer ii
229 !
230 hdrbufsize = hdrbuf(1)
231 ! IF ( hdrbuf(2) .NE. int_open_for_write_begin ) THEN
232 ! CALL wrf_error_fatal ( "int_get_ofwb_header: hdrbuf ne int_open_for_write_begin")
233 ! ENDIF
234 i = 3
235 DataHandle = hdrbuf(i) ; i = i+1
236 io_form = hdrbuf(i) ; i = i+1
237 call int_unpack_string( FileName, hdrbuf(i), n ) ; i = i+n
238 call int_unpack_string( SysDepInfo, hdrbuf(i), n ) ; i = i+n
239 RETURN
240 END SUBROUTINE int_get_ofwb_header
241
242 !!!!!!!!!!
243
244 SUBROUTINE int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
245 DataHandle , code )
246 IMPLICIT NONE
247 #include "intio_tags.h"
248 INTEGER, INTENT(INOUT) :: hdrbuf(*)
249 INTEGER, INTENT(OUT) :: hdrbufsize
250 INTEGER, INTENT(INOUT) :: itypesize
251 INTEGER , INTENT(IN) :: DataHandle, code
252 !Local
253 INTEGER i
254 !
255 hdrbuf(1) = 0 !deferred
256 hdrbuf(2) = code
257 i = 3
258 hdrbuf(i) = DataHandle ; i = i+1
259 hdrbufsize = (i-1) * itypesize ! return the number in bytes
260 hdrbuf(1) = hdrbufsize
261 RETURN
262 END SUBROUTINE int_gen_handle_header
263
264 SUBROUTINE int_get_handle_header( hdrbuf, hdrbufsize, itypesize, &
265 DataHandle , code )
266 IMPLICIT NONE
267 #include "intio_tags.h"
268 INTEGER, INTENT(INOUT) :: hdrbuf(*)
269 INTEGER, INTENT(OUT) :: hdrbufsize
270 INTEGER, INTENT(INOUT) :: itypesize
271 INTEGER , INTENT(OUT) :: DataHandle, code
272 !Local
273 INTEGER i
274 !
275 hdrbufsize = hdrbuf(1)
276 code = hdrbuf(2)
277 i = 3
278 DataHandle = hdrbuf(i) ; i = i+1
279 RETURN
280 END SUBROUTINE int_get_handle_header
281
282 !!!!!!!!!!!!
283
284 SUBROUTINE int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
285 DataHandle, Element, Data, Count, code )
286 IMPLICIT NONE
287 #include "intio_tags.h"
288 INTEGER, INTENT(INOUT) :: hdrbuf(*)
289 INTEGER, INTENT(OUT) :: hdrbufsize
290 INTEGER, INTENT(IN) :: itypesize, typesize
291 CHARACTER*(*) :: Element
292 INTEGER, INTENT(IN) :: Data, Count
293 INTEGER, INTENT(IN) :: DataHandle, code
294 !Local
295 INTEGER i, n
296 !
297 CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
298 DataHandle, Data, Count, code )
299 i = hdrbufsize/itypesize + 1 ;
300 CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
301 hdrbufsize = n * itypesize + hdrbufsize ! return the number in bytes
302 hdrbuf(1) = hdrbufsize
303 RETURN
304 END SUBROUTINE int_gen_ti_header
305
306 SUBROUTINE int_get_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, &
307 DataHandle, Element, Data, Count, code )
308 IMPLICIT NONE
309 #include "intio_tags.h"
310 INTEGER, INTENT(INOUT) :: hdrbuf(*)
311 INTEGER, INTENT(OUT) :: hdrbufsize
312 INTEGER, INTENT(IN) :: itypesize, typesize
313 CHARACTER*(*) :: Element
314 INTEGER, INTENT(OUT) :: Data, Count
315 INTEGER, INTENT(OUT) :: DataHandle, code
316 !Local
317 INTEGER i, n
318 !
319
320 CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
321 DataHandle, Data, Count, code )
322 i = 1
323 CALL int_unpack_string ( Element, hdrbuf( n/itypesize + 1 ), n ) ;
324 hdrbufsize = hdrbuf(1)
325 RETURN
326 END SUBROUTINE int_get_ti_header
327
328 !!!!!!!!!!!!
329
330 SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
331 DataHandle, Element, VarName, Data, code )
332 IMPLICIT NONE
333 #include "intio_tags.h"
334 INTEGER, INTENT(INOUT) :: hdrbuf(*)
335 INTEGER, INTENT(OUT) :: hdrbufsize
336 INTEGER, INTENT(IN) :: itypesize
337 CHARACTER*(*) :: Element, Data, VarName
338 INTEGER, INTENT(IN) :: DataHandle, code
339 !Local
340 INTEGER :: DummyData
341 INTEGER i, n, Count, DummyCount
342 !
343 DummyCount = 0
344 CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, &
345 DataHandle, DummyData, DummyCount, code )
346 i = hdrbufsize/itypesize+1 ;
347 CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
348 CALL int_pack_string ( Data , hdrbuf( i ), n ) ; i = i + n
349 CALL int_pack_string ( VarName , hdrbuf( i ), n ) ; i = i + n
350 hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
351 hdrbuf(1) = hdrbufsize
352 RETURN
353 END SUBROUTINE int_gen_ti_header_char
354
355 SUBROUTINE int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
356 DataHandle, Element, VarName, Data, code )
357 IMPLICIT NONE
358 #include "intio_tags.h"
359 INTEGER, INTENT(INOUT) :: hdrbuf(*)
360 INTEGER, INTENT(OUT) :: hdrbufsize
361 INTEGER, INTENT(IN) :: itypesize
362 CHARACTER*(*) :: Element, VarName
363 CHARACTER*(*) :: Data
364 INTEGER, INTENT(OUT) :: DataHandle, code
365 !Local
366 INTEGER i, n, DummyCount, typesize
367 CHARACTER * 132 dummyData
368 !
369 CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
370 DataHandle, dummyData, DummyCount, code )
371 i = n/itypesize+1 ;
372 CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n
373 CALL int_unpack_string ( Data , hdrbuf( i ), n ) ; i = i + n
374 CALL int_unpack_string ( VarName , hdrbuf( i ), n ) ; i = i + n
375 hdrbufsize = hdrbuf(1)
376
377 RETURN
378 END SUBROUTINE int_get_ti_header_char
379
380
381 !!!!!!!!!!!!
382
383 SUBROUTINE int_gen_td_header( hdrbuf, hdrbufsize, itypesize, typesize, &
384 DataHandle, DateStr, Element, Data, Count, code )
385 IMPLICIT NONE
386 #include "intio_tags.h"
387 INTEGER, INTENT(INOUT) :: hdrbuf(*)
388 INTEGER, INTENT(OUT) :: hdrbufsize
389 INTEGER, INTENT(IN) :: itypesize, typesize
390 CHARACTER*(*) :: DateStr, Element
391 INTEGER, INTENT(IN) :: Data, Count
392 INTEGER, INTENT(IN) :: DataHandle, code
393 !Local
394 INTEGER i, n
395 !
396
397 CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, typesize, &
398 DataHandle, Data, Count, code )
399 i = hdrbufsize/itypesize + 1 ;
400 CALL int_pack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n
401 CALL int_pack_string ( Element, hdrbuf( i ), n ) ; i = i + n
402 hdrbufsize = (i-1) * itypesize + hdrbufsize ! return the number in bytes
403 hdrbuf(1) = hdrbufsize
404 RETURN
405 END SUBROUTINE int_gen_td_header
406
407 SUBROUTINE int_get_td_header( hdrbuf, hdrbufsize, itypesize, typesize, &
408 DataHandle, DateStr, Element, Data, Count, code )
409 IMPLICIT NONE
410 #include "intio_tags.h"
411 INTEGER, INTENT(INOUT) :: hdrbuf(*)
412 INTEGER, INTENT(OUT) :: hdrbufsize
413 INTEGER, INTENT(IN) :: itypesize, typesize
414 CHARACTER*(*) :: DateStr, Element
415 INTEGER, INTENT(OUT) :: Data, Count
416 INTEGER, INTENT(OUT) :: DataHandle, code
417 !Local
418 INTEGER i, n
419 !
420
421 CALL int_get_ti_header_c ( hdrbuf, hdrbufsize, n, itypesize, typesize, &
422 DataHandle, Data, Count, code )
423 i = n/itypesize + 1 ;
424 CALL int_unpack_string ( DateStr, hdrbuf( i ), n ) ; i = i + n ;
425 CALL int_unpack_string ( Element, hdrbuf( i ), n ) ; i = i + n ;
426 hdrbufsize = hdrbuf(1)
427 RETURN
428 END SUBROUTINE int_get_td_header
429
430 !!!!!!!!!!!!!!
431
432 SUBROUTINE int_gen_noop_header ( hdrbuf, hdrbufsize, itypesize )
433 IMPLICIT NONE
434 #include "intio_tags.h"
435 INTEGER, INTENT(INOUT) :: hdrbuf(*)
436 INTEGER, INTENT(OUT) :: hdrbufsize
437 INTEGER, INTENT(INOUT) :: itypesize
438 !Local
439 INTEGER i
440 !
441 hdrbuf(1) = 0 !deferred
442 hdrbuf(2) = int_noop
443 i = 3
444 hdrbufsize = (i-1) * itypesize ! return the number in bytes
445 hdrbuf(1) = hdrbufsize
446 RETURN
447 END SUBROUTINE int_gen_noop_header
448
449 SUBROUTINE int_get_noop_header( hdrbuf, hdrbufsize, itypesize )
450 IMPLICIT NONE
451 #include "intio_tags.h"
452 INTEGER, INTENT(INOUT) :: hdrbuf(*)
453 INTEGER, INTENT(OUT) :: hdrbufsize
454 INTEGER, INTENT(INOUT) :: itypesize
455 !Local
456 INTEGER i
457 !
458 hdrbufsize = hdrbuf(1)
459 IF ( hdrbuf(2) .NE. int_noop ) THEN
460 CALL wrf_error_fatal ( "int_get_noop_header: hdrbuf ne int_noop")
461 ENDIF
462 i = 3
463 RETURN
464 END SUBROUTINE int_get_noop_header
465
466
467 ! first int is length of string to follow then string encodes as ints
468 SUBROUTINE int_pack_string ( str, buf, n )
469 IMPLICIT NONE
470 CHARACTER*(*) :: str
471 INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints stored in buf
472 INTEGER, INTENT(OUT), DIMENSION(*) :: buf
473 INTEGER i
474 n = 1
475 buf(n) = LEN(TRIM(str))
476 n = n+1
477 DO i = 1, LEN(TRIM(str))
478 buf(n) = ichar(str(i:i))
479 n = n+1
480 ENDDO
481 n = n - 1
482 END SUBROUTINE int_pack_string
483
484 SUBROUTINE int_unpack_string ( str, buf, n )
485 IMPLICIT NONE
486 CHARACTER*(*) :: str
487 INTEGER, INTENT(OUT) :: n ! on return, N is the number of ints copied from buf
488 INTEGER, INTENT(IN), DIMENSION(*) :: buf
489 INTEGER i
490 INTEGER strlen
491 strlen = buf(1)
492 str = ""
493 DO i = 1, strlen
494 str(i:i) = char(buf(i+1))
495 ENDDO
496 n = strlen + 1
497 END SUBROUTINE int_unpack_string
498
499