!/***************************************************************************
!* The HDF5 WRF IO module was written by the the HDF Group at NCSA, the *
!* National Center for Supercomputing Applications. *
!* HDF Group *
!* National Center for Supercomputing Applications *
!* University of Illinois at Urbana-Champaign *
!* 605 E. Springfield, Champaign IL 61820 *
!* http://hdf.ncsa.uiuc.edu/ *
!* *
!* Copyright 2004 by the Board of Trustees, University of Illinois, *
!* *
!* Redistribution or use of this IO module, with or without modification, *
!* is permitted for any purpose, including commercial purposes. *
!* *
!* This software is an unsupported prototype. Use at your own risk. *
!* http://hdf.ncsa.uiuc.edu/apps/WRF-ROMS *
!* *
!* This work was funded by the MEAD expedition at the National Center *
!* for Supercomputing Applications, NCSA. For more information see: *
!* http://www.ncsa.uiuc.edu/expeditions/MEAD *
!* *
!* *
!****************************************************************************/
subroutine HDF5IOWRITE(DataHandle,Comm,DateStr,Length,DomainStart,DomainEnd & 2,9
,PatchStart,PatchEnd,MemoryOrder &
,WrfDType,FieldType,groupID,TimeIndex &
,DimRank ,DatasetName,XField,Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'mpif.h'
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
integer ,intent(inout) :: Comm
character*(*) ,intent(in) :: DateStr
integer,dimension(NVarDims) ,intent(in) :: Length
integer,dimension(NVarDims) ,intent(in) :: DomainStart
integer,dimension(NVarDims) ,intent(in) :: DomainEnd
integer,dimension(NVarDims) ,intent(in) :: PatchStart
integer,dimension(NVarDims) ,intent(in) :: PatchEnd
character*(*) ,intent(in) :: MemoryOrder
integer ,intent(in) :: WrfDType
integer(hid_t) ,intent(in) :: FieldType
integer(hid_t) ,intent(in) :: groupID
integer ,intent(in) :: TimeIndex
integer,dimension(*) ,intent(in) :: DimRank
character (*) ,intent(in) :: DatasetName
integer,dimension(*) ,intent(inout) :: XField
integer ,intent(out) :: Status
integer(hid_t) :: dset_id
integer :: NDim
integer,dimension(NVarDims) :: VStart
integer,dimension(NVarDims) :: VCount
character (3) :: Mem0
character (3) :: UCMem0
type(wrf_phdf5_data_handle) ,pointer :: DH
! attribute defination
integer(hid_t) :: dimaspace_id ! DimRank dataspace id
integer(hid_t) :: dimattr_id ! DimRank attribute id
integer(hsize_t) ,dimension(1) :: dim_space
INTEGER(HID_T) :: dspace_id ! Raw Data memory Dataspace id
INTEGER(HID_T) :: fspace_id ! Raw Data file Dataspace id
INTEGER(HID_T) :: crp_list ! chunk identifier
integer(hid_t) :: h5_atypeid ! for fieldtype,memorder attribute
integer(hid_t) :: h5_aspaceid ! for fieldtype,memorder
integer(hid_t) :: h5_attrid ! for fieldtype,memorder
integer(hsize_t), dimension(7) :: adata_dims
integer :: routine_atype
integer, dimension(:),allocatable :: dimrank_data
INTEGER(HSIZE_T), dimension(:),allocatable :: dims ! Dataset dimensions
INTEGER(HSIZE_T), dimension(:),allocatable :: sizes ! Dataset dimensions
INTEGER(HSIZE_T), dimension(:),allocatable :: chunk_dims
INTEGER(HSIZE_T), dimension(:),allocatable :: hdf5_maxdims
INTEGER(HSIZE_T), dimension(:),allocatable :: offset
INTEGER(HSIZE_T), dimension(:),allocatable :: count
INTEGER(HSIZE_T), DIMENSION(7) :: dimsfi
integer :: hdf5err
integer :: i,j
integer(size_t) :: dsetsize
! FOR PARALLEL IO
integer(hid_t) :: xfer_list
logical :: no_par
! INTEGER :: myproc
!
! CALL mpi_comm_rank( MPI_COMM_WORLD, myproc, Status )
! get the handle
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! get the rank of the dimension
call GetDim(MemoryOrder,NDim,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! If patch is equal to domain, the parallel is not necessary, sequential is used.
! In this version, we haven't implemented this yet.
! We use no_par to check whether we can use compact data storage.
no_par = .TRUE.
do i = 1,NDim
if((PatchStart(i)/=DomainStart(i)).or.(PatchEnd(i)/=DomainEnd(i))) then
no_par = .FALSE.
exit
endif
enddo
! change the different Memory Order to XYZ for patch and domain
if(MemoryOrder.NE.'0') then
call ExtOrder(MemoryOrder,PatchStart,Status)
call ExtOrder(MemoryOrder,PatchEnd,Status)
call ExtOrder(MemoryOrder,DomainStart,Status)
call ExtOrder(MemoryOrder,DomainEnd,Status)
endif
! allocating memory for dynamic arrays;
! since the time step is always 1, we may ignore the fourth
! dimension time; now keep it to make it consistent with sequential version
allocate(dims(NDim+1))
allocate(count(NDim+1))
allocate(offset(NDim+1))
allocate(sizes(NDim+1))
! arrange offset, count for each hyperslab
dims(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1
dims(NDim+1) = 1
count(NDim+1) = 1
count(1:NDim) = Length(1:NDim)
offset(NDim+1) = 0
offset(1:NDim) = PatchStart(1:NDim) - 1
! IF (myproc == 1) count(:) = 0
! allocate the dataspace to write hyperslab data
dimsfi = 0
do i = 1, NDim + 1
dimsfi(i) = count(i)
enddo
! create the memory space id
call h5screate_simple_f(NDim+1,count,dspace_id,hdf5err,count)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
! create file space
call h5screate_simple_f(NDim+1,dims,fspace_id,hdf5err,dims)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
! compact storage when the patch is equal to the whole domain
! calculate the non-decomposed dataset size
call h5tget_size_f(FieldType,dsetsize,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
do i =1,NDim
dsetsize = dsetsize*dims(i)
enddo
if(no_par.and.(dsetsize.le.CompDsetSize)) then
call h5pcreate_f(H5P_DATASET_CREATE_F,crp_list,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
call h5pset_layout_f(crp_list,0,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
call h5dcreate_f(DH%TgroupIDs(TimeIndex),DatasetName,FieldType,fspace_id,dset_id,&
hdf5err,crp_list)
call h5pclose_f(crp_list,hdf5err)
else
call h5dcreate_f(DH%TgroupIDs(TimeIndex),DatasetName,FieldType,fspace_id,dset_id,hdf5err)
endif
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
! select the correct hyperslab for file space id
CALL h5sselect_hyperslab_f(fspace_id, H5S_SELECT_SET_F, offset, count &
,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
! Create property list for collective dataset write
CALL h5pcreate_f(H5P_DATASET_XFER_F, xfer_list, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
CALL h5pset_dxpl_mpio_f(xfer_list, H5FD_MPIO_COLLECTIVE_F&
,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
! write the data in memory space to file space
CALL h5dwrite_f(dset_id,FieldType,XField,dimsfi,hdf5err,&
mem_space_id =dspace_id,file_space_id =fspace_id, &
xfer_prp = xfer_list)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
CALL h5pclose_f(xfer_list,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
if(TimeIndex == 1) then
do i =1, MaxVars
if(DH%dsetids(i) == -1) then
DH%dsetids(i) = dset_id
DH%VarNames(i) = DataSetName
exit
endif
enddo
! Only writing attributes when TimeIndex ==1
call write_hdf5_attributes(DataHandle,MemoryOrder,WrfDType,DimRank,&
NDim,dset_id,Status)
endif
call h5sclose_f(fspace_id,hdf5err)
call h5sclose_f(dspace_id,hdf5err)
if(TimeIndex /= 1) then
call h5dclose_f(dset_id,hdf5err)
endif
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dims)
deallocate(count)
deallocate(offset)
deallocate(sizes)
return
endif
Status = WRF_NO_ERR
return
end subroutine HDF5IOWRITE
subroutine ext_phdf5_ioinit(SysDepInfo, Status) 2,1
use wrf_phdf5_data
use HDF5
implicit none
include 'wrf_status_codes.h'
include 'mpif.h'
CHARACTER*(*), INTENT(IN) :: SysDepInfo
integer, intent(out) :: status
integer :: hdf5err
! set up some variables inside the derived type
WrfDataHandles(1:WrfDataHandleMax)%Free = .true.
! ?
WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times'
WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time'
! set up HDF5 global variables
call h5open_f(hdf5err)
if(hdf5err .lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_ioinit
subroutine ext_phdf5_ioclose( DataHandle, Status) 2,5
use wrf_phdf5_data
use ext_phdf5_support_routines
use hdf5
implicit none
include 'wrf_status_codes.h'
include 'mpif.h'
integer ,intent(in) :: DataHandle
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: stat
integer :: NVar
integer :: hdferr
integer :: table_length
integer :: i
integer(hid_t) :: dtype_id
integer :: obj_count
integer(hid_t),allocatable,dimension(:) :: obj_ids
character(len=100) :: buf
integer(size_t) :: name_size
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', 906
call wrf_debug ( WARN , msg)
return
endif
! THE FOLLOWING section writes dimscale information to the data set,may be put into a subroutine
! check the file status, should be either open_for_read or opened_and_committed
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_HDF5_ERR_FILE_OPEN
write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_HDF5_ERR_DRYRUN_CLOSE
write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
! Handle dim. scale
! STORE "Times" as the first element of the dimensional table
DH%DIMTABLE(1)%dim_name = 'Time'
DH%DIMTABLE(1)%Length = DH%TimeIndex
DH%DIMTABLE(1)%unlimited = 1
do i =1,MaxTabDims
if(DH%DIMTABLE(i)%dim_name== NO_NAME) then
exit
endif
enddo
table_length = i-1
call store_table(DataHandle,table_length,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
continue
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! call h5dclose_f(DH%TimesID,hdferr)
! if(hdferr.lt.0) then
! Status = WRF_HDF5_ERR_DATASET_CLOSE
! write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
! call wrf_debug ( WARN , msg)
! return
! endif
continue
else
Status = WRF_HDF5_ERR_BAD_FILE_STATUS
write(msg,*) 'Fatal hdf5err BAD FILE STATUS in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
! close HDF5 APIs
do NVar = 1, MaxVars
if(DH%DsetIDs(NVar) /= -1) then
call h5dclose_f(DH%DsetIDs(NVar),hdferr)
if(hdferr .ne. 0) then
Status = WRF_HDF5_ERR_DATASET_CLOSE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
endif
enddo
do i = 1, MaxTimes
if(DH%TgroupIDs(i) /= -1) then
call h5gclose_f(DH%TgroupIDs(i),hdferr)
if(hdferr .ne. 0) then
Status = WRF_HDF5_ERR_DATASET_CLOSE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
endif
enddo
call h5gclose_f(DH%GroupID,hdferr)
if(hdferr .ne. 0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5gclose_f(DH%DimGroupID,hdferr)
if(hdferr .ne. 0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(Status /= WRF_NO_ERR) then
write(msg,*) 'HDF5 IO CLOSE error in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5fclose_f(DH%FileID,hdferr)
if(hdferr .ne. 0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(Status /= WRF_NO_ERR) then
write(msg,*) 'HDF5 IO CLOSE error in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call free_memory(DataHandle,Status)
if(Status /= WRF_NO_ERR) then
Status = WRF_HDF5_ERR_OTHERS
write(msg,*) 'Warning Status = ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
DH%Free=.true.
return
end subroutine ext_phdf5_ioclose
subroutine ext_phdf5_ioexit(Status) 2,3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
include 'mpif.h'
integer ,intent(out) :: Status
integer :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
integer :: i
integer :: stat
! free memories
do i=1,WrfDataHandleMax
if(.not.WrfDataHandles(i)%Free) then
call free_memory(i,Status)
exit
endif
enddo
if(Status /= WRF_NO_ERR) then
write(msg,*) 'free resources error in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
CALL h5close_f(hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
return
end subroutine ext_phdf5_ioexit
!! This routine will set up everything to read HDF5 files
subroutine ext_phdf5_open_for_read(FileName,Comm,iocomm,SysDepInfo,DataHandle,Status) 1,5
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'mpif.h'
include 'wrf_status_codes.h'
character*(*),intent(in) :: FileName
integer ,intent(in) :: Comm
integer ,intent(in) :: iocomm
character*(*),intent(in) :: SysDepInfo
integer ,intent(out) :: DataHandle
type(wrf_phdf5_data_handle),pointer :: DH
integer ,intent(out) :: Status
integer(hid_t) :: Fileid
integer(hid_t) :: tgroupid
integer(hid_t) :: dsetid
integer(hid_t) :: dspaceid
integer(hid_t) :: dtypeid
integer(hid_t) :: acc_plist
integer :: nmembers
integer :: submembers
integer :: tmembers
integer :: ObjType
character(len= 256) :: ObjName
character(len= 256) :: GroupName
integer :: i,j
integer(hsize_t), dimension(7) :: data_dims
integer(hsize_t), dimension(1) :: h5dims
integer(hsize_t), dimension(1) :: h5maxdims
integer :: StoredDim
integer :: NumVars
integer :: hdf5err
integer :: info,mpi_size,mpi_rank
character(Len = MaxTimeSLen) :: tname
character(Len = 512) :: tgroupname
! Allocating the data handle
call allocHandle(DataHandle,DH,Comm,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5pcreate_f(H5P_FILE_ACCESS_F,acc_plist,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
info = MPI_INFO_NULL
CALL h5pset_fapl_mpio_f(acc_plist, comm, info, hdf5err)
! call h5pset_fapl_mpiposix_f(acc_plist,comm,.false.,hdf5err)
if(hdf5err .lt. 0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
!close every objects when closing HDF5 file.
call h5pset_fclose_degree_f(acc_plist,H5F_CLOSE_STRONG_F,hdf5err)
if(hdf5err .lt. 0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Open the file
call h5fopen_f(FileName,H5F_ACC_RDWR_F,Fileid,hdf5err &
,acc_plist)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_FILE_OPEN
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5pclose_f(acc_plist,hdf5err)
if(hdf5err .lt. 0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Obtain the number of group
DH%FileID = Fileid
call h5gn_members_f(Fileid,"/",nmembers,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Retrieve group id and dimensional group id, the index must be from 0
do i = 0, nmembers - 1
call h5gget_obj_info_idx_f(Fileid,"/",i,ObjName,ObjType,&
hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(ObjName=='DIM_GROUP') then
call h5gopen_f(Fileid,"/DIM_GROUP",DH%DimGroupID,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! For WRF model, the first seven character must be DATASET
else if(ObjName(1:7)=='DATASET')then
GroupName="/"//ObjName
call h5gopen_f(Fileid,GroupName,DH%GroupID,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5gn_members_f(FileID,GroupName,submembers,Status)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
do j = 0, submembers -1
call h5gget_obj_info_idx_f(Fileid,GroupName,j,ObjName,ObjType,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call numtochar(j+1,tname)
tgroupname = 'TIME_STAMP_'//tname
if(ObjName(1:17)==tgroupname) then
call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5gn_members_f(DH%GroupID,tgroupname,tmembers,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dopen_f(tgroupid,"Times",dsetid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_OPEN
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dget_space_f(dsetid,dspaceid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sget_simple_extent_ndims_f(dspaceid,StoredDim,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sget_simple_extent_dims_f(dspaceid,h5dims,h5maxdims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
data_dims(1) = h5dims(1)
call h5dget_type_f(dsetid,dtypeid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dread_f(dsetid,dtypeid,DH%Times(j+1),data_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
DH%CurrentVariable = 0
DH%CurrentTime = 0
DH%TimeIndex = 0
call h5tclose_f(dtypeid,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
endif
enddo
DH%NumberTimes = submembers
! the total member of HDF5 dataset.
DH%NumVars = tmembers*submembers
else
Status = WRF_HDF5_ERR_OTHERS
endif
enddo
DH%FileStatus = WRF_FILE_OPENED_FOR_READ
DH%FileName = FileName
! obtain dimensional scale table
call retrieve_table(DataHandle,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_open_for_read
subroutine ext_phdf5_inquire_opened(DataHandle,FileName,FileStatus,Status),3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: FileName
integer ,intent(out) :: FileStatus
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
FileStatus = WRF_FILE_NOT_OPENED
return
endif
if(FileName /= DH%FileName) then
FileStatus = WRF_FILE_NOT_OPENED
else
FileStatus = DH%FileStatus
endif
Status = WRF_NO_ERR
return
end subroutine ext_phdf5_inquire_opened
subroutine ext_phdf5_inquire_filename(DataHandle,FileName,FileStatus,Status) 2,3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(out) :: FileName
integer ,intent(out) :: FileStatus
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
! This line is added to make sure the wrong file will not be opened
FileStatus = WRF_FILE_NOT_OPENED
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,',line',__LINE__
call wrf_debug (WARN, msg)
return
endif
FileName = DH%FileName
FileStatus = DH%FileStatus
Status = WRF_NO_ERR
return
end subroutine ext_phdf5_inquire_filename
! The real routine to read HDF5 files
subroutine ext_phdf5_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, & 1,12
IOComm, DomainDesc, MemoryOrder, Stagger, DimNames, &
DomainStart,DomainEnd,MemoryStart,MemoryEnd, &
PatchStart,PatchEnd,Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
integer ,intent(out) :: Field(*)
integer ,intent(in) :: FieldType
integer ,intent(inout) :: Comm
integer ,intent(inout) :: IOComm
integer ,intent(in) :: DomainDesc
character*(*) ,intent(in) :: MemoryOrder
character*(*) ,intent(in) :: Stagger ! Dummy for now
character*(*) , dimension (*) ,intent(in) :: DimNames
integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
integer :: NDim
integer(hid_t) :: GroupID
character (VarNameLen) :: VarName
integer ,dimension(NVarDims) :: Length
integer ,dimension(NVarDims) :: StoredStart
integer ,dimension(NVarDims) :: StoredLen
integer, dimension(NVarDims) :: TemDataStart
integer ,dimension(:,:,:,:) ,allocatable :: XField
integer :: NVar
integer :: j
integer :: i1,i2,j1,j2,k1,k2
integer :: x1,x2,y1,y2,z1,z2
integer :: l1,l2,m1,m2,n1,n2
character (VarNameLen) :: Name
integer :: XType
integer :: StoredDim
integer :: NAtts
integer :: Len
integer :: stat
integer :: di
integer :: FType
integer(hsize_t),dimension(7) :: data_dims
integer(hsize_t),dimension(:) ,allocatable :: h5_dims
integer(hsize_t),dimension(:) ,allocatable :: h5_maxdims
integer(hsize_t),dimension(:) ,allocatable :: DataStart
integer(hsize_t),dimension(:) ,allocatable :: Datacount
integer(hid_t) :: tgroupid
integer(hid_t) :: dsetid
integer(hid_t) :: dtype_id
integer(hid_t) :: dmemtype_id
integer(hid_t) :: dspace_id
integer(hid_t) :: memspace_id
integer :: class_type
integer :: TimeIndex
logical :: flag
integer :: hdf5err
character(Len = MaxTimeSLen) :: tname
character(Len = 512) :: tgroupname
! FOR PARALLEL IO
integer :: mpi_rank
integer(hid_t) :: xfer_list
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_HDF5_ERR_FILE_NOT_OPENED
write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_HDF5_ERR_DRYRUN_READ
write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
Status = WRF_HDF5_ERR_READ_WONLY_FILE
write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! obtain TimeIndex
call GetDataTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
! obtain the absolute name of the group where the dataset is located
call numtochar(TimeIndex,tname)
tgroupname = 'TIME_STAMP_'//tname
call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dopen_f(tgroupid,Var,dsetid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_OPEN
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Obtain the memory datatype
select case(FieldType)
case (WRF_REAL)
dmemtype_id = H5T_NATIVE_REAL
case (WRF_DOUBLE)
dmemtype_id = H5T_NATIVE_DOUBLE
case (WRF_INTEGER)
dmemtype_id = H5T_NATIVE_INTEGER
case (WRF_LOGICAL)
dmemtype_id = DH%EnumID
case default
Status = WRF_HDF5_ERR_DATA_TYPE_NOTFOUND
write(msg,*) 'Warning BAD Memory Data type in ',__FILE__,',line',__LINE__
call wrf_debug(WARN,msg)
return
end select
! Obtain the datatype
call h5dget_type_f(dsetid,dtype_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! double check whether the Fieldtype is the type of the dataset
! we may do the force coercion between real and double
call h5tget_class_f(dtype_id,class_type,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then
if ( class_type /= H5T_FLOAT_F) then
Status = WRF_HDF5_ERR_TYPE_MISMATCH
write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
else if(FieldType == WRF_CHARACTER) then
if(class_type /= H5T_STRING_F) then
Status = WRF_HDF5_ERR_TYPE_MISMATCH
write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
else if(FieldType == WRF_INTEGER) then
if(class_type /= H5T_INTEGER_F) then
Status = WRF_HDF5_ERR_TYPE_MISMATCH
write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
else if(FieldType == WRF_LOGICAL) then
if(class_type /= H5T_ENUM_F) then
Status = WRF_HDF5_ERR_TYPE_MISMATCH
write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tequal_f(dtype_id,DH%EnumID,flag,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_OPEN
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(flag .EQV. .FALSE.) then
Status = WRF_HDF5_ERR_TYPE_MISMATCH
write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
else
Status = WRF_HDF5_ERR_BAD_DATA_TYPE
write(msg,*)'Fatal Non-WRF supported TYPE in ',__FILE__,', line',__LINE__
call wrf_debug(FATAL, msg)
return
endif
! Obtain the dataspace, check whether the dataspace is within the range
! transpose the memory order to the disk order
call h5dget_space_f(dsetid,dspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call GetDim(MemoryOrder,NDim,Status)
Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
call ExtOrder(MemoryOrder,Length,Status)
! Obtain the rank of the dimension
call h5sget_simple_extent_ndims_f(dspace_id,StoredDim,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! From NetCDF implementation, only do error handling
if((NDim+1) /= StoredDim) then
Status = WRF_HDF5_ERR_BAD_VARIABLE_DIM
write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
allocate(h5_dims(StoredDim))
allocate(h5_maxdims(StoredDim))
allocate(DataStart(StoredDim))
allocate(DataCount(StoredDim))
call h5sget_simple_extent_dims_f(dspace_id,h5_dims,h5_maxdims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! This part of code needs to be adjusted, currently use NetCDF convention
do j = 1, NDim
if(Length(j) > h5_dims(j)) then
Status = WRF_HDF5_ERR_READ_PAST_EOF
write(msg,*) 'Warning READ PAST EOF in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
elseif(Length(j) <= 0) then
Status = WRF_HDF5_ERR_ZERO_LENGTH_READ
write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
enddo
! create memspace_id
data_dims(1:NDim) = Length(1:NDim)
data_dims(NDim+1) = 1
call h5screate_simple_f(NDim+1,data_dims,memspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! DataStart can start from PatchStart.
TEMDataStart(1:NDim) = PatchStart(1:NDim)-1
if(MemoryOrder.NE.'0') then
call ExtOrder(MemoryOrder,TEMDataStart,Status)
endif
DataStart(1:NDim) = TEMDataStart(1:NDim)
DataStart(NDim+1) = 0
DataCount(1:NDim) = Length(1:NDim)
DataCount(NDim+1) = 1
! transpose the data XField to Field
call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
StoredStart = 1
StoredLen(1:NDim) = Length(1:NDim)
! the dimensional information inside the disk may be greater than
! the dimension(PatchEnd-PatchStart); here we can speed up
! the performance by using hyperslab selection
call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2)
call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2)
! di is for double type data
di = 1
if(FieldType == WRF_DOUBLE) di = 2
allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
! use hyperslab to only read this current timestamp
call h5sselect_hyperslab_f(dspace_id,H5S_SELECT_SET_F, &
DataStart,DataCount,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! read the data in this time stamp
call h5dread_f(dsetid,dmemtype_id,XField,data_dims,hdf5err, &
memspace_id,dspace_id,H5P_DEFAULT_F)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
,XField,x1,x2,y1,y2,z1,z2 &
,i1,i2,j1,j2,k1,k2 )
deallocate(XField, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
call h5dclose_f(dsetid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_CLOSE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
deallocate(h5_dims)
deallocate(h5_maxdims)
deallocate(DataStart)
deallocate(DataCount)
else
Status = WRF_HDF5_ERR_BAD_FILE_STATUS
write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
endif
DH%first_operation = .FALSE.
return
end subroutine ext_phdf5_read_field
!! This routine essentially sets up everything to write HDF5 files
SUBROUTINE ext_phdf5_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status) 1,3
use wrf_phdf5_data
use HDF5
use ext_phdf5_support_routines
implicit none
include 'mpif.h'
include 'wrf_status_codes.h'
character*(*) ,intent(in) :: FileName
integer ,intent(in) :: Comm
integer ,intent(in) :: IOComm
character*(*) ,intent(in) :: SysDepInfo
integer ,intent(out) :: DataHandle
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer(hid_t) :: file5_id
integer(hid_t) :: g_id
integer(hid_t) :: gdim_id
integer :: hdferr
integer :: i
integer :: stat
character (7) :: Buffer
integer :: VDimIDs(2)
character(Len = 512) :: groupname
! For parallel IO
integer(hid_t) :: plist_id
integer :: hdf5_comm,info,mpi_size,mpi_rank
call allocHandle(DataHandle,DH,Comm,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
DH%TimeIndex = 0
DH%Times = ZeroDate
CALL h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr)
if(hdferr .lt. 0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
info = MPI_INFO_NULL
CALL h5pset_fapl_mpio_f(plist_id, comm, info, hdferr)
if(hdferr .lt. 0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5fcreate_f(FileName,H5F_ACC_TRUNC_F,file5_id,hdferr &
,access_prp = plist_id)
if(hdferr .lt. 0) then
Status = WRF_HDF5_ERR_FILE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5pclose_f(plist_id,hdferr)
if(hdferr .lt. 0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
DH%FileName = FileName
! should add a check to see whether the file opened has been used by previous handles
DH%VarNames (1:MaxVars) = NO_NAME
DH%MDVarNames(1:MaxVars) = NO_NAME
! group name information is stored at SysDepInfo
groupname = "/"//SysDepInfo
! write(*,*) "groupname ",groupname
call h5gcreate_f(file5_id,groupname,g_id,hdferr)
if(hdferr .lt. 0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! create dimensional group id
call h5gcreate_f(file5_id,"/DIM_GROUP",gdim_id,hdferr)
if(hdferr .lt. 0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
DH%FileID = file5_id
DH%GroupID = g_id
DH%DIMGroupID = gdim_id
return
end subroutine ext_phdf5_open_for_write_begin
! HDF5 doesnot need this stage, basically this routine
! just updates the File status.
SUBROUTINE ext_phdf5_open_for_write_commit(DataHandle, Status) 1,3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer(hid_t) :: enum_type
integer :: i
integer :: stat
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
DH%FileStatus = WRF_FILE_OPENED_AND_COMMITTED
DH%first_operation = .TRUE.
return
end subroutine ext_phdf5_open_for_write_commit
! The real routine to write HDF5 file
subroutine ext_phdf5_write_field(DataHandle,DateStr,Var,Field,FieldType,& 1,15
Comm,IOComm,DomainDesc,MemoryOrder, &
Stagger,DimNames,DomainStart,DomainEnd,&
MemoryStart,MemoryEnd,PatchStart,PatchEnd,&
Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
integer ,intent(inout) :: Field(*)
integer ,intent(in) :: FieldType
integer ,intent(inout) :: Comm
integer ,intent(inout) :: IOComm
integer ,intent(in) :: DomainDesc
character*(*) ,intent(in) :: MemoryOrder
character*(*) ,intent(in) :: Stagger ! Dummy for now
character*(*) , dimension (*) ,intent(in) :: DimNames
integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
integer(hid_t) :: GroupID
integer :: NDim
character (VarNameLen) :: VarName
character (3) :: MemO
character (3) :: UCMemO
integer(hid_t) :: DsetID
integer ,dimension(NVarDims) :: Length
integer ,dimension(NVarDims) :: DomLength
integer ,dimension(NVarDims+1) :: DimRank
character(256),dimension(NVarDims) :: RODimNames
integer ,dimension(NVarDims) :: StoredStart
integer ,dimension(:,:,:,:),allocatable :: XField
integer ,dimension(:,:,:,:),allocatable :: BUFFER! for logical field
integer :: stat
integer :: NVar
integer :: i,j,k,m,dim_flag
integer :: i1,i2,j1,j2,k1,k2
integer :: x1,x2,y1,y2,z1,z2
integer :: l1,l2,m1,m2,n1,n2
integer(hid_t) :: XType
integer :: di
character (256) :: NullName
integer :: TimeIndex
integer ,dimension(NVarDims+1) :: temprank
logical :: NotFound
NullName = char(0)
dim_flag = 0
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Examine here, Nov. 7th, 2003
if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
! obtain group id and initialize the rank of dimensional attributes
GroupID = DH%GroupID
DimRank = -1
! get the rank of the dimension based on MemoryOrder string(cleaver from NetCDF)
call GetDim(MemoryOrder,NDim,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! get the dataset name and dimensional information of the data
VarName = Var
Length(1:NDim) = PatchEnd(1:NDim) - PatchStart(1:NDim) + 1
DomLength(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1
! Transposing the data order and dim. string order, store to RODimNames
call ExtOrder(MemoryOrder,Length,Status)
call ExtOrder(MemoryOrder,DomLength,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Map datatype from WRF to HDF5
select case (FieldType)
case (WRF_REAL)
XType = H5T_NATIVE_REAL
case (WRF_DOUBLE)
Xtype = H5T_NATIVE_DOUBLE
case (WRF_INTEGER)
XType = H5T_NATIVE_INTEGER
case (WRF_LOGICAL)
XType = DH%EnumID
case default
Status = WRF_HDF5_ERR_DATA_TYPE_NOTFOUND
return
end select
! HANDLE with dim. scale
! handle dimensional scale data; search and store them in a table.
! The table is one dimensional array of compound data type. One member of
! the type is HDF5 string, representing the name of the dim(west_east_stag eg.)
! Another number is the length of the dimension(west_east_stag = 31)
! In this part, we will not store TIME but leave it at the end since the time
! index won't be known until the end of the run; since all fields(HDF5 datasets)
! have the same timestamp, writing it once should be fine.
! 1) create a loop for dimensions
call GetDataTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
if(TimeIndex == 1) then
! 2) get the dim. name, the first dim. is reserved for time,
call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning BAD MEMORY ORDER in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! 3) get the dim. length
! 4) inside the loop, search the table for dimensional name( table module)
! IF FOUND, go to the next dimension, return the table dimensional rank
! (For example, find west_east_stag in the table, the rank of "west_east_stag"
! is 3; so return 3 for the array dimrank.)
! in the table; so through the table, we can find the information
! such as names, length of this dimension
! 4.1) save the rank into an array for attribute
! if not found, go to 5)
! 4)' the first dimension is reserved for time, so table starts from j = 2
!
! 5) NOT FOUND, inside the loop add the new dimensional information to the
! table(table module)
! The first dimension of the field is always "time" and "time"
! is also the first dimension of the "table".
k = 2
DimRank(1) = 1
do i = 1,NDim
do j = 2,MaxTabDims
! Search for the table and see if we are at the end of the table
if (DH%DIMTABLE(j)%dim_name == NO_NAME) then
! Sometimes the RODimNames is NULLName or ''. If that happens,
! we will search the table from the beginning and see
! whether the name is FAKEDIM(the default name) and the
! current length of the dim. is the same as that of FAKEDIM;
! if yes, use this FAKEDIM for the current field dim.
if(RODimNames(i) ==''.or. RODimNames(i)==NullName) then
do m = 2,j
if(DomLength(i)==DH%DIMTABLE(m)%Length.and. &
DH%DIMTABLE(m)%dim_name(1:7)=='FAKEDIM')then
DimRank(k) = m
k = k + 1
dim_flag = 1
exit
endif
enddo
! No FAKEDIM and the same length dim. is found,
! Add another dimension "FAKEDIM + j", with the length
! as DomLength(i)
if (dim_flag == 1) then
dim_flag = 0
else
RODimNames(i) = 'FAKEDIM'//achar(j+iachar('0'))
DH%DIMTABLE(j)%dim_name = RODimNames(i)
DH%DIMTABLE(j)%length = DomLength(i)
DimRank(k) = j
k = k + 1
endif
! no '' or NULLName is found, then assign this RODimNames
! to the dim. table.
else
DH%DIMTABLE(j)%dim_name = RODimNames(i)
DH%DIMTABLE(j)%length = DomLength(i)
DimRank(k) = j
k = k + 1
endif
exit
! If we found the current dim. in the table already,save the rank
else if(DH%DIMTABLE(j)%dim_name == RODimNames(i)) then
! remember the rank of dimensional scale
DimRank(k) = j
k = k + 1
exit
else
continue
endif
enddo
enddo
endif ! end of timeindex of 1
! 6) create an attribute array called DimRank to store the rank of the attribute.
! This will be done in the HDF5IOWRITE routine
! 7) before the end of the run, 1) update time, 2) write the table to HDF5.
! get the index of l1,.......for writing HDF5 file.
StoredStart = 1
call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2)
call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
di=1
if(FieldType == WRF_DOUBLE) di = 2
allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
if(stat/= 0) then
Status = WRF_ERR_FATAL_ALLOCATION_ERROR
write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
call wrf_debug ( FATAL , msg)
return
endif
! Transpose the real data for tools people
call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
,XField,x1,x2,y1,y2,z1,z2 &
,i1,i2,j1,j2,k1,k2 )
! handle with logical data separately,because of not able to
! map Fortran Logical type to C type
if(FieldType .eq. WRF_LOGICAL) then
allocate(BUFFER(di,x1:x2,y1:y2,z1:z2), STAT=stat)
do k =z1,z2
do j = y1,y2
do i = x1,x2
do m = 1,di
if(XField(m,i,j,k)/= 0) then
BUFFER(m,i,j,k) = 1
else
BUFFER(m,i,j,k) = 0
endif
enddo
enddo
enddo
enddo
call HDF5IOWRITE(DataHandle,Comm,DateStr,Length,DomainStart, DomainEnd &
,PatchStart,PatchEnd, MemoryOrder &
,FieldType,XType,groupID,TimeIndex,DimRank &
,Var,BUFFER,Status)
deallocate(BUFFER,STAT=stat)
if(stat/=0) then
Status = WRF_ERR_FATAL_ALLOCATION_ERROR
write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
call wrf_debug ( FATAL , msg)
return
endif
else
call HDF5IOWRITE(DataHandle,Comm,DateStr,Length, DomainStart, DomainEnd &
,PatchStart, PatchEnd, MemoryOrder &
,FieldType,XType,groupID,TimeIndex,DimRank &
,Var,XField,Status)
endif
if (Status /= WRF_NO_ERR) then
return
endif
deallocate(XField,STAT=stat)
if(stat/=0) then
Status = WRF_ERR_FATAL_ALLOCATION_ERROR
write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line',__LINE__
call wrf_debug ( FATAL , msg)
return
endif
endif
DH%first_operation = .FALSE.
return
end subroutine ext_phdf5_write_field
! set_time routine is only used for open_for_read
subroutine ext_phdf5_set_time(DataHandle, DateStr, Status),4
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: DateStr
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
integer :: i
! check whether the Date length is equal to DateStrLen defined at wrf_phdf5_data
! sees not enough, leave it for the time being 3/12/2003
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_HDF5_ERR_FILE_NOT_OPENED
write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_HDF5_ERR_FILE_NOT_COMMITTED
write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
Status = WRF_HDF5_ERR_READ_WONLY_FILE
write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
do i=1,MaxTimes
if(DH%Times(i)==DateStr) then
DH%CurrentTime = i
exit
endif
if(i==MaxTimes) then
Status = WRF_HDF5_ERR_TIME
return
endif
enddo
DH%CurrentVariable = 0
Status = WRF_NO_ERR
else
Status = WRF_HDF5_ERR_BAD_FILE_STATUS
write(msg,*) 'FATAL BAD FILE STATUS in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
endif
return
end subroutine ext_phdf5_set_time
! get_next_time routine is only used for open_for_read
subroutine ext_phdf5_get_next_time(DataHandle, DateStr, Status) 1,3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(out) :: DateStr
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_HDF5_ERR_FILE_NOT_OPENED
write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_HDF5_ERR_DRYRUN_READ
write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
Status = WRF_HDF5_ERR_READ_WONLY_FILE
write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
if(DH%CurrentTime >= DH%NumberTimes) then
Status = WRF_HDF5_ERR_TIME
write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
DH%CurrentTime = DH%CurrentTime +1
DateStr = DH%Times(DH%CurrentTime)
DH%CurrentVariable = 0
Status = WRF_NO_ERR
else
Status = WRF_HDF5_ERR_BAD_FILE_STATUS
write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
endif
return
end subroutine ext_phdf5_get_next_time
! get_previous_time routine
subroutine ext_phdf5_get_previous_time(DataHandle, DateStr, Status),3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(out) :: DateStr
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_HDF5_ERR_FILE_NOT_OPENED
write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_HDF5_ERR_DRYRUN_READ
write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
Status = WRF_HDF5_ERR_READ_WONLY_FILE
write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
if(DH%CurrentTime.GT.0) then
DH%CurrentTime = DH%CurrentTime - 1
endif
DateStr = DH%Times(DH%CurrentTime)
DH%CurrentVariable = 0
Status = WRF_NO_ERR
else
Status = WRF_HDF5_ERR_BAD_FILE_STATUS
write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
endif
return
end subroutine ext_phdf5_get_previous_time
subroutine ext_phdf5_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status),8
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Name
integer ,intent(out) :: NDim
character*(*) ,intent(out) :: MemoryOrder
character*(*) ,intent(out) :: Stagger ! Dummy for now
integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd
integer ,intent(out) :: WrfType
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle) ,pointer :: DH
integer :: VarID
integer ,dimension(NVarDims) :: VDimIDs
integer :: j
integer :: hdf5err
integer :: XType
character(Len =MaxTimeSLen) :: tname
character(Len = 512) :: tgroupname
integer(hid_t) :: tgroupid
integer(hid_t) :: dsetid
integer(hid_t) :: dspaceid
integer :: HDF5_NDim
integer(hsize_t),dimension(:),allocatable :: h5dims
integer(hsize_t),dimension(:),allocatable :: h5maxdims
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , TRIM(msg))
return
endif
if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
Status = WRF_HDF5_ERR_FILE_NOT_OPENED
write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , TRIM(msg))
return
elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_HDF5_ERR_DRYRUN_READ
write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , TRIM(msg))
return
elseif(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
Status = WRF_HDF5_ERR_READ_WONLY_FILE
write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , TRIM(msg))
return
elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
if(Name /= "Times") then
call numtochar(1,tname)
tgroupname = 'TIME_STAMP_'//tname
call h5gopen_f(DH%GroupID,tgroupname,tgroupid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_GROUP
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dopen_f(tgroupid,Name,dsetid,hdf5err)
if(hdf5err /= 0) then
STATUS = WRF_HDF5_ERR_DATASET_OPEN
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dget_space_f(dsetid,dspaceid,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sget_simple_extent_ndims_f(dspaceid,HDF5_NDim,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call ext_phdf5_get_var_ti_char(DataHandle,"MemoryOrder",Name,MemoryOrder,Status)
if(Status /= WRF_NO_ERR) then
Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! get the rank of the dimension
call GetDim(MemoryOrder,NDim,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if((NDim+1)/= HDF5_NDim)then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call ext_phdf5_get_var_ti_char(DataHandle,"Stagger",Name,Stagger,Status)
if(Status /= WRF_NO_ERR) then
Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call ext_phdf5_get_var_ti_integer(DataHandle,"FieldType",Name,WrfType,Status)
if(Status /= WRF_NO_ERR) then
Status = WRF_HDF5_ERR_ATTRIBUTE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! obtain Domain Start and Domain End.
allocate(h5dims(NDim+1))
allocate(h5maxdims(NDim+1))
call h5sget_simple_extent_dims_f(dspaceid,h5dims,h5maxdims,hdf5err)
if(hdf5err .lt. 0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
do j =1, NDim
DomainStart(j) = 1
DomainEnd(j) = h5dims(j)
enddo
deallocate(h5dims)
deallocate(h5maxdims)
endif
return
endif
return
end subroutine ext_phdf5_get_var_info
! obtain the domain time independent attribute with REAL type
subroutine ext_phdf5_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
real ,intent(out) :: Data(*)
real ,dimension(:),allocatable :: buffer
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer :: rank
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
! Do nothing unless it is time to read time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
attr_type = H5T_NATIVE_REAL
call get_attrid(DataHandle,Element,h5_attrid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (Status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (Status /= WRF_NO_ERR) then
return
endif
allocate(buffer(OutCount))
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
data(1:OutCount) = buffer(1:OutCount)
deallocate(buffer)
return
end subroutine ext_phdf5_get_dom_ti_real
! obtain the domain time independent attribute with REAL8 type
subroutine ext_phdf5_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status),6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
real*8 ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer :: rank
integer :: hdf5err
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
! Do nothing unless it is time to read time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
attr_type = H5T_NATIVE_DOUBLE
call get_attrid(DataHandle,Element,h5_attrid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (Status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (Status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_get_dom_ti_double
! obtain the domain time independent attribute with integer type
subroutine ext_phdf5_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
integer ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer :: rank
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
! Do nothing unless it is time to read time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
attr_type = H5T_NATIVE_INTEGER
call get_attrid(DataHandle,Element,h5_attrid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (Status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (Status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,attr_type,Data,h5_dims,Status)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_get_dom_ti_integer
subroutine ext_phdf5_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status),7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
logical ,intent(out) :: Data(*)
integer, dimension(:),allocatable :: buffer
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer :: rank
integer(hid_t) :: attr_type
type(wrf_phdf5_data_handle),pointer :: DH
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Do nothing unless it is time to read time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
attr_type = DH%EnumID
call get_attrid(DataHandle,Element,h5_attrid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (Status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
allocate(buffer(OutCount))
call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
Data(1:OutCount) = buffer(1:OutCount)==1
deallocate(buffer)
return
end subroutine ext_phdf5_get_dom_ti_logical
! obtain the domain time independent attribute with char type
subroutine ext_phdf5_get_dom_ti_char(DataHandle,Element,Data,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(out) :: Data
integer :: Count
integer :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer :: rank
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
! Do nothing unless it is time to read time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_get_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
attr_type = H5T_NATIVE_CHARACTER
call get_attrid(DataHandle,Element,h5_attrid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if(Status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,h5_atypeid,data,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_get_dom_ti_char
subroutine ext_phdf5_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
real ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
call ext_phdf5_put_var_td_real(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
Data,Count,Status)
return
end subroutine ext_phdf5_put_dom_td_real
subroutine ext_phdf5_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
real*8 ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
call ext_phdf5_put_var_td_double(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
Data,Count,Status)
return
end subroutine ext_phdf5_put_dom_td_double
subroutine ext_phdf5_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
logical ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
call ext_phdf5_put_var_td_logical(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
Data,Count,Status)
return
end subroutine ext_phdf5_put_dom_td_logical
subroutine ext_phdf5_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
integer ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
call ext_phdf5_put_var_td_integer(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
Data,Count,Status)
return
end subroutine ext_phdf5_put_dom_td_integer
subroutine ext_phdf5_put_dom_td_char(DataHandle,Element,DateStr,Data,Status) 1,1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Data
integer ,intent(out) :: Status
call ext_phdf5_put_var_td_char(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',&
Data,Status)
return
end subroutine ext_phdf5_put_dom_td_char
subroutine ext_phdf5_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
real ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
call ext_phdf5_get_var_td_real(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
return
end subroutine ext_phdf5_get_dom_td_real
subroutine ext_phdf5_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
real*8 ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
call ext_phdf5_get_var_td_double(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
return
end subroutine ext_phdf5_get_dom_td_double
subroutine ext_phdf5_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
integer ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
call ext_phdf5_get_var_td_integer(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
return
end subroutine ext_phdf5_get_dom_td_integer
subroutine ext_phdf5_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
logical ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
call ext_phdf5_get_var_td_logical(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Count,OutCount,Status)
return
end subroutine ext_phdf5_get_dom_td_logical
subroutine ext_phdf5_get_dom_td_char(DataHandle,Element,DateStr,Data,Status),1
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(out) :: Data
integer ,intent(out) :: Status
call ext_phdf5_get_var_td_char(DataHandle,Element,DateStr,&
'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_',Data,Status)
return
end subroutine ext_phdf5_get_dom_td_char
subroutine ext_phdf5_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status) 1,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len = 256) :: DataSetName
real ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: fspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(1) :: dims
integer :: hdf5err
integer :: i
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
dims(1) = Count
! Get the time index
call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! Set up dataspace,property list
call GetName(Element,Var,DataSetName,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_REAL,Count,&
dset_id,dspaceid,fspaceid,tgroupid,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5dwrite_f(dset_id,H5T_NATIVE_REAL,Data,dims,hdf5err,dspaceid,&
fspaceid)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5sclose_f(fspaceid,hdf5err)
! call h5gclose_f(tgroupid,hdf5err)
endif
return
end subroutine ext_phdf5_put_var_td_real
subroutine ext_phdf5_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status) 1,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len = 256) :: DataSetName
real*8 ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: fspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(1) :: dims
integer :: hdf5err
integer :: i
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
dims(1) = Count
! Get the time index
call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! Set up dataspace,property list
call GetName(Element,Var,DataSetName,Status)
call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_DOUBLE,Count,&
dset_id,dspaceid,fspaceid,tgroupid,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE,Data,dims,hdf5err,dspaceid,&
fspaceid)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5sclose_f(fspaceid,hdf5err)
! call h5gclose_f(tgroupid,hdf5err)
endif
return
end subroutine ext_phdf5_put_var_td_double
subroutine ext_phdf5_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status) 1,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len = 256) :: DataSetName
integer ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: fspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(1) :: dims
integer :: hdf5err
integer :: i
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
dims(1) = Count
! Get the time index
call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! Set up dataspace,property list
call GetName(Element,Var,DataSetName,Status)
call setup_wrtd_dataset(DataHandle,DataSetName,H5T_NATIVE_INTEGER, &
Count,dset_id,dspaceid,fspaceid,tgroupid, &
TimeIndex, Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER,Data,dims,hdf5err,dspaceid,&
fspaceid)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5sclose_f(fspaceid,hdf5err)
! call h5gclose_f(tgroupid,hdf5err)
endif
return
end subroutine ext_phdf5_put_var_td_integer
subroutine ext_phdf5_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status) 1,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len = 256) :: DataSetName
logical ,intent(in) :: Data(*)
integer ,dimension(:),allocatable :: Buffer
integer ,intent(in) :: Count
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: fspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(1) :: dims
integer :: hdf5err
integer :: i
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
allocate(buffer(count))
do i = 1, count
if(data(i).EQV..TRUE.) then
buffer(i) = 1
else
buffer(i) = 0
endif
enddo
dims(1) = Count
! Get the time index
call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! Set up dataspace,property list
call GetName(Element,Var,DataSetName,Status)
call setup_wrtd_dataset(DataHandle,DataSetName,DH%EnumID, &
Count,dset_id,dspaceid, &
fspaceid,tgroupid,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5dwrite_f(dset_id,DH%EnumID,Buffer,dims,hdf5err,dspaceid,&
fspaceid)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5sclose_f(fspaceid,hdf5err)
! call h5gclose_f(tgroupid,hdf5err)
deallocate(Buffer)
endif
return
end subroutine ext_phdf5_put_var_td_logical
subroutine ext_phdf5_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) 1,8
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len = 256) :: DataSetName
character*(*) ,intent(in) :: Data
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: fspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(1) :: dims
integer :: hdf5err
integer :: i
integer :: str_id
integer :: str_len
integer :: count
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_AND_COMMITTED) then
dims(1) = 1
! Get the time index
call GetAttrTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! make str id
str_len = len_trim(Data)
call make_strid(str_len,str_id,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! assign count of the string to 1
count = 1
! Set up dataspace,property list
call GetName(Element,Var,DataSetName,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call setup_wrtd_dataset(DataHandle,DataSetName,str_id, &
count,dset_id,dspaceid, &
fspaceid,tgroupid,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5dwrite_f(dset_id,str_id,Data,dims,hdf5err,dspaceid,&
fspaceid)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! close the string id
call h5tclose_f(str_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5sclose_f(fspaceid,hdf5err)
! call h5gclose_f(tgroupid,hdf5err)
endif
return
end subroutine ext_phdf5_put_var_td_char
subroutine ext_phdf5_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) 1,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len =256) :: DataSetName
real ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: memspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(7) :: data_dims
integer :: hdf5err
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! get the time-dependent attribute name
call GetName(Element,Var,DataSetName,Status)
! get time index of the time-dependent attribute
call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! For parallel, find the group and obtain the attribute.
! set up for reading the time-dependent attribute
call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_REAL,TimeIndex,&
Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,&
Status)
if(Status /= WRF_NO_ERR) then
return
endif
data_dims(1) = OutCount
! read the dataset
call h5dread_f(dset_id,H5T_NATIVE_REAL,data,data_dims,hdf5err, &
memspaceid,dspaceid,H5P_DEFAULT_F)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sclose_f(memspaceid,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5dclose_f(dset_id,hdf5err)
call h5gclose_f(tgroupid,hdf5err)
endif
end subroutine ext_phdf5_get_var_td_real
subroutine ext_phdf5_get_var_td_double(DataHandle,Element,DateStr,Var,Data,& 1,7
Count,OutCount,Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len =256) :: DataSetName
real*8 ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: memspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(7) :: data_dims
integer :: hdf5err
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! get the time-dependent attribute name
call GetName(Element,Var,DataSetName,Status)
! get time index of the time-dependent attribute
call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! set up for reading the time-dependent attribute
call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_DOUBLE,TimeIndex,&
Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,&
Status)
if(Status /= WRF_NO_ERR) then
return
endif
data_dims(1) = OutCount
! read the dataset
call h5dread_f(dset_id,H5T_NATIVE_DOUBLE,data,data_dims,hdf5err, &
memspaceid,dspaceid,H5P_DEFAULT_F)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sclose_f(memspaceid,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5dclose_f(dset_id,hdf5err)
call h5gclose_f(tgroupid,hdf5err)
endif
end subroutine ext_phdf5_get_var_td_double
subroutine ext_phdf5_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,& 1,7
Count,OutCount,Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len =256) :: DataSetName
integer ,intent(out) :: Data(*)
integer ,intent(in) :: Count
INTEGER ,intent(out) :: OutCount
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: memspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(7) :: data_dims
integer :: hdf5err
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! get the time-dependent attribute name
call GetName(Element,Var,DataSetName,Status)
! get time index of the time-dependent attribute
call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! set up for reading the time-dependent attribute
call setup_rdtd_dataset(DataHandle,DataSetName,H5T_NATIVE_INTEGER,TimeIndex,&
Count,OutCount,dset_id,memspaceid,dspaceid,tgroupid,&
Status)
if(Status /= WRF_NO_ERR) then
return
endif
data_dims(1) = OutCount
! read the dataset
call h5dread_f(dset_id,H5T_NATIVE_INTEGER,data,data_dims,hdf5err, &
memspaceid,dspaceid,H5P_DEFAULT_F)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sclose_f(memspaceid,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5dclose_f(dset_id,hdf5err)
call h5gclose_f(tgroupid,hdf5err)
endif
end subroutine ext_phdf5_get_var_td_integer
subroutine ext_phdf5_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,& 1,7
Count,OutCount,Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len =256) :: DataSetName
logical ,intent(out) :: Data(*)
integer, dimension(:),allocatable :: Buffer
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: memspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(7) :: data_dims
integer :: hdf5err
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! get the time-dependent attribute name
call GetName(Element,Var,DataSetName,Status)
! get time index of the time-dependent attribute
call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! set up for reading the time-dependent attribute
call setup_rdtd_dataset(DataHandle,DataSetName,DH%EnumID,TimeIndex,&
Count,OutCount,dset_id,memspaceid,dspaceid,&
tgroupid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
data_dims(1) = OutCount
! read the dataset
allocate(Buffer(OutCount))
call h5dread_f(dset_id,DH%EnumID,buffer,data_dims,hdf5err, &
memspaceid,dspaceid,H5P_DEFAULT_F)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
data(1:OutCount) = buffer(1:OutCount) == 1
deallocate(buffer)
call h5sclose_f(memspaceid,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5dclose_f(dset_id,hdf5err)
call h5gclose_f(tgroupid,hdf5err)
endif
end subroutine ext_phdf5_get_var_td_logical
subroutine ext_phdf5_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status) 1,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: DateStr
character*(*) ,intent(in) :: Var
character(len =256) :: DataSetName
character*(*) ,intent(out) :: Data
integer :: Count
integer :: OutCount
integer ,intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer :: TimeIndex
integer(hid_t) :: dset_id
integer(hid_t) :: dspaceid
integer(hid_t) :: memspaceid
integer(hid_t) :: tgroupid
integer(hsize_t),dimension(7) :: data_dims
integer :: hdf5err
integer(hid_t) :: str_id
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! check whether the DateStr is the correct length
call DateCheck(DateStr,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
! get the time-dependent attribute name
call GetName(Element,Var,DataSetName,Status)
! get time index of the time-dependent attribute
call GetAttrTimeIndex('read',DataHandle,DateStr,TimeIndex,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! set up for reading the time-dependent attribute
str_id = H5T_NATIVE_CHARACTER
Count = 1
call setup_rdtd_dataset(DataHandle,DataSetName,str_id,TimeIndex,&
Count,OutCount,dset_id,memspaceid,dspaceid,&
tgroupid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
data_dims(1) = Count
! read the dataset
call h5dread_f(dset_id,str_id,data,data_dims,hdf5err, &
memspaceid,dspaceid,H5P_DEFAULT_F)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sclose_f(memspaceid,hdf5err)
call h5sclose_f(dspaceid,hdf5err)
call h5dclose_f(dset_id,hdf5err)
call h5gclose_f(tgroupid,hdf5err)
endif
end subroutine ext_phdf5_get_var_td_char
! obtain the variable time independent attribute with REAL type
subroutine ext_phdf5_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status),6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
real ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
attr_type = H5T_NATIVE_REAL
call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if(Status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_get_var_ti_real
! obtain the variable time independent attribute with REAL8 type
subroutine ext_phdf5_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status),6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
real*8 ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
attr_type = H5T_NATIVE_DOUBLE
call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if(Status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
end subroutine ext_phdf5_get_var_ti_double
! obtain the variable time independent attribute with integer type
subroutine ext_phdf5_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
integer ,intent(out) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
attr_type = H5T_NATIVE_INTEGER
call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
if (status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,attr_type,data,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_get_var_ti_integer
! obtain the variable time independent attribute with logical type
subroutine ext_phdf5_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status),7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
logical ,intent(out) :: Data(*)
integer, dimension(:),allocatable :: Buffer
integer ,intent(in) :: Count
integer ,intent(out) :: OutCount
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hid_t) :: attr_type
type(wrf_phdf5_data_handle),pointer :: DH
integer(hsize_t), dimension(7) :: h5_dims
integer :: hdf5err
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
attr_type = DH%EnumID
call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
if(Status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (status /= WRF_NO_ERR) then
return
endif
h5_dims(1) = OutCount
allocate(buffer(OutCount))
call h5aread_f(h5_attrid,attr_type,buffer,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
Data(1:OutCount) = buffer(1:OutCount)==1
deallocate(buffer)
return
end subroutine ext_phdf5_get_var_ti_logical
! obtain the domain variable independent attribute with Char type
subroutine ext_phdf5_get_var_ti_char(DataHandle,Element,Var,Data,Status) 2,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
use get_attrid_routine
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
character*(*) ,intent(out) :: Data
integer ,intent(out) :: Status
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hid_t) :: attr_type
integer(hsize_t), dimension(7) :: h5_dims
integer :: Count
integer :: OutCount
integer :: hdf5err
attr_type = H5T_NATIVE_CHARACTER
call get_attrid(DataHandle,Element,h5_attrid,Status,Var)
if (status /= WRF_NO_ERR) then
return
endif
call check_type(DataHandle,attr_type,h5_attrid,Status)
if (status /= WRF_NO_ERR) then
return
endif
call retrieve_ti_info(DataHandle,h5_attrid,h5_atypeid,&
Count,OutCount,Status)
if (status /= WRF_NO_ERR) then
return
endif
if(OutCount /= 1) then
Status = WRF_HDF5_ERR_ATTRIBUTE_OTHERS
endif
h5_dims(1) = OutCount
call h5aread_f(h5_attrid,h5_atypeid,data,h5_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine ext_phdf5_get_var_ti_char
! write the domain time independent attribute with real type
subroutine ext_phdf5_put_dom_ti_real(DataHandle,Element,Data,Count,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
real ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
character(VarNameLen) :: var
! Do nothing unless it is time to write time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
var = 'DUMMY'
routine_type = 'DOM'
routine_atype = WRF_REAL
adata_dims(1) = Count
call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_dom_ti_real
! write the domain time independent attribute with integer type
subroutine ext_phdf5_put_dom_ti_integer(DataHandle,Element,Data,Count,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
integer ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
character(VarNameLen) :: var
! Do nothing unless it is time to write time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
var = 'DUMMY'
routine_type = 'DOM'
routine_atype = WRF_INTEGER
adata_dims(1) = Count
call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_dom_ti_integer
! write the domain time independent attribute with double type
subroutine ext_phdf5_put_dom_ti_double(DataHandle,Element,Data,Count,Status),6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
real*8 ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
character(VarNameLen) :: var
! Do nothing unless it is time to write time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
var = 'DUMMY'
routine_type = 'DOM'
routine_atype = WRF_DOUBLE
adata_dims(1) = Count
call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_dom_ti_double
! write the domain time independent attribute with logical type
subroutine ext_phdf5_put_dom_ti_logical(DataHandle,Element,Data,Count,Status),6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
logical ,intent(in) :: Data(*)
integer ,dimension(:),allocatable :: Buffer
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer :: i
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
character(VarNameLen) :: var
! Do nothing unless it is time to write time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
var = 'DUMMY'
routine_type = 'DOM'
routine_atype = WRF_LOGICAL
adata_dims(1) = Count
allocate(Buffer(Count))
do i = 1,Count
if(Data(i) .EQV. .TRUE.) then
Buffer(i) = 1
else
Buffer(i) = 0
endif
enddo
call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status,DataHandle)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Buffer,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
deallocate(Buffer)
end subroutine ext_phdf5_put_dom_ti_logical
! write the domain time independent attribute with char type
subroutine ext_phdf5_put_dom_ti_char(DataHandle,Element,Data,Status) 1,6
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
!!!! Need more work.
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Data
integer :: Count ! always 1 for char
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 1 ! is a string type
integer(hid_t) :: hdf5err
integer :: len_str
character(VarNameLen) :: var
character(1) :: RepData =' '
! Do nothing unless it is time to write time-independent domain metadata.
IF ( .NOT. phdf5_ok_to_put_dom_ti( DataHandle ) ) THEN
Status = WRF_NO_ERR
return
ENDIF
Count = 1
var = 'DUMMY'
routine_type = 'DOM'
routine_atype = WRF_CHARACTER
adata_dims(1) = Count
call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! This part may need more work, a special case is that the length of the
! string may be 0, HDF5 cannot handle 0 length string(?),so set the length
! to 1
len_str = len_trim(Data)
if(len_str == 0) then
len_str = 1
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,len_str,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(len_trim(Data) == 0) then
call h5awrite_f(h5_attrid,h5_atypeid,RepData,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
else
call h5awrite_f(h5_attrid,h5_atypeid,trim(Data),adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_dom_ti_char
! write the variable time independent attribute with real type
subroutine ext_phdf5_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status),7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
real ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
routine_type = 'VAR'
routine_atype = WRF_REAL
adata_dims(1) = Count
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! The following two checks must be here to avoid duplicating attributes
if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_NO_ERR
return
endif
if(DH%TimeIndex > 1) then
Status = WRF_NO_ERR
return
endif
call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_var_ti_real
! write the variable time independent attribute with double type
subroutine ext_phdf5_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status),7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
real*8 ,intent(in) :: Data(*)
character*(*) ,intent(in) :: Var
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
routine_type = 'VAR'
routine_atype = WRF_DOUBLE
adata_dims(1) = Count
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_NO_ERR
return
endif
if(DH%TimeIndex > 1) then
Status = WRF_NO_ERR
return
endif
call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_var_ti_double
! write the variable time independent attribute with integer type
subroutine ext_phdf5_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status),7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
integer ,intent(in) :: Data(*)
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
routine_type = 'VAR'
routine_atype = WRF_INTEGER
adata_dims(1) = Count
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! The following two checks must be here to avoid duplicating attributes
if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_NO_ERR
return
endif
if(DH%TimeIndex > 1) then
Status = WRF_NO_ERR
return
endif
call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_var_ti_integer
! write the variable time independent attribute with logical type
subroutine ext_phdf5_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status),7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Var
logical ,intent(in) :: Data(*)
integer ,dimension(:),allocatable :: Buffer
integer ,intent(in) :: Count
integer ,intent(out) :: Status
integer :: i
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 0 ! not a string type
integer(hid_t) :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
routine_type = 'VAR'
routine_atype = WRF_LOGICAL
adata_dims(1) = Count
allocate(Buffer(Count))
do i = 1,Count
if(Data(i) .EQV. .TRUE.) then
Buffer(i) = 1
else
Buffer(i) = 0
endif
enddo
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! The following two checks must be here to avoid duplicating attributes
if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_NO_ERR
return
endif
if(DH%TimeIndex > 1) then
Status = WRF_NO_ERR
return
endif
call create_phdf5_objid(DataHandle,h5_objid,routine_type,var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,Count,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,Buffer,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(buffer)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_var_ti_logical
! write the variable time independent attribute with char type
subroutine ext_phdf5_put_var_ti_char(DataHandle,Element,Var,Data,Status) 6,7
use wrf_phdf5_data
use ext_phdf5_support_routines
USE HDF5 ! This module contains all necessary modules
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: Element
character*(*) ,intent(in) :: Data
character*(*) ,intent(in) :: Var
integer :: Count
integer ,intent(out) :: Status
integer(hid_t) :: h5_objid
integer(hid_t) :: h5_atypeid
integer(hid_t) :: h5_aspaceid
integer(hid_t) :: h5_attrid
integer(hsize_t), dimension(7) :: adata_dims
character*3 :: routine_type
integer :: routine_atype
integer :: str_flag = 1 ! IS string type
integer(hid_t) :: hdf5err
integer :: len_str
character(1) :: RepData = ' '
type(wrf_phdf5_data_handle),pointer :: DH
Count = 1
routine_type = 'VAR'
routine_atype = WRF_CHARACTER
adata_dims(1) = Count
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! The following two checks must be here to avoid duplicating attributes
if (DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
Status = WRF_NO_ERR
return
endif
if(DH%TimeIndex > 1) then
Status = WRF_NO_ERR
return
endif
call create_phdf5_objid(DataHandle,h5_objid,routine_type,Var,Status)
if(Status /= WRF_NO_ERR) then
return
endif
len_str = len_trim(Data)
if(len_str .eq. 0) then
len_str = 1
endif
call create_phdf5_adtypeid(h5_atypeid,routine_atype,len_str,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call create_phdf5_adspaceid(Count,str_flag,h5_aspaceid,Status)
if(Status /= WRF_NO_ERR) then
return
endif
call h5acreate_f(h5_objid,Element,h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(len_trim(Data) == 0) then
call h5awrite_f(h5_attrid,h5_atypeid,RepData,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
else
call h5awrite_f(h5_attrid,h5_atypeid,trim(Data),adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,str_flag,Status)
if(Status /= WRF_NO_ERR) then
return
endif
return
end subroutine ext_phdf5_put_var_ti_char
! This routine will retrieve the dimensional table, should be useful
! for tool developers.
subroutine retrieve_table(DataHandle,Status) 1,3
use wrf_phdf5_data
use ext_phdf5_support_routines
use hdf5
implicit none
include 'wrf_status_codes.h'
character*256,dimension(MaxTabDims) :: dim_name
integer,dimension(:),allocatable :: length
integer,dimension(:),allocatable :: unlimited
integer, intent(in) :: DataHandle
integer, intent(out) :: Status
integer(hid_t) :: dset_id
integer(hid_t) :: dataspace_id
integer(hid_t) :: dtstr_id
integer(hid_t) :: dt1_id
integer(hid_t) :: dtint1_id
integer(hid_t) :: dtint2_id
integer(size_t) :: type_sizei
integer(size_t) :: offset
integer :: table_length
integer(size_t) :: string_size
integer(hsize_t),dimension(7) :: data_dims
integer(hsize_t) :: table_size
integer :: i
integer :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dopen_f(DH%DimGroupID,"h5dim_table",dset_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_OPEN
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dget_space_f(dset_id,dataspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sget_simple_extent_npoints_f(dataspace_id,table_size,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
data_dims(1) = table_size
allocate(length(table_size))
allocate(unlimited(table_size))
! the name of the dimension
call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
string_size = 256
call h5tset_size_f(dtstr_id,string_size,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tcreate_f(H5T_COMPOUND_F,string_size,dt1_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
offset = 0
call h5tinsert_f(dt1_id,"dim_name",offset,dtstr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5dread_f(dset_id,dt1_id,dim_name,data_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
! the length of the dimension
call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint1_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
offset = 0
call h5tinsert_f(dtint1_id,"dim_length",offset,H5T_NATIVE_INTEGER,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5dread_f(dset_id,dtint1_id,length,data_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
! the unlimited info. of the dimension
call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint2_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
offset = 0
call h5tinsert_f(dtint2_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5dread_f(dset_id,dtint2_id,unlimited,data_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_READ
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
! Store the information to the table array
do i =1,table_size
DH%DIMTABLE(i)%dim_name = dim_name(i)
DH%DIMTABLE(i)%length = length(i)
DH%DIMTABLE(i)%unlimited = unlimited(i)
enddo
deallocate(length)
deallocate(unlimited)
call h5tclose_f(dtint1_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dtstr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dtint2_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dt1_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sclose_f(dataspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_CLOSE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
Status = WRF_NO_ERR
return
end subroutine retrieve_table
! store(write) the dimensional table into the HDF5 file
subroutine store_table(DataHandle,table_length,Status) 1,4
use wrf_phdf5_data
use ext_phdf5_support_routines
use hdf5
implicit none
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
integer, intent(in) :: table_length
integer, intent(out) :: Status
type(wrf_phdf5_data_handle),pointer :: DH
integer(hid_t) :: group_id
integer(hid_t) :: dset_id
integer(hid_t) :: dtype_id
integer(hid_t) :: dtstr_id
integer(hid_t) :: dtstrm_id
integer(hid_t) :: dtint1_id
integer(hid_t) :: dtint2_id
integer(hid_t) :: plist_id
integer(size_t) :: type_size
integer(size_t) :: type_sizes
integer(size_t) :: type_sizei
integer(size_t) :: offset
character*256 ,dimension(MaxTabDims) :: dim_name
integer ,dimension(:),allocatable :: length
integer ,dimension(:),allocatable :: unlimited
integer(hid_t) :: dspace_id
integer(hsize_t) ,dimension(1) :: table_dims
integer :: table_rank
integer(hsize_t) ,dimension(7) :: data_dims
integer :: i,j
integer :: hdf5err
data_dims(1) = table_length
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call create_h5filetype(dtype_id,Status)
if(Status /= WRF_NO_ERR) then
return
endif
! obtain group id
group_id = DH%DimGroupID
! create data space
table_rank = 1
table_dims(1) = table_length
call h5screate_simple_f(table_rank,table_dims,dspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! obtain the data
allocate(length(table_length))
allocate(unlimited(table_length))
do i =1, table_length
length(i) = DH%DIMTABLE(i)%length
unlimited(i) = DH%DIMTABLE(i)%unlimited
enddo
do i=1,table_length
do j=1,256
dim_name(i)(j:j)=DH%DIMTABLE(i)%dim_name(j:j)
enddo
enddo
! under dimensional group
call h5dcreate_f(group_id,"h5dim_table",dtype_id,dspace_id,&
dset_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
! create memory types
call h5tget_size_f(H5T_NATIVE_INTEGER,type_sizei,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
! FOR string, it needs extra handling
call h5tcopy_f(H5T_NATIVE_CHARACTER,dtstr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
type_size = 256
call h5tset_size_f(dtstr_id, type_size,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tget_size_f(dtstr_id, type_size,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tcreate_f(H5T_COMPOUND_F,type_size,dtstrm_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
offset = 0
call h5tinsert_f(dtstrm_id,"dim_name",offset,dtstr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint1_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
offset = 0
call h5tinsert_f(dtint1_id,"dim_length",offset,H5T_NATIVE_INTEGER,&
hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5tcreate_f(H5T_COMPOUND_F,type_sizei,dtint2_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
offset = 0
call h5tinsert_f(dtint2_id,"dim_unlimited",offset,H5T_NATIVE_INTEGER,&
hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATATYPE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
! write data by fields in the datatype,but first create a property list
call h5pcreate_f(H5P_DATASET_XFER_F,plist_id, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5pset_preserve_f(plist_id,.TRUE.,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_PROPERTY_LIST
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5dwrite_f(dset_id,dtstrm_id,dim_name,data_dims,hdf5err,&
xfer_prp = plist_id)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5dwrite_f(dset_id,dtint1_id,length,data_dims,hdf5err,&
xfer_prp = plist_id)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
call h5dwrite_f(dset_id,dtint2_id,unlimited,data_dims,hdf5err,&
xfer_prp = plist_id)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(length)
deallocate(unlimited)
return
endif
deallocate(length)
deallocate(unlimited)
! release resources
call h5tclose_f(dtstr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dtstrm_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dtint1_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dtint2_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5tclose_f(dtype_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5pclose_f(plist_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5dclose_f(dset_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASET_CLOSE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5sclose_f(dspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_CLOSE_GENERAL
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
return
end subroutine store_table
subroutine free_memory(DataHandle,Status) 2,3
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'wrf_status_codes.h'
include 'mpif.h'
integer ,intent(in) :: DataHandle
integer ,intent(out) :: Status
integer :: hdf5err
type(wrf_phdf5_data_handle),pointer :: DH
integer :: i
integer :: stat
real*8 :: timeaw,timebw
call GetDH(DataHandle,DH,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
if(DH%Free) then
Status = WRF_HDF5_ERR_OTHERS
write(msg,*) '',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
deallocate(DH%Times, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%DimLengths, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%DimIDs, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%DimNames, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%DIMTABLE, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%MDDsetIDs, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%MDVarDimLens, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%MDVarNames, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%DsetIDs, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%VarDimLens, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
deallocate(DH%VarNames, STAT=stat)
if(stat/= 0) then
Status = WRF_HDF5_ERR_DEALLOCATION
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call wrf_debug ( FATAL , msg)
return
endif
return
end subroutine free_memory
subroutine write_hdf5_attributes(DataHandle,MemoryOrder,WrfDType,DimRank,& 2,10
NDim,dset_id,Status)
use wrf_phdf5_data
use ext_phdf5_support_routines
use HDF5
implicit none
include 'mpif.h'
include 'wrf_status_codes.h'
integer ,intent(in) :: DataHandle
character*(*) ,intent(in) :: MemoryOrder
integer ,intent(in) :: WrfDType
integer,dimension(*) ,intent(in) :: DimRank
integer ,intent(in) :: NDim
integer(hid_t) ,intent(in) :: dset_id
integer ,intent(out) :: Status
character (3) :: Mem0
character (3) :: UCMem0
type(wrf_phdf5_data_handle) ,pointer :: DH
! attribute defination
integer(hid_t) :: dimaspace_id ! DimRank dataspace id
integer(hid_t) :: dimattr_id ! DimRank attribute id
integer(hsize_t) ,dimension(1) :: dim_space
integer(hid_t) :: h5_atypeid ! for fieldtype,memorder attribute
integer(hid_t) :: h5_aspaceid ! for fieldtype,memorder
integer(hid_t) :: h5_attrid ! for fieldtype,memorder
integer(hsize_t), dimension(7) :: adata_dims
integer :: routine_atype
integer, dimension(:),allocatable :: dimrank_data
integer :: hdf5err
integer :: j
! For time function
real*8 :: timebw
real*8 :: timeaw
integer :: total_ele
!
! write dimensional rank attribute. This is the temporary fix for dim. scale
! the first dimension is always time
allocate(dimrank_data(NDim+1))
do j =1, NDim+1
dimrank_data(j) = DimRank(j)
enddo
dim_space(1) = NDim+1
adata_dims(1) = NDim+1
call h5screate_simple_f(1,dim_space,dimaspace_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_DATASPACE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dimrank_data)
return
endif
call h5acreate_f(dset_id,'H5_DimRank',H5T_NATIVE_INTEGER,dimaspace_id, &
dimattr_id,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dimrank_data)
return
endif
call h5awrite_f(dimattr_id,H5T_NATIVE_INTEGER,dimrank_data,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
deallocate(dimrank_data)
return
endif
deallocate(dimrank_data)
! close space and attribute id
call clean_phdf5_attrids(H5T_NATIVE_INTEGER,dimaspace_id,dimattr_id,0,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Write memory order and FieldType attribute, both MemoryOrder and FieldType are 1 element
adata_dims(1) = 1
! output memoryorder attribute
call reorder(MemoryOrder,Mem0)
call uppercase(Mem0,UCMem0)
routine_atype = WRF_CHARACTER
! The size of memoryorder string is always MemOrdLen
call create_phdf5_adtypeid(h5_atypeid,routine_atype,MemOrdLen,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! Count for string attribute is always 1
call create_phdf5_adspaceid(1,1,h5_aspaceid,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5acreate_f(dset_id,'MemoryOrder',h5_atypeid,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,h5_atypeid,UCMem0,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(h5_atypeid,h5_aspaceid,h5_attrid,1,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
! output fieldtype attribute
call create_phdf5_adspaceid(1,1,h5_aspaceid,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5acreate_f(dset_id,'FieldType',H5T_NATIVE_INTEGER,h5_aspaceid, &
h5_attrid, hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_CREATE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call h5awrite_f(h5_attrid,H5T_NATIVE_INTEGER,WrfDType,adata_dims,hdf5err)
if(hdf5err.lt.0) then
Status = WRF_HDF5_ERR_ATTRIBUTE_WRITE
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
call clean_phdf5_attrids(H5T_NATIVE_INTEGER,h5_aspaceid,h5_attrid,0,Status)
if(Status.ne.WRF_NO_ERR) then
write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
call wrf_debug ( WARN , msg)
return
endif
end subroutine write_hdf5_attributes