PageRenderTime 66ms CodeModel.GetById 29ms RepoModel.GetById 1ms app.codeStats 0ms

/wrfv2_fire/frame/module_internal_header_util.F

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