Context Navigation

wrf-phdf5support.F90

Last change on this file was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 46.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format