!/*************************************************************************** !* 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 & ,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 ! 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 ! 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) 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) 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) 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) 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) 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) 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, & 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) 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) 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,& 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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,& 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,& 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,& 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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,& 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