| blob | e8701887342c51ef9f6045153c4931c98e164643 |
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 !****************************************************************************/
26 subroutine HDF5IOWRITE(DataHandle,Comm,DateStr,Length,DomainStart,DomainEnd &
27 ,PatchStart,PatchEnd,MemoryOrder &
28 ,WrfDType,FieldType,groupID,TimeIndex &
29 ,DimRank ,DatasetName,XField,Status)
31 use wrf_phdf5_data
32 use ext_phdf5_support_routines
33 use HDF5
34 implicit none
35 include 'mpif.h'
36 include 'wrf_status_codes.h'
38 integer ,intent(in) :: DataHandle
39 integer ,intent(inout) :: Comm
40 character*(*) ,intent(in) :: DateStr
41 integer,dimension(NVarDims) ,intent(in) :: Length
43 integer,dimension(NVarDims) ,intent(in) :: DomainStart
44 integer,dimension(NVarDims) ,intent(in) :: DomainEnd
45 integer,dimension(NVarDims) ,intent(in) :: PatchStart
46 integer,dimension(NVarDims) ,intent(in) :: PatchEnd
48 character*(*) ,intent(in) :: MemoryOrder
50 integer ,intent(in) :: WrfDType
51 integer(hid_t) ,intent(in) :: FieldType
52 integer(hid_t) ,intent(in) :: groupID
53 integer ,intent(in) :: TimeIndex
55 integer,dimension(*) ,intent(in) :: DimRank
56 character (*) ,intent(in) :: DatasetName
57 integer,dimension(*) ,intent(inout) :: XField
58 integer ,intent(out) :: Status
60 integer(hid_t) :: dset_id
61 integer :: NDim
62 integer,dimension(NVarDims) :: VStart
63 integer,dimension(NVarDims) :: VCount
64 character (3) :: Mem0
65 character (3) :: UCMem0
66 type(wrf_phdf5_data_handle) ,pointer :: DH
68 ! attribute defination
69 integer(hid_t) :: dimaspace_id ! DimRank dataspace id
70 integer(hid_t) :: dimattr_id ! DimRank attribute id
71 integer(hsize_t) ,dimension(1) :: dim_space
72 INTEGER(HID_T) :: dspace_id ! Raw Data memory Dataspace id
73 INTEGER(HID_T) :: fspace_id ! Raw Data file Dataspace id
74 INTEGER(HID_T) :: crp_list ! chunk identifier
75 integer(hid_t) :: h5_atypeid ! for fieldtype,memorder attribute
76 integer(hid_t) :: h5_aspaceid ! for fieldtype,memorder
77 integer(hid_t) :: h5_attrid ! for fieldtype,memorder
78 integer(hsize_t), dimension(7) :: adata_dims
79 integer :: routine_atype
82 integer, dimension(:),allocatable :: dimrank_data
84 INTEGER(HSIZE_T), dimension(:),allocatable :: dims ! Dataset dimensions
85 INTEGER(HSIZE_T), dimension(:),allocatable :: sizes ! Dataset dimensions
86 INTEGER(HSIZE_T), dimension(:),allocatable :: chunk_dims
87 INTEGER(HSIZE_T), dimension(:),allocatable :: hdf5_maxdims
88 INTEGER(HSIZE_T), dimension(:),allocatable :: offset
89 INTEGER(HSIZE_T), dimension(:),allocatable :: count
90 INTEGER(HSIZE_T), DIMENSION(7) :: dimsfi
91 integer :: hdf5err
92 integer :: i,j
93 integer(size_t) :: dsetsize
95 ! FOR PARALLEL IO
96 integer(hid_t) :: xfer_list
97 logical :: no_par
100 ! get the handle
101 call GetDH(DataHandle,DH,Status)
102 if(Status /= WRF_NO_ERR) then
103 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
104 call wrf_debug ( WARN , msg)
105 return
106 endif
108 ! get the rank of the dimension
109 call GetDim(MemoryOrder,NDim,Status)
110 if(Status /= WRF_NO_ERR) then
111 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
112 call wrf_debug ( WARN , msg)
113 return
114 endif
116 ! If patch is equal to domain, the parallel is not necessary, sequential is used.
117 ! In this version, we haven't implemented this yet.
118 ! We use no_par to check whether we can use compact data storage.
119 no_par = .TRUE.
120 do i = 1,NDim
121 if((PatchStart(i)/=DomainStart(i)).or.(PatchEnd(i)/=DomainEnd(i))) then
122 no_par = .FALSE.
123 exit
124 endif
125 enddo
127 ! change the different Memory Order to XYZ for patch and domain
128 if(MemoryOrder.NE.'0') then
129 call ExtOrder(MemoryOrder,PatchStart,Status)
130 call ExtOrder(MemoryOrder,PatchEnd,Status)
131 call ExtOrder(MemoryOrder,DomainStart,Status)
132 call ExtOrder(MemoryOrder,DomainEnd,Status)
133 endif
135 ! allocating memory for dynamic arrays;
136 ! since the time step is always 1, we may ignore the fourth
137 ! dimension time; now keep it to make it consistent with sequential version
138 allocate(dims(NDim+1))
139 allocate(count(NDim+1))
140 allocate(offset(NDim+1))
141 allocate(sizes(NDim+1))
144 ! arrange offset, count for each hyperslab
145 dims(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1
146 dims(NDim+1) = 1
148 count(NDim+1) = 1
149 count(1:NDim) = Length(1:NDim)
151 offset(NDim+1) = 0
152 offset(1:NDim) = PatchStart(1:NDim) - 1
155 ! allocate the dataspace to write hyperslab data
157 dimsfi = 0
158 do i = 1, NDim + 1
159 dimsfi(i) = count(i)
160 enddo
162 ! create the memory space id
163 call h5screate_simple_f(NDim+1,count,dspace_id,hdf5err,count)
164 if(hdf5err.lt.0) then
165 Status = WRF_HDF5_ERR_DATASPACE
166 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
167 call wrf_debug ( WARN , msg)
168 deallocate(dims)
169 deallocate(count)
170 deallocate(offset)
171 deallocate(sizes)
172 return
173 endif
176 ! create file space
177 call h5screate_simple_f(NDim+1,dims,fspace_id,hdf5err,dims)
178 if(hdf5err.lt.0) then
179 Status = WRF_HDF5_ERR_DATASPACE
180 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
181 call wrf_debug ( WARN , msg)
182 deallocate(dims)
183 deallocate(count)
184 deallocate(offset)
185 deallocate(sizes)
186 return
187 endif
189 ! compact storage when the patch is equal to the whole domain
190 ! calculate the non-decomposed dataset size
192 call h5tget_size_f(FieldType,dsetsize,hdf5err)
193 if(hdf5err.lt.0) then
194 Status = WRF_HDF5_ERR_DATATYPE
195 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
196 call wrf_debug ( WARN , msg)
197 deallocate(dims)
198 deallocate(count)
199 deallocate(offset)
200 deallocate(sizes)
201 return
202 endif
204 do i =1,NDim
205 dsetsize = dsetsize*dims(i)
206 enddo
207 if(no_par.and.(dsetsize.le.CompDsetSize)) then
208 call h5pcreate_f(H5P_DATASET_CREATE_F,crp_list,hdf5err)
209 if(hdf5err.lt.0) then
210 Status = WRF_HDF5_ERR_PROPERTY_LIST
211 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
212 call wrf_debug ( WARN , msg)
213 deallocate(dims)
214 deallocate(count)
215 deallocate(offset)
216 deallocate(sizes)
217 return
218 endif
219 call h5pset_layout_f(crp_list,0,hdf5err)
220 if(hdf5err.lt.0) then
221 Status = WRF_HDF5_ERR_PROPERTY_LIST
222 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
223 call wrf_debug ( WARN , msg)
224 deallocate(dims)
225 deallocate(count)
226 deallocate(offset)
227 deallocate(sizes)
228 return
229 endif
230 call h5dcreate_f(DH%TgroupIDs(TimeIndex),DatasetName,FieldType,fspace_id,dset_id,&
231 hdf5err,crp_list)
232 call h5pclose_f(crp_list,hdf5err)
233 else
234 call h5dcreate_f(DH%TgroupIDs(TimeIndex),DatasetName,FieldType,fspace_id,dset_id,hdf5err)
235 endif
237 if(hdf5err.lt.0) then
238 Status = WRF_HDF5_ERR_DATASET_CREATE
239 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
240 call wrf_debug ( WARN , msg)
241 deallocate(dims)
242 deallocate(count)
243 deallocate(offset)
244 deallocate(sizes)
245 return
246 endif
248 ! select the correct hyperslab for file space id
249 CALL h5sselect_hyperslab_f(fspace_id, H5S_SELECT_SET_F, offset, count &
250 ,hdf5err)
251 if(hdf5err.lt.0) then
252 Status = WRF_HDF5_ERR_DATASET_GENERAL
253 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
254 call wrf_debug ( WARN , msg)
255 deallocate(dims)
256 deallocate(count)
257 deallocate(offset)
258 deallocate(sizes)
259 return
260 endif
262 ! Create property list for collective dataset write
263 CALL h5pcreate_f(H5P_DATASET_XFER_F, xfer_list, hdf5err)
264 if(hdf5err.lt.0) then
265 Status = WRF_HDF5_ERR_PROPERTY_LIST
266 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
267 call wrf_debug ( WARN , msg)
268 deallocate(dims)
269 deallocate(count)
270 deallocate(offset)
271 deallocate(sizes)
272 return
273 endif
275 CALL h5pset_dxpl_mpio_f(xfer_list, H5FD_MPIO_COLLECTIVE_F&
276 ,hdf5err)
277 if(hdf5err.lt.0) then
278 Status = WRF_HDF5_ERR_PROPERTY_LIST
279 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
280 call wrf_debug ( WARN , msg)
281 deallocate(dims)
282 deallocate(count)
283 deallocate(offset)
284 deallocate(sizes)
285 return
286 endif
289 ! write the data in memory space to file space
290 CALL h5dwrite_f(dset_id,FieldType,XField,dimsfi,hdf5err,&
291 mem_space_id =dspace_id,file_space_id =fspace_id, &
292 xfer_prp = xfer_list)
293 if(hdf5err.lt.0) then
294 Status = WRF_HDF5_ERR_DATASET_WRITE
295 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
296 call wrf_debug ( WARN , msg)
297 deallocate(dims)
298 deallocate(count)
299 deallocate(offset)
300 deallocate(sizes)
301 return
302 endif
304 CALL h5pclose_f(xfer_list,hdf5err)
305 if(hdf5err.lt.0) then
306 Status = WRF_HDF5_ERR_PROPERTY_LIST
307 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
308 call wrf_debug ( WARN , msg)
309 deallocate(dims)
310 deallocate(count)
311 deallocate(offset)
312 deallocate(sizes)
313 return
314 endif
316 if(TimeIndex == 1) then
317 do i =1, MaxVars
318 if(DH%dsetids(i) == -1) then
319 DH%dsetids(i) = dset_id
320 DH%VarNames(i) = DataSetName
321 exit
322 endif
323 enddo
324 ! Only writing attributes when TimeIndex ==1
325 call write_hdf5_attributes(DataHandle,MemoryOrder,WrfDType,DimRank,&
326 NDim,dset_id,Status)
327 endif
329 call h5sclose_f(fspace_id,hdf5err)
330 call h5sclose_f(dspace_id,hdf5err)
331 if(TimeIndex /= 1) then
332 call h5dclose_f(dset_id,hdf5err)
333 endif
334 if(hdf5err.lt.0) then
335 Status = WRF_HDF5_ERR_DATASPACE
336 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
337 call wrf_debug ( WARN , msg)
338 deallocate(dims)
339 deallocate(count)
340 deallocate(offset)
341 deallocate(sizes)
342 return
343 endif
344 Status = WRF_NO_ERR
345 return
346 end subroutine HDF5IOWRITE
349 subroutine ext_phdf5_ioinit(SysDepInfo, Status)
351 use wrf_phdf5_data
352 use HDF5
353 implicit none
355 include 'wrf_status_codes.h'
356 include 'mpif.h'
358 CHARACTER*(*), INTENT(IN) :: SysDepInfo
359 integer, intent(out) :: status
360 integer :: hdf5err
362 ! set up some variables inside the derived type
363 WrfDataHandles(1:WrfDataHandleMax)%Free = .true.
364 ! ?
365 WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times'
366 WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time'
368 ! set up HDF5 global variables
369 call h5open_f(hdf5err)
370 if(hdf5err .lt.0) then
371 Status = WRF_HDF5_ERR_CLOSE_GENERAL
372 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
373 call wrf_debug ( WARN , msg)
374 return
375 endif
376 return
377 end subroutine ext_phdf5_ioinit
380 subroutine ext_phdf5_ioclose( DataHandle, Status)
382 use wrf_phdf5_data
383 use ext_phdf5_support_routines
384 use hdf5
385 implicit none
386 include 'wrf_status_codes.h'
387 include 'mpif.h'
389 integer ,intent(in) :: DataHandle
390 integer ,intent(out) :: Status
391 type(wrf_phdf5_data_handle),pointer :: DH
392 integer :: stat
393 integer :: NVar
394 integer :: hdferr
395 integer :: table_length
396 integer :: i
397 integer(hid_t) :: dtype_id
398 integer :: obj_count
399 integer(hid_t),allocatable,dimension(:) :: obj_ids
400 character(len=100) :: buf
401 integer(size_t) :: name_size
403 call GetDH(DataHandle,DH,Status)
404 if(Status /= WRF_NO_ERR) then
405 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', 906
406 call wrf_debug ( WARN , msg)
407 return
408 endif
410 ! THE FOLLOWING section writes dimscale information to the data set,may be put into a subroutine
412 ! check the file status, should be either open_for_read or opened_and_committed
413 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
414 Status = WRF_HDF5_ERR_FILE_OPEN
415 write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
416 call wrf_debug ( WARN , msg)
417 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
418 Status = WRF_HDF5_ERR_DRYRUN_CLOSE
419 write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ',__FILE__,', line', __LINE__
420 call wrf_debug ( WARN , msg)
422 elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
423 ! Handle dim. scale
424 ! STORE "Times" as the first element of the dimensional table
426 DH%DIMTABLE(1)%dim_name = 'Time'
427 DH%DIMTABLE(1)%Length = DH%TimeIndex
428 DH%DIMTABLE(1)%unlimited = 1
430 do i =1,MaxTabDims
431 if(DH%DIMTABLE(i)%dim_name== NO_NAME) then
432 exit
433 endif
434 enddo
436 table_length = i-1
437 call store_table(DataHandle,table_length,Status)
438 if(Status.ne.WRF_NO_ERR) then
439 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
440 call wrf_debug ( WARN , msg)
441 return
442 endif
443 continue
444 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
445 ! call h5dclose_f(DH%TimesID,hdferr)
446 ! if(hdferr.lt.0) then
447 ! Status = WRF_HDF5_ERR_DATASET_CLOSE
448 ! write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
449 ! call wrf_debug ( WARN , msg)
450 ! return
451 ! endif
452 continue
453 else
454 Status = WRF_HDF5_ERR_BAD_FILE_STATUS
455 write(msg,*) 'Fatal hdf5err BAD FILE STATUS in ',__FILE__,', line', __LINE__
456 call wrf_debug ( FATAL , msg)
457 return
458 endif
460 ! close HDF5 APIs
461 do NVar = 1, MaxVars
462 if(DH%DsetIDs(NVar) /= -1) then
463 call h5dclose_f(DH%DsetIDs(NVar),hdferr)
464 if(hdferr .ne. 0) then
465 Status = WRF_HDF5_ERR_DATASET_CLOSE
466 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
467 call wrf_debug ( WARN , msg)
468 return
469 endif
470 endif
471 enddo
473 do i = 1, MaxTimes
474 if(DH%TgroupIDs(i) /= -1) then
475 call h5gclose_f(DH%TgroupIDs(i),hdferr)
476 if(hdferr .ne. 0) then
477 Status = WRF_HDF5_ERR_DATASET_CLOSE
478 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
479 call wrf_debug ( WARN , msg)
480 return
481 endif
482 endif
483 enddo
485 call h5gclose_f(DH%GroupID,hdferr)
486 if(hdferr .ne. 0) then
487 Status = WRF_HDF5_ERR_CLOSE_GENERAL
488 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
489 call wrf_debug ( WARN , msg)
490 return
491 endif
493 call h5gclose_f(DH%DimGroupID,hdferr)
494 if(hdferr .ne. 0) then
495 Status = WRF_HDF5_ERR_CLOSE_GENERAL
496 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
497 call wrf_debug ( WARN , msg)
498 return
499 endif
501 if(Status /= WRF_NO_ERR) then
502 write(msg,*) 'HDF5 IO CLOSE error in ',__FILE__,', line', __LINE__
503 call wrf_debug ( WARN , msg)
504 return
505 endif
507 call h5fclose_f(DH%FileID,hdferr)
508 if(hdferr .ne. 0) then
509 Status = WRF_HDF5_ERR_CLOSE_GENERAL
510 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
511 call wrf_debug ( WARN , msg)
512 return
513 endif
515 if(Status /= WRF_NO_ERR) then
516 write(msg,*) 'HDF5 IO CLOSE error in ',__FILE__,', line', __LINE__
517 call wrf_debug ( WARN , msg)
518 return
519 endif
521 call free_memory(DataHandle,Status)
522 if(Status /= WRF_NO_ERR) then
523 Status = WRF_HDF5_ERR_OTHERS
524 write(msg,*) 'Warning Status = ',__FILE__,', line', __LINE__
525 call wrf_debug ( WARN , msg)
526 return
527 endif
529 DH%Free=.true.
530 return
531 end subroutine ext_phdf5_ioclose
534 subroutine ext_phdf5_ioexit(Status)
536 use wrf_phdf5_data
537 use ext_phdf5_support_routines
538 use HDF5
539 implicit none
540 include 'wrf_status_codes.h'
541 include 'mpif.h'
543 integer ,intent(out) :: Status
544 integer :: hdf5err
545 type(wrf_phdf5_data_handle),pointer :: DH
546 integer :: i
547 integer :: stat
550 ! free memories
551 do i=1,WrfDataHandleMax
552 if(.not.WrfDataHandles(i)%Free) then
553 call free_memory(i,Status)
554 exit
555 endif
556 enddo
558 if(Status /= WRF_NO_ERR) then
559 write(msg,*) 'free resources error in ',__FILE__,', line', __LINE__
560 call wrf_debug ( WARN , msg)
561 return
562 endif
564 CALL h5close_f(hdf5err)
566 if(hdf5err.lt.0) then
567 Status = WRF_HDF5_ERR_CLOSE_GENERAL
568 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
569 call wrf_debug ( FATAL , msg)
570 return
571 endif
573 return
574 end subroutine ext_phdf5_ioexit
578 !! This routine will set up everything to read HDF5 files
579 subroutine ext_phdf5_open_for_read(FileName,Comm,iocomm,SysDepInfo,DataHandle,Status)
581 use wrf_phdf5_data
582 use ext_phdf5_support_routines
583 use HDF5
584 implicit none
585 include 'mpif.h'
586 include 'wrf_status_codes.h'
588 character*(*),intent(in) :: FileName
589 integer ,intent(in) :: Comm
590 integer ,intent(in) :: iocomm
591 character*(*),intent(in) :: SysDepInfo
592 integer ,intent(out) :: DataHandle
593 type(wrf_phdf5_data_handle),pointer :: DH
594 integer ,intent(out) :: Status
596 integer(hid_t) :: Fileid
597 integer(hid_t) :: tgroupid
598 integer(hid_t) :: dsetid
599 integer(hid_t) :: dspaceid
600 integer(hid_t) :: dtypeid
601 integer(hid_t) :: acc_plist
602 integer :: nmembers
603 integer :: submembers
604 integer :: tmembers
605 integer :: ObjType
606 character(len= 256) :: ObjName
607 character(len= 256) :: GroupName
609 integer :: i,j
610 integer(hsize_t), dimension(7) :: data_dims
611 integer(hsize_t), dimension(1) :: h5dims
612 integer(hsize_t), dimension(1) :: h5maxdims
613 integer :: StoredDim
614 integer :: NumVars
616 integer :: hdf5err
617 integer :: info,mpi_size,mpi_rank
618 character(Len = MaxTimeSLen) :: tname
619 character(Len = 512) :: tgroupname
622 ! Allocating the data handle
623 call allocHandle(DataHandle,DH,Comm,Status)
624 if(Status /= WRF_NO_ERR) then
625 return
626 endif
628 call h5pcreate_f(H5P_FILE_ACCESS_F,acc_plist,hdf5err)
629 if(hdf5err.lt.0) then
630 Status = WRF_HDF5_ERR_PROPERTY_LIST
631 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
632 call wrf_debug ( WARN , msg)
633 return
634 endif
636 info = MPI_INFO_NULL
637 CALL h5pset_fapl_mpio_f(acc_plist, comm, info, hdf5err)
638 ! call h5pset_fapl_mpiposix_f(acc_plist,comm,.false.,hdf5err)
639 if(hdf5err .lt. 0) then
640 Status = WRF_HDF5_ERR_PROPERTY_LIST
641 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
642 call wrf_debug ( WARN , msg)
643 return
644 endif
645 !close every objects when closing HDF5 file.
646 call h5pset_fclose_degree_f(acc_plist,H5F_CLOSE_STRONG_F,hdf5err)
647 if(hdf5err .lt. 0) then
648 Status = WRF_HDF5_ERR_PROPERTY_LIST
649 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
650 call wrf_debug ( WARN , msg)
651 return
652 endif
655 ! Open the file
656 call h5fopen_f(FileName,H5F_ACC_RDWR_F,Fileid,hdf5err &
657 ,acc_plist)
658 if(hdf5err.lt.0) then
659 Status = WRF_HDF5_ERR_FILE_OPEN
660 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
661 call wrf_debug ( WARN , msg)
662 return
663 endif
664 call h5pclose_f(acc_plist,hdf5err)
665 if(hdf5err .lt. 0) then
666 Status = WRF_HDF5_ERR_PROPERTY_LIST
667 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
668 call wrf_debug ( WARN , msg)
669 return
670 endif
673 ! Obtain the number of group
674 DH%FileID = Fileid
675 call h5gn_members_f(Fileid,"/",nmembers,hdf5err)
676 if(hdf5err.lt.0) then
677 Status = WRF_HDF5_ERR_GROUP
678 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
679 call wrf_debug ( WARN , msg)
680 return
681 endif
683 ! Retrieve group id and dimensional group id, the index must be from 0
684 do i = 0, nmembers - 1
685 call h5gget_obj_info_idx_f(Fileid,"/",i,ObjName,ObjType,&
686 hdf5err)
687 if(hdf5err.lt.0) then
688 Status = WRF_HDF5_ERR_GROUP
689 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
690 call wrf_debug ( WARN , msg)
691 return
692 endif
694 if(ObjName=='DIM_GROUP') then
696 call h5gopen_f(Fileid,"/DIM_GROUP",DH%DimGroupID,hdf5err)
697 if(hdf5err.lt.0) then
698 Status = WRF_HDF5_ERR_GROUP
699 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
700 call wrf_debug ( WARN , msg)
701 return
702 endif
704 ! For WRF model, the first seven character must be DATASET
705 else if(ObjName(1:7)=='DATASET')then
707 GroupName="/"//ObjName
708 call h5gopen_f(Fileid,GroupName,DH%GroupID,hdf5err)
709 if(hdf5err.lt.0) then
710 Status = WRF_HDF5_ERR_GROUP
711 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
712 call wrf_debug ( WARN , msg)
713 return
714 endif
716 call h5gn_members_f(FileID,GroupName,submembers,Status)
717 if(hdf5err.lt.0) then
718 Status = WRF_HDF5_ERR_GROUP
719 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
720 call wrf_debug ( WARN , msg)
721 return
722 endif
724 do j = 0, submembers -1
725 call h5gget_obj_info_idx_f(Fileid,GroupName,j,ObjName,ObjType,hdf5err)
726 if(hdf5err.lt.0) then
727 Status = WRF_HDF5_ERR_GROUP
728 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
729 call wrf_debug ( WARN , msg)
730 return
731 endif
732 call numtochar(j+1,tname)
733 tgroupname = 'TIME_STAMP_'//tname
735 if(ObjName(1:17)==tgroupname) then
736 call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err)
737 if(hdf5err.lt.0) then
738 Status = WRF_HDF5_ERR_GROUP
739 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
740 call wrf_debug ( WARN , msg)
741 return
742 endif
743 call h5gn_members_f(DH%GroupID,tgroupname,tmembers,hdf5err)
744 if(hdf5err.lt.0) then
745 Status = WRF_HDF5_ERR_GROUP
746 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
747 call wrf_debug ( WARN , msg)
748 return
749 endif
750 call h5dopen_f(tgroupid,"Times",dsetid,hdf5err)
751 if(hdf5err.lt.0) then
752 Status = WRF_HDF5_ERR_DATASET_OPEN
753 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
754 call wrf_debug ( WARN , msg)
755 return
756 endif
757 call h5dget_space_f(dsetid,dspaceid,hdf5err)
758 if(hdf5err.lt.0) then
759 Status = WRF_HDF5_ERR_DATASPACE
760 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
761 call wrf_debug ( WARN , msg)
762 return
763 endif
764 call h5sget_simple_extent_ndims_f(dspaceid,StoredDim,hdf5err)
765 if(hdf5err.lt.0) then
766 Status = WRF_HDF5_ERR_DATASPACE
767 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
768 call wrf_debug ( WARN , msg)
769 return
770 endif
771 call h5sget_simple_extent_dims_f(dspaceid,h5dims,h5maxdims,hdf5err)
772 if(hdf5err.lt.0) then
773 Status = WRF_HDF5_ERR_DATASPACE
774 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
775 call wrf_debug ( WARN , msg)
776 return
777 endif
778 data_dims(1) = h5dims(1)
779 call h5dget_type_f(dsetid,dtypeid,hdf5err)
780 if(hdf5err.lt.0) then
781 Status = WRF_HDF5_ERR_DATATYPE
782 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
783 call wrf_debug ( WARN , msg)
784 return
785 endif
786 call h5dread_f(dsetid,dtypeid,DH%Times(j+1),data_dims,hdf5err)
787 if(hdf5err.lt.0) then
788 Status = WRF_HDF5_ERR_DATASET_READ
789 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
790 call wrf_debug ( WARN , msg)
791 return
792 endif
793 DH%CurrentVariable = 0
794 DH%CurrentTime = 0
795 DH%TimeIndex = 0
796 call h5tclose_f(dtypeid,hdf5err)
797 call h5sclose_f(dspaceid,hdf5err)
798 endif
799 enddo
800 DH%NumberTimes = submembers
802 ! the total member of HDF5 dataset.
803 DH%NumVars = tmembers*submembers
804 else
805 Status = WRF_HDF5_ERR_OTHERS
806 endif
807 enddo
809 DH%FileStatus = WRF_FILE_OPENED_FOR_READ
810 DH%FileName = FileName
812 ! obtain dimensional scale table
813 call retrieve_table(DataHandle,Status)
814 if(Status /= WRF_NO_ERR) then
815 return
816 endif
817 return
819 end subroutine ext_phdf5_open_for_read
822 subroutine ext_phdf5_inquire_opened(DataHandle,FileName,FileStatus,Status)
824 use wrf_phdf5_data
825 use ext_phdf5_support_routines
826 use HDF5
827 implicit none
828 include 'wrf_status_codes.h'
829 integer ,intent(in) :: DataHandle
830 character*(*) ,intent(in) :: FileName
831 integer ,intent(out) :: FileStatus
832 integer ,intent(out) :: Status
833 type(wrf_phdf5_data_handle) ,pointer :: DH
836 call GetDH(DataHandle,DH,Status)
837 if(Status /= WRF_NO_ERR) then
838 FileStatus = WRF_FILE_NOT_OPENED
839 return
840 endif
841 if(FileName /= DH%FileName) then
842 FileStatus = WRF_FILE_NOT_OPENED
843 else
844 FileStatus = DH%FileStatus
845 endif
846 Status = WRF_NO_ERR
847 return
848 end subroutine ext_phdf5_inquire_opened
851 subroutine ext_phdf5_inquire_filename(DataHandle,FileName,FileStatus,Status)
853 use wrf_phdf5_data
854 use ext_phdf5_support_routines
855 use HDF5
856 implicit none
857 include 'wrf_status_codes.h'
859 integer ,intent(in) :: DataHandle
860 character*(*) ,intent(out) :: FileName
861 integer ,intent(out) :: FileStatus
862 integer ,intent(out) :: Status
863 type(wrf_phdf5_data_handle) ,pointer :: DH
865 ! This line is added to make sure the wrong file will not be opened
866 FileStatus = WRF_FILE_NOT_OPENED
868 call GetDH(DataHandle,DH,Status)
869 if(Status /= WRF_NO_ERR) then
870 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,',line',__LINE__
871 call wrf_debug (WARN, msg)
872 return
873 endif
875 FileName = DH%FileName
876 FileStatus = DH%FileStatus
877 Status = WRF_NO_ERR
879 return
880 end subroutine ext_phdf5_inquire_filename
883 ! The real routine to read HDF5 files
884 subroutine ext_phdf5_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, &
885 IOComm, DomainDesc, MemoryOrder, Stagger, DimNames, &
886 DomainStart,DomainEnd,MemoryStart,MemoryEnd, &
887 PatchStart,PatchEnd,Status)
889 use wrf_phdf5_data
890 use ext_phdf5_support_routines
891 use HDF5
893 implicit none
894 include 'wrf_status_codes.h'
895 integer ,intent(in) :: DataHandle
896 character*(*) ,intent(in) :: DateStr
897 character*(*) ,intent(in) :: Var
898 integer ,intent(out) :: Field(*)
899 integer ,intent(in) :: FieldType
900 integer ,intent(inout) :: Comm
901 integer ,intent(inout) :: IOComm
902 integer ,intent(in) :: DomainDesc
903 character*(*) ,intent(in) :: MemoryOrder
904 character*(*) ,intent(in) :: Stagger ! Dummy for now
905 character*(*) , dimension (*) ,intent(in) :: DimNames
906 integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
907 integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
908 integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
909 integer ,intent(out) :: Status
911 type(wrf_phdf5_data_handle) ,pointer :: DH
912 integer :: NDim
913 integer(hid_t) :: GroupID
914 character (VarNameLen) :: VarName
915 integer ,dimension(NVarDims) :: Length
916 integer ,dimension(NVarDims) :: StoredStart
917 integer ,dimension(NVarDims) :: StoredLen
918 integer, dimension(NVarDims) :: TemDataStart
919 integer ,dimension(:,:,:,:) ,allocatable :: XField
920 integer :: NVar
921 integer :: j
922 integer :: i1,i2,j1,j2,k1,k2
923 integer :: x1,x2,y1,y2,z1,z2
924 integer :: l1,l2,m1,m2,n1,n2
925 character (VarNameLen) :: Name
926 integer :: XType
927 integer :: StoredDim
928 integer :: NAtts
929 integer :: Len
930 integer :: stat
931 integer :: di
932 integer :: FType
933 integer(hsize_t),dimension(7) :: data_dims
934 integer(hsize_t),dimension(:) ,allocatable :: h5_dims
935 integer(hsize_t),dimension(:) ,allocatable :: h5_maxdims
936 integer(hsize_t),dimension(:) ,allocatable :: DataStart
937 integer(hsize_t),dimension(:) ,allocatable :: Datacount
938 integer(hid_t) :: tgroupid
939 integer(hid_t) :: dsetid
940 integer(hid_t) :: dtype_id
941 integer(hid_t) :: dmemtype_id
942 integer(hid_t) :: dspace_id
943 integer(hid_t) :: memspace_id
944 integer :: class_type
945 integer :: TimeIndex
946 logical :: flag
947 integer :: hdf5err
949 character(Len = MaxTimeSLen) :: tname
950 character(Len = 512) :: tgroupname
953 ! FOR PARALLEL IO
954 integer :: mpi_rank
955 integer(hid_t) :: xfer_list
958 call GetDH(DataHandle,DH,Status)
959 if(Status /= WRF_NO_ERR) then
960 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
961 call wrf_debug ( WARN , msg)
962 return
963 endif
965 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
966 Status = WRF_HDF5_ERR_FILE_NOT_OPENED
967 write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
968 call wrf_debug ( WARN , msg)
969 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
970 Status = WRF_HDF5_ERR_DRYRUN_READ
971 write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
972 call wrf_debug ( WARN , msg)
973 elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
974 Status = WRF_HDF5_ERR_READ_WONLY_FILE
975 write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
976 call wrf_debug ( WARN , msg)
977 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
979 ! obtain TimeIndex
980 call GetDataTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
982 ! obtain the absolute name of the group where the dataset is located
983 call numtochar(TimeIndex,tname)
984 tgroupname = 'TIME_STAMP_'//tname
986 call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err)
987 if(hdf5err.lt.0) then
988 Status = WRF_HDF5_ERR_GROUP
989 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
990 call wrf_debug ( WARN , msg)
991 return
992 endif
994 call h5dopen_f(tgroupid,Var,dsetid,hdf5err)
995 if(hdf5err.lt.0) then
996 Status = WRF_HDF5_ERR_DATASET_OPEN
997 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
998 call wrf_debug ( WARN , msg)
999 return
1000 endif
1002 ! Obtain the memory datatype
1003 select case(FieldType)
1004 case (WRF_REAL)
1005 dmemtype_id = H5T_NATIVE_REAL
1006 case (WRF_DOUBLE)
1007 dmemtype_id = H5T_NATIVE_DOUBLE
1008 case (WRF_INTEGER)
1009 dmemtype_id = H5T_NATIVE_INTEGER
1010 case (WRF_LOGICAL)
1011 dmemtype_id = DH%EnumID
1012 case default
1013 Status = WRF_HDF5_ERR_DATA_TYPE_NOTFOUND
1014 write(msg,*) 'Warning BAD Memory Data type in ',__FILE__,',line',__LINE__
1015 call wrf_debug(WARN,msg)
1016 return
1017 end select
1019 ! Obtain the datatype
1020 call h5dget_type_f(dsetid,dtype_id,hdf5err)
1021 if(hdf5err.lt.0) then
1022 Status = WRF_HDF5_ERR_DATATYPE
1023 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1024 call wrf_debug ( WARN , msg)
1025 return
1026 endif
1028 ! double check whether the Fieldtype is the type of the dataset
1029 ! we may do the force coercion between real and double
1030 call h5tget_class_f(dtype_id,class_type,hdf5err)
1031 if(hdf5err.lt.0) then
1032 Status = WRF_HDF5_ERR_DATATYPE
1033 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1034 call wrf_debug ( WARN , msg)
1035 return
1036 endif
1038 if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then
1039 if ( class_type /= H5T_FLOAT_F) then
1040 Status = WRF_HDF5_ERR_TYPE_MISMATCH
1041 write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1042 call wrf_debug ( WARN , msg)
1043 return
1044 endif
1045 else if(FieldType == WRF_CHARACTER) then
1046 if(class_type /= H5T_STRING_F) then
1047 Status = WRF_HDF5_ERR_TYPE_MISMATCH
1048 write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1049 call wrf_debug ( WARN , msg)
1050 return
1051 endif
1052 else if(FieldType == WRF_INTEGER) then
1053 if(class_type /= H5T_INTEGER_F) then
1054 Status = WRF_HDF5_ERR_TYPE_MISMATCH
1055 write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1056 call wrf_debug ( WARN , msg)
1057 return
1058 endif
1059 else if(FieldType == WRF_LOGICAL) then
1060 if(class_type /= H5T_ENUM_F) then
1061 Status = WRF_HDF5_ERR_TYPE_MISMATCH
1062 write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1063 call wrf_debug ( WARN , msg)
1064 return
1065 endif
1066 call h5tequal_f(dtype_id,DH%EnumID,flag,hdf5err)
1067 if(hdf5err.lt.0) then
1068 Status = WRF_HDF5_ERR_DATASET_OPEN
1069 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1070 call wrf_debug ( WARN , msg)
1071 return
1072 endif
1073 if(flag .EQV. .FALSE.) then
1074 Status = WRF_HDF5_ERR_TYPE_MISMATCH
1075 write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1076 call wrf_debug ( WARN , msg)
1077 return
1078 endif
1079 else
1080 Status = WRF_HDF5_ERR_BAD_DATA_TYPE
1081 write(msg,*)'Fatal Non-WRF supported TYPE in ',__FILE__,', line',__LINE__
1082 call wrf_debug(FATAL, msg)
1083 return
1084 endif
1086 ! Obtain the dataspace, check whether the dataspace is within the range
1087 ! transpose the memory order to the disk order
1088 call h5dget_space_f(dsetid,dspace_id,hdf5err)
1089 if(hdf5err.lt.0) then
1090 Status = WRF_HDF5_ERR_DATASPACE
1091 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1092 call wrf_debug ( WARN , msg)
1093 return
1094 endif
1096 call GetDim(MemoryOrder,NDim,Status)
1098 Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
1099 call ExtOrder(MemoryOrder,Length,Status)
1101 ! Obtain the rank of the dimension
1102 call h5sget_simple_extent_ndims_f(dspace_id,StoredDim,hdf5err)
1103 if(hdf5err.lt.0) then
1104 Status = WRF_HDF5_ERR_DATASPACE
1105 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1106 call wrf_debug ( WARN , msg)
1107 return
1108 endif
1110 ! From NetCDF implementation, only do error handling
1111 if((NDim+1) /= StoredDim) then
1112 Status = WRF_HDF5_ERR_BAD_VARIABLE_DIM
1113 write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ',__FILE__,', line', __LINE__
1114 call wrf_debug ( FATAL , msg)
1115 return
1116 endif
1117 allocate(h5_dims(StoredDim))
1118 allocate(h5_maxdims(StoredDim))
1119 allocate(DataStart(StoredDim))
1120 allocate(DataCount(StoredDim))
1122 call h5sget_simple_extent_dims_f(dspace_id,h5_dims,h5_maxdims,hdf5err)
1123 if(hdf5err.lt.0) then
1124 Status = WRF_HDF5_ERR_DATASPACE
1125 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1126 call wrf_debug ( WARN , msg)
1127 return
1128 endif
1130 ! This part of code needs to be adjusted, currently use NetCDF convention
1131 do j = 1, NDim
1132 if(Length(j) > h5_dims(j)) then
1133 Status = WRF_HDF5_ERR_READ_PAST_EOF
1134 write(msg,*) 'Warning READ PAST EOF in ',__FILE__,', line', __LINE__
1135 call wrf_debug ( WARN , msg)
1136 return
1137 elseif(Length(j) <= 0) then
1138 Status = WRF_HDF5_ERR_ZERO_LENGTH_READ
1139 write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__
1140 call wrf_debug ( WARN , msg)
1141 return
1142 endif
1143 enddo
1145 ! create memspace_id
1146 data_dims(1:NDim) = Length(1:NDim)
1147 data_dims(NDim+1) = 1
1149 call h5screate_simple_f(NDim+1,data_dims,memspace_id,hdf5err)
1150 if(hdf5err.lt.0) then
1151 Status = WRF_HDF5_ERR_DATASPACE
1152 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1153 call wrf_debug ( WARN , msg)
1154 return
1155 endif
1157 ! DataStart can start from PatchStart.
1158 TEMDataStart(1:NDim) = PatchStart(1:NDim)-1
1160 if(MemoryOrder.NE.'0') then
1161 call ExtOrder(MemoryOrder,TEMDataStart,Status)
1162 endif
1164 DataStart(1:NDim) = TEMDataStart(1:NDim)
1165 DataStart(NDim+1) = 0
1166 DataCount(1:NDim) = Length(1:NDim)
1167 DataCount(NDim+1) = 1
1169 ! transpose the data XField to Field
1170 call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
1171 StoredStart = 1
1172 StoredLen(1:NDim) = Length(1:NDim)
1174 ! the dimensional information inside the disk may be greater than
1175 ! the dimension(PatchEnd-PatchStart); here we can speed up
1176 ! the performance by using hyperslab selection
1177 call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2)
1178 call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2)
1180 ! di is for double type data
1181 di = 1
1182 if(FieldType == WRF_DOUBLE) di = 2
1183 allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
1185 ! use hyperslab to only read this current timestamp
1186 call h5sselect_hyperslab_f(dspace_id,H5S_SELECT_SET_F, &
1187 DataStart,DataCount,hdf5err)
1188 if(hdf5err.lt.0) then
1189 Status = WRF_HDF5_ERR_DATASET_GENERAL
1190 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1191 call wrf_debug ( WARN , msg)
1192 return
1193 endif
1195 ! read the data in this time stamp
1196 call h5dread_f(dsetid,dmemtype_id,XField,data_dims,hdf5err, &
1197 memspace_id,dspace_id,H5P_DEFAULT_F)
1198 if(hdf5err.lt.0) then
1199 Status = WRF_HDF5_ERR_DATASET_READ
1200 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1201 call wrf_debug ( WARN , msg)
1202 return
1203 endif
1205 call transpose_hdf5('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
1206 ,XField,x1,x2,y1,y2,z1,z2 &
1207 ,i1,i2,j1,j2,k1,k2 )
1209 deallocate(XField, STAT=stat)
1210 if(stat/= 0) then
1211 Status = WRF_HDF5_ERR_DEALLOCATION
1212 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
1213 call wrf_debug ( FATAL , msg)
1214 return
1215 endif
1217 call h5dclose_f(dsetid,hdf5err)
1218 if(hdf5err.lt.0) then
1219 Status = WRF_HDF5_ERR_DATASET_CLOSE
1220 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1221 call wrf_debug ( WARN , msg)
1222 return
1223 endif
1224 deallocate(h5_dims)
1225 deallocate(h5_maxdims)
1226 deallocate(DataStart)
1227 deallocate(DataCount)
1228 else
1229 Status = WRF_HDF5_ERR_BAD_FILE_STATUS
1230 write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1231 call wrf_debug ( FATAL , msg)
1232 endif
1234 DH%first_operation = .FALSE.
1236 return
1237 end subroutine ext_phdf5_read_field
1239 !! This routine essentially sets up everything to write HDF5 files
1240 SUBROUTINE ext_phdf5_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status)
1242 use wrf_phdf5_data
1243 use HDF5
1244 use ext_phdf5_support_routines
1245 implicit none
1246 include 'mpif.h'
1247 include 'wrf_status_codes.h'
1249 character*(*) ,intent(in) :: FileName
1250 integer ,intent(in) :: Comm
1251 integer ,intent(in) :: IOComm
1252 character*(*) ,intent(in) :: SysDepInfo
1253 integer ,intent(out) :: DataHandle
1254 integer ,intent(out) :: Status
1255 type(wrf_phdf5_data_handle),pointer :: DH
1256 integer(hid_t) :: file5_id
1257 integer(hid_t) :: g_id
1258 integer(hid_t) :: gdim_id
1259 integer :: hdferr
1260 integer :: i
1261 integer :: stat
1262 character (7) :: Buffer
1263 integer :: VDimIDs(2)
1264 character(Len = 512) :: groupname
1266 ! For parallel IO
1267 integer(hid_t) :: plist_id
1268 integer :: hdf5_comm,info,mpi_size,mpi_rank
1271 call allocHandle(DataHandle,DH,Comm,Status)
1272 if(Status /= WRF_NO_ERR) then
1273 write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
1274 call wrf_debug ( FATAL , msg)
1275 return
1276 endif
1277 DH%TimeIndex = 0
1278 DH%Times = ZeroDate
1280 CALL h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr)
1281 if(hdferr .lt. 0) then
1282 Status = WRF_HDF5_ERR_PROPERTY_LIST
1283 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1284 call wrf_debug ( WARN , msg)
1285 return
1286 endif
1288 info = MPI_INFO_NULL
1290 CALL h5pset_fapl_mpio_f(plist_id, comm, info, hdferr)
1292 if(hdferr .lt. 0) then
1293 Status = WRF_HDF5_ERR_PROPERTY_LIST
1294 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1295 call wrf_debug ( WARN , msg)
1296 return
1297 endif
1299 call h5fcreate_f(FileName,H5F_ACC_TRUNC_F,file5_id,hdferr &
1300 ,access_prp = plist_id)
1301 if(hdferr .lt. 0) then
1302 Status = WRF_HDF5_ERR_FILE_CREATE
1303 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1304 call wrf_debug ( WARN , msg)
1305 return
1306 endif
1308 call h5pclose_f(plist_id,hdferr)
1309 if(hdferr .lt. 0) then
1310 Status = WRF_HDF5_ERR_PROPERTY_LIST
1311 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1312 call wrf_debug ( WARN , msg)
1313 return
1314 endif
1316 DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
1317 DH%FileName = FileName
1318 ! should add a check to see whether the file opened has been used by previous handles
1319 DH%VarNames (1:MaxVars) = NO_NAME
1320 DH%MDVarNames(1:MaxVars) = NO_NAME
1322 ! group name information is stored at SysDepInfo
1323 groupname = "/"//SysDepInfo
1324 ! write(*,*) "groupname ",groupname
1325 call h5gcreate_f(file5_id,groupname,g_id,hdferr)
1326 if(hdferr .lt. 0) then
1327 Status = WRF_HDF5_ERR_GROUP
1328 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1329 call wrf_debug ( WARN , msg)
1330 return
1331 endif
1333 ! create dimensional group id
1334 call h5gcreate_f(file5_id,"/DIM_GROUP",gdim_id,hdferr)
1335 if(hdferr .lt. 0) then
1336 Status = WRF_HDF5_ERR_GROUP
1337 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1338 call wrf_debug ( WARN , msg)
1339 return
1340 endif
1342 DH%FileID = file5_id
1343 DH%GroupID = g_id
1344 DH%DIMGroupID = gdim_id
1346 return
1348 end subroutine ext_phdf5_open_for_write_begin
1350 ! HDF5 doesnot need this stage, basically this routine
1351 ! just updates the File status.
1352 SUBROUTINE ext_phdf5_open_for_write_commit(DataHandle, Status)
1354 use wrf_phdf5_data
1355 use ext_phdf5_support_routines
1356 use HDF5
1357 implicit none
1358 include 'wrf_status_codes.h'
1360 integer ,intent(in) :: DataHandle
1361 integer ,intent(out) :: Status
1362 type(wrf_phdf5_data_handle),pointer :: DH
1363 integer(hid_t) :: enum_type
1364 integer :: i
1365 integer :: stat
1368 call GetDH(DataHandle,DH,Status)
1369 if(Status /= WRF_NO_ERR) then
1370 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1371 call wrf_debug ( WARN , msg)
1372 return
1373 endif
1375 DH%FileStatus = WRF_FILE_OPENED_AND_COMMITTED
1376 DH%first_operation = .TRUE.
1377 return
1378 end subroutine ext_phdf5_open_for_write_commit
1380 ! The real routine to write HDF5 file
1381 subroutine ext_phdf5_write_field(DataHandle,DateStr,Var,Field,FieldType,&
1382 Comm,IOComm,DomainDesc,MemoryOrder, &
1383 Stagger,DimNames,DomainStart,DomainEnd,&
1384 MemoryStart,MemoryEnd,PatchStart,PatchEnd,&
1385 Status)
1387 use wrf_phdf5_data
1388 use ext_phdf5_support_routines
1389 USE HDF5 ! This module contains all necessary modules
1390 implicit none
1391 include 'wrf_status_codes.h'
1393 integer ,intent(in) :: DataHandle
1394 character*(*) ,intent(in) :: DateStr
1395 character*(*) ,intent(in) :: Var
1396 integer ,intent(inout) :: Field(*)
1397 integer ,intent(in) :: FieldType
1398 integer ,intent(inout) :: Comm
1399 integer ,intent(inout) :: IOComm
1400 integer ,intent(in) :: DomainDesc
1401 character*(*) ,intent(in) :: MemoryOrder
1402 character*(*) ,intent(in) :: Stagger ! Dummy for now
1403 character*(*) , dimension (*) ,intent(in) :: DimNames
1404 integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
1405 integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
1406 integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
1407 integer ,intent(out) :: Status
1409 type(wrf_phdf5_data_handle) ,pointer :: DH
1410 integer(hid_t) :: GroupID
1411 integer :: NDim
1412 character (VarNameLen) :: VarName
1413 character (3) :: MemO
1414 character (3) :: UCMemO
1415 integer(hid_t) :: DsetID
1416 integer ,dimension(NVarDims) :: Length
1417 integer ,dimension(NVarDims) :: DomLength
1418 integer ,dimension(NVarDims+1) :: DimRank
1419 character(256),dimension(NVarDims) :: RODimNames
1420 integer ,dimension(NVarDims) :: StoredStart
1421 integer ,dimension(:,:,:,:),allocatable :: XField
1422 integer ,dimension(:,:,:,:),allocatable :: BUFFER! for logical field
1423 integer :: stat
1424 integer :: NVar
1425 integer :: i,j,k,m,dim_flag
1426 integer :: i1,i2,j1,j2,k1,k2
1427 integer :: x1,x2,y1,y2,z1,z2
1428 integer :: l1,l2,m1,m2,n1,n2
1429 integer(hid_t) :: XType
1430 integer :: di
1431 character (256) :: NullName
1432 integer :: TimeIndex
1433 integer ,dimension(NVarDims+1) :: temprank
1434 logical :: NotFound
1437 NullName = char(0)
1438 dim_flag = 0
1440 call GetDH(DataHandle,DH,Status)
1441 if(Status /= WRF_NO_ERR) then
1442 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1443 call wrf_debug ( WARN , msg)
1444 return
1445 endif
1447 ! Examine here, Nov. 7th, 2003
1448 if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
1450 ! obtain group id and initialize the rank of dimensional attributes
1451 GroupID = DH%GroupID
1452 DimRank = -1
1454 ! get the rank of the dimension based on MemoryOrder string(cleaver from NetCDF)
1455 call GetDim(MemoryOrder,NDim,Status)
1456 if(Status /= WRF_NO_ERR) then
1457 write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__
1458 call wrf_debug ( WARN , msg)
1459 return
1460 endif
1462 ! check whether the DateStr is the correct length
1463 call DateCheck(DateStr,Status)
1464 if(Status /= WRF_NO_ERR) then
1465 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
1466 call wrf_debug ( WARN , msg)
1467 return
1468 endif
1470 ! get the dataset name and dimensional information of the data
1471 VarName = Var
1472 Length(1:NDim) = PatchEnd(1:NDim) - PatchStart(1:NDim) + 1
1473 DomLength(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1
1475 ! Transposing the data order and dim. string order, store to RODimNames
1476 call ExtOrder(MemoryOrder,Length,Status)
1477 call ExtOrder(MemoryOrder,DomLength,Status)
1478 if(Status /= WRF_NO_ERR) then
1479 write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__
1480 call wrf_debug ( WARN , msg)
1481 return
1482 endif
1484 ! Map datatype from WRF to HDF5
1485 select case (FieldType)
1486 case (WRF_REAL)
1487 XType = H5T_NATIVE_REAL
1488 case (WRF_DOUBLE)
1489 Xtype = H5T_NATIVE_DOUBLE
1490 case (WRF_INTEGER)
1491 XType = H5T_NATIVE_INTEGER
1492 case (WRF_LOGICAL)
1493 XType = DH%EnumID
1494 case default
1495 Status = WRF_HDF5_ERR_DATA_TYPE_NOTFOUND
1496 return
1497 end select
1499 ! HANDLE with dim. scale
1500 ! handle dimensional scale data; search and store them in a table.
1501 ! The table is one dimensional array of compound data type. One member of
1502 ! the type is HDF5 string, representing the name of the dim(west_east_stag eg.)
1503 ! Another number is the length of the dimension(west_east_stag = 31)
1504 ! In this part, we will not store TIME but leave it at the end since the time
1505 ! index won't be known until the end of the run; since all fields(HDF5 datasets)
1506 ! have the same timestamp, writing it once should be fine.
1508 ! 1) create a loop for dimensions
1509 call GetDataTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
1510 if(Status /= WRF_NO_ERR) then
1511 return
1512 endif
1514 if(TimeIndex == 1) then
1516 ! 2) get the dim. name, the first dim. is reserved for time,
1517 call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status)
1518 if(Status /= WRF_NO_ERR) then
1519 write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__
1520 call wrf_debug ( WARN , msg)
1521 return
1522 endif
1523 ! 3) get the dim. length
1524 ! 4) inside the loop, search the table for dimensional name( table module)
1525 ! IF FOUND, go to the next dimension, return the table dimensional rank
1526 ! (For example, find west_east_stag in the table, the rank of "west_east_stag"
1527 ! is 3; so return 3 for the array dimrank.)
1528 ! in the table; so through the table, we can find the information
1529 ! such as names, length of this dimension
1530 ! 4.1) save the rank into an array for attribute
1531 ! if not found, go to 5)
1532 ! 4)' the first dimension is reserved for time, so table starts from j = 2
1533 !
1534 ! 5) NOT FOUND, inside the loop add the new dimensional information to the
1535 ! table(table module)
1537 ! The first dimension of the field is always "time" and "time"
1538 ! is also the first dimension of the "table".
1539 k = 2
1540 DimRank(1) = 1
1542 do i = 1,NDim
1543 do j = 2,MaxTabDims
1545 ! Search for the table and see if we are at the end of the table
1546 if (DH%DIMTABLE(j)%dim_name == NO_NAME) then
1548 ! Sometimes the RODimNames is NULLName or ''. If that happens,
1549 ! we will search the table from the beginning and see
1550 ! whether the name is FAKEDIM(the default name) and the
1551 ! current length of the dim. is the same as that of FAKEDIM;
1552 ! if yes, use this FAKEDIM for the current field dim.
1554 if(RODimNames(i) ==''.or. RODimNames(i)==NullName) then
1555 do m = 2,j
1556 if(DomLength(i)==DH%DIMTABLE(m)%Length.and. &
1557 DH%DIMTABLE(m)%dim_name(1:7)=='FAKEDIM')then
1558 DimRank(k) = m
1559 k = k + 1
1560 dim_flag = 1
1561 exit
1562 endif
1563 enddo
1564 ! No FAKEDIM and the same length dim. is found,
1565 ! Add another dimension "FAKEDIM + j", with the length
1566 ! as DomLength(i)
1567 if (dim_flag == 1) then
1568 dim_flag = 0
1569 else
1570 RODimNames(i) = 'FAKEDIM'//achar(j+iachar('0'))
1571 DH%DIMTABLE(j)%dim_name = RODimNames(i)
1572 DH%DIMTABLE(j)%length = DomLength(i)
1573 DimRank(k) = j
1574 k = k + 1
1575 endif
1576 ! no '' or NULLName is found, then assign this RODimNames
1577 ! to the dim. table.
1578 else
1579 DH%DIMTABLE(j)%dim_name = RODimNames(i)
1580 DH%DIMTABLE(j)%length = DomLength(i)
1581 DimRank(k) = j
1582 k = k + 1
1583 endif
1584 exit
1585 ! If we found the current dim. in the table already,save the rank
1586 else if(DH%DIMTABLE(j)%dim_name == RODimNames(i)) then
1587 ! remember the rank of dimensional scale
1588 DimRank(k) = j
1589 k = k + 1
1590 exit
1591 else
1592 continue
1593 endif
1594 enddo
1595 enddo
1596 endif ! end of timeindex of 1
1598 ! 6) create an attribute array called DimRank to store the rank of the attribute.
1599 ! This will be done in the HDF5IOWRITE routine
1601 ! 7) before the end of the run, 1) update time, 2) write the table to HDF5.
1603 ! get the index of l1,.......for writing HDF5 file.
1604 StoredStart = 1
1605 call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
1606 call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2)
1607 call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
1608 di=1
1609 if(FieldType == WRF_DOUBLE) di = 2
1610 allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
1611 if(stat/= 0) then
1612 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
1613 write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
1614 call wrf_debug ( FATAL , msg)
1615 return
1616 endif
1618 ! Transpose the real data for tools people
1619 call Transpose_hdf5('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
1620 ,XField,x1,x2,y1,y2,z1,z2 &
1621 ,i1,i2,j1,j2,k1,k2 )
1623 ! handle with logical data separately,because of not able to
1624 ! map Fortran Logical type to C type
1625 if(FieldType .eq. WRF_LOGICAL) then
1626 allocate(BUFFER(di,x1:x2,y1:y2,z1:z2), STAT=stat)
1627 do k =z1,z2
1628 do j = y1,y2
1629 do i = x1,x2
1630 do m = 1,di
1631 if(XField(m,i,j,k)/= 0) then
1632 BUFFER(m,i,j,k) = 1
1633 else
1634 BUFFER(m,i,j,k) = 0
1635 endif
1636 enddo
1637 enddo
1638 enddo
1639 enddo
1640 call HDF5IOWRITE(DataHandle,Comm,DateStr,Length,DomainStart, DomainEnd &
1641 ,PatchStart,PatchEnd, MemoryOrder &
1642 ,FieldType,XType,groupID,TimeIndex,DimRank &
1643 ,Var,BUFFER,Status)
1644 deallocate(BUFFER,STAT=stat)
1645 if(stat/=0) then
1646 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
1647 write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
1648 call wrf_debug ( FATAL , msg)
1649 return
1650 endif
1651 else
1652 call HDF5IOWRITE(DataHandle,Comm,DateStr,Length, DomainStart, DomainEnd &
1653 ,PatchStart, PatchEnd, MemoryOrder &
1654 ,FieldType,XType,groupID,TimeIndex,DimRank &
1655 ,Var,XField,Status)
1656 endif
1658 if (Status /= WRF_NO_ERR) then
1659 return
1660 endif
1662 deallocate(XField,STAT=stat)
1663 if(stat/=0) then
1664 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
1665 write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
1666 call wrf_debug ( FATAL , msg)
1667 return
1668 endif
1669 endif
1671 DH%first_operation = .FALSE.
1673 return
1675 end subroutine ext_phdf5_write_field
1677 ! set_time routine is only used for open_for_read
1678 subroutine ext_phdf5_set_time(DataHandle, DateStr, Status)
1680 use wrf_phdf5_data
1681 use ext_phdf5_support_routines
1682 use HDF5
1683 implicit none
1684 include 'wrf_status_codes.h'
1686 integer ,intent(in) :: DataHandle
1687 character*(*) ,intent(in) :: DateStr
1688 integer ,intent(out) :: Status
1689 type(wrf_phdf5_data_handle) ,pointer :: DH
1690 integer :: i
1692 ! check whether the Date length is equal to DateStrLen defined at wrf_phdf5_data
1693 ! sees not enough, leave it for the time being 3/12/2003
1694 call DateCheck(DateStr,Status)
1695 if(Status /= WRF_NO_ERR) then
1696 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
1697 call wrf_debug ( WARN , msg)
1698 return
1699 endif
1701 call GetDH(DataHandle,DH,Status)
1702 if(Status /= WRF_NO_ERR) then
1703 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1704 call wrf_debug ( WARN , msg)
1705 return
1706 endif
1707 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1708 Status = WRF_HDF5_ERR_FILE_NOT_OPENED
1709 write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1710 call wrf_debug ( WARN , msg)
1711 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1712 Status = WRF_HDF5_ERR_FILE_NOT_COMMITTED
1713 write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1714 call wrf_debug ( WARN , msg)
1715 elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
1716 Status = WRF_HDF5_ERR_READ_WONLY_FILE
1717 write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
1718 call wrf_debug ( WARN , msg)
1719 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1720 do i=1,MaxTimes
1721 if(DH%Times(i)==DateStr) then
1722 DH%CurrentTime = i
1723 exit
1724 endif
1725 if(i==MaxTimes) then
1726 Status = WRF_HDF5_ERR_TIME
1727 return
1728 endif
1729 enddo
1730 DH%CurrentVariable = 0
1731 Status = WRF_NO_ERR
1732 else
1733 Status = WRF_HDF5_ERR_BAD_FILE_STATUS
1734 write(msg,*) 'FATAL BAD FILE STATUS in ',__FILE__,', line', __LINE__
1735 call wrf_debug ( FATAL , msg)
1736 endif
1737 return
1738 end subroutine ext_phdf5_set_time
1740 ! get_next_time routine is only used for open_for_read
1741 subroutine ext_phdf5_get_next_time(DataHandle, DateStr, Status)
1742 use wrf_phdf5_data
1743 use ext_phdf5_support_routines
1744 use HDF5
1745 implicit none
1746 include 'wrf_status_codes.h'
1748 integer ,intent(in) :: DataHandle
1749 character*(*) ,intent(out) :: DateStr
1750 integer ,intent(out) :: Status
1751 type(wrf_phdf5_data_handle) ,pointer :: DH
1753 call GetDH(DataHandle,DH,Status)
1754 if(Status /= WRF_NO_ERR) then
1755 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1756 call wrf_debug ( WARN , msg)
1757 return
1758 endif
1760 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1761 Status = WRF_HDF5_ERR_FILE_NOT_OPENED
1762 write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1763 call wrf_debug ( WARN , msg)
1764 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1765 Status = WRF_HDF5_ERR_DRYRUN_READ
1766 write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
1767 call wrf_debug ( WARN , msg)
1768 elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
1769 Status = WRF_HDF5_ERR_READ_WONLY_FILE
1770 write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
1771 call wrf_debug ( WARN , msg)
1772 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1773 if(DH%CurrentTime >= DH%NumberTimes) then
1774 Status = WRF_HDF5_ERR_TIME
1775 write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
1776 call wrf_debug ( WARN , msg)
1777 return
1778 endif
1779 DH%CurrentTime = DH%CurrentTime +1
1780 DateStr = DH%Times(DH%CurrentTime)
1781 DH%CurrentVariable = 0
1782 Status = WRF_NO_ERR
1783 else
1784 Status = WRF_HDF5_ERR_BAD_FILE_STATUS
1785 write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1786 call wrf_debug ( FATAL , msg)
1787 endif
1788 return
1789 end subroutine ext_phdf5_get_next_time
1791 ! get_previous_time routine
1792 subroutine ext_phdf5_get_previous_time(DataHandle, DateStr, Status)
1793 use wrf_phdf5_data
1794 use ext_phdf5_support_routines
1795 use HDF5
1796 implicit none
1797 include 'wrf_status_codes.h'
1799 integer ,intent(in) :: DataHandle
1800 character*(*) ,intent(out) :: DateStr
1801 integer ,intent(out) :: Status
1802 type(wrf_phdf5_data_handle) ,pointer :: DH
1804 call GetDH(DataHandle,DH,Status)
1805 if(Status /= WRF_NO_ERR) then
1806 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1807 call wrf_debug ( WARN , msg)
1808 return
1809 endif
1811 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1812 Status = WRF_HDF5_ERR_FILE_NOT_OPENED
1813 write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1814 call wrf_debug ( WARN , msg)
1815 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1816 Status = WRF_HDF5_ERR_DRYRUN_READ
1817 write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
1818 call wrf_debug ( WARN , msg)
1819 elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
1820 Status = WRF_HDF5_ERR_READ_WONLY_FILE
1821 write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
1822 call wrf_debug ( WARN , msg)
1823 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1824 if(DH%CurrentTime.GT.0) then
1825 DH%CurrentTime = DH%CurrentTime - 1
1826 endif
1827 DateStr = DH%Times(DH%CurrentTime)
1828 DH%CurrentVariable = 0
1829 Status = WRF_NO_ERR
1830 else
1831 Status = WRF_HDF5_ERR_BAD_FILE_STATUS
1832 write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1833 call wrf_debug ( FATAL , msg)
1834 endif
1835 return
1836 end subroutine ext_phdf5_get_previous_time
1838 subroutine ext_phdf5_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status)
1840 use wrf_phdf5_data
1841 use ext_phdf5_support_routines
1842 use HDF5
1843 implicit none
1844 include 'wrf_status_codes.h'
1845 integer ,intent(in) :: DataHandle
1846 character*(*) ,intent(in) :: Name
1847 integer ,intent(out) :: NDim
1848 character*(*) ,intent(out) :: MemoryOrder
1849 character*(*) ,intent(out) :: Stagger ! Dummy for now
1850 integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd
1851 integer ,intent(out) :: WrfType
1852 integer ,intent(out) :: Status
1853 type(wrf_phdf5_data_handle) ,pointer :: DH
1854 integer :: VarID
1855 integer ,dimension(NVarDims) :: VDimIDs
1856 integer :: j
1857 integer :: hdf5err
1858 integer :: XType
1860 character(Len =MaxTimeSLen) :: tname
1861 character(Len = 512) :: tgroupname
1862 integer(hid_t) :: tgroupid
1863 integer(hid_t) :: dsetid
1864 integer(hid_t) :: dspaceid
1865 integer :: HDF5_NDim
1866 integer(hsize_t),dimension(:),allocatable :: h5dims
1867 integer(hsize_t),dimension(:),allocatable :: h5maxdims
1869 call GetDH(DataHandle,DH,Status)
1870 if(Status /= WRF_NO_ERR) then
1871 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1872 call wrf_debug ( WARN , TRIM(msg))
1873 return
1874 endif
1875 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1876 Status = WRF_HDF5_ERR_FILE_NOT_OPENED
1877 write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1878 call wrf_debug ( WARN , TRIM(msg))
1879 return
1880 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1881 Status = WRF_HDF5_ERR_DRYRUN_READ
1882 write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
1883 call wrf_debug ( WARN , TRIM(msg))
1884 return
1885 elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
1886 Status = WRF_HDF5_ERR_READ_WONLY_FILE
1887 write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
1888 call wrf_debug ( WARN , TRIM(msg))
1889 return
1890 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1891 if(Name /= "Times") then
1892 call numtochar(1,tname)
1893 tgroupname = 'TIME_STAMP_'//tname
1894 call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err)
1895 if(hdf5err.lt.0) then
1896 Status = WRF_HDF5_ERR_GROUP
1897 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1898 call wrf_debug ( WARN , msg)
1899 return
1900 endif
1901 call h5dopen_f(tgroupid,Name,dsetid,hdf5err)
1902 if(hdf5err /= 0) then
1903 STATUS = WRF_HDF5_ERR_DATASET_OPEN
1904 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1905 call wrf_debug ( WARN , msg)
1906 return
1907 endif
1908 call h5dget_space_f(dsetid,dspaceid,hdf5err)
1909 if(hdf5err.lt.0) then
1910 Status = WRF_HDF5_ERR_DATASPACE
1911 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1912 call wrf_debug ( WARN , msg)
1913 return
1914 endif
1916 call h5sget_simple_extent_ndims_f(dspaceid,HDF5_NDim,hdf5err)
1917 if(hdf5err.lt.0) then
1918 Status = WRF_HDF5_ERR_DATASPACE
1919 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1920 call wrf_debug ( WARN , msg)
1921 return
1922 endif
1924 call ext_phdf5_get_var_ti_char(DataHandle,"MemoryOrder",Name,MemoryOrder,Status)
1925 if(Status /= WRF_NO_ERR) then
1926 Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL
1927 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1928 call wrf_debug ( WARN , msg)
1929 return
1930 endif
1932 ! get the rank of the dimension
1933 call GetDim(MemoryOrder,NDim,Status)
1934 if(Status /= WRF_NO_ERR) then
1935 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1936 call wrf_debug ( WARN , msg)
1937 return
1938 endif
1939 if((NDim+1)/= HDF5_NDim)then
1940 Status = WRF_HDF5_ERR_DATASPACE
1941 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1942 call wrf_debug ( WARN , msg)
1943 return
1944 endif
1945 call ext_phdf5_get_var_ti_char(DataHandle,"Stagger",Name,Stagger,Status)
1946 if(Status /= WRF_NO_ERR) then
1947 Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL
1948 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1949 call wrf_debug ( WARN , msg)
1950 return
1951 endif
1952 call ext_phdf5_get_var_ti_integer(DataHandle,"FieldType",Name,WrfType,Status)
1953 if(Status /= WRF_NO_ERR) then
1954 Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL
1955 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1956 call wrf_debug ( WARN , msg)
1957 return
1958 endif
1960 ! obtain Domain Start and Domain End.
1961 allocate(h5dims(NDim+1))
1962 allocate(h5maxdims(NDim+1))
1963 call h5sget_simple_extent_dims_f(dspaceid,h5dims,h5maxdims,hdf5err)
1964 if(hdf5err .lt. 0) then
1965 Status = WRF_HDF5_ERR_DATASPACE
1966 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1967 call wrf_debug ( WARN , msg)
1968 return
1969 endif
1971 do j =1, NDim
1972 DomainStart(j) = 1
1973 DomainEnd(j) = h5dims(j)
1974 enddo
1975 deallocate(h5dims)
1976 deallocate(h5maxdims)
1977 endif
1978 return
1979 endif
1980 return
1981 end subroutine ext_phdf5_get_var_info
1983 ! obtain the domain time independent attribute with REAL type
1984 subroutine ext_phdf5_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status)
1986 use wrf_phdf5_data
1987 use ext_phdf5_support_routines
1988 USE HDF5 ! This module contains all necessary modules
1989 use get_attrid_routine
1990 implicit none
1991 include 'wrf_status_codes.h'
1993 integer ,intent(in) :: DataHandle
1994 character*(*) ,intent(in) :: Element
1995 real ,intent(out) :: Data(*)
1996 real ,dimension(:),allocatable :: buffer
1997 integer ,intent(in) :: Count
1998 integer ,intent(out) :: OutCount
1999 integer ,intent(out) :: Status
2000 integer(hid_t) :: h5_atypeid
2001 integer(hid_t) :: h5_aspaceid
2002 integer(hid_t) :: h5_attrid
2003 integer :: rank
2004 integer(hid_t) :: attr_type
2005 integer(hsize_t), dimension(7) :: h5_dims
2006 integer :: hdf5err
2008 ! Do nothing unless it is time to read time-independent domain metadata.
2009 IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
2010 Status = WRF_NO_ERR
2011 return
2012 ENDIF
2014 attr_type = H5T_NATIVE_REAL
2016 call get_attrid(DataHandle,Element,h5_attrid,Status)
2017 if(Status /= WRF_NO_ERR) then
2018 return
2019 endif
2021 call check_type(DataHandle,attr_type,h5_attrid,Status)
2022 if (Status /= WRF_NO_ERR) then
2023 return
2024 endif
2026 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
2027 Count,OutCount,Status)
2028 if (Status /= WRF_NO_ERR) then
2029 return
2030 endif
2032 allocate(buffer(OutCount))
2034 h5_dims(1) = OutCount
2035 call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err)
2036 if(hdf5err.lt.0) then
2037 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
2038 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2039 call wrf_debug ( WARN , msg)
2040 deallocate(buffer)
2041 return
2042 endif
2044 data(1:OutCount) = buffer(1:OutCount)
2046 deallocate(buffer)
2048 return
2050 end subroutine ext_phdf5_get_dom_ti_real
2052 ! obtain the domain time independent attribute with REAL8 type
2053 subroutine ext_phdf5_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status)
2055 use wrf_phdf5_data
2056 use ext_phdf5_support_routines
2057 USE HDF5 ! This module contains all necessary modules
2058 use get_attrid_routine
2059 implicit none
2060 include 'wrf_status_codes.h'
2062 integer ,intent(in) :: DataHandle
2063 character*(*) ,intent(in) :: Element
2064 real*8 ,intent(out) :: Data(*)
2065 integer ,intent(in) :: Count
2066 integer ,intent(out) :: OutCount
2067 integer ,intent(out) :: Status
2068 integer(hid_t) :: h5_atypeid
2069 integer(hid_t) :: h5_aspaceid
2070 integer(hid_t) :: h5_attrid
2071 integer :: rank
2072 integer :: hdf5err
2073 integer(hid_t) :: attr_type
2074 integer(hsize_t), dimension(7) :: h5_dims
2076 ! Do nothing unless it is time to read time-independent domain metadata.
2077 IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
2078 Status = WRF_NO_ERR
2079 return
2080 ENDIF
2082 attr_type = H5T_NATIVE_DOUBLE
2083 call get_attrid(DataHandle,Element,h5_attrid,Status)
2084 if(Status /= WRF_NO_ERR) then
2085 return
2086 endif
2088 call check_type(DataHandle,attr_type,h5_attrid,Status)
2089 if (Status /= WRF_NO_ERR) then
2090 return
2091 endif
2093 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
2094 Count,OutCount,Status)
2095 if (Status /= WRF_NO_ERR) then
2096 return
2097 endif
2099 h5_dims(1) = OutCount
2100 call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
2101 if(hdf5err.lt.0) then
2102 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
2103 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2104 call wrf_debug ( WARN , msg)
2105 return
2106 endif
2108 return
2109 end subroutine ext_phdf5_get_dom_ti_double
2112 ! obtain the domain time independent attribute with integer type
2113 subroutine ext_phdf5_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status)
2115 use wrf_phdf5_data
2116 use ext_phdf5_support_routines
2117 USE HDF5 ! This module contains all necessary modules
2118 use get_attrid_routine
2119 implicit none
2120 include 'wrf_status_codes.h'
2122 integer ,intent(in) :: DataHandle
2123 character*(*) ,intent(in) :: Element
2124 integer ,intent(out) :: Data(*)
2125 integer ,intent(in) :: Count
2126 integer ,intent(out) :: OutCount
2127 integer ,intent(out) :: Status
2128 integer(hid_t) :: h5_atypeid
2129 integer(hid_t) :: h5_aspaceid
2130 integer(hid_t) :: h5_attrid
2131 integer :: rank
2132 integer(hid_t) :: attr_type
2133 integer(hsize_t), dimension(7) :: h5_dims
2134 integer :: hdf5err
2136 ! Do nothing unless it is time to read time-independent domain metadata.
2137 IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
2138 Status = WRF_NO_ERR
2139 return
2140 ENDIF
2142 attr_type = H5T_NATIVE_INTEGER
2144 call get_attrid(DataHandle,Element,h5_attrid,Status)
2145 if(Status /= WRF_NO_ERR) then
2146 return
2147 endif
2149 call check_type(DataHandle,attr_type,h5_attrid,Status)
2150 if (Status /= WRF_NO_ERR) then
2151 return
2152 endif
2154 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
2155 Count,OutCount,Status)
2156 if (Status /= WRF_NO_ERR) then
2157 return
2158 endif
2160 h5_dims(1) = OutCount
2161 call h5aread_f(h5_attrid,attr_type,Data,h5_dims,Status)
2162 if(hdf5err.lt.0) then
2163 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
2164 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2165 call wrf_debug ( WARN , msg)
2166 return
2167 endif
2169 return
2170 end subroutine ext_phdf5_get_dom_ti_integer
2173 subroutine ext_phdf5_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status)
2175 use wrf_phdf5_data
2176 use ext_phdf5_support_routines
2177 USE HDF5 ! This module contains all necessary modules
2178 use get_attrid_routine
2179 implicit none
2180 include 'wrf_status_codes.h'
2182 integer ,intent(in) :: DataHandle
2183 character*(*) ,intent(in) :: Element
2184 logical ,intent(out) :: Data(*)
2185 integer, dimension(:),allocatable :: buffer
2186 integer ,intent(in) :: Count
2187 integer ,intent(out) :: OutCount
2188 integer ,intent(out) :: Status
2189 integer(hid_t) :: h5_atypeid
2190 integer(hid_t) :: h5_aspaceid
2191 integer(hid_t) :: h5_attrid
2192 integer :: rank
2193 integer(hid_t) :: attr_type
2194 type(wrf_phdf5_data_handle),pointer :: DH
2195 integer(hsize_t), dimension(7) :: h5_dims
2196 integer :: hdf5err
2199 call GetDH(DataHandle,DH,Status)
2200 if(Status /= WRF_NO_ERR) then
2201 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2202 call wrf_debug ( WARN , msg)
2203 return
2204 endif
2206 ! Do nothing unless it is time to read time-independent domain metadata.
2207 IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
2208 Status = WRF_NO_ERR
2209 return
2210 ENDIF
2212 attr_type = DH%EnumID
2213 call get_attrid(DataHandle,Element,h5_attrid,Status)
2214 if(Status /= WRF_NO_ERR) then
2215 return
2216 endif
2218 call check_type(DataHandle,attr_type,h5_attrid,Status)
2219 if (status /= WRF_NO_ERR) then
2220 return
2221 endif
2223 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
2224 Count,OutCount,Status)
2225 if (Status /= WRF_NO_ERR) then
2226 return
2227 endif
2229 h5_dims(1) = OutCount
2231 allocate(buffer(OutCount))
2233 call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err)
2234 if(hdf5err.lt.0) then
2235 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
2236 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2237 call wrf_debug ( WARN , msg)
2238 deallocate(buffer)
2239 return
2240 endif
2242 Data(1:OutCount) = buffer(1:OutCount)==1
2243 deallocate(buffer)
2244 return
2245 end subroutine ext_phdf5_get_dom_ti_logical
2247 ! obtain the domain time independent attribute with char type
2248 subroutine ext_phdf5_get_dom_ti_char(DataHandle,Element,Data,Status)
2250 use wrf_phdf5_data
2251 use ext_phdf5_support_routines
2252 USE HDF5 ! This module contains all necessary modules
2253 use get_attrid_routine
2254 implicit none
2255 include 'wrf_status_codes.h'
2257 integer ,intent(in) :: DataHandle
2258 character*(*) ,intent(in) :: Element
2259 character*(*) ,intent(out) :: Data
2260 integer :: Count
2261 integer :: OutCount
2262 integer ,intent(out) :: Status
2263 integer(hid_t) :: h5_atypeid
2264 integer(hid_t) :: h5_aspaceid
2265 integer(hid_t) :: h5_attrid
2266 integer :: rank
2267 integer(hid_t) :: attr_type
2268 integer(hsize_t), dimension(7) :: h5_dims
2269 integer :: hdf5err
2271 ! Do nothing unless it is time to read time-independent domain metadata.
2272 IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
2273 Status = WRF_NO_ERR
2274 return
2275 ENDIF
2277 attr_type = H5T_NATIVE_CHARACTER
2279 call get_attrid(DataHandle,Element,h5_attrid,Status)
2280 if(Status /= WRF_NO_ERR) then
2281 return
2282 endif
2284 call check_type(DataHandle,attr_type,h5_attrid,Status)
2285 if (status /= WRF_NO_ERR) then
2286 return
2287 endif
2289 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
2290 Count,OutCount,Status)
2291 if(Status /= WRF_NO_ERR) then
2292 return
2293 endif
2295 h5_dims(1) = OutCount
2296 call h5aread_f(h5_attrid,h5_atypeid,data,h5_dims,hdf5err)
2297 if(hdf5err.lt.0) then
2298 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
2299 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2300 call wrf_debug ( WARN , msg)
2301 return
2302 endif
2304 return
2305 end subroutine ext_phdf5_get_dom_ti_char
2307 subroutine ext_phdf5_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status)
2308 integer ,intent(in) :: DataHandle
2309 character*(*) ,intent(in) :: Element
2310 character*(*) ,intent(in) :: DateStr
2311 real ,intent(in) :: Data(*)
2312 integer ,intent(in) :: Count
2313 integer ,intent(out) :: Status
2315 call ext_phdf5_put_var_td_real(DataHandle,Element,DateStr,&
2316 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
2317 Data,Count,Status)
2318 return
2319 end subroutine ext_phdf5_put_dom_td_real
2321 subroutine ext_phdf5_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status)
2322 integer ,intent(in) :: DataHandle
2323 character*(*) ,intent(in) :: Element
2324 character*(*) ,intent(in) :: DateStr
2325 real*8 ,intent(in) :: Data(*)
2326 integer ,intent(in) :: Count
2327 integer ,intent(out) :: Status
2329 call ext_phdf5_put_var_td_double(DataHandle,Element,DateStr,&
2330 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
2331 Data,Count,Status)
2332 return
2333 end subroutine ext_phdf5_put_dom_td_double
2335 subroutine ext_phdf5_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status)
2336 integer ,intent(in) :: DataHandle
2337 character*(*) ,intent(in) :: Element
2338 character*(*) ,intent(in) :: DateStr
2339 logical ,intent(in) :: Data(*)
2340 integer ,intent(in) :: Count
2341 integer ,intent(out) :: Status
2343 call ext_phdf5_put_var_td_logical(DataHandle,Element,DateStr,&
2344 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
2345 Data,Count,Status)
2346 return
2348 end subroutine ext_phdf5_put_dom_td_logical
2349 subroutine ext_phdf5_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status)
2350 integer ,intent(in) :: DataHandle
2351 character*(*) ,intent(in) :: Element
2352 character*(*) ,intent(in) :: DateStr
2353 integer ,intent(in) :: Data(*)
2354 integer ,intent(in) :: Count
2355 integer ,intent(out) :: Status
2357 call ext_phdf5_put_var_td_integer(DataHandle,Element,DateStr,&
2358 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
2359 Data,Count,Status)
2360 return
2361 end subroutine ext_phdf5_put_dom_td_integer
2363 subroutine ext_phdf5_put_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2365 integer ,intent(in) :: DataHandle
2366 character*(*) ,intent(in) :: Element
2367 character*(*) ,intent(in) :: DateStr
2368 character*(*) ,intent(in) :: Data
2369 integer ,intent(out) :: Status
2371 call ext_phdf5_put_var_td_char(DataHandle,Element,DateStr,&
2372 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
2373 Data,Status)
2374 return
2376 end subroutine ext_phdf5_put_dom_td_char
2378 subroutine ext_phdf5_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2381 integer ,intent(in) :: DataHandle
2382 character*(*) ,intent(in) :: Element
2383 character*(*) ,intent(in) :: DateStr
2384 real ,intent(out) :: Data(*)
2385 integer ,intent(in) :: Count
2386 integer ,intent(out) :: OutCount
2387 integer ,intent(out) :: Status
2389 call ext_phdf5_get_var_td_real(DataHandle,Element,DateStr,&
2390 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
2391 return
2392 end subroutine ext_phdf5_get_dom_td_real
2394 subroutine ext_phdf5_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2396 integer ,intent(in) :: DataHandle
2397 character*(*) ,intent(in) :: Element
2398 character*(*) ,intent(in) :: DateStr
2399 real*8 ,intent(out) :: Data(*)
2400 integer ,intent(in) :: Count
2401 integer ,intent(out) :: OutCount
2402 integer ,intent(out) :: Status
2404 call ext_phdf5_get_var_td_double(DataHandle,Element,DateStr,&
2405 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
2406 return
2407 end subroutine ext_phdf5_get_dom_td_double
2410 subroutine ext_phdf5_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2412 integer ,intent(in) :: DataHandle
2413 character*(*) ,intent(in) :: Element
2414 character*(*) ,intent(in) :: DateStr
2415 integer ,intent(out) :: Data(*)
2416 integer ,intent(in) :: Count
2417 integer ,intent(out) :: OutCount
2418 integer ,intent(out) :: Status
2420 call ext_phdf5_get_var_td_integer(DataHandle,Element,DateStr,&
2421 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
2422 return
2424 end subroutine ext_phdf5_get_dom_td_integer
2426 subroutine ext_phdf5_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2427 integer ,intent(in) :: DataHandle
2428 character*(*) ,intent(in) :: Element
2429 character*(*) ,intent(in) :: DateStr
2430 logical ,intent(out) :: Data(*)
2431 integer ,intent(in) :: Count
2432 integer ,intent(out) :: OutCount
2433 integer ,intent(out) :: Status
2435 call ext_phdf5_get_var_td_logical(DataHandle,Element,DateStr,&
2436 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
2437 return
2439 end subroutine ext_phdf5_get_dom_td_logical
2442 subroutine ext_phdf5_get_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2444 integer ,intent(in) :: DataHandle
2445 character*(*) ,intent(in) :: Element
2446 character*(*) ,intent(in) :: DateStr
2447 character*(*) ,intent(out) :: Data
2448 integer ,intent(out) :: Status
2451 call ext_phdf5_get_var_td_char(DataHandle,Element,DateStr,&
2452 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Status)
2453 return
2456 end subroutine ext_phdf5_get_dom_td_char
2458 subroutine ext_phdf5_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status)
2460 use wrf_phdf5_data
2461 use ext_phdf5_support_routines
2462 USE HDF5 ! This module contains all necessary modules
2463 implicit none
2464 include 'wrf_status_codes.h'
2466 integer ,intent(in) :: DataHandle
2467 character*(*) ,intent(in) :: Element
2468 character*(*) ,intent(in) :: DateStr
2469 character*(*) ,intent(in) :: Var
2470 character(len = 256) :: DataSetName
2471 real ,intent(in) :: Data(*)
2472 integer ,intent(in) :: Count
2473 integer ,intent(out) :: Status
2474 type(wrf_phdf5_data_handle),pointer :: DH
2475 integer :: TimeIndex
2476 integer(hid_t) :: dset_id
2477 integer(hid_t) :: dspaceid
2478 integer(hid_t) :: fspaceid
2479 integer(hid_t) :: tgroupid
2480 integer(hsize_t),dimension(1) :: dims
2481 integer :: hdf5err
2482 integer :: i
2484 call GetDH(DataHandle,DH,Status)
2485 if(Status /= WRF_NO_ERR) then
2486 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2487 call wrf_debug ( WARN , msg)
2488 return
2489 endif
2491 ! check whether the DateStr is the correct length
2492 call DateCheck(DateStr,Status)
2493 if(Status /= WRF_NO_ERR) then
2494 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2495 call wrf_debug ( WARN , msg)
2496 return
2497 endif
2499 if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
2501 dims(1) = Count
2503 ! Get the time index
2504 call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
2505 if(Status /= WRF_NO_ERR) then
2506 return
2507 endif
2509 ! Set up dataspace,property list
2510 call GetName(Element,Var,DataSetName,Status)
2511 if(Status /= WRF_NO_ERR) then
2512 return
2513 endif
2515 call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_REAL,Count,&
2516 dset_id,dspaceid,fspaceid,tgroupid,TimeIndex,Status)
2517 if(Status /= WRF_NO_ERR) then
2518 return
2519 endif
2521 call h5dwrite_f(dset_id,H5T_NATIVE_REAL,Data,dims,hdf5err,dspaceid,&
2522 fspaceid)
2523 if(hdf5err.lt.0) then
2524 Status = WRF_HDF5_ERR_DATASET_WRITE
2525 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2526 call wrf_debug ( WARN , msg)
2527 return
2528 endif
2529 call h5dclose_f(dset_id,hdf5err)
2530 call h5sclose_f(dspaceid,hdf5err)
2531 call h5sclose_f(fspaceid,hdf5err)
2532 ! call h5gclose_f(tgroupid,hdf5err)
2533 endif
2534 return
2535 end subroutine ext_phdf5_put_var_td_real
2537 subroutine ext_phdf5_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status)
2538 use wrf_phdf5_data
2539 use ext_phdf5_support_routines
2540 USE HDF5 ! This module contains all necessary modules
2541 implicit none
2542 include 'wrf_status_codes.h'
2544 integer ,intent(in) :: DataHandle
2545 character*(*) ,intent(in) :: Element
2546 character*(*) ,intent(in) :: DateStr
2547 character*(*) ,intent(in) :: Var
2548 character(len = 256) :: DataSetName
2549 real*8 ,intent(in) :: Data(*)
2550 integer ,intent(in) :: Count
2551 integer ,intent(out) :: Status
2552 type(wrf_phdf5_data_handle),pointer :: DH
2553 integer :: TimeIndex
2554 integer(hid_t) :: dset_id
2555 integer(hid_t) :: dspaceid
2556 integer(hid_t) :: fspaceid
2557 integer(hid_t) :: tgroupid
2558 integer(hsize_t),dimension(1) :: dims
2559 integer :: hdf5err
2560 integer :: i
2562 call GetDH(DataHandle,DH,Status)
2563 if(Status /= WRF_NO_ERR) then
2564 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2565 call wrf_debug ( WARN , msg)
2566 return
2567 endif
2569 ! check whether the DateStr is the correct length
2570 call DateCheck(DateStr,Status)
2571 if(Status /= WRF_NO_ERR) then
2572 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2573 call wrf_debug ( WARN , msg)
2574 return
2575 endif
2577 if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
2580 dims(1) = Count
2581 ! Get the time index
2582 call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
2583 if(Status /= WRF_NO_ERR) then
2584 return
2585 endif
2587 ! Set up dataspace,property list
2588 call GetName(Element,Var,DataSetName,Status)
2589 call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_DOUBLE,Count,&
2590 dset_id,dspaceid,fspaceid,tgroupid,TimeIndex,Status)
2592 if(Status /= WRF_NO_ERR) then
2593 return
2594 endif
2596 call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE,Data,dims,hdf5err,dspaceid,&
2597 fspaceid)
2598 if(hdf5err.lt.0) then
2599 Status = WRF_HDF5_ERR_DATASET_WRITE
2600 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2601 call wrf_debug ( WARN , msg)
2602 return
2603 endif
2605 call h5dclose_f(dset_id,hdf5err)
2606 call h5sclose_f(dspaceid,hdf5err)
2607 call h5sclose_f(fspaceid,hdf5err)
2608 ! call h5gclose_f(tgroupid,hdf5err)
2610 endif
2611 return
2612 end subroutine ext_phdf5_put_var_td_double
2614 subroutine ext_phdf5_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status)
2616 use wrf_phdf5_data
2617 use ext_phdf5_support_routines
2618 USE HDF5 ! This module contains all necessary modules
2619 implicit none
2620 include 'wrf_status_codes.h'
2622 integer ,intent(in) :: DataHandle
2623 character*(*) ,intent(in) :: Element
2624 character*(*) ,intent(in) :: DateStr
2625 character*(*) ,intent(in) :: Var
2626 character(len = 256) :: DataSetName
2627 integer ,intent(in) :: Data(*)
2628 integer ,intent(in) :: Count
2629 integer ,intent(out) :: Status
2630 type(wrf_phdf5_data_handle),pointer :: DH
2631 integer :: TimeIndex
2632 integer(hid_t) :: dset_id
2633 integer(hid_t) :: dspaceid
2634 integer(hid_t) :: fspaceid
2635 integer(hid_t) :: tgroupid
2636 integer(hsize_t),dimension(1) :: dims
2637 integer :: hdf5err
2638 integer :: i
2640 call GetDH(DataHandle,DH,Status)
2641 if(Status /= WRF_NO_ERR) then
2642 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2643 call wrf_debug ( WARN , msg)
2644 return
2645 endif
2647 ! check whether the DateStr is the correct length
2648 call DateCheck(DateStr,Status)
2649 if(Status /= WRF_NO_ERR) then
2650 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2651 call wrf_debug ( WARN , msg)
2652 return
2653 endif
2655 if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
2658 dims(1) = Count
2659 ! Get the time index
2660 call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
2661 if(Status /= WRF_NO_ERR) then
2662 return
2663 endif
2665 ! Set up dataspace,property list
2666 call GetName(Element,Var,DataSetName,Status)
2668 call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_INTEGER, &
2669 Count,dset_id,dspaceid,fspaceid,tgroupid, &
2670 TimeIndex, Status)
2671 if(Status /= WRF_NO_ERR) then
2672 return
2673 endif
2675 call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER,Data,dims,hdf5err,dspaceid,&
2676 fspaceid)
2677 if(hdf5err.lt.0) then
2678 Status = WRF_HDF5_ERR_DATASET_WRITE
2679 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2680 call wrf_debug ( WARN , msg)
2681 return
2682 endif
2684 call h5dclose_f(dset_id,hdf5err)
2685 call h5sclose_f(dspaceid,hdf5err)
2686 call h5sclose_f(fspaceid,hdf5err)
2687 ! call h5gclose_f(tgroupid,hdf5err)
2689 endif
2690 return
2692 end subroutine ext_phdf5_put_var_td_integer
2694 subroutine ext_phdf5_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status)
2696 use wrf_phdf5_data
2697 use ext_phdf5_support_routines
2698 USE HDF5 ! This module contains all necessary modules
2699 implicit none
2700 include 'wrf_status_codes.h'
2702 integer ,intent(in) :: DataHandle
2703 character*(*) ,intent(in) :: Element
2704 character*(*) ,intent(in) :: DateStr
2705 character*(*) ,intent(in) :: Var
2706 character(len = 256) :: DataSetName
2707 logical ,intent(in) :: Data(*)
2708 integer ,dimension(:),allocatable :: Buffer
2709 integer ,intent(in) :: Count
2710 integer ,intent(out) :: Status
2711 type(wrf_phdf5_data_handle),pointer :: DH
2712 integer :: TimeIndex
2713 integer(hid_t) :: dset_id
2714 integer(hid_t) :: dspaceid
2715 integer(hid_t) :: fspaceid
2716 integer(hid_t) :: tgroupid
2717 integer(hsize_t),dimension(1) :: dims
2718 integer :: hdf5err
2719 integer :: i
2721 call GetDH(DataHandle,DH,Status)
2722 if(Status /= WRF_NO_ERR) then
2723 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2724 call wrf_debug ( WARN , msg)
2725 return
2726 endif
2728 ! check whether the DateStr is the correct length
2729 call DateCheck(DateStr,Status)
2730 if(Status /= WRF_NO_ERR) then
2731 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2732 call wrf_debug ( WARN , msg)
2733 return
2734 endif
2736 if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
2738 allocate(buffer(count))
2739 do i = 1, count
2740 if(data(i).EQV..TRUE.) then
2741 buffer(i) = 1
2742 else
2743 buffer(i) = 0
2744 endif
2745 enddo
2747 dims(1) = Count
2748 ! Get the time index
2749 call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
2750 if(Status /= WRF_NO_ERR) then
2751 return
2752 endif
2754 ! Set up dataspace,property list
2755 call GetName(Element,Var,DataSetName,Status)
2757 call setup_wrtd_dataset(DataHandle,DataSetName,DH%EnumID, &
2758 Count,dset_id,dspaceid, &
2759 fspaceid,tgroupid,TimeIndex,Status)
2760 if(Status /= WRF_NO_ERR) then
2761 return
2762 endif
2764 call h5dwrite_f(dset_id,DH%EnumID,Buffer,dims,hdf5err,dspaceid,&
2765 fspaceid)
2766 if(hdf5err.lt.0) then
2767 Status = WRF_HDF5_ERR_DATASET_WRITE
2768 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2769 call wrf_debug ( WARN , msg)
2770 return
2771 endif
2772 call h5dclose_f(dset_id,hdf5err)
2773 call h5sclose_f(dspaceid,hdf5err)
2774 call h5sclose_f(fspaceid,hdf5err)
2775 ! call h5gclose_f(tgroupid,hdf5err)
2776 deallocate(Buffer)
2777 endif
2778 return
2779 end subroutine ext_phdf5_put_var_td_logical
2781 subroutine ext_phdf5_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
2783 use wrf_phdf5_data
2784 use ext_phdf5_support_routines
2785 USE HDF5 ! This module contains all necessary modules
2786 implicit none
2787 include 'wrf_status_codes.h'
2789 integer ,intent(in) :: DataHandle
2790 character*(*) ,intent(in) :: Element
2791 character*(*) ,intent(in) :: DateStr
2792 character*(*) ,intent(in) :: Var
2793 character(len = 256) :: DataSetName
2794 character*(*) ,intent(in) :: Data
2795 integer ,intent(out) :: Status
2796 type(wrf_phdf5_data_handle),pointer :: DH
2797 integer :: TimeIndex
2798 integer(hid_t) :: dset_id
2799 integer(hid_t) :: dspaceid
2800 integer(hid_t) :: fspaceid
2801 integer(hid_t) :: tgroupid
2802 integer(hsize_t),dimension(1) :: dims
2803 integer :: hdf5err
2804 integer :: i
2806 integer :: str_id
2807 integer :: str_len
2808 integer :: count
2810 call GetDH(DataHandle,DH,Status)
2811 if(Status /= WRF_NO_ERR) then
2812 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2813 call wrf_debug ( WARN , msg)
2814 return
2815 endif
2817 ! check whether the DateStr is the correct length
2818 call DateCheck(DateStr,Status)
2819 if(Status /= WRF_NO_ERR) then
2820 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2821 call wrf_debug ( WARN , msg)
2822 return
2823 endif
2825 if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
2827 dims(1) = 1
2829 ! Get the time index
2830 call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
2831 if(Status /= WRF_NO_ERR) then
2832 return
2833 endif
2835 ! make str id
2836 str_len = len_trim(Data)
2837 call make_strid(str_len,str_id,Status)
2838 if(Status /= WRF_NO_ERR) then
2839 return
2840 endif
2842 ! assign count of the string to 1
2843 count = 1
2845 ! Set up dataspace,property list
2846 call GetName(Element,Var,DataSetName,Status)
2847 if(Status /= WRF_NO_ERR) then
2848 return
2849 endif
2850 call setup_wrtd_dataset(DataHandle,DataSetName,str_id, &
2851 count,dset_id,dspaceid, &
2852 fspaceid,tgroupid,TimeIndex,Status)
2853 if(Status /= WRF_NO_ERR) then
2854 return
2855 endif
2857 call h5dwrite_f(dset_id,str_id,Data,dims,hdf5err,dspaceid,&
2858 fspaceid)
2859 if(hdf5err.lt.0) then
2860 Status = WRF_HDF5_ERR_DATASET_WRITE
2861 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2862 call wrf_debug ( WARN , msg)
2863 return
2864 endif
2866 ! close the string id
2867 call h5tclose_f(str_id,hdf5err)
2868 if(hdf5err.lt.0) then
2869 Status = WRF_HDF5_ERR_DATATYPE
2870 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2871 call wrf_debug ( WARN , msg)
2872 return
2873 endif
2874 call h5dclose_f(dset_id,hdf5err)
2875 call h5sclose_f(dspaceid,hdf5err)
2876 call h5sclose_f(fspaceid,hdf5err)
2877 ! call h5gclose_f(tgroupid,hdf5err)
2879 endif
2880 return
2882 end subroutine ext_phdf5_put_var_td_char
2884 subroutine ext_phdf5_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2886 use wrf_phdf5_data
2887 use ext_phdf5_support_routines
2888 USE HDF5 ! This module contains all necessary modules
2889 implicit none
2890 include 'wrf_status_codes.h'
2892 integer ,intent(in) :: DataHandle
2893 character*(*) ,intent(in) :: Element
2894 character*(*) ,intent(in) :: DateStr
2895 character*(*) ,intent(in) :: Var
2896 character(len =256) :: DataSetName
2897 real ,intent(out) :: Data(*)
2898 integer ,intent(in) :: Count
2899 integer ,intent(out) :: OutCount
2900 integer ,intent(out) :: Status
2901 type(wrf_phdf5_data_handle),pointer :: DH
2902 integer :: TimeIndex
2903 integer(hid_t) :: dset_id
2904 integer(hid_t) :: dspaceid
2905 integer(hid_t) :: memspaceid
2906 integer(hid_t) :: tgroupid
2907 integer(hsize_t),dimension(7) :: data_dims
2908 integer :: hdf5err
2910 call GetDH(DataHandle,DH,Status)
2911 if(Status /= WRF_NO_ERR) then
2912 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2913 call wrf_debug ( WARN , msg)
2914 return
2915 endif
2917 ! check whether the DateStr is the correct length
2918 call DateCheck(DateStr,Status)
2919 if(Status /= WRF_NO_ERR) then
2920 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2921 call wrf_debug ( WARN , msg)
2922 return
2923 endif
2925 if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2927 ! get the time-dependent attribute name
2929 call GetName(Element,Var,DataSetName,Status)
2931 ! get time index of the time-dependent attribute
2932 call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
2933 if(Status /= WRF_NO_ERR) then
2934 return
2935 endif
2937 ! For parallel, find the group and obtain the attribute.
2938 ! set up for reading the time-dependent attribute
2939 call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_REAL,TimeIndex,&
2940 Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,&
2941 Status)
2942 if(Status /= WRF_NO_ERR) then
2943 return
2944 endif
2946 data_dims(1) = OutCount
2948 ! read the dataset
2949 call h5dread_f(dset_id,H5T_NATIVE_REAL,data,data_dims,hdf5err, &
2950 memspaceid,dspaceid,H5P_DEFAULT_F)
2951 if(hdf5err.lt.0) then
2952 Status = WRF_HDF5_ERR_DATASET_READ
2953 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2954 call wrf_debug ( WARN , msg)
2955 return
2956 endif
2957 call h5sclose_f(memspaceid,hdf5err)
2958 call h5sclose_f(dspaceid,hdf5err)
2959 call h5dclose_f(dset_id,hdf5err)
2960 call h5gclose_f(tgroupid,hdf5err)
2961 endif
2963 end subroutine ext_phdf5_get_var_td_real
2965 subroutine ext_phdf5_get_var_td_double(DataHandle,Element,DateStr,Var,Data,&
2966 Count,OutCount,Status)
2968 use wrf_phdf5_data
2969 use ext_phdf5_support_routines
2970 USE HDF5 ! This module contains all necessary modules
2971 implicit none
2972 include 'wrf_status_codes.h'
2974 integer ,intent(in) :: DataHandle
2975 character*(*) ,intent(in) :: Element
2976 character*(*) ,intent(in) :: DateStr
2977 character*(*) ,intent(in) :: Var
2978 character(len =256) :: DataSetName
2979 real*8 ,intent(out) :: Data(*)
2980 integer ,intent(in) :: Count
2981 integer ,intent(out) :: OutCount
2982 integer ,intent(out) :: Status
2983 type(wrf_phdf5_data_handle),pointer :: DH
2984 integer :: TimeIndex
2985 integer(hid_t) :: dset_id
2986 integer(hid_t) :: dspaceid
2987 integer(hid_t) :: memspaceid
2988 integer(hid_t) :: tgroupid
2989 integer(hsize_t),dimension(7) :: data_dims
2990 integer :: hdf5err
2992 call GetDH(DataHandle,DH,Status)
2993 if(Status /= WRF_NO_ERR) then
2994 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2995 call wrf_debug ( WARN , msg)
2996 return
2997 endif
2999 ! check whether the DateStr is the correct length
3000 call DateCheck(DateStr,Status)
3001 if(Status /= WRF_NO_ERR) then
3002 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
3003 call wrf_debug ( WARN , msg)
3004 return
3005 endif
3007 if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3009 ! get the time-dependent attribute name
3010 call GetName(Element,Var,DataSetName,Status)
3012 ! get time index of the time-dependent attribute
3013 call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
3014 if(Status /= WRF_NO_ERR) then
3015 return
3016 endif
3018 ! set up for reading the time-dependent attribute
3019 call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_DOUBLE,TimeIndex,&
3020 Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,&
3021 Status)
3022 if(Status /= WRF_NO_ERR) then
3023 return
3024 endif
3026 data_dims(1) = OutCount
3028 ! read the dataset
3029 call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,data,data_dims,hdf5err, &
3030 memspaceid,dspaceid,H5P_DEFAULT_F)
3031 if(hdf5err.lt.0) then
3032 Status = WRF_HDF5_ERR_DATASET_READ
3033 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3034 call wrf_debug ( WARN , msg)
3035 return
3036 endif
3038 call h5sclose_f(memspaceid,hdf5err)
3039 call h5sclose_f(dspaceid,hdf5err)
3040 call h5dclose_f(dset_id,hdf5err)
3041 call h5gclose_f(tgroupid,hdf5err)
3043 endif
3045 end subroutine ext_phdf5_get_var_td_double
3047 subroutine ext_phdf5_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,&
3048 Count,OutCount,Status)
3050 use wrf_phdf5_data
3051 use ext_phdf5_support_routines
3052 USE HDF5 ! This module contains all necessary modules
3053 implicit none
3054 include 'wrf_status_codes.h'
3056 integer ,intent(in) :: DataHandle
3057 character*(*) ,intent(in) :: Element
3058 character*(*) ,intent(in) :: DateStr
3059 character*(*) ,intent(in) :: Var
3060 character(len =256) :: DataSetName
3061 integer ,intent(out) :: Data(*)
3062 integer ,intent(in) :: Count
3063 INTEGER ,intent(out) :: OutCount
3064 integer ,intent(out) :: Status
3065 type(wrf_phdf5_data_handle),pointer :: DH
3066 integer :: TimeIndex
3067 integer(hid_t) :: dset_id
3068 integer(hid_t) :: dspaceid
3069 integer(hid_t) :: memspaceid
3070 integer(hid_t) :: tgroupid
3071 integer(hsize_t),dimension(7) :: data_dims
3072 integer :: hdf5err
3074 call GetDH(DataHandle,DH,Status)
3075 if(Status /= WRF_NO_ERR) then
3076 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3077 call wrf_debug ( WARN , msg)
3078 return
3079 endif
3081 ! check whether the DateStr is the correct length
3082 call DateCheck(DateStr,Status)
3083 if(Status /= WRF_NO_ERR) then
3084 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
3085 call wrf_debug ( WARN , msg)
3086 return
3087 endif
3089 if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3091 ! get the time-dependent attribute name
3092 call GetName(Element,Var,DataSetName,Status)
3094 ! get time index of the time-dependent attribute
3095 call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
3096 if(Status /= WRF_NO_ERR) then
3097 return
3098 endif
3100 ! set up for reading the time-dependent attribute
3101 call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_INTEGER,TimeIndex,&
3102 Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,&
3103 Status)
3104 if(Status /= WRF_NO_ERR) then
3105 return
3106 endif
3108 data_dims(1) = OutCount
3110 ! read the dataset
3111 call h5dread_f(dset_id,H5T_NATIVE_INTEGER,data,data_dims,hdf5err, &
3112 memspaceid,dspaceid,H5P_DEFAULT_F)
3113 if(hdf5err.lt.0) then
3114 Status = WRF_HDF5_ERR_DATASET_READ
3115 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3116 call wrf_debug ( WARN , msg)
3117 return
3118 endif
3120 call h5sclose_f(memspaceid,hdf5err)
3121 call h5sclose_f(dspaceid,hdf5err)
3122 call h5dclose_f(dset_id,hdf5err)
3123 call h5gclose_f(tgroupid,hdf5err)
3124 endif
3125 end subroutine ext_phdf5_get_var_td_integer
3127 subroutine ext_phdf5_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,&
3128 Count,OutCount,Status)
3129 use wrf_phdf5_data
3130 use ext_phdf5_support_routines
3131 USE HDF5 ! This module contains all necessary modules
3132 implicit none
3133 include 'wrf_status_codes.h'
3135 integer ,intent(in) :: DataHandle
3136 character*(*) ,intent(in) :: Element
3137 character*(*) ,intent(in) :: DateStr
3138 character*(*) ,intent(in) :: Var
3139 character(len =256) :: DataSetName
3140 logical ,intent(out) :: Data(*)
3141 integer, dimension(:),allocatable :: Buffer
3142 integer ,intent(in) :: Count
3143 integer ,intent(out) :: OutCount
3144 integer ,intent(out) :: Status
3145 type(wrf_phdf5_data_handle),pointer :: DH
3146 integer :: TimeIndex
3147 integer(hid_t) :: dset_id
3148 integer(hid_t) :: dspaceid
3149 integer(hid_t) :: memspaceid
3150 integer(hid_t) :: tgroupid
3151 integer(hsize_t),dimension(7) :: data_dims
3152 integer :: hdf5err
3154 call GetDH(DataHandle,DH,Status)
3155 if(Status /= WRF_NO_ERR) then
3156 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3157 call wrf_debug ( WARN , msg)
3158 return
3159 endif
3161 ! check whether the DateStr is the correct length
3162 call DateCheck(DateStr,Status)
3163 if(Status /= WRF_NO_ERR) then
3164 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
3165 call wrf_debug ( WARN , msg)
3166 return
3167 endif
3169 if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3171 ! get the time-dependent attribute name
3172 call GetName(Element,Var,DataSetName,Status)
3174 ! get time index of the time-dependent attribute
3175 call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
3176 if(Status /= WRF_NO_ERR) then
3177 return
3178 endif
3180 ! set up for reading the time-dependent attribute
3181 call setup_rdtd_dataset(DataHandle,DataSetName,DH%EnumID,TimeIndex,&
3182 Count,OutCount,dset_id,memspaceid,dspaceid,&
3183 tgroupid,Status)
3184 if(Status /= WRF_NO_ERR) then
3185 return
3186 endif
3188 data_dims(1) = OutCount
3189 ! read the dataset
3191 allocate(Buffer(OutCount))
3192 call h5dread_f(dset_id,DH%EnumID,buffer,data_dims,hdf5err, &
3193 memspaceid,dspaceid,H5P_DEFAULT_F)
3194 if(hdf5err.lt.0) then
3195 Status = WRF_HDF5_ERR_DATASET_READ
3196 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3197 call wrf_debug ( WARN , msg)
3198 return
3199 endif
3200 data(1:OutCount) = buffer(1:OutCount) == 1
3201 deallocate(buffer)
3202 call h5sclose_f(memspaceid,hdf5err)
3203 call h5sclose_f(dspaceid,hdf5err)
3204 call h5dclose_f(dset_id,hdf5err)
3205 call h5gclose_f(tgroupid,hdf5err)
3206 endif
3208 end subroutine ext_phdf5_get_var_td_logical
3210 subroutine ext_phdf5_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
3212 use wrf_phdf5_data
3213 use ext_phdf5_support_routines
3214 USE HDF5 ! This module contains all necessary modules
3215 implicit none
3216 include 'wrf_status_codes.h'
3218 integer ,intent(in) :: DataHandle
3219 character*(*) ,intent(in) :: Element
3220 character*(*) ,intent(in) :: DateStr
3221 character*(*) ,intent(in) :: Var
3222 character(len =256) :: DataSetName
3223 character*(*) ,intent(out) :: Data
3224 integer :: Count
3225 integer :: OutCount
3226 integer ,intent(out) :: Status
3227 type(wrf_phdf5_data_handle),pointer :: DH
3228 integer :: TimeIndex
3229 integer(hid_t) :: dset_id
3230 integer(hid_t) :: dspaceid
3231 integer(hid_t) :: memspaceid
3232 integer(hid_t) :: tgroupid
3233 integer(hsize_t),dimension(7) :: data_dims
3234 integer :: hdf5err
3236 integer(hid_t) :: str_id
3238 call GetDH(DataHandle,DH,Status)
3239 if(Status /= WRF_NO_ERR) then
3240 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3241 call wrf_debug ( WARN , msg)
3242 return
3243 endif
3245 ! check whether the DateStr is the correct length
3246 call DateCheck(DateStr,Status)
3247 if(Status /= WRF_NO_ERR) then
3248 write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
3249 call wrf_debug ( WARN , msg)
3250 return
3251 endif
3253 if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3255 ! get the time-dependent attribute name
3256 call GetName(Element,Var,DataSetName,Status)
3258 ! get time index of the time-dependent attribute
3259 call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
3260 if(Status /= WRF_NO_ERR) then
3261 return
3262 endif
3264 ! set up for reading the time-dependent attribute
3265 str_id = H5T_NATIVE_CHARACTER
3266 Count = 1
3267 call setup_rdtd_dataset(DataHandle,DataSetName,str_id,TimeIndex,&
3268 Count,OutCount,dset_id,memspaceid,dspaceid,&
3269 tgroupid,Status)
3270 if(Status /= WRF_NO_ERR) then
3271 return
3272 endif
3274 data_dims(1) = Count
3276 ! read the dataset
3277 call h5dread_f(dset_id,str_id,data,data_dims,hdf5err, &
3278 memspaceid,dspaceid,H5P_DEFAULT_F)
3279 if(hdf5err.lt.0) then
3280 Status = WRF_HDF5_ERR_DATASET_READ
3281 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3282 call wrf_debug ( WARN , msg)
3283 return
3284 endif
3285 call h5sclose_f(memspaceid,hdf5err)
3286 call h5sclose_f(dspaceid,hdf5err)
3287 call h5dclose_f(dset_id,hdf5err)
3288 call h5gclose_f(tgroupid,hdf5err)
3289 endif
3291 end subroutine ext_phdf5_get_var_td_char
3293 ! obtain the variable time independent attribute with REAL type
3294 subroutine ext_phdf5_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status)
3296 use wrf_phdf5_data
3297 use ext_phdf5_support_routines
3298 USE HDF5 ! This module contains all necessary modules
3299 use get_attrid_routine
3300 implicit none
3301 include 'wrf_status_codes.h'
3303 integer ,intent(in) :: DataHandle
3304 character*(*) ,intent(in) :: Element
3305 character*(*) ,intent(in) :: Var
3306 real ,intent(out) :: Data(*)
3307 integer ,intent(in) :: Count
3308 integer ,intent(out) :: OutCount
3309 integer ,intent(out) :: Status
3310 integer(hid_t) :: h5_atypeid
3311 integer(hid_t) :: h5_aspaceid
3312 integer(hid_t) :: h5_attrid
3313 integer(hid_t) :: attr_type
3314 integer(hsize_t), dimension(7) :: h5_dims
3315 integer :: hdf5err
3317 attr_type = H5T_NATIVE_REAL
3319 call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
3320 if(Status /= WRF_NO_ERR) then
3321 return
3322 endif
3324 call check_type(DataHandle,attr_type,h5_attrid,Status)
3325 if (status /= WRF_NO_ERR) then
3326 return
3327 endif
3329 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
3330 Count,OutCount,Status)
3331 if(Status /= WRF_NO_ERR) then
3332 return
3333 endif
3335 h5_dims(1) = OutCount
3336 call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
3337 if(hdf5err.lt.0) then
3338 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
3339 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3340 call wrf_debug ( WARN , msg)
3341 return
3342 endif
3344 return
3345 end subroutine ext_phdf5_get_var_ti_real
3347 ! obtain the variable time independent attribute with REAL8 type
3348 subroutine ext_phdf5_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status)
3350 use wrf_phdf5_data
3351 use ext_phdf5_support_routines
3352 USE HDF5 ! This module contains all necessary modules
3353 use get_attrid_routine
3354 implicit none
3355 include 'wrf_status_codes.h'
3357 integer ,intent(in) :: DataHandle
3358 character*(*) ,intent(in) :: Element
3359 character*(*) ,intent(in) :: Var
3360 real*8 ,intent(out) :: Data(*)
3361 integer ,intent(in) :: Count
3362 integer ,intent(out) :: OutCount
3363 integer ,intent(out) :: Status
3364 integer(hid_t) :: h5_atypeid
3365 integer(hid_t) :: h5_aspaceid
3366 integer(hid_t) :: h5_attrid
3367 integer(hid_t) :: attr_type
3368 integer(hsize_t), dimension(7) :: h5_dims
3369 integer :: hdf5err
3371 attr_type = H5T_NATIVE_DOUBLE
3373 call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
3374 if(Status /= WRF_NO_ERR) then
3375 return
3376 endif
3378 call check_type(DataHandle,attr_type,h5_attrid,Status)
3379 if (status /= WRF_NO_ERR) then
3380 return
3381 endif
3383 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
3384 Count,OutCount,Status)
3385 if(Status /= WRF_NO_ERR) then
3386 return
3387 endif
3389 h5_dims(1) = OutCount
3390 call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
3391 if(hdf5err.lt.0) then
3392 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
3393 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3394 call wrf_debug ( WARN , msg)
3395 return
3396 endif
3398 end subroutine ext_phdf5_get_var_ti_double
3400 ! obtain the variable time independent attribute with integer type
3401 subroutine ext_phdf5_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status)
3403 use wrf_phdf5_data
3404 use ext_phdf5_support_routines
3405 USE HDF5 ! This module contains all necessary modules
3406 use get_attrid_routine
3407 implicit none
3408 include 'wrf_status_codes.h'
3410 integer ,intent(in) :: DataHandle
3411 character*(*) ,intent(in) :: Element
3412 character*(*) ,intent(in) :: Var
3413 integer ,intent(out) :: Data(*)
3414 integer ,intent(in) :: Count
3415 integer ,intent(out) :: OutCount
3416 integer ,intent(out) :: Status
3417 integer(hid_t) :: h5_atypeid
3418 integer(hid_t) :: h5_aspaceid
3419 integer(hid_t) :: h5_attrid
3420 integer(hid_t) :: attr_type
3421 integer(hsize_t), dimension(7) :: h5_dims
3422 integer :: hdf5err
3424 attr_type = H5T_NATIVE_INTEGER
3426 call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
3427 if (status /= WRF_NO_ERR) then
3428 return
3429 endif
3431 call check_type(DataHandle,attr_type,h5_attrid,Status)
3432 if (status /= WRF_NO_ERR) then
3433 return
3434 endif
3436 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
3437 Count,OutCount,Status)
3438 if (status /= WRF_NO_ERR) then
3439 return
3440 endif
3442 h5_dims(1) = OutCount
3443 call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
3444 if(hdf5err.lt.0) then
3445 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
3446 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3447 call wrf_debug ( WARN , msg)
3448 return
3449 endif
3451 return
3453 end subroutine ext_phdf5_get_var_ti_integer
3455 ! obtain the variable time independent attribute with logical type
3456 subroutine ext_phdf5_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status)
3458 use wrf_phdf5_data
3459 use ext_phdf5_support_routines
3460 USE HDF5 ! This module contains all necessary modules
3461 use get_attrid_routine
3462 implicit none
3463 include 'wrf_status_codes.h'
3465 integer ,intent(in) :: DataHandle
3466 character*(*) ,intent(in) :: Element
3467 character*(*) ,intent(in) :: Var
3468 logical ,intent(out) :: Data(*)
3469 integer, dimension(:),allocatable :: Buffer
3470 integer ,intent(in) :: Count
3471 integer ,intent(out) :: OutCount
3472 integer ,intent(out) :: Status
3473 integer(hid_t) :: h5_atypeid
3474 integer(hid_t) :: h5_aspaceid
3475 integer(hid_t) :: h5_attrid
3476 integer(hid_t) :: attr_type
3477 type(wrf_phdf5_data_handle),pointer :: DH
3478 integer(hsize_t), dimension(7) :: h5_dims
3479 integer :: hdf5err
3481 call GetDH(DataHandle,DH,Status)
3482 if(Status /= WRF_NO_ERR) then
3483 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3484 call wrf_debug ( WARN , msg)
3485 return
3486 endif
3488 attr_type = DH%EnumID
3489 call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
3490 if(Status /= WRF_NO_ERR) then
3491 return
3492 endif
3494 call check_type(DataHandle,attr_type,h5_attrid,Status)
3495 if (status /= WRF_NO_ERR) then
3496 return
3497 endif
3499 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
3500 Count,OutCount,Status)
3501 if (status /= WRF_NO_ERR) then
3502 return
3503 endif
3505 h5_dims(1) = OutCount
3507 allocate(buffer(OutCount))
3508 call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err)
3509 if(hdf5err.lt.0) then
3510 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
3511 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3512 call wrf_debug ( WARN , msg)
3513 deallocate(buffer)
3514 return
3515 endif
3517 Data(1:OutCount) = buffer(1:OutCount)==1
3518 deallocate(buffer)
3519 return
3521 end subroutine ext_phdf5_get_var_ti_logical
3524 ! obtain the domain variable independent attribute with Char type
3525 subroutine ext_phdf5_get_var_ti_char(DataHandle,Element,Var,Data,Status)
3527 use wrf_phdf5_data
3528 use ext_phdf5_support_routines
3529 USE HDF5 ! This module contains all necessary modules
3530 use get_attrid_routine
3531 implicit none
3532 include 'wrf_status_codes.h'
3534 integer ,intent(in) :: DataHandle
3535 character*(*) ,intent(in) :: Element
3536 character*(*) ,intent(in) :: Var
3537 character*(*) ,intent(out) :: Data
3538 integer ,intent(out) :: Status
3540 integer(hid_t) :: h5_atypeid
3541 integer(hid_t) :: h5_aspaceid
3542 integer(hid_t) :: h5_attrid
3543 integer(hid_t) :: attr_type
3544 integer(hsize_t), dimension(7) :: h5_dims
3545 integer :: Count
3546 integer :: OutCount
3547 integer :: hdf5err
3549 attr_type = H5T_NATIVE_CHARACTER
3550 call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
3551 if (status /= WRF_NO_ERR) then
3552 return
3553 endif
3555 call check_type(DataHandle,attr_type,h5_attrid,Status)
3556 if (status /= WRF_NO_ERR) then
3557 return
3558 endif
3560 call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
3561 Count,OutCount,Status)
3562 if (status /= WRF_NO_ERR) then
3563 return
3564 endif
3566 if(OutCount /= 1) then
3567 Status = WRF_HDF5_ERR_ATTRIBUTE_OTHERS
3568 endif
3569 h5_dims(1) = OutCount
3570 call h5aread_f(h5_attrid,h5_atypeid,data,h5_dims,hdf5err)
3571 if(hdf5err.lt.0) then
3572 Status = WRF_HDF5_ERR_ATTRIBUTE_READ
3573 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3574 call wrf_debug ( WARN , msg)
3575 return
3576 endif
3578 return
3580 end subroutine ext_phdf5_get_var_ti_char
3583 ! write the domain time independent attribute with real type
3584 subroutine ext_phdf5_put_dom_ti_real(DataHandle,Element,Data,Count,Status)
3586 use wrf_phdf5_data
3587 use ext_phdf5_support_routines
3588 USE HDF5 ! This module contains all necessary modules
3589 implicit none
3590 include 'wrf_status_codes.h'
3592 integer ,intent(in) :: DataHandle
3593 character*(*) ,intent(in) :: Element
3594 real ,intent(in) :: Data(*)
3595 integer ,intent(in) :: Count
3596 integer ,intent(out) :: Status
3598 integer(hid_t) :: h5_objid
3599 integer(hid_t) :: h5_atypeid
3600 integer(hid_t) :: h5_aspaceid
3601 integer(hid_t) :: h5_attrid
3602 integer(hsize_t), dimension(7) :: adata_dims
3603 character*3 :: routine_type
3604 integer :: routine_atype
3605 integer :: str_flag = 0 ! not a string type
3606 integer(hid_t) :: hdf5err
3607 character(VarNameLen) :: var
3609 ! Do nothing unless it is time to write time-independent domain metadata.
3610 IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
3611 Status = WRF_NO_ERR
3612 return
3613 ENDIF
3615 var = 'DUMMY'
3616 routine_type = 'DOM'
3617 routine_atype = WRF_REAL
3618 adata_dims(1) = Count
3620 call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
3621 if(Status /= WRF_NO_ERR) then
3622 return
3623 endif
3625 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
3626 if(Status /= WRF_NO_ERR) then
3627 return
3628 endif
3630 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
3631 if(Status /= WRF_NO_ERR) then
3632 return
3633 endif
3635 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
3636 h5_attrid, hdf5err)
3637 if(hdf5err.lt.0) then
3638 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
3639 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3640 call wrf_debug ( WARN , msg)
3641 return
3642 endif
3644 call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
3645 if(hdf5err.lt.0) then
3646 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
3647 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3648 call wrf_debug ( WARN , msg)
3649 return
3650 endif
3652 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
3653 if(Status /= WRF_NO_ERR) then
3654 return
3655 endif
3657 return
3658 end subroutine ext_phdf5_put_dom_ti_real
3660 ! write the domain time independent attribute with integer type
3661 subroutine ext_phdf5_put_dom_ti_integer(DataHandle,Element,Data,Count,Status)
3663 use wrf_phdf5_data
3664 use ext_phdf5_support_routines
3665 USE HDF5 ! This module contains all necessary modules
3666 implicit none
3667 include 'wrf_status_codes.h'
3669 integer ,intent(in) :: DataHandle
3670 character*(*) ,intent(in) :: Element
3671 integer ,intent(in) :: Data(*)
3672 integer ,intent(in) :: Count
3673 integer ,intent(out) :: Status
3674 integer(hid_t) :: h5_objid
3675 integer(hid_t) :: h5_atypeid
3676 integer(hid_t) :: h5_aspaceid
3677 integer(hid_t) :: h5_attrid
3678 integer(hsize_t), dimension(7) :: adata_dims
3679 character*3 :: routine_type
3680 integer :: routine_atype
3681 integer :: str_flag = 0 ! not a string type
3682 integer(hid_t) :: hdf5err
3683 character(VarNameLen) :: var
3685 ! Do nothing unless it is time to write time-independent domain metadata.
3686 IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
3687 Status = WRF_NO_ERR
3688 return
3689 ENDIF
3691 var = 'DUMMY'
3692 routine_type = 'DOM'
3693 routine_atype = WRF_INTEGER
3694 adata_dims(1) = Count
3696 call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
3697 if(Status /= WRF_NO_ERR) then
3698 return
3699 endif
3701 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
3702 if(Status /= WRF_NO_ERR) then
3703 return
3704 endif
3706 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
3707 if(Status /= WRF_NO_ERR) then
3708 return
3709 endif
3711 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
3712 h5_attrid, hdf5err)
3713 if(hdf5err.lt.0) then
3714 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
3715 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3716 call wrf_debug ( WARN , msg)
3717 return
3718 endif
3720 call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
3721 if(hdf5err.lt.0) then
3722 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
3723 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3724 call wrf_debug ( WARN , msg)
3725 return
3726 endif
3728 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
3729 if(Status /= WRF_NO_ERR) then
3730 return
3731 endif
3733 return
3734 end subroutine ext_phdf5_put_dom_ti_integer
3736 ! write the domain time independent attribute with double type
3737 subroutine ext_phdf5_put_dom_ti_double(DataHandle,Element,Data,Count,Status)
3739 use wrf_phdf5_data
3740 use ext_phdf5_support_routines
3741 USE HDF5 ! This module contains all necessary modules
3742 implicit none
3743 include 'wrf_status_codes.h'
3745 integer ,intent(in) :: DataHandle
3746 character*(*) ,intent(in) :: Element
3747 real*8 ,intent(in) :: Data(*)
3748 integer ,intent(in) :: Count
3749 integer ,intent(out) :: Status
3750 integer(hid_t) :: h5_objid
3751 integer(hid_t) :: h5_atypeid
3752 integer(hid_t) :: h5_aspaceid
3753 integer(hid_t) :: h5_attrid
3754 integer(hsize_t), dimension(7) :: adata_dims
3756 character*3 :: routine_type
3757 integer :: routine_atype
3758 integer :: str_flag = 0 ! not a string type
3759 integer(hid_t) :: hdf5err
3760 character(VarNameLen) :: var
3762 ! Do nothing unless it is time to write time-independent domain metadata.
3763 IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
3764 Status = WRF_NO_ERR
3765 return
3766 ENDIF
3768 var = 'DUMMY'
3769 routine_type = 'DOM'
3770 routine_atype = WRF_DOUBLE
3771 adata_dims(1) = Count
3773 call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
3774 if(Status /= WRF_NO_ERR) then
3775 return
3776 endif
3778 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
3779 if(Status /= WRF_NO_ERR) then
3780 return
3781 endif
3783 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
3784 if(Status /= WRF_NO_ERR) then
3785 return
3786 endif
3788 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
3789 h5_attrid, hdf5err)
3790 if(hdf5err.lt.0) then
3791 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
3792 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3793 call wrf_debug ( WARN , msg)
3794 return
3795 endif
3797 call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
3798 if(hdf5err.lt.0) then
3799 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
3800 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3801 call wrf_debug ( WARN , msg)
3802 return
3803 endif
3805 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
3806 if(Status /= WRF_NO_ERR) then
3807 return
3808 endif
3809 return
3811 end subroutine ext_phdf5_put_dom_ti_double
3813 ! write the domain time independent attribute with logical type
3814 subroutine ext_phdf5_put_dom_ti_logical(DataHandle,Element,Data,Count,Status)
3816 use wrf_phdf5_data
3817 use ext_phdf5_support_routines
3818 USE HDF5 ! This module contains all necessary modules
3819 implicit none
3820 include 'wrf_status_codes.h'
3822 integer ,intent(in) :: DataHandle
3823 character*(*) ,intent(in) :: Element
3824 logical ,intent(in) :: Data(*)
3825 integer ,dimension(:),allocatable :: Buffer
3826 integer ,intent(in) :: Count
3827 integer ,intent(out) :: Status
3829 integer :: i
3830 integer(hid_t) :: h5_objid
3831 integer(hid_t) :: h5_atypeid
3832 integer(hid_t) :: h5_aspaceid
3833 integer(hid_t) :: h5_attrid
3834 integer(hsize_t), dimension(7) :: adata_dims
3836 character*3 :: routine_type
3837 integer :: routine_atype
3838 integer :: str_flag = 0 ! not a string type
3839 integer(hid_t) :: hdf5err
3840 character(VarNameLen) :: var
3842 ! Do nothing unless it is time to write time-independent domain metadata.
3843 IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
3844 Status = WRF_NO_ERR
3845 return
3846 ENDIF
3848 var = 'DUMMY'
3849 routine_type = 'DOM'
3850 routine_atype = WRF_LOGICAL
3851 adata_dims(1) = Count
3853 allocate(Buffer(Count))
3855 do i = 1,Count
3856 if(Data(i) .EQV. .TRUE.) then
3857 Buffer(i) = 1
3858 else
3859 Buffer(i) = 0
3860 endif
3861 enddo
3863 call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
3864 if(Status /= WRF_NO_ERR) then
3865 return
3866 endif
3868 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status,DataHandle)
3869 if(Status /= WRF_NO_ERR) then
3870 return
3871 endif
3873 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
3874 if(Status /= WRF_NO_ERR) then
3875 return
3876 endif
3878 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
3879 h5_attrid, hdf5err)
3880 if(hdf5err.lt.0) then
3881 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
3882 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3883 call wrf_debug ( WARN , msg)
3884 deallocate(buffer)
3885 return
3886 endif
3888 call h5awrite_f(h5_attrid,h5_atypeid,Buffer,adata_dims,hdf5err)
3889 if(hdf5err.lt.0) then
3890 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
3891 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3892 call wrf_debug ( WARN , msg)
3893 deallocate(buffer)
3894 return
3895 endif
3897 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
3898 if(Status /= WRF_NO_ERR) then
3899 return
3900 endif
3902 deallocate(Buffer)
3904 end subroutine ext_phdf5_put_dom_ti_logical
3907 ! write the domain time independent attribute with char type
3908 subroutine ext_phdf5_put_dom_ti_char(DataHandle,Element,Data,Status)
3910 use wrf_phdf5_data
3911 use ext_phdf5_support_routines
3912 USE HDF5 ! This module contains all necessary modules
3913 implicit none
3914 include 'wrf_status_codes.h'
3916 !!!! Need more work.
3917 integer ,intent(in) :: DataHandle
3918 character*(*) ,intent(in) :: Element
3919 character*(*) ,intent(in) :: Data
3920 integer :: Count ! always 1 for char
3921 integer ,intent(out) :: Status
3923 integer(hid_t) :: h5_objid
3924 integer(hid_t) :: h5_atypeid
3925 integer(hid_t) :: h5_aspaceid
3926 integer(hid_t) :: h5_attrid
3927 integer(hsize_t), dimension(7) :: adata_dims
3928 character*3 :: routine_type
3929 integer :: routine_atype
3930 integer :: str_flag = 1 ! is a string type
3931 integer(hid_t) :: hdf5err
3932 integer :: len_str
3933 character(VarNameLen) :: var
3934 character(1) :: RepData =' '
3936 ! Do nothing unless it is time to write time-independent domain metadata.
3937 IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
3938 Status = WRF_NO_ERR
3939 return
3940 ENDIF
3942 Count = 1
3943 var = 'DUMMY'
3944 routine_type = 'DOM'
3945 routine_atype = WRF_CHARACTER
3946 adata_dims(1) = Count
3948 call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
3949 if(Status /= WRF_NO_ERR) then
3950 return
3951 endif
3953 ! This part may need more work, a special case is that the length of the
3954 ! string may be 0, HDF5 cannot handle 0 length string(?),so set the length
3955 ! to 1
3957 len_str = len_trim(Data)
3958 if(len_str == 0) then
3959 len_str = 1
3960 endif
3962 call create_phdf5_adtypeid(h5_atypeid,routine_atype,len_str,Status)
3963 if(Status /= WRF_NO_ERR) then
3964 return
3965 endif
3967 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
3968 if(Status /= WRF_NO_ERR) then
3969 return
3970 endif
3972 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
3973 h5_attrid, hdf5err)
3974 if(hdf5err.lt.0) then
3975 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
3976 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3977 call wrf_debug ( WARN , msg)
3978 return
3979 endif
3982 if(len_trim(Data) == 0) then
3984 call h5awrite_f(h5_attrid,h5_atypeid,RepData,adata_dims,hdf5err)
3985 if(hdf5err.lt.0) then
3986 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
3987 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3988 call wrf_debug ( WARN , msg)
3989 return
3990 endif
3991 else
3993 call h5awrite_f(h5_attrid,h5_atypeid,trim(Data),adata_dims,hdf5err)
3994 if(hdf5err.lt.0) then
3995 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
3996 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3997 call wrf_debug ( WARN , msg)
3998 return
3999 endif
4000 endif
4002 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
4003 if(Status /= WRF_NO_ERR) then
4004 return
4005 endif
4007 return
4008 end subroutine ext_phdf5_put_dom_ti_char
4010 ! write the variable time independent attribute with real type
4011 subroutine ext_phdf5_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status)
4013 use wrf_phdf5_data
4014 use ext_phdf5_support_routines
4015 USE HDF5 ! This module contains all necessary modules
4016 implicit none
4017 include 'wrf_status_codes.h'
4019 integer ,intent(in) :: DataHandle
4020 character*(*) ,intent(in) :: Element
4021 character*(*) ,intent(in) :: Var
4022 real ,intent(in) :: Data(*)
4023 integer ,intent(in) :: Count
4024 integer ,intent(out) :: Status
4026 integer(hid_t) :: h5_objid
4027 integer(hid_t) :: h5_atypeid
4028 integer(hid_t) :: h5_aspaceid
4029 integer(hid_t) :: h5_attrid
4030 integer(hsize_t), dimension(7) :: adata_dims
4031 character*3 :: routine_type
4032 integer :: routine_atype
4033 integer :: str_flag = 0 ! not a string type
4034 integer(hid_t) :: hdf5err
4035 type(wrf_phdf5_data_handle),pointer :: DH
4038 routine_type = 'VAR'
4039 routine_atype = WRF_REAL
4040 adata_dims(1) = Count
4042 call GetDH(DataHandle,DH,Status)
4043 if(Status /= WRF_NO_ERR) then
4044 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4045 call wrf_debug ( WARN , msg)
4046 return
4047 endif
4049 ! The following two checks must be here to avoid duplicating attributes
4050 if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
4051 Status = WRF_NO_ERR
4052 return
4053 endif
4054 if(DH%TimeIndex > 1) then
4055 Status = WRF_NO_ERR
4056 return
4057 endif
4059 call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
4060 if(Status /= WRF_NO_ERR) then
4061 return
4062 endif
4064 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
4065 if(Status /= WRF_NO_ERR) then
4066 return
4067 endif
4069 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
4070 if(Status /= WRF_NO_ERR) then
4071 return
4072 endif
4074 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
4075 h5_attrid, hdf5err)
4076 if(hdf5err.lt.0) then
4077 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
4078 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4079 call wrf_debug ( WARN , msg)
4080 return
4081 endif
4083 call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
4084 if(hdf5err.lt.0) then
4085 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
4086 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4087 call wrf_debug ( WARN , msg)
4088 return
4089 endif
4091 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
4092 if(Status /= WRF_NO_ERR) then
4093 return
4094 endif
4096 return
4097 end subroutine ext_phdf5_put_var_ti_real
4099 ! write the variable time independent attribute with double type
4100 subroutine ext_phdf5_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status)
4102 use wrf_phdf5_data
4103 use ext_phdf5_support_routines
4104 USE HDF5 ! This module contains all necessary modules
4105 implicit none
4106 include 'wrf_status_codes.h'
4108 integer ,intent(in) :: DataHandle
4109 character*(*) ,intent(in) :: Element
4110 real*8 ,intent(in) :: Data(*)
4111 character*(*) ,intent(in) :: Var
4112 integer ,intent(in) :: Count
4113 integer ,intent(out) :: Status
4115 integer(hid_t) :: h5_objid
4116 integer(hid_t) :: h5_atypeid
4117 integer(hid_t) :: h5_aspaceid
4118 integer(hid_t) :: h5_attrid
4119 integer(hsize_t), dimension(7) :: adata_dims
4121 character*3 :: routine_type
4122 integer :: routine_atype
4123 integer :: str_flag = 0 ! not a string type
4124 integer(hid_t) :: hdf5err
4125 type(wrf_phdf5_data_handle),pointer :: DH
4127 routine_type = 'VAR'
4128 routine_atype = WRF_DOUBLE
4129 adata_dims(1) = Count
4131 call GetDH(DataHandle,DH,Status)
4132 if(Status /= WRF_NO_ERR) then
4133 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4134 call wrf_debug ( WARN , msg)
4135 return
4136 endif
4138 if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
4139 Status = WRF_NO_ERR
4140 return
4141 endif
4142 if(DH%TimeIndex > 1) then
4143 Status = WRF_NO_ERR
4144 return
4145 endif
4147 call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
4148 if(Status /= WRF_NO_ERR) then
4149 return
4150 endif
4152 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
4153 if(Status /= WRF_NO_ERR) then
4154 return
4155 endif
4157 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
4158 if(Status /= WRF_NO_ERR) then
4159 return
4160 endif
4162 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
4163 h5_attrid, hdf5err)
4164 if(hdf5err.lt.0) then
4165 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
4166 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4167 call wrf_debug ( WARN , msg)
4168 return
4169 endif
4172 call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
4173 if(hdf5err.lt.0) then
4174 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
4175 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4176 call wrf_debug ( WARN , msg)
4177 return
4178 endif
4180 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
4181 if(Status /= WRF_NO_ERR) then
4182 return
4183 endif
4185 return
4187 end subroutine ext_phdf5_put_var_ti_double
4189 ! write the variable time independent attribute with integer type
4190 subroutine ext_phdf5_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status)
4192 use wrf_phdf5_data
4193 use ext_phdf5_support_routines
4194 USE HDF5 ! This module contains all necessary modules
4195 implicit none
4196 include 'wrf_status_codes.h'
4198 integer ,intent(in) :: DataHandle
4199 character*(*) ,intent(in) :: Element
4200 character*(*) ,intent(in) :: Var
4201 integer ,intent(in) :: Data(*)
4202 integer ,intent(in) :: Count
4203 integer ,intent(out) :: Status
4205 integer(hid_t) :: h5_objid
4206 integer(hid_t) :: h5_atypeid
4207 integer(hid_t) :: h5_aspaceid
4208 integer(hid_t) :: h5_attrid
4209 integer(hsize_t), dimension(7) :: adata_dims
4211 character*3 :: routine_type
4212 integer :: routine_atype
4213 integer :: str_flag = 0 ! not a string type
4214 integer(hid_t) :: hdf5err
4215 type(wrf_phdf5_data_handle),pointer :: DH
4217 routine_type = 'VAR'
4218 routine_atype = WRF_INTEGER
4219 adata_dims(1) = Count
4221 call GetDH(DataHandle,DH,Status)
4222 if(Status /= WRF_NO_ERR) then
4223 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4224 call wrf_debug ( WARN , msg)
4225 return
4226 endif
4228 ! The following two checks must be here to avoid duplicating attributes
4229 if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
4230 Status = WRF_NO_ERR
4231 return
4232 endif
4233 if(DH%TimeIndex > 1) then
4234 Status = WRF_NO_ERR
4235 return
4236 endif
4238 call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
4239 if(Status /= WRF_NO_ERR) then
4240 return
4241 endif
4243 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
4244 if(Status /= WRF_NO_ERR) then
4245 return
4246 endif
4248 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
4249 if(Status /= WRF_NO_ERR) then
4250 return
4251 endif
4253 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
4254 h5_attrid, hdf5err)
4255 if(hdf5err.lt.0) then
4256 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
4257 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4258 call wrf_debug ( WARN , msg)
4259 return
4260 endif
4263 call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
4264 if(hdf5err.lt.0) then
4265 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
4266 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4267 call wrf_debug ( WARN , msg)
4268 return
4269 endif
4272 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
4273 if(Status /= WRF_NO_ERR) then
4274 return
4275 endif
4277 return
4278 end subroutine ext_phdf5_put_var_ti_integer
4281 ! write the variable time independent attribute with logical type
4282 subroutine ext_phdf5_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status)
4284 use wrf_phdf5_data
4285 use ext_phdf5_support_routines
4286 USE HDF5 ! This module contains all necessary modules
4287 implicit none
4288 include 'wrf_status_codes.h'
4290 integer ,intent(in) :: DataHandle
4291 character*(*) ,intent(in) :: Element
4292 character*(*) ,intent(in) :: Var
4293 logical ,intent(in) :: Data(*)
4294 integer ,dimension(:),allocatable :: Buffer
4295 integer ,intent(in) :: Count
4296 integer ,intent(out) :: Status
4298 integer :: i
4299 integer(hid_t) :: h5_objid
4300 integer(hid_t) :: h5_atypeid
4301 integer(hid_t) :: h5_aspaceid
4302 integer(hid_t) :: h5_attrid
4303 integer(hsize_t), dimension(7) :: adata_dims
4305 character*3 :: routine_type
4306 integer :: routine_atype
4307 integer :: str_flag = 0 ! not a string type
4308 integer(hid_t) :: hdf5err
4309 type(wrf_phdf5_data_handle),pointer :: DH
4311 routine_type = 'VAR'
4312 routine_atype = WRF_LOGICAL
4313 adata_dims(1) = Count
4315 allocate(Buffer(Count))
4317 do i = 1,Count
4318 if(Data(i) .EQV. .TRUE.) then
4319 Buffer(i) = 1
4320 else
4321 Buffer(i) = 0
4322 endif
4323 enddo
4325 call GetDH(DataHandle,DH,Status)
4326 if(Status /= WRF_NO_ERR) then
4327 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4328 call wrf_debug ( WARN , msg)
4329 return
4330 endif
4332 ! The following two checks must be here to avoid duplicating attributes
4333 if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
4334 Status = WRF_NO_ERR
4335 return
4336 endif
4338 if(DH%TimeIndex > 1) then
4339 Status = WRF_NO_ERR
4340 return
4341 endif
4343 call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
4344 if(Status /= WRF_NO_ERR) then
4345 return
4346 endif
4348 call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
4349 if(Status /= WRF_NO_ERR) then
4350 return
4351 endif
4353 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
4354 if(Status /= WRF_NO_ERR) then
4355 return
4356 endif
4358 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
4359 h5_attrid, hdf5err)
4360 if(hdf5err.lt.0) then
4361 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
4362 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4363 call wrf_debug ( WARN , msg)
4364 deallocate(buffer)
4365 return
4366 endif
4369 call h5awrite_f(h5_attrid,h5_atypeid,Buffer,adata_dims,hdf5err)
4370 if(hdf5err.lt.0) then
4371 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
4372 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4373 call wrf_debug ( WARN , msg)
4374 deallocate(buffer)
4375 return
4376 endif
4378 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
4379 if(Status /= WRF_NO_ERR) then
4380 return
4381 endif
4383 return
4384 end subroutine ext_phdf5_put_var_ti_logical
4386 ! write the variable time independent attribute with char type
4387 subroutine ext_phdf5_put_var_ti_char(DataHandle,Element,Var,Data,Status)
4389 use wrf_phdf5_data
4390 use ext_phdf5_support_routines
4391 USE HDF5 ! This module contains all necessary modules
4392 implicit none
4393 include 'wrf_status_codes.h'
4395 integer ,intent(in) :: DataHandle
4396 character*(*) ,intent(in) :: Element
4397 character*(*) ,intent(in) :: Data
4398 character*(*) ,intent(in) :: Var
4399 integer :: Count
4400 integer ,intent(out) :: Status
4401 integer(hid_t) :: h5_objid
4402 integer(hid_t) :: h5_atypeid
4403 integer(hid_t) :: h5_aspaceid
4404 integer(hid_t) :: h5_attrid
4405 integer(hsize_t), dimension(7) :: adata_dims
4407 character*3 :: routine_type
4408 integer :: routine_atype
4409 integer :: str_flag = 1 ! IS string type
4410 integer(hid_t) :: hdf5err
4411 integer :: len_str
4412 character(1) :: RepData = ' '
4413 type(wrf_phdf5_data_handle),pointer :: DH
4415 Count = 1
4416 routine_type = 'VAR'
4417 routine_atype = WRF_CHARACTER
4418 adata_dims(1) = Count
4420 call GetDH(DataHandle,DH,Status)
4421 if(Status /= WRF_NO_ERR) then
4422 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
4423 ', line', __LINE__
4424 call wrf_debug ( WARN , msg)
4425 return
4426 endif
4428 ! The following two checks must be here to avoid duplicating attributes
4429 if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
4430 Status = WRF_NO_ERR
4431 return
4432 endif
4434 if(DH%TimeIndex > 1) then
4435 Status = WRF_NO_ERR
4436 return
4437 endif
4439 call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
4440 if(Status /= WRF_NO_ERR) then
4441 return
4442 endif
4444 len_str = len_trim(Data)
4446 if(len_str .eq. 0) then
4447 len_str = 1
4448 endif
4450 call create_phdf5_adtypeid(h5_atypeid,routine_atype,len_str,Status)
4451 if(Status /= WRF_NO_ERR) then
4452 return
4453 endif
4455 call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
4456 if(Status /= WRF_NO_ERR) then
4457 return
4458 endif
4460 call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
4461 h5_attrid, hdf5err)
4462 if(hdf5err.lt.0) then
4463 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
4464 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4465 call wrf_debug ( WARN , msg)
4466 return
4467 endif
4469 if(len_trim(Data) == 0) then
4471 call h5awrite_f(h5_attrid,h5_atypeid,RepData,adata_dims,hdf5err)
4472 if(hdf5err.lt.0) then
4473 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
4474 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4475 call wrf_debug ( WARN , msg)
4476 return
4477 endif
4478 else
4479 call h5awrite_f(h5_attrid,h5_atypeid,trim(Data),adata_dims,hdf5err)
4480 if(hdf5err.lt.0) then
4481 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
4482 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4483 call wrf_debug ( WARN , msg)
4484 return
4485 endif
4486 endif
4488 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
4489 if(Status /= WRF_NO_ERR) then
4490 return
4491 endif
4493 return
4494 end subroutine ext_phdf5_put_var_ti_char
4498 ! This routine will retrieve the dimensional table, should be useful
4499 ! for tool developers.
4501 subroutine retrieve_table(DataHandle,Status)
4503 use wrf_phdf5_data
4504 use ext_phdf5_support_routines
4505 use hdf5
4506 implicit none
4507 include 'wrf_status_codes.h'
4509 character*256,dimension(MaxTabDims) :: dim_name
4510 integer,dimension(:),allocatable :: length
4511 integer,dimension(:),allocatable :: unlimited
4512 integer, intent(in) :: DataHandle
4513 integer, intent(out) :: Status
4515 integer(hid_t) :: dset_id
4516 integer(hid_t) :: dataspace_id
4517 integer(hid_t) :: dtstr_id
4518 integer(hid_t) :: dt1_id
4519 integer(hid_t) :: dtint1_id
4520 integer(hid_t) :: dtint2_id
4521 integer(size_t) :: type_sizei
4522 integer(size_t) :: offset
4523 integer :: table_length
4524 integer(size_t) :: string_size
4525 integer(hsize_t),dimension(7) :: data_dims
4526 integer(hsize_t) :: table_size
4527 integer :: i
4528 integer :: hdf5err
4530 type(wrf_phdf5_data_handle),pointer :: DH
4532 call GetDH(DataHandle,DH,Status)
4533 if(Status /= WRF_NO_ERR) then
4534 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4535 call wrf_debug ( WARN , msg)
4536 return
4537 endif
4539 call h5dopen_f(DH%DimGroupID,"h5dim_table",dset_id,hdf5err)
4540 if(hdf5err.lt.0) then
4541 Status = WRF_HDF5_ERR_DATASET_OPEN
4542 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4543 call wrf_debug ( WARN , msg)
4544 return
4545 endif
4547 call h5dget_space_f(dset_id,dataspace_id,hdf5err)
4548 if(hdf5err.lt.0) then
4549 Status = WRF_HDF5_ERR_DATASPACE
4550 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4551 call wrf_debug ( WARN , msg)
4552 return
4553 endif
4555 call h5sget_simple_extent_npoints_f(dataspace_id,table_size,hdf5err)
4556 if(hdf5err.lt.0) then
4557 Status = WRF_HDF5_ERR_DATASPACE
4558 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4559 call wrf_debug ( WARN , msg)
4560 return
4561 endif
4563 data_dims(1) = table_size
4564 allocate(length(table_size))
4565 allocate(unlimited(table_size))
4568 ! the name of the dimension
4569 call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err)
4570 if(hdf5err.lt.0) then
4571 Status = WRF_HDF5_ERR_DATATYPE
4572 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4573 call wrf_debug ( WARN , msg)
4574 deallocate(length)
4575 deallocate(unlimited)
4576 return
4577 endif
4579 string_size = 256
4580 call h5tset_size_f(dtstr_id,string_size,hdf5err)
4581 if(hdf5err.lt.0) then
4582 Status = WRF_HDF5_ERR_DATATYPE
4583 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4584 call wrf_debug ( WARN , msg)
4585 deallocate(length)
4586 deallocate(unlimited)
4587 return
4588 endif
4590 call h5tcreate_f(H5T_COMPOUND_F,string_size,dt1_id,hdf5err)
4591 if(hdf5err.lt.0) then
4592 Status = WRF_HDF5_ERR_DATATYPE
4593 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4594 call wrf_debug ( WARN , msg)
4595 deallocate(length)
4596 deallocate(unlimited)
4597 return
4598 endif
4600 offset = 0
4601 call h5tinsert_f(dt1_id,"dim_name",offset,dtstr_id,hdf5err)
4602 if(hdf5err.lt.0) then
4603 Status = WRF_HDF5_ERR_DATATYPE
4604 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4605 call wrf_debug ( WARN , msg)
4606 deallocate(length)
4607 deallocate(unlimited)
4608 return
4609 endif
4611 call h5dread_f(dset_id,dt1_id,dim_name,data_dims,hdf5err)
4612 if(hdf5err.lt.0) then
4613 Status = WRF_HDF5_ERR_DATASET_READ
4614 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4615 call wrf_debug ( WARN , msg)
4616 deallocate(length)
4617 deallocate(unlimited)
4618 return
4619 endif
4621 ! the length of the dimension
4622 call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err)
4623 if(hdf5err.lt.0) then
4624 Status = WRF_HDF5_ERR_DATATYPE
4625 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4626 call wrf_debug ( WARN , msg)
4627 deallocate(length)
4628 deallocate(unlimited)
4629 return
4630 endif
4632 call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint1_id,hdf5err)
4633 if(hdf5err.lt.0) then
4634 Status = WRF_HDF5_ERR_DATATYPE
4635 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4636 call wrf_debug ( WARN , msg)
4637 deallocate(length)
4638 deallocate(unlimited)
4639 return
4640 endif
4642 offset = 0
4643 call h5tinsert_f(dtint1_id,"dim_length",offset,H5T_NATIVE_INTEGER,hdf5err)
4644 if(hdf5err.lt.0) then
4645 Status = WRF_HDF5_ERR_DATATYPE
4646 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4647 call wrf_debug ( WARN , msg)
4648 deallocate(length)
4649 deallocate(unlimited)
4650 return
4651 endif
4653 call h5dread_f(dset_id,dtint1_id,length,data_dims,hdf5err)
4654 if(hdf5err.lt.0) then
4655 Status = WRF_HDF5_ERR_DATASET_READ
4656 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4657 call wrf_debug ( WARN , msg)
4658 deallocate(length)
4659 deallocate(unlimited)
4660 return
4661 endif
4664 ! the unlimited info. of the dimension
4665 call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err)
4666 if(hdf5err.lt.0) then
4667 Status = WRF_HDF5_ERR_DATATYPE
4668 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4669 call wrf_debug ( WARN , msg)
4670 deallocate(length)
4671 deallocate(unlimited)
4672 return
4673 endif
4675 call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint2_id,hdf5err)
4676 if(hdf5err.lt.0) then
4677 Status = WRF_HDF5_ERR_DATATYPE
4678 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4679 call wrf_debug ( WARN , msg)
4680 deallocate(length)
4681 deallocate(unlimited)
4682 return
4683 endif
4685 offset = 0
4686 call h5tinsert_f(dtint2_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,hdf5err)
4687 if(hdf5err.lt.0) then
4688 Status = WRF_HDF5_ERR_DATATYPE
4689 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4690 call wrf_debug ( WARN , msg)
4691 deallocate(length)
4692 deallocate(unlimited)
4693 return
4694 endif
4696 call h5dread_f(dset_id,dtint2_id,unlimited,data_dims,hdf5err)
4697 if(hdf5err.lt.0) then
4698 Status = WRF_HDF5_ERR_DATASET_READ
4699 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4700 call wrf_debug ( WARN , msg)
4701 deallocate(length)
4702 deallocate(unlimited)
4703 return
4704 endif
4706 ! Store the information to the table array
4707 do i =1,table_size
4708 DH%DIMTABLE(i)%dim_name = dim_name(i)
4709 DH%DIMTABLE(i)%length = length(i)
4710 DH%DIMTABLE(i)%unlimited = unlimited(i)
4711 enddo
4713 deallocate(length)
4714 deallocate(unlimited)
4716 call h5tclose_f(dtint1_id,hdf5err)
4717 if(hdf5err.lt.0) then
4718 Status = WRF_HDF5_ERR_CLOSE_GENERAL
4719 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4720 call wrf_debug ( WARN , msg)
4721 return
4722 endif
4724 call h5tclose_f(dtstr_id,hdf5err)
4725 if(hdf5err.lt.0) then
4726 Status = WRF_HDF5_ERR_CLOSE_GENERAL
4727 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4728 call wrf_debug ( WARN , msg)
4729 return
4730 endif
4732 call h5tclose_f(dtint2_id,hdf5err)
4733 if(hdf5err.lt.0) then
4734 Status = WRF_HDF5_ERR_CLOSE_GENERAL
4735 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4736 call wrf_debug ( WARN , msg)
4737 return
4738 endif
4740 call h5tclose_f(dt1_id,hdf5err)
4741 if(hdf5err.lt.0) then
4742 Status = WRF_HDF5_ERR_CLOSE_GENERAL
4743 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4744 call wrf_debug ( WARN , msg)
4745 return
4746 endif
4748 call h5sclose_f(dataspace_id,hdf5err)
4749 if(hdf5err.lt.0) then
4750 Status = WRF_HDF5_ERR_CLOSE_GENERAL
4751 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4752 call wrf_debug ( WARN , msg)
4753 return
4754 endif
4756 call h5dclose_f(dset_id,hdf5err)
4757 if(hdf5err.lt.0) then
4758 Status = WRF_HDF5_ERR_DATASET_CLOSE
4759 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4760 call wrf_debug ( WARN , msg)
4761 return
4762 endif
4764 Status = WRF_NO_ERR
4765 return
4766 end subroutine retrieve_table
4768 ! store(write) the dimensional table into the HDF5 file
4769 subroutine store_table(DataHandle,table_length,Status)
4771 use wrf_phdf5_data
4772 use ext_phdf5_support_routines
4773 use hdf5
4774 implicit none
4775 include 'wrf_status_codes.h'
4777 integer ,intent(in) :: DataHandle
4778 integer, intent(in) :: table_length
4779 integer, intent(out) :: Status
4781 type(wrf_phdf5_data_handle),pointer :: DH
4783 integer(hid_t) :: group_id
4784 integer(hid_t) :: dset_id
4785 integer(hid_t) :: dtype_id
4786 integer(hid_t) :: dtstr_id
4787 integer(hid_t) :: dtstrm_id
4788 integer(hid_t) :: dtint1_id
4789 integer(hid_t) :: dtint2_id
4790 integer(hid_t) :: plist_id
4791 integer(size_t) :: type_size
4792 integer(size_t) :: type_sizes
4793 integer(size_t) :: type_sizei
4794 integer(size_t) :: offset
4795 character*256 ,dimension(MaxTabDims) :: dim_name
4796 integer ,dimension(:),allocatable :: length
4797 integer ,dimension(:),allocatable :: unlimited
4798 integer(hid_t) :: dspace_id
4799 integer(hsize_t) ,dimension(1) :: table_dims
4800 integer :: table_rank
4801 integer(hsize_t) ,dimension(7) :: data_dims
4802 integer :: i,j
4803 integer :: hdf5err
4805 data_dims(1) = table_length
4806 call GetDH(DataHandle,DH,Status)
4807 if(Status /= WRF_NO_ERR) then
4808 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
4809 ', line', __LINE__
4810 call wrf_debug ( WARN , msg)
4811 return
4812 endif
4814 call create_h5filetype(dtype_id,Status)
4815 if(Status /= WRF_NO_ERR) then
4816 return
4817 endif
4819 ! obtain group id
4820 group_id = DH%DimGroupID
4822 ! create data space
4823 table_rank = 1
4824 table_dims(1) = table_length
4826 call h5screate_simple_f(table_rank,table_dims,dspace_id,hdf5err)
4827 if(hdf5err.lt.0) then
4828 Status = WRF_HDF5_ERR_DATASPACE
4829 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4830 call wrf_debug ( WARN , msg)
4831 return
4832 endif
4834 ! obtain the data
4835 allocate(length(table_length))
4836 allocate(unlimited(table_length))
4838 do i =1, table_length
4839 length(i) = DH%DIMTABLE(i)%length
4840 unlimited(i) = DH%DIMTABLE(i)%unlimited
4841 enddo
4843 do i=1,table_length
4844 do j=1,256
4845 dim_name(i)(j:j)=DH%DIMTABLE(i)%dim_name(j:j)
4846 enddo
4847 enddo
4849 ! under dimensional group
4850 call h5dcreate_f(group_id,"h5dim_table",dtype_id,dspace_id,&
4851 dset_id,hdf5err)
4852 if(hdf5err.lt.0) then
4853 Status = WRF_HDF5_ERR_DATASET_CREATE
4854 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4855 call wrf_debug ( WARN , msg)
4856 deallocate(length)
4857 deallocate(unlimited)
4858 return
4859 endif
4861 ! create memory types
4862 call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err)
4863 if(hdf5err.lt.0) then
4864 Status = WRF_HDF5_ERR_DATATYPE
4865 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4866 call wrf_debug ( WARN , msg)
4867 deallocate(length)
4868 deallocate(unlimited)
4869 return
4870 endif
4872 ! FOR string, it needs extra handling
4873 call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err)
4874 if(hdf5err.lt.0) then
4875 Status = WRF_HDF5_ERR_DATATYPE
4876 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4877 call wrf_debug ( WARN , msg)
4878 deallocate(length)
4879 deallocate(unlimited)
4880 return
4881 endif
4883 type_size = 256
4885 call h5tset_size_f(dtstr_id, type_size,hdf5err)
4886 if(hdf5err.lt.0) then
4887 Status = WRF_HDF5_ERR_DATATYPE
4888 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4889 call wrf_debug ( WARN , msg)
4890 deallocate(length)
4891 deallocate(unlimited)
4892 return
4893 endif
4895 call h5tget_size_f(dtstr_id, type_size,hdf5err)
4896 if(hdf5err.lt.0) then
4897 Status = WRF_HDF5_ERR_DATATYPE
4898 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4899 call wrf_debug ( WARN , msg)
4900 deallocate(length)
4901 deallocate(unlimited)
4902 return
4903 endif
4905 call h5tcreate_f(H5T_COMPOUND_F,type_size,dtstrm_id,hdf5err)
4906 if(hdf5err.lt.0) then
4907 Status = WRF_HDF5_ERR_DATATYPE
4908 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4909 call wrf_debug ( WARN , msg)
4910 deallocate(length)
4911 deallocate(unlimited)
4912 return
4913 endif
4915 offset = 0
4916 call h5tinsert_f(dtstrm_id,"dim_name",offset,dtstr_id,hdf5err)
4917 if(hdf5err.lt.0) then
4918 Status = WRF_HDF5_ERR_DATATYPE
4919 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4920 call wrf_debug ( WARN , msg)
4921 deallocate(length)
4922 deallocate(unlimited)
4923 return
4924 endif
4926 call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint1_id,hdf5err)
4927 if(hdf5err.lt.0) then
4928 Status = WRF_HDF5_ERR_DATATYPE
4929 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4930 call wrf_debug ( WARN , msg)
4931 deallocate(length)
4932 deallocate(unlimited)
4933 return
4934 endif
4936 offset = 0
4937 call h5tinsert_f(dtint1_id,"dim_length",offset,H5T_NATIVE_INTEGER,&
4938 hdf5err)
4939 if(hdf5err.lt.0) then
4940 Status = WRF_HDF5_ERR_DATATYPE
4941 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4942 call wrf_debug ( WARN , msg)
4943 deallocate(length)
4944 deallocate(unlimited)
4945 return
4946 endif
4948 call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint2_id,hdf5err)
4949 if(hdf5err.lt.0) then
4950 Status = WRF_HDF5_ERR_DATATYPE
4951 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4952 call wrf_debug ( WARN , msg)
4953 deallocate(length)
4954 deallocate(unlimited)
4955 return
4956 endif
4958 offset = 0
4959 call h5tinsert_f(dtint2_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,&
4960 hdf5err)
4961 if(hdf5err.lt.0) then
4962 Status = WRF_HDF5_ERR_DATATYPE
4963 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4964 call wrf_debug ( WARN , msg)
4965 deallocate(length)
4966 deallocate(unlimited)
4967 return
4968 endif
4970 ! write data by fields in the datatype,but first create a property list
4972 call h5pcreate_f(H5P_DATASET_XFER_F,plist_id, hdf5err)
4973 if(hdf5err.lt.0) then
4974 Status = WRF_HDF5_ERR_PROPERTY_LIST
4975 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4976 call wrf_debug ( WARN , msg)
4977 deallocate(length)
4978 deallocate(unlimited)
4979 return
4980 endif
4982 call h5pset_preserve_f(plist_id,.TRUE.,hdf5err)
4983 if(hdf5err.lt.0) then
4984 Status = WRF_HDF5_ERR_PROPERTY_LIST
4985 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4986 call wrf_debug ( WARN , msg)
4987 deallocate(length)
4988 deallocate(unlimited)
4989 return
4990 endif
4992 call h5dwrite_f(dset_id,dtstrm_id,dim_name,data_dims,hdf5err,&
4993 xfer_prp = plist_id)
4994 if(hdf5err.lt.0) then
4995 Status = WRF_HDF5_ERR_DATASET_WRITE
4996 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
4997 call wrf_debug ( WARN , msg)
4998 deallocate(length)
4999 deallocate(unlimited)
5000 return
5001 endif
5003 call h5dwrite_f(dset_id,dtint1_id,length,data_dims,hdf5err,&
5004 xfer_prp = plist_id)
5005 if(hdf5err.lt.0) then
5006 Status = WRF_HDF5_ERR_DATASET_WRITE
5007 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5008 call wrf_debug ( WARN , msg)
5009 deallocate(length)
5010 deallocate(unlimited)
5011 return
5012 endif
5014 call h5dwrite_f(dset_id,dtint2_id,unlimited,data_dims,hdf5err,&
5015 xfer_prp = plist_id)
5016 if(hdf5err.lt.0) then
5017 Status = WRF_HDF5_ERR_DATASET_WRITE
5018 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5019 call wrf_debug ( WARN , msg)
5020 deallocate(length)
5021 deallocate(unlimited)
5022 return
5023 endif
5025 deallocate(length)
5026 deallocate(unlimited)
5028 ! release resources
5030 call h5tclose_f(dtstr_id,hdf5err)
5031 if(hdf5err.lt.0) then
5032 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5033 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5034 call wrf_debug ( WARN , msg)
5035 return
5036 endif
5038 call h5tclose_f(dtstrm_id,hdf5err)
5039 if(hdf5err.lt.0) then
5040 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5041 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5042 call wrf_debug ( WARN , msg)
5043 return
5044 endif
5046 call h5tclose_f(dtint1_id,hdf5err)
5047 if(hdf5err.lt.0) then
5048 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5049 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5050 call wrf_debug ( WARN , msg)
5051 return
5052 endif
5054 call h5tclose_f(dtint2_id,hdf5err)
5055 if(hdf5err.lt.0) then
5056 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5057 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5058 call wrf_debug ( WARN , msg)
5059 return
5060 endif
5062 call h5tclose_f(dtype_id,hdf5err)
5063 if(hdf5err.lt.0) then
5064 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5065 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5066 call wrf_debug ( WARN , msg)
5067 return
5068 endif
5070 call h5pclose_f(plist_id,hdf5err)
5071 if(hdf5err.lt.0) then
5072 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5073 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5074 call wrf_debug ( WARN , msg)
5075 return
5076 endif
5078 call h5dclose_f(dset_id,hdf5err)
5079 if(hdf5err.lt.0) then
5080 Status = WRF_HDF5_ERR_DATASET_CLOSE
5081 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5082 call wrf_debug ( WARN , msg)
5083 return
5084 endif
5086 call h5sclose_f(dspace_id,hdf5err)
5087 if(hdf5err.lt.0) then
5088 Status = WRF_HDF5_ERR_CLOSE_GENERAL
5089 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5090 call wrf_debug ( WARN , msg)
5091 return
5092 endif
5094 return
5095 end subroutine store_table
5098 subroutine free_memory(DataHandle,Status)
5100 use wrf_phdf5_data
5101 use ext_phdf5_support_routines
5102 use HDF5
5103 implicit none
5104 include 'wrf_status_codes.h'
5105 include 'mpif.h'
5107 integer ,intent(in) :: DataHandle
5108 integer ,intent(out) :: Status
5109 integer :: hdf5err
5110 type(wrf_phdf5_data_handle),pointer :: DH
5111 integer :: i
5112 integer :: stat
5113 real*8 :: timeaw,timebw
5116 call GetDH(DataHandle,DH,Status)
5117 if(Status /= WRF_NO_ERR) then
5118 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5119 call wrf_debug ( WARN , msg)
5120 return
5121 endif
5123 if(DH%Free) then
5124 Status = WRF_HDF5_ERR_OTHERS
5125 write(msg,*) '',__FILE__,', line', __LINE__
5126 call wrf_debug ( WARN , msg)
5127 return
5128 endif
5130 deallocate(DH%Times, STAT=stat)
5131 if(stat/= 0) then
5132 Status = WRF_HDF5_ERR_DEALLOCATION
5133 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5134 call wrf_debug ( FATAL , msg)
5135 return
5136 endif
5137 deallocate(DH%DimLengths, STAT=stat)
5138 if(stat/= 0) then
5139 Status = WRF_HDF5_ERR_DEALLOCATION
5140 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5141 call wrf_debug ( FATAL , msg)
5142 return
5143 endif
5144 deallocate(DH%DimIDs, STAT=stat)
5145 if(stat/= 0) then
5146 Status = WRF_HDF5_ERR_DEALLOCATION
5147 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5148 call wrf_debug ( FATAL , msg)
5149 return
5150 endif
5151 deallocate(DH%DimNames, STAT=stat)
5152 if(stat/= 0) then
5153 Status = WRF_HDF5_ERR_DEALLOCATION
5154 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5155 call wrf_debug ( FATAL , msg)
5156 return
5157 endif
5158 deallocate(DH%DIMTABLE, STAT=stat)
5159 if(stat/= 0) then
5160 Status = WRF_HDF5_ERR_DEALLOCATION
5161 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5162 call wrf_debug ( FATAL , msg)
5163 return
5164 endif
5165 deallocate(DH%MDDsetIDs, STAT=stat)
5166 if(stat/= 0) then
5167 Status = WRF_HDF5_ERR_DEALLOCATION
5168 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5169 call wrf_debug ( FATAL , msg)
5170 return
5171 endif
5172 deallocate(DH%MDVarDimLens, STAT=stat)
5173 if(stat/= 0) then
5174 Status = WRF_HDF5_ERR_DEALLOCATION
5175 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5176 call wrf_debug ( FATAL , msg)
5177 return
5178 endif
5179 deallocate(DH%MDVarNames, STAT=stat)
5180 if(stat/= 0) then
5181 Status = WRF_HDF5_ERR_DEALLOCATION
5182 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5183 call wrf_debug ( FATAL , msg)
5184 return
5185 endif
5186 deallocate(DH%DsetIDs, STAT=stat)
5187 if(stat/= 0) then
5188 Status = WRF_HDF5_ERR_DEALLOCATION
5189 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5190 call wrf_debug ( FATAL , msg)
5191 return
5192 endif
5193 deallocate(DH%VarDimLens, STAT=stat)
5194 if(stat/= 0) then
5195 Status = WRF_HDF5_ERR_DEALLOCATION
5196 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5197 call wrf_debug ( FATAL , msg)
5198 return
5199 endif
5200 deallocate(DH%VarNames, STAT=stat)
5201 if(stat/= 0) then
5202 Status = WRF_HDF5_ERR_DEALLOCATION
5203 write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
5204 call wrf_debug ( FATAL , msg)
5205 return
5206 endif
5207 return
5208 end subroutine free_memory
5210 subroutine write_hdf5_attributes(DataHandle,MemoryOrder,WrfDType,DimRank,&
5211 NDim,dset_id,Status)
5213 use wrf_phdf5_data
5214 use ext_phdf5_support_routines
5215 use HDF5
5216 implicit none
5217 include 'mpif.h'
5218 include 'wrf_status_codes.h'
5221 integer ,intent(in) :: DataHandle
5222 character*(*) ,intent(in) :: MemoryOrder
5223 integer ,intent(in) :: WrfDType
5224 integer,dimension(*) ,intent(in) :: DimRank
5226 integer ,intent(in) :: NDim
5228 integer(hid_t) ,intent(in) :: dset_id
5229 integer ,intent(out) :: Status
5231 character (3) :: Mem0
5232 character (3) :: UCMem0
5233 type(wrf_phdf5_data_handle) ,pointer :: DH
5235 ! attribute defination
5236 integer(hid_t) :: dimaspace_id ! DimRank dataspace id
5237 integer(hid_t) :: dimattr_id ! DimRank attribute id
5238 integer(hsize_t) ,dimension(1) :: dim_space
5240 integer(hid_t) :: h5_atypeid ! for fieldtype,memorder attribute
5241 integer(hid_t) :: h5_aspaceid ! for fieldtype,memorder
5242 integer(hid_t) :: h5_attrid ! for fieldtype,memorder
5243 integer(hsize_t), dimension(7) :: adata_dims
5244 integer :: routine_atype
5245 integer, dimension(:),allocatable :: dimrank_data
5246 integer :: hdf5err
5247 integer :: j
5249 ! For time function
5250 real*8 :: timebw
5251 real*8 :: timeaw
5252 integer :: total_ele
5254 !
5255 ! write dimensional rank attribute. This is the temporary fix for dim. scale
5256 ! the first dimension is always time
5257 allocate(dimrank_data(NDim+1))
5258 do j =1, NDim+1
5259 dimrank_data(j) = DimRank(j)
5260 enddo
5262 dim_space(1) = NDim+1
5263 adata_dims(1) = NDim+1
5264 call h5screate_simple_f(1,dim_space,dimaspace_id,hdf5err)
5265 if(hdf5err.lt.0) then
5266 Status = WRF_HDF5_ERR_DATASPACE
5267 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5268 call wrf_debug ( WARN , msg)
5269 deallocate(dimrank_data)
5270 return
5271 endif
5273 call h5acreate_f(dset_id,'H5_DimRank',H5T_NATIVE_INTEGER,dimaspace_id, &
5274 dimattr_id,hdf5err)
5275 if(hdf5err.lt.0) then
5276 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
5277 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5278 call wrf_debug ( WARN , msg)
5279 deallocate(dimrank_data)
5280 return
5281 endif
5283 call h5awrite_f(dimattr_id,H5T_NATIVE_INTEGER,dimrank_data,adata_dims,hdf5err)
5284 if(hdf5err.lt.0) then
5285 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
5286 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5287 call wrf_debug ( WARN , msg)
5288 deallocate(dimrank_data)
5289 return
5290 endif
5291 deallocate(dimrank_data)
5293 ! close space and attribute id
5294 call clean_phdf5_attrids(H5T_NATIVE_INTEGER,dimaspace_id,dimattr_id,0,Status)
5295 if(Status.ne.WRF_NO_ERR) then
5296 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5297 call wrf_debug ( WARN , msg)
5298 return
5299 endif
5300 ! Write memory order and FieldType attribute, both MemoryOrder and FieldType are 1 element
5301 adata_dims(1) = 1
5303 ! output memoryorder attribute
5304 call reorder(MemoryOrder,Mem0)
5305 call uppercase(Mem0,UCMem0)
5307 routine_atype = WRF_CHARACTER
5309 ! The size of memoryorder string is always MemOrdLen
5310 call create_phdf5_adtypeid(h5_atypeid,routine_atype,MemOrdLen,Status)
5311 if(Status.ne.WRF_NO_ERR) then
5312 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5313 call wrf_debug ( WARN , msg)
5314 return
5315 endif
5317 ! Count for string attribute is always 1
5318 call create_phdf5_adspaceid(1,1,h5_aspaceid,Status)
5319 if(Status.ne.WRF_NO_ERR) then
5320 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5321 call wrf_debug ( WARN , msg)
5322 return
5323 endif
5324 call h5acreate_f(dset_id,'MemoryOrder',h5_atypeid,h5_aspaceid, &
5325 h5_attrid, hdf5err)
5326 if(hdf5err.lt.0) then
5327 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
5328 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5329 call wrf_debug ( WARN , msg)
5330 return
5331 endif
5333 call h5awrite_f(h5_attrid,h5_atypeid,UCMem0,adata_dims,hdf5err)
5334 if(hdf5err.lt.0) then
5335 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
5336 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5337 call wrf_debug ( WARN , msg)
5338 return
5339 endif
5340 call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,1,Status)
5341 if(Status.ne.WRF_NO_ERR) then
5342 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5343 call wrf_debug ( WARN , msg)
5344 return
5345 endif
5347 ! output fieldtype attribute
5348 call create_phdf5_adspaceid(1,1,h5_aspaceid,Status)
5349 if(Status.ne.WRF_NO_ERR) then
5350 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5351 call wrf_debug ( WARN , msg)
5352 return
5353 endif
5355 call h5acreate_f(dset_id,'FieldType',H5T_NATIVE_INTEGER,h5_aspaceid, &
5356 h5_attrid, hdf5err)
5357 if(hdf5err.lt.0) then
5358 Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
5359 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5360 call wrf_debug ( WARN , msg)
5361 return
5362 endif
5364 call h5awrite_f(h5_attrid,H5T_NATIVE_INTEGER,WrfDType,adata_dims,hdf5err)
5365 if(hdf5err.lt.0) then
5366 Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
5367 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5368 call wrf_debug ( WARN , msg)
5369 return
5370 endif
5371 call clean_phdf5_attrids(H5T_NATIVE_INTEGER,h5_aspaceid,h5_attrid,0,Status)
5372 if(Status.ne.WRF_NO_ERR) then
5373 write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
5374 call wrf_debug ( WARN , msg)
5375 return
5376 endif
5378 end subroutine write_hdf5_attributes