PageRenderTime 53ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/external/io_phdf5/wrf-phdf5support.F90

http://github.com/jbeezley/wrf-fire
FORTRAN Modern | 1395 lines | 1072 code | 179 blank | 144 comment | 129 complexity | 7f2f9dae02a932bb43002d5f4fac432e MD5 | raw file
Possible License(s): AGPL-1.0
  1. !/***************************************************************************
  2. !* The HDF5 WRF IO module was written by the the HDF Group at NCSA, the *
  3. !* National Center for Supercomputing Applications. *
  4. !* HDF Group *
  5. !* National Center for Supercomputing Applications *
  6. !* University of Illinois at Urbana-Champaign *
  7. !* 605 E. Springfield, Champaign IL 61820 *
  8. !* http://hdf.ncsa.uiuc.edu/ *
  9. !* *
  10. !* Copyright 2004 by the Board of Trustees, University of Illinois, *
  11. !* *
  12. !* Redistribution or use of this IO module, with or without modification, *
  13. !* is permitted for any purpose, including commercial purposes. *
  14. !* *
  15. !* This software is an unsupported prototype. Use at your own risk. *
  16. !* http://hdf.ncsa.uiuc.edu/apps/WRF-ROMS *
  17. !* *
  18. !* This work was funded by the MEAD expedition at the National Center *
  19. !* for Supercomputing Applications, NCSA. For more information see: *
  20. !* http://www.ncsa.uiuc.edu/expeditions/MEAD *
  21. !* *
  22. !* *
  23. !****************************************************************************/
  24. module wrf_phdf5_data
  25. use HDF5
  26. integer , parameter :: FATAL = 1
  27. integer , parameter :: WARN = 1
  28. integer , parameter :: WrfDataHandleMax = 99
  29. integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS
  30. integer , parameter :: MaxTabDims = 100 ! temporary,changable
  31. integer , parameter :: MaxVars = 2000
  32. integer , parameter :: MaxTimes = 9999 ! temporary, changable
  33. integer , parameter :: MaxTimeSLen = 6 ! not exceed 1,000,000 timestamp
  34. integer , parameter :: DateStrLen = 19
  35. integer , parameter :: VarNameLen = 31
  36. integer , parameter :: NO_DIM = 0
  37. integer , parameter :: NVarDims = 4
  38. integer , parameter :: NMDVarDims = 2
  39. integer , parameter :: CompDsetSize = 64256 ! set to 63K
  40. character (8) , parameter :: NO_NAME = 'NULL'
  41. character(4) , parameter :: hdf5_true ='TRUE'
  42. character(5) , parameter :: hdf5_false ='FALSE'
  43. integer , parameter :: MemOrdLen = 3
  44. character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00'
  45. #include "wrf_io_flags.h"
  46. ! This is a hack. WRF IOAPI no longer supports WRF_CHARACTER. Rip this out!
  47. integer, parameter :: WRF_CHARACTER = 1080
  48. character (120) :: msg
  49. ! derived data type for dimensional table
  50. type :: dim_scale
  51. character (len = 256) :: dim_name
  52. integer :: length
  53. integer :: unlimited
  54. end type dim_scale
  55. type :: wrf_phdf5_data_handle
  56. character (256) :: FileName
  57. integer :: FileStatus
  58. integer :: Comm
  59. integer(hid_t) :: FileID
  60. integer(hid_t) :: GroupID
  61. integer(hid_t) :: DimGroupID
  62. integer(hid_t) :: EnumID
  63. character (256) :: GroupName
  64. character (256) :: DimGroupName
  65. logical :: Free
  66. logical :: Write
  67. character (5) :: TimesName
  68. integer :: TimeIndex
  69. integer :: MaxTimeCount
  70. integer :: CurrentTime !Only used for read
  71. integer :: NumberTimes !Only used for read
  72. character (DateStrLen), pointer :: Times(:)
  73. integer(hid_t) :: TimesID
  74. integer(hid_t) :: str_id
  75. integer , pointer :: DimLengths(:)
  76. integer , pointer :: DimIDs(:)
  77. character (31) , pointer :: DimNames(:)
  78. integer :: DimUnlimID
  79. character (9) :: DimUnlimName
  80. type (dim_scale) , pointer :: DIMTABLE(:)
  81. integer , dimension(NVarDims) :: DimID
  82. integer , dimension(NVarDims) :: Dimension
  83. ! integer , pointer :: MDDsetIDs(:)
  84. integer , pointer :: MDVarDimLens(:)
  85. character (256) , pointer :: MDVarNames(:)
  86. integer(hid_t) , pointer :: TgroupIDs(:)
  87. integer(hid_t) , pointer :: DsetIDs(:)
  88. integer(hid_t) , pointer :: MDDsetIDs(:)
  89. ! integer(hid_t) :: DimTableID
  90. integer , pointer :: VarDimLens(:,:)
  91. character (VarNameLen), pointer :: VarNames(:)
  92. integer :: CurrentVariable !Only used for read
  93. integer :: NumVars
  94. ! first_operation is set to .TRUE. when a new handle is allocated
  95. ! or when open-for-write or open-for-read are committed. It is set
  96. ! to .FALSE. when the first field is read or written.
  97. logical :: first_operation
  98. end type wrf_phdf5_data_handle
  99. type(wrf_phdf5_data_handle),target :: WrfDataHandles(WrfDataHandleMax)
  100. end module wrf_phdf5_data
  101. module ext_phdf5_support_routines
  102. implicit none
  103. CONTAINS
  104. subroutine allocHandle(DataHandle,DH,Comm,Status)
  105. use wrf_phdf5_data
  106. use HDF5
  107. include 'wrf_status_codes.h'
  108. integer ,intent(out) :: DataHandle
  109. type(wrf_phdf5_data_handle),pointer:: DH
  110. integer ,intent(IN) :: Comm
  111. integer ,intent(out) :: Status
  112. integer :: i
  113. integer :: j
  114. integer :: stat
  115. integer(hid_t) :: enum_type
  116. ! character (256) :: NullName
  117. ! NullName = char(0)
  118. do i=1,WrfDataHandleMax
  119. if(WrfDataHandles(i)%Free) then
  120. DH => WrfDataHandles(i)
  121. DataHandle = i
  122. DH%MaxTimeCount = 1
  123. DH%FileID = -1
  124. DH%GroupID = -1
  125. DH%DimGroupID = -1
  126. call SetUp_EnumID(enum_type,Status)
  127. if(Status /= 0) then
  128. Status = WRF_HDF5_ERR_ALLOCATION
  129. write(msg,*) 'Fatal enum ALLOCATION ERROR in ',__FILE__,', line',__LINE__
  130. call wrf_debug ( FATAL , msg)
  131. return
  132. endif
  133. DH%EnumID = enum_type
  134. allocate(DH%Times(MaxTimes), STAT=stat)
  135. if(stat/= 0) then
  136. Status = WRF_HDF5_ERR_ALLOCATION
  137. write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
  138. call wrf_debug ( FATAL , msg)
  139. return
  140. endif
  141. ! wait in the future
  142. ! DH%Times(1:MaxTimes) = NullName
  143. allocate(DH%DimLengths(MaxDims), STAT=stat)
  144. if(stat/= 0) then
  145. Status = WRF_HDF5_ERR_ALLOCATION
  146. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line',__LINE__
  147. call wrf_debug ( FATAL , msg)
  148. return
  149. endif
  150. allocate(DH%DimIDs(MaxDims), STAT=stat)
  151. if(stat/= 0) then
  152. Status = WRF_HDF5_ERR_ALLOCATION
  153. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  154. call wrf_debug ( FATAL , msg)
  155. return
  156. endif
  157. allocate(DH%DimNames(MaxDims), STAT=stat)
  158. if(stat/= 0) then
  159. Status = WRF_HDF5_ERR_ALLOCATION
  160. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  161. call wrf_debug ( FATAL , msg)
  162. return
  163. endif
  164. allocate(DH%DIMTABLE(MaxTabDims), STAT = stat)
  165. if(stat/= 0) then
  166. Status = WRF_HDF5_ERR_ALLOCATION
  167. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  168. call wrf_debug ( FATAL , msg)
  169. return
  170. endif
  171. do j =1,MaxTabDims
  172. DH%DIMTABLE(j)%dim_name = NO_NAME
  173. DH%DIMTABLE(j)%unlimited = -1
  174. enddo
  175. allocate(DH%MDDsetIDs(MaxVars), STAT=stat)
  176. if(stat/= 0) then
  177. Status = WRF_HDF5_ERR_ALLOCATION
  178. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  179. call wrf_debug ( FATAL , msg)
  180. return
  181. endif
  182. allocate(DH%MDVarDimLens(MaxVars), STAT=stat)
  183. if(stat/= 0) then
  184. Status = WRF_HDF5_ERR_ALLOCATION
  185. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  186. call wrf_debug ( FATAL , msg)
  187. return
  188. endif
  189. allocate(DH%MDVarNames(MaxVars), STAT=stat)
  190. if(stat/= 0) then
  191. Status = WRF_HDF5_ERR_ALLOCATION
  192. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  193. call wrf_debug ( FATAL , msg)
  194. return
  195. endif
  196. allocate(DH%DsetIDs(MaxVars), STAT=stat)
  197. if(stat/= 0) then
  198. Status = WRF_HDF5_ERR_ALLOCATION
  199. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  200. call wrf_debug ( FATAL , msg)
  201. return
  202. endif
  203. DH%DsetIDs = -1
  204. allocate(DH%TgroupIDs(MaxTimes), STAT=stat)
  205. if(stat/= 0) then
  206. Status = WRF_HDF5_ERR_ALLOCATION
  207. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  208. call wrf_debug ( FATAL , msg)
  209. return
  210. endif
  211. DH%TgroupIDs = -1
  212. allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat)
  213. if(stat/= 0) then
  214. Status = WRF_HDF5_ERR_ALLOCATION
  215. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  216. call wrf_debug ( FATAL , msg)
  217. return
  218. endif
  219. allocate(DH%VarNames(MaxVars), STAT=stat)
  220. if(stat/= 0) then
  221. Status = WRF_HDF5_ERR_ALLOCATION
  222. write(msg,*) 'Fatal ALLOCATION ERROR in ',"__FILE__",', line', __LINE__
  223. call wrf_debug ( FATAL , msg)
  224. return
  225. endif
  226. exit
  227. endif
  228. if(i==WrfDataHandleMax) then
  229. Status = WRF_HDF5_ERR_TOO_MANY_FILES
  230. write(msg,*) 'Warning TOO MANY FILES in ',"__FILE__",', line', __LINE__
  231. call wrf_debug ( WARN , msg)
  232. return
  233. endif
  234. enddo
  235. DH%Free =.false.
  236. DH%Comm = Comm
  237. DH%Write =.false.
  238. DH%first_operation = .TRUE.
  239. Status = WRF_NO_ERR
  240. end subroutine allocHandle
  241. ! Obtain data handler
  242. subroutine GetDH(DataHandle,DH,Status)
  243. use wrf_phdf5_data
  244. include 'wrf_status_codes.h'
  245. integer ,intent(in) :: DataHandle
  246. type(wrf_phdf5_data_handle) ,pointer :: DH
  247. integer ,intent(out) :: Status
  248. if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then
  249. Status = WRF_HDF5_ERR_BAD_DATA_HANDLE
  250. return
  251. endif
  252. DH => WrfDataHandles(DataHandle)
  253. if(DH%Free) then
  254. Status = WRF_HDF5_ERR_BAD_DATA_HANDLE
  255. return
  256. endif
  257. Status = WRF_NO_ERR
  258. return
  259. end subroutine GetDH
  260. ! Set up eumerate datatype for possible logical type
  261. subroutine SetUp_EnumID(enum_type,Status)
  262. use wrf_phdf5_data
  263. use HDF5
  264. implicit none
  265. include 'wrf_status_codes.h'
  266. integer(hid_t) ,intent(out) :: enum_type
  267. integer ,intent(out) :: Status
  268. integer :: hdf5err
  269. integer, dimension(2) :: data
  270. data(1) = 1
  271. data(2) = 0
  272. call h5tenum_create_f(H5T_NATIVE_INTEGER,enum_type,hdf5err)
  273. if(hdf5err.lt.0) then
  274. Status = WRF_HDF5_ERR_DATATYPE
  275. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  276. call wrf_debug ( WARN , msg)
  277. return
  278. endif
  279. call h5tenum_insert_f(enum_type,hdf5_true,data(1),hdf5err)
  280. if(hdf5err.lt.0) then
  281. Status = WRF_HDF5_ERR_DATATYPE
  282. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  283. call wrf_debug ( WARN , msg)
  284. return
  285. endif
  286. call h5tenum_insert_f(enum_type,hdf5_false,data(2),Status)
  287. if(hdf5err.lt.0) then
  288. Status = WRF_HDF5_ERR_DATATYPE
  289. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  290. call wrf_debug ( WARN , msg)
  291. return
  292. endif
  293. Status = WRF_NO_ERR
  294. return
  295. end subroutine SetUp_EnumID
  296. ! Returns .TRUE. iff it is OK to write time-independent domain metadata to the
  297. ! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is
  298. ! returned.
  299. LOGICAL FUNCTION phdf5_ok_to_put_dom_ti( DataHandle )
  300. use wrf_phdf5_data
  301. include 'wrf_status_codes.h'
  302. INTEGER, INTENT(IN) :: DataHandle
  303. CHARACTER*80 :: fname
  304. INTEGER :: filestate
  305. INTEGER :: Status
  306. LOGICAL :: dryrun, first_output, retval
  307. call ext_phdf5_inquire_filename( DataHandle, fname, filestate, Status )
  308. IF ( Status /= WRF_NO_ERR ) THEN
  309. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
  310. ', line', __LINE__
  311. call wrf_debug ( WARN , TRIM(msg) )
  312. retval = .FALSE.
  313. ELSE
  314. dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
  315. first_output = phdf5_is_first_operation( DataHandle )
  316. retval = .NOT. dryrun .AND. first_output
  317. ENDIF
  318. phdf5_ok_to_put_dom_ti = retval
  319. RETURN
  320. END FUNCTION phdf5_ok_to_put_dom_ti
  321. ! Returns .TRUE. iff it is OK to read time-independent domain metadata from the
  322. ! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is
  323. ! returned.
  324. LOGICAL FUNCTION phdf5_ok_to_get_dom_ti( DataHandle )
  325. use wrf_phdf5_data
  326. include 'wrf_status_codes.h'
  327. INTEGER, INTENT(IN) :: DataHandle
  328. CHARACTER*80 :: fname
  329. INTEGER :: filestate
  330. INTEGER :: Status
  331. LOGICAL :: dryrun, retval
  332. call ext_phdf5_inquire_filename( DataHandle, fname, filestate, Status )
  333. IF ( Status /= WRF_NO_ERR ) THEN
  334. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
  335. ', line', __LINE__
  336. call wrf_debug ( WARN , TRIM(msg) )
  337. retval = .FALSE.
  338. ELSE
  339. dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
  340. retval = .NOT. dryrun
  341. ENDIF
  342. phdf5_ok_to_get_dom_ti = retval
  343. RETURN
  344. END FUNCTION phdf5_ok_to_get_dom_ti
  345. ! Returns .TRUE. iff nothing has been read from or written to the file
  346. ! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned.
  347. LOGICAL FUNCTION phdf5_is_first_operation( DataHandle )
  348. use wrf_phdf5_data
  349. INCLUDE 'wrf_status_codes.h'
  350. INTEGER, INTENT(IN) :: DataHandle
  351. TYPE(wrf_phdf5_data_handle) ,POINTER :: DH
  352. INTEGER :: Status
  353. LOGICAL :: retval
  354. CALL GetDH( DataHandle, DH, Status )
  355. IF ( Status /= WRF_NO_ERR ) THEN
  356. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
  357. ', line', __LINE__
  358. call wrf_debug ( WARN , TRIM(msg) )
  359. retval = .FALSE.
  360. ELSE
  361. retval = DH%first_operation
  362. ENDIF
  363. phdf5_is_first_operation = retval
  364. RETURN
  365. END FUNCTION phdf5_is_first_operation
  366. end module ext_phdf5_support_routines
  367. !module wrf_phdf5_opt_data
  368. ! integer ,parameter :: MaxOptVars = 100
  369. !end module wrf_phdf5_opt_data
  370. !module opt_data_module
  371. !use wrf_phdf5_opt_data
  372. ! type :: field
  373. ! logical :: Free
  374. ! integer,pointer :: darrays(:)
  375. ! integer :: index
  376. ! end type field
  377. ! type(field),target :: fieldhandle(MaxOptVars)
  378. !end module opt_data_module
  379. !module opt_support_module
  380. ! implicit none
  381. !contains
  382. ! subroutine alloc_opt_handle(ODH)
  383. ! use opt_data_module
  384. ! type(field),pointer::DH
  385. ! integer :: i
  386. ! do i =1,MaxOptVars
  387. ! DH=>fieldhandle(i)
  388. ! DH%index = 0
  389. ! enddo
  390. !end module opt_support_module
  391. ! check the date, only use the length
  392. subroutine DateCheck(Date,Status)
  393. use wrf_phdf5_data
  394. include 'wrf_status_codes.h'
  395. character*(*) ,intent(in) :: Date
  396. integer ,intent(out) :: Status
  397. if(len(Date) /= DateStrLen) then
  398. Status = WRF_HDF5_ERR_DATESTR_BAD_LENGTH
  399. else
  400. Status = WRF_NO_ERR
  401. endif
  402. return
  403. end subroutine DateCheck
  404. ! This routine is for meta-data time dependent varible attribute
  405. subroutine GetName(Element,Var,Name,Status)
  406. use wrf_phdf5_data
  407. include 'wrf_status_codes.h'
  408. character*(*) ,intent(in) :: Element
  409. character*(*) ,intent(in) :: Var
  410. character*(*) ,intent(out) :: Name
  411. integer ,intent(out) :: Status
  412. character (VarNameLen) :: VarName
  413. character (1) :: c
  414. integer :: i
  415. integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A')
  416. VarName = Var
  417. Name = 'MD___'//trim(Element)//VarName
  418. do i=1,len(Name)
  419. c=Name(i:i)
  420. if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower)
  421. if(c=='-'.or.c==':') Name(i:i)='_'
  422. enddo
  423. Status = WRF_NO_ERR
  424. return
  425. end subroutine GetName
  426. ! Obtain TimeIndex
  427. subroutine GetDataTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
  428. use HDF5
  429. use wrf_phdf5_data
  430. use ext_phdf5_support_routines
  431. implicit none
  432. include 'wrf_status_codes.h'
  433. character (*) ,intent(in) :: IO
  434. integer ,intent(in) :: DataHandle
  435. character*(*) ,intent(in) :: DateStr
  436. character (DateStrLen), pointer :: TempTimes(:)
  437. integer ,intent(out) :: TimeIndex
  438. integer ,intent(out) :: Status
  439. type(wrf_phdf5_data_handle) ,pointer :: DH
  440. integer :: VStart(2)
  441. integer :: VCount(2)
  442. integer :: stat
  443. integer :: i
  444. integer :: PreTimeCount
  445. integer :: rank
  446. integer(hsize_t), dimension(1) :: chunk_dims =(/1/)
  447. integer(hsize_t), dimension(1) :: dims
  448. integer(hsize_t), dimension(1) :: hdf5_maxdims
  449. integer(hsize_t), dimension(1) :: offset
  450. integer(hsize_t), dimension(1) :: count
  451. integer(hsize_t), dimension(1) :: sizes
  452. INTEGER(HID_T) :: dset_id ! Dataset ID
  453. INTEGER(HID_T) :: dspace_id ! Dataspace ID
  454. INTEGER(HID_T) :: fspace_id ! Dataspace ID
  455. INTEGER(HID_T) :: crp_list ! chunk ID
  456. integer(hid_t) :: str_id ! string ID
  457. integer :: hdf5err
  458. integer(hid_t) :: group_id
  459. character(Len = 512) :: groupname
  460. ! for debug
  461. character(len=100) :: buf
  462. integer(size_t) :: name_size
  463. integer(size_t) :: datelen_size
  464. ! suppose the output will not exceed 100,0000 timesteps.
  465. character(Len = MaxTimeSLen) :: tname
  466. ! DH => WrfDataHandles(DataHandle), don't know why NetCDF doesn't use GetDH
  467. call GetDH(DataHandle,DH,Status)
  468. if(Status /= WRF_NO_ERR) then
  469. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  470. call wrf_debug ( WARN , msg)
  471. return
  472. endif
  473. call DateCheck(DateStr,Status)
  474. if(Status /= WRF_NO_ERR) then
  475. Status = WRF_HDF5_ERR_DATESTR_ERROR
  476. write(msg,*) 'Warning DATE STRING ERROR in ',"__FILE__",', line', __LINE__
  477. call wrf_debug ( WARN , msg)
  478. return
  479. endif
  480. if(IO == 'write') then
  481. TimeIndex = DH%TimeIndex
  482. if(TimeIndex <= 0) then
  483. TimeIndex = 1
  484. elseif(DateStr < DH%Times(TimeIndex)) then
  485. Status = WRF_HDF5_ERR_DATE_LT_LAST_DATE
  486. write(msg,*) 'Warning DATE < LAST DATE in ',"__FILE__",', line', __LINE__
  487. call wrf_debug ( WARN , msg)
  488. return
  489. elseif(DateStr == DH%Times(TimeIndex)) then
  490. Status = WRF_NO_ERR
  491. return
  492. else
  493. TimeIndex = TimeIndex + 1
  494. ! If exceeding the maximum timestep, updating the maximum timestep
  495. if(TimeIndex > MaxTimes*(DH%MaxTimeCount)) then
  496. PreTimeCount = DH%MaxTimeCount
  497. allocate(TempTimes(PreTimeCount*MaxTimes))
  498. TempTimes(1:MaxTimes*PreTimeCount)=DH%Times(1:MaxTimes &
  499. *PreTimeCount)
  500. DH%MaxTimeCount = DH%MaxTimeCount +1
  501. deallocate(DH%Times)
  502. allocate(DH%Times(DH%MaxTimeCount*MaxTimes))
  503. DH%Times(1:MaxTimes*PreTimeCount)=TempTimes(1:MaxTimes &
  504. *PreTimeCount)
  505. deallocate(TempTimes)
  506. endif
  507. endif
  508. DH%TimeIndex = TimeIndex
  509. DH%Times(TimeIndex) = DateStr
  510. ! From NetCDF implementation, keep it in case it can be used.
  511. ! VStart(1) = 1
  512. ! VStart(2) = TimeIndex
  513. ! VCount(1) = DateStrLen
  514. ! VCount(2) = 1
  515. ! create memory dataspace id and file dataspace id
  516. dims(1) = 1
  517. count(1) = 1
  518. offset(1) = TimeIndex -1
  519. sizes(1) = TimeIndex
  520. ! create group id for different time stamp
  521. call numtochar(TimeIndex,tname)
  522. groupname = 'TIME_STAMP_'//tname
  523. ! call h5gn_members_f(DH%GroupID,DH%GroupName,nmembers,hdf5err)
  524. ! do i = 0, nmembers - 1
  525. ! call h5gget_obj_info_idx_f(DH%GroupID,DH%GroupName,i,ObjName, ObjType, &
  526. ! hdf5err)
  527. ! if(ObjName(1:17) == groupname) then
  528. ! call h5gopen_f(DH%GroupID,groupname,tgroupid,hdf5err)
  529. ! exit
  530. ! endif
  531. ! enddo
  532. if(DH%Tgroupids(TimeIndex) == -1) then
  533. call h5gcreate_f(DH%groupid,groupname,group_id,hdf5err)
  534. if(hdf5err .lt. 0) then
  535. Status = WRF_HDF5_ERR_GROUP
  536. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  537. call wrf_debug ( WARN , msg)
  538. return
  539. endif
  540. DH%Tgroupids(TimeIndex) = group_id
  541. else
  542. ! call h5gopen_f(DH%groupid,groupname,group_id,
  543. group_id = DH%Tgroupids(TimeIndex)
  544. endif
  545. call h5screate_simple_f(1,dims,dspace_id,hdf5err,dims)
  546. if(hdf5err.lt.0) then
  547. Status = WRF_HDF5_ERR_DATASPACE
  548. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  549. call wrf_debug ( WARN , msg)
  550. return
  551. endif
  552. ! create HDF5 string handler for time
  553. if(TimeIndex == 1) then
  554. call h5tcopy_f(H5T_NATIVE_CHARACTER, str_id, hdf5err)
  555. if(hdf5err.lt.0) then
  556. Status = WRF_HDF5_ERR_DATATYPE
  557. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  558. call wrf_debug ( WARN , msg)
  559. return
  560. endif
  561. datelen_size = DateStrLen
  562. call h5tset_size_f(str_id,datelen_size,hdf5err)
  563. if(hdf5err.lt.0) then
  564. Status = WRF_HDF5_ERR_DATATYPE
  565. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  566. call wrf_debug ( WARN , msg)
  567. return
  568. endif
  569. else
  570. str_id = DH%str_id
  571. endif
  572. call h5dcreate_f(group_id,DH%TimesName,str_id,dspace_id,&
  573. DH%TimesID, hdf5err)
  574. if(hdf5err.lt.0) then
  575. Status = WRF_HDF5_ERR_DATASET_CREATE
  576. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  577. call wrf_debug ( WARN , msg)
  578. return
  579. endif
  580. ! write the data in memory space to file space
  581. CALL h5dwrite_f(DH%TimesID,str_id,DateStr,dims,hdf5err,dspace_id,dspace_id)
  582. if(hdf5err.lt.0) then
  583. Status = WRF_HDF5_ERR_DATASET_WRITE
  584. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  585. call wrf_debug ( WARN , msg)
  586. return
  587. endif
  588. if(TimeIndex == 1) then
  589. DH%str_id = str_id
  590. endif
  591. call h5sclose_f(dspace_id,hdf5err)
  592. if(hdf5err.lt.0) then
  593. Status = WRF_HDF5_ERR_DATASPACE
  594. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  595. call wrf_debug ( WARN , msg)
  596. return
  597. endif
  598. call h5dclose_f(DH%TimesID,hdf5err)
  599. if(hdf5err.lt.0) then
  600. Status = WRF_HDF5_ERR_DATASET_GENERAL
  601. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  602. call wrf_debug ( WARN , msg)
  603. return
  604. endif
  605. else
  606. ! This is for IO read
  607. ! Find the timeIndex(very expensive for large
  608. ! time stamp, should use hashing table)
  609. do i=1,MaxTimes*DH%MaxTimeCount
  610. ! For handling reading maximum timestamp greater than 9000 in the future
  611. ! if(DH%Times(i) == NullName) then
  612. ! Status = WRF_HDF5_ERR_TIME
  613. ! write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"__FILE__",&
  614. ! ', line', __LINE__
  615. ! call wrf_debug ( WARN , msg)
  616. ! return
  617. ! endif
  618. if(DH%Times(i) == DateStr) then
  619. Status = WRF_NO_ERR
  620. TimeIndex = i
  621. exit
  622. endif
  623. ! Need a recursive function to handle this
  624. ! This is a potential bug
  625. if(i == MaxTimes*DH%MaxTimeCount) then
  626. ! PreTimeCount = DH%MaxTimeCount
  627. ! allocate(TempTimes(PreTimeCount*MaxTimes))
  628. ! TempTimes(1:MaxTimes*PreTimeCount)=DH%Times(1:MaxTimes &
  629. ! *PreTimeCount)
  630. ! DH%MaxTimeCount = DH%MaxTimeCount +1
  631. ! deallocate(DH%Times)
  632. ! allocate(DH%Times(DH%MaxTimeCount*MaxTimes))
  633. ! DH%Times(1:MaxTimes*PreTimeCount)=TempTimes(1:MaxTimes &
  634. ! *PreTimeCount)
  635. ! deallocate(TempTimes)
  636. Status = WRF_HDF5_ERR_TIME
  637. write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"__FILE__",&
  638. ', line', __LINE__
  639. call wrf_debug ( WARN , msg)
  640. return
  641. endif
  642. enddo
  643. ! do the hyperslab selection
  644. endif
  645. return
  646. end subroutine GetDataTimeIndex
  647. subroutine GetAttrTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
  648. use HDF5
  649. use wrf_phdf5_data
  650. use ext_phdf5_support_routines
  651. implicit none
  652. include 'wrf_status_codes.h'
  653. character (*) ,intent(in) :: IO
  654. integer ,intent(in) :: DataHandle
  655. character*(*) ,intent(in) :: DateStr
  656. character (DateStrLen), pointer :: TempTimes(:)
  657. integer ,intent(out) :: TimeIndex
  658. integer ,intent(out) :: Status
  659. type(wrf_phdf5_data_handle) ,pointer :: DH
  660. integer :: VStart(2)
  661. integer :: VCount(2)
  662. integer :: stat
  663. integer :: i
  664. integer :: PreTimeCount
  665. integer :: rank
  666. integer(hsize_t), dimension(1) :: chunk_dims =(/1/)
  667. integer(hsize_t), dimension(1) :: dims
  668. integer(hsize_t), dimension(1) :: hdf5_maxdims
  669. integer(hsize_t), dimension(1) :: offset
  670. integer(hsize_t), dimension(1) :: count
  671. integer(hsize_t), dimension(1) :: sizes
  672. INTEGER(HID_T) :: dset_id ! Dataset ID
  673. INTEGER(HID_T) :: dspace_id ! Dataspace ID
  674. INTEGER(HID_T) :: fspace_id ! Dataspace ID
  675. INTEGER(HID_T) :: crp_list ! chunk ID
  676. integer(hid_t) :: str_id ! string ID
  677. integer :: hdf5err
  678. integer(size_t) :: datelen_size
  679. integer(hid_t) :: group_id
  680. character(Len = 512) :: groupname
  681. ! suppose the output will not exceed 100,0000 timesteps.
  682. character(Len = MaxTimeSLen) :: tname
  683. ! DH => WrfDataHandles(DataHandle), don't know why NetCDF doesn't use GetDH
  684. call GetDH(DataHandle,DH,Status)
  685. if(Status /= WRF_NO_ERR) then
  686. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  687. call wrf_debug ( WARN , msg)
  688. return
  689. endif
  690. call DateCheck(DateStr,Status)
  691. if(Status /= WRF_NO_ERR) then
  692. Status = WRF_HDF5_ERR_DATESTR_ERROR
  693. write(msg,*) 'Warning DATE STRING ERROR in ',"__FILE__",', line', __LINE__
  694. call wrf_debug ( WARN , msg)
  695. return
  696. endif
  697. if(IO == 'write') then
  698. TimeIndex = DH%TimeIndex
  699. if(TimeIndex <= 0) then
  700. TimeIndex = 1
  701. elseif(DateStr < DH%Times(TimeIndex)) then
  702. Status = WRF_HDF5_ERR_DATE_LT_LAST_DATE
  703. write(msg,*) 'Warning DATE < LAST DATE in ',"__FILE__",', line', __LINE__
  704. call wrf_debug ( WARN , msg)
  705. return
  706. elseif(DateStr == DH%Times(TimeIndex)) then
  707. Status = WRF_NO_ERR
  708. return
  709. else
  710. TimeIndex = TimeIndex + 1
  711. ! If exceeding the maximum timestep, updating the maximum timestep
  712. if(TimeIndex > MaxTimes*(DH%MaxTimeCount)) then
  713. PreTimeCount = DH%MaxTimeCount
  714. allocate(TempTimes(PreTimeCount*MaxTimes))
  715. TempTimes(1:MaxTimes*PreTimeCount)=DH%Times(1:MaxTimes &
  716. *PreTimeCount)
  717. DH%MaxTimeCount = DH%MaxTimeCount +1
  718. deallocate(DH%Times)
  719. allocate(DH%Times(DH%MaxTimeCount*MaxTimes))
  720. DH%Times(1:MaxTimes*PreTimeCount)=TempTimes(1:MaxTimes &
  721. *PreTimeCount)
  722. deallocate(TempTimes)
  723. endif
  724. endif
  725. DH%TimeIndex = TimeIndex
  726. DH%Times(TimeIndex) = DateStr
  727. ! From NetCDF implementation, keep it in case it can be used.
  728. ! VStart(1) = 1
  729. ! VStart(2) = TimeIndex
  730. ! VCount(1) = DateStrLen
  731. ! VCount(2) = 1
  732. ! create memory dataspace id and file dataspace id
  733. dims(1) = 1
  734. count(1) = 1
  735. offset(1) = TimeIndex -1
  736. sizes(1) = TimeIndex
  737. ! create group id for different time stamp
  738. call numtochar(TimeIndex,tname)
  739. groupname = 'TIME_STAMP_'//tname
  740. if(DH%Tgroupids(TimeIndex) == -1) then
  741. call h5gcreate_f(DH%groupid,groupname,group_id,hdf5err)
  742. if(hdf5err .lt. 0) then
  743. Status = WRF_HDF5_ERR_GROUP
  744. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  745. call wrf_debug ( WARN , msg)
  746. return
  747. endif
  748. DH%Tgroupids(TimeIndex) = group_id
  749. else
  750. ! call h5gopen_f(DH%groupid,groupname,group_id,
  751. group_id = DH%Tgroupids(TimeIndex)
  752. endif
  753. call h5screate_simple_f(1,dims,dspace_id,hdf5err,dims)
  754. if(hdf5err.lt.0) then
  755. Status = WRF_HDF5_ERR_DATASPACE
  756. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  757. call wrf_debug ( WARN , msg)
  758. return
  759. endif
  760. ! create HDF5 string handler for time
  761. if(TimeIndex == 1) then
  762. call h5tcopy_f(H5T_NATIVE_CHARACTER, str_id, hdf5err)
  763. if(hdf5err.lt.0) then
  764. Status = WRF_HDF5_ERR_DATATYPE
  765. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  766. call wrf_debug ( WARN , msg)
  767. return
  768. endif
  769. datelen_size = DateStrLen
  770. call h5tset_size_f(str_id,datelen_size,hdf5err)
  771. if(hdf5err.lt.0) then
  772. Status = WRF_HDF5_ERR_DATATYPE
  773. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  774. call wrf_debug ( WARN , msg)
  775. return
  776. endif
  777. else
  778. str_id = DH%str_id
  779. endif
  780. call h5dcreate_f(group_id,DH%TimesName,str_id,dspace_id,&
  781. DH%TimesID, hdf5err)
  782. if(hdf5err.lt.0) then
  783. Status = WRF_HDF5_ERR_DATASET_CREATE
  784. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  785. call wrf_debug ( WARN , msg)
  786. return
  787. endif
  788. ! write the data in memory space to file space
  789. CALL h5dwrite_f(DH%TimesID,str_id,DateStr,dims,hdf5err,dspace_id,dspace_id)
  790. if(hdf5err.lt.0) then
  791. Status = WRF_HDF5_ERR_DATASET_WRITE
  792. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  793. call wrf_debug ( WARN , msg)
  794. return
  795. endif
  796. if(TimeIndex == 1) then
  797. DH%str_id = str_id
  798. endif
  799. call h5sclose_f(dspace_id,hdf5err)
  800. if(hdf5err.lt.0) then
  801. Status = WRF_HDF5_ERR_DATASPACE
  802. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  803. call wrf_debug ( WARN , msg)
  804. return
  805. endif
  806. call h5dclose_f(DH%TimesID,hdf5err)
  807. if(hdf5err.lt.0) then
  808. Status = WRF_HDF5_ERR_DATASET_GENERAL
  809. write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
  810. call wrf_debug ( WARN , msg)
  811. return
  812. endif
  813. else
  814. ! This is for IO read
  815. ! Find the timeIndex(very expensive for large
  816. ! time stamp, should use hashing table)
  817. do i=1,MaxTimes*DH%MaxTimeCount
  818. if(DH%Times(i) == DateStr) then
  819. Status = WRF_NO_ERR
  820. TimeIndex = i
  821. exit
  822. endif
  823. ! Need a recursive function to handle this
  824. ! This is a potential bug
  825. if(i == MaxTimes*DH%MaxTimeCount) then
  826. Status = WRF_HDF5_ERR_TIME
  827. write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',"__FILE__",&
  828. ', line', __LINE__
  829. call wrf_debug ( WARN , msg)
  830. return
  831. endif
  832. enddo
  833. ! do the hyperslab selection
  834. endif
  835. return
  836. end subroutine GetAttrTimeIndex
  837. ! Obtain the rank of the dimension
  838. subroutine GetDim(MemoryOrder,NDim,Status)
  839. include 'wrf_status_codes.h'
  840. character*(*) ,intent(in) :: MemoryOrder
  841. integer ,intent(out) :: NDim
  842. integer ,intent(out) :: Status
  843. character*3 :: MemOrd
  844. call LowerCase(MemoryOrder,MemOrd)
  845. select case (MemOrd)
  846. case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez')
  847. NDim = 3
  848. case ('xy','yx','xs','xe','ys','ye')
  849. NDim = 2
  850. case ('z','c','0')
  851. NDim = 1
  852. case default
  853. Status = WRF_HDF5_ERR_BAD_MEMORYORDER
  854. return
  855. end select
  856. Status = WRF_NO_ERR
  857. return
  858. end subroutine GetDim
  859. ! Obtain the index for transposing
  860. subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2)
  861. integer ,intent(in) :: NDim
  862. integer ,dimension(*),intent(in) :: Start,End
  863. integer ,intent(out) :: i1,i2,j1,j2,k1,k2
  864. i1=1
  865. i2=1
  866. j1=1
  867. j2=1
  868. k1=1
  869. k2=1
  870. i1 = Start(1)
  871. i2 = End (1)
  872. if(NDim == 1) return
  873. j1 = Start(2)
  874. j2 = End (2)
  875. if(NDim == 2) return
  876. k1 = Start(3)
  877. k2 = End (3)
  878. return
  879. end subroutine GetIndices
  880. ! shuffling the memory order to XYZ order
  881. subroutine ExtOrder(MemoryOrder,Vector,Status)
  882. use wrf_phdf5_data
  883. include 'wrf_status_codes.h'
  884. character*(*) ,intent(in) :: MemoryOrder
  885. integer,dimension(*) ,intent(inout) :: Vector
  886. integer ,intent(out) :: Status
  887. integer :: NDim
  888. integer,dimension(NVarDims) :: temp
  889. character*3 :: MemOrd
  890. call GetDim(MemoryOrder,NDim,Status)
  891. temp(1:NDim) = Vector(1:NDim)
  892. call LowerCase(MemoryOrder,MemOrd)
  893. select case (MemOrd)
  894. case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
  895. continue
  896. case ('0')
  897. Vector(1) = 1
  898. case ('xzy')
  899. Vector(2) = temp(3)
  900. Vector(3) = temp(2)
  901. case ('yxz')
  902. Vector(1) = temp(2)
  903. Vector(2) = temp(1)
  904. case ('yzx')
  905. Vector(1) = temp(3)
  906. Vector(2) = temp(1)
  907. Vector(3) = temp(2)
  908. case ('zxy')
  909. Vector(1) = temp(2)
  910. Vector(2) = temp(3)
  911. Vector(3) = temp(1)
  912. case ('zyx')
  913. Vector(1) = temp(3)
  914. Vector(3) = temp(1)
  915. case ('yx')
  916. Vector(1) = temp(2)
  917. Vector(2) = temp(1)
  918. case default
  919. Status = WRF_HDF5_ERR_BAD_MEMORYORDER
  920. return
  921. end select
  922. Status = WRF_NO_ERR
  923. return
  924. end subroutine ExtOrder
  925. ! shuffling the dimensional name order
  926. subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status)
  927. use wrf_phdf5_data
  928. include 'wrf_status_codes.h'
  929. character*(*) ,intent(in) :: MemoryOrder
  930. character*(*),dimension(*) ,intent(in) :: Vector
  931. character(256),dimension(NVarDims),intent(out) :: ROVector
  932. integer ,intent(out) :: Status
  933. integer :: NDim
  934. character*3 :: MemOrd
  935. call GetDim(MemoryOrder,NDim,Status)
  936. ROVector(1:NDim) = Vector(1:NDim)
  937. call LowerCase(MemoryOrder,MemOrd)
  938. select case (MemOrd)
  939. case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
  940. continue
  941. case ('0')
  942. ROVector(1) = 'ext_scalar'
  943. case ('xzy')
  944. ROVector(2) = Vector(3)
  945. ROVector(3) = Vector(2)
  946. case ('yxz')
  947. ROVector(1) = Vector(2)
  948. ROVector(2) = Vector(1)
  949. case ('yzx')
  950. ROVector(1) = Vector(3)
  951. ROVector(2) = Vector(1)
  952. ROVector(3) = Vector(2)
  953. case ('zxy')
  954. ROVector(1) = Vector(2)
  955. ROVector(2) = Vector(3)
  956. ROVector(3) = Vector(1)
  957. case ('zyx')
  958. ROVector(1) = Vector(3)
  959. ROVector(3) = Vector(1)
  960. case ('yx')
  961. ROVector(1) = Vector(2)
  962. ROVector(2) = Vector(1)
  963. case default
  964. Status = WRF_HDF5_ERR_BAD_MEMORYORDER
  965. return
  966. end select
  967. Status = WRF_NO_ERR
  968. return
  969. end subroutine ExtOrderStr
  970. subroutine LowerCase(MemoryOrder,MemOrd)
  971. character*(*) ,intent(in) :: MemoryOrder
  972. character*(*) ,intent(out) :: MemOrd
  973. character*3 :: c
  974. integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A')
  975. integer :: i,N
  976. MemOrd = ' '
  977. N = len(MemoryOrder)
  978. MemOrd(1:N) = MemoryOrder(1:N)
  979. do i=1,N
  980. c = MemoryOrder(i:i)
  981. if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
  982. enddo
  983. return
  984. end subroutine LowerCase
  985. subroutine UpperCase(MemoryOrder,MemOrd)
  986. character*(*) ,intent(in) :: MemoryOrder
  987. character*(*) ,intent(out) :: MemOrd
  988. character*3 :: c
  989. integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a')
  990. integer :: i,N
  991. MemOrd = ' '
  992. N = len(MemoryOrder)
  993. MemOrd(1:N) = MemoryOrder(1:N)
  994. do i=1,N
  995. c = MemoryOrder(i:i)
  996. if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper)
  997. enddo
  998. return
  999. end subroutine UpperCase
  1000. ! subroutine used in transpose routine
  1001. subroutine reorder (MemoryOrder,MemO)
  1002. character*(*) ,intent(in) :: MemoryOrder
  1003. character*3 ,intent(out) :: MemO
  1004. character*3 :: MemOrd
  1005. integer :: N,i,i1,i2,i3
  1006. MemO = MemoryOrder
  1007. N = len_trim(MemoryOrder)
  1008. if(N == 1) return
  1009. call lowercase(MemoryOrder,MemOrd)
  1010. i1 = 1
  1011. i3 = 1
  1012. do i=2,N
  1013. if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i
  1014. if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i
  1015. enddo
  1016. if(N == 2) then
  1017. i2=i3
  1018. else
  1019. i2 = 6-i1-i3
  1020. endif
  1021. MemO(1:1) = MemoryOrder(i1:i1)
  1022. MemO(2:2) = MemoryOrder(i2:i2)
  1023. if(N == 3) MemO(3:3) = MemoryOrder(i3:i3)
  1024. if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then
  1025. MemO(1:N-1) = MemO(2:N)
  1026. MemO(N:N ) = MemoryOrder(i1:i1)
  1027. endif
  1028. return
  1029. end subroutine reorder
  1030. subroutine Transpose_hdf5(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
  1031. ,XField,x1,x2,y1,y2,z1,z2 &
  1032. ,i1,i2,j1,j2,k1,k2 )
  1033. character*(*) ,intent(in) :: IO
  1034. character*(*) ,intent(in) :: MemoryOrder
  1035. integer ,intent(in) :: l1,l2,m1,m2,n1,n2
  1036. integer ,intent(in) :: di
  1037. integer ,intent(in) :: x1,x2,y1,y2,z1,z2
  1038. integer ,intent(in) :: i1,i2,j1,j2,k1,k2
  1039. integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2)
  1040. !jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2)
  1041. integer ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1))
  1042. character*3 :: MemOrd
  1043. character*3 :: MemO
  1044. integer ,parameter :: MaxUpperCase=IACHAR('Z')
  1045. integer :: i,j,k,ix,jx,kx
  1046. call LowerCase(MemoryOrder,MemOrd)
  1047. select case (MemOrd)
  1048. !#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1))
  1049. case ('xzy')
  1050. ix=0
  1051. jx=0
  1052. kx=0
  1053. call reorder(MemoryOrder,MemO)
  1054. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1055. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1056. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1057. do k=k1,k2
  1058. do j=j1,j2
  1059. do i=i1,i2
  1060. if(IO == 'write') then
  1061. XField(1:di,(i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1062. else
  1063. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(i-i1+1+(i2-i1+1)*((k-k1)+(j-j1)*(k2-k1+1))))
  1064. endif
  1065. enddo
  1066. enddo
  1067. enddo
  1068. return
  1069. case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
  1070. ix=0
  1071. jx=0
  1072. kx=0
  1073. call reorder(MemoryOrder,MemO)
  1074. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1075. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1076. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1077. do k=k1,k2
  1078. do j=j1,j2
  1079. do i=i1,i2
  1080. if(IO == 'write') then
  1081. XField(1:di,(i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1082. else
  1083. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(i-i1+1+(i2-i1+1)*((j-j1)+(k-k1)*(j2-j1+1))))
  1084. endif
  1085. enddo
  1086. enddo
  1087. enddo
  1088. return
  1089. case ('yxz')
  1090. ix=0
  1091. jx=0
  1092. kx=0
  1093. call reorder(MemoryOrder,MemO)
  1094. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1095. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1096. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1097. do k=k1,k2
  1098. do j=j1,j2
  1099. do i=i1,i2
  1100. if(IO == 'write') then
  1101. XField(1:di,(j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1102. else
  1103. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))))
  1104. endif
  1105. enddo
  1106. enddo
  1107. enddo
  1108. return
  1109. case ('zxy')
  1110. ix=0
  1111. jx=0
  1112. kx=0
  1113. call reorder(MemoryOrder,MemO)
  1114. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1115. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1116. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1117. do k=k1,k2
  1118. do j=j1,j2
  1119. do i=i1,i2
  1120. if(IO == 'write') then
  1121. XField(1:di,(k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1122. else
  1123. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(k-k1+1+(k2-k1+1)*((i-i1)+(j-j1)*(i2-i1+1))))
  1124. endif
  1125. enddo
  1126. enddo
  1127. enddo
  1128. return
  1129. case ('yzx')
  1130. ix=0
  1131. jx=0
  1132. kx=0
  1133. call reorder(MemoryOrder,MemO)
  1134. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1135. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1136. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1137. do k=k1,k2
  1138. do j=j1,j2
  1139. do i=i1,i2
  1140. if(IO == 'write') then
  1141. XField(1:di,(j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1142. else
  1143. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(j-j1+1+(j2-j1+1)*((k-k1)+(i-i1)*(k2-k1+1))))
  1144. endif
  1145. enddo
  1146. enddo
  1147. enddo
  1148. return
  1149. case ('zyx')
  1150. ix=0
  1151. jx=0
  1152. kx=0
  1153. call reorder(MemoryOrder,MemO)
  1154. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1155. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1156. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1157. do k=k1,k2
  1158. do j=j1,j2
  1159. do i=i1,i2
  1160. if(IO == 'write') then
  1161. XField(1:di,(k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1162. else
  1163. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(k-k1+1+(k2-k1+1)*((j-j1)+(i-i1)*(j2-j1+1))))
  1164. endif
  1165. enddo
  1166. enddo
  1167. enddo
  1168. return
  1169. case ('yx')
  1170. ix=0
  1171. jx=0
  1172. kx=0
  1173. call reorder(MemoryOrder,MemO)
  1174. if(IACHAR(MemO(1:1)) > MaxUpperCase) ix=i2+i1
  1175. if(IACHAR(MemO(2:2)) > MaxUpperCase) jx=j2+j1
  1176. if(IACHAR(MemO(3:3)) > MaxUpperCase) kx=k2+k1
  1177. do k=k1,k2
  1178. do j=j1,j2
  1179. do i=i1,i2
  1180. if(IO == 'write') then
  1181. XField(1:di,(j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1)))) = Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k))
  1182. else
  1183. Field(1:di,abs(ix-i),abs(jx-j),abs(kx-k)) = XField(1:di,(j-j1+1+(j2-j1+1)*((i-i1)+(k-k1)*(i2-i1+1))))
  1184. endif
  1185. enddo
  1186. enddo
  1187. enddo
  1188. return
  1189. end select
  1190. return
  1191. end subroutine Transpose_hdf5
  1192. subroutine numtochar(TimeIndex,tname,Status)
  1193. use wrf_phdf5_data
  1194. integer, intent(in) :: TimeIndex
  1195. character(len=MaxTimeSLen),intent(out)::tname
  1196. integer ,intent(out)::Status
  1197. integer :: i,ten_pow,temp
  1198. integer :: maxtimestep
  1199. maxtimestep =1
  1200. do i =1,MaxTimeSLen
  1201. maxtimestep = maxtimestep * 10
  1202. enddo
  1203. if(TimeIndex >= maxtimestep) then
  1204. Status = WRF_HDF5_ERR_OTHERS
  1205. write(msg,*) 'Cannot exceed the maximum timestep',maxtimestep,'in',__FILE__,' line',__LINE__
  1206. call wrf_debug(FATAL,msg)
  1207. return
  1208. endif
  1209. ten_pow = 1
  1210. temp =10
  1211. do i =1,MaxTimeSLen
  1212. tname(MaxTimeSLen+1-i:MaxTimeSLen+1-i) = achar(modulo(TimeIndex/ten_pow,temp)+iachar('0'))
  1213. ten_pow = 10* ten_pow
  1214. enddo
  1215. return
  1216. end subroutine numtochar