frame/module_internal_header_util.F

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