source: lmdz_wrf/trunk/WRFV3/frame/module_internal_header_util.F @ 1465

Last change on this file since 1465 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 
1MODULE 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
34INTERFACE int_get_ti_header
35   MODULE PROCEDURE int_get_ti_header_integer, int_get_ti_header_real
36END INTERFACE
37INTERFACE int_gen_ti_header
38   MODULE PROCEDURE int_gen_ti_header_integer, int_gen_ti_header_real
39END INTERFACE
40INTERFACE int_get_td_header
41   MODULE PROCEDURE int_get_td_header_integer, int_get_td_header_real
42END INTERFACE
43INTERFACE int_gen_td_header
44   MODULE PROCEDURE int_gen_td_header_integer, int_gen_td_header_real
45END INTERFACE
46
47PRIVATE :: int_pack_string, int_unpack_string
48
49CONTAINS
50!!!!!!!!!!!!! header manipulation routines !!!!!!!!!!!!!!!
51
52INTEGER FUNCTION get_hdr_tag( hdrbuf )
53  IMPLICIT NONE
54  INTEGER, INTENT(IN) :: hdrbuf(*)
55  get_hdr_tag = hdrbuf(2)
56  RETURN
57END FUNCTION get_hdr_tag
58
59INTEGER FUNCTION get_hdr_rec_size( hdrbuf )
60  IMPLICIT NONE
61  INTEGER, INTENT(IN) :: hdrbuf(*)
62  get_hdr_rec_size = hdrbuf(1)
63  RETURN
64END FUNCTION get_hdr_rec_size
65
66SUBROUTINE 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
179END SUBROUTINE int_gen_write_field_header
180
181
182SUBROUTINE 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
249END SUBROUTINE int_get_write_field_header
250
251!!!!!!!!
252
253!generate open for read header
254SUBROUTINE 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
304END SUBROUTINE int_gen_ofr_header
305
306!get open for read header
307SUBROUTINE 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
335END SUBROUTINE int_get_ofr_header
336
337!!!!!!!!
338
339!generate open for write begin header
340SUBROUTINE 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
398END SUBROUTINE int_gen_ofwb_header
399
400!get open for write begin header
401SUBROUTINE 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
442END SUBROUTINE int_get_ofwb_header
443
444!!!!!!!!!!
445
446SUBROUTINE 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
484END SUBROUTINE int_gen_handle_header
485
486SUBROUTINE 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
508END SUBROUTINE int_get_handle_header
509
510!!!!!!!!!!!!
511
512SUBROUTINE 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
563END SUBROUTINE int_gen_ti_header_integer
564
565SUBROUTINE 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
621END SUBROUTINE int_gen_ti_header_integer_varname
622
623SUBROUTINE 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
649END SUBROUTINE int_gen_ti_header_real
650
651SUBROUTINE 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
680END SUBROUTINE int_get_ti_header_integer_varname
681
682SUBROUTINE 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
709END SUBROUTINE int_get_ti_header_integer
710
711SUBROUTINE 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
738END SUBROUTINE int_get_ti_header_real
739
740!!!!!!!!!!!!
741
742SUBROUTINE 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
798END SUBROUTINE int_gen_ti_header_char
799
800SUBROUTINE 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
828END SUBROUTINE int_get_ti_header_char
829
830
831!!!!!!!!!!!!
832
833SUBROUTINE 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
887END SUBROUTINE int_gen_td_header_char
888
889SUBROUTINE 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
916END SUBROUTINE int_get_td_header_char
917
918SUBROUTINE 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
972END SUBROUTINE int_gen_td_header_integer
973
974SUBROUTINE 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
1001END SUBROUTINE int_gen_td_header_real
1002
1003SUBROUTINE 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
1030END SUBROUTINE int_get_td_header_integer
1031
1032SUBROUTINE 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
1059END SUBROUTINE int_get_td_header_real
1060
1061!!!!!!!!!!!!!!
1062
1063SUBROUTINE 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
1095END SUBROUTINE int_gen_noop_header
1096
1097SUBROUTINE 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
1118END SUBROUTINE int_get_noop_header
1119
1120
1121! first int is length of string to follow then string encodes as ints
1122SUBROUTINE 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
1144END SUBROUTINE int_pack_string
1145
1146SUBROUTINE 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
1167END SUBROUTINE int_unpack_string
1168
1169END MODULE module_internal_header_util
1170
Note: See TracBrowser for help on using the repository browser.