Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

wrf_io.F90 @ 2759

Last change on this file since 2759 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: 119.5 KB

Line
1	!*------------------------------------------------------------------------------
2	!* Standard Disclaimer
3	!*
4	!* Forecast Systems Laboratory
5	!* NOAA/OAR/ERL/FSL
6	!* 325 Broadway
7	!* Boulder, CO 80303
8	!*
9	!* AVIATION DIVISION
10	!* ADVANCED COMPUTING BRANCH
11	!* SMS/NNT Version: 2.0.0
12	!*
13	!* This software and its documentation are in the public domain and
14	!* are furnished "as is". The United States government, its
15	!* instrumentalities, officers, employees, and agents make no
16	!* warranty, express or implied, as to the usefulness of the software
17	!* and documentation for any purpose. They assume no
18	!* responsibility (1) for the use of the software and documentation;
19	!* or (2) to provide technical support to users.
20	!*
21	!* Permission to use, copy, modify, and distribute this software is
22	!* hereby granted, provided that this disclaimer notice appears in
23	!* all copies. All modifications to this software must be clearly
24	!* documented, and are solely the responsibility of the agent making
25	!* the modification. If significant modifications or enhancements
26	!* are made to this software, the SMS Development team
27	!* (sms-info@fsl.noaa.gov) should be notified.
28	!*
29	!*----------------------------------------------------------------------------
30	!*
31	!* WRF NetCDF I/O
32	! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov
33	!* Date: October 6, 2000
34	!*
35	!*----------------------------------------------------------------------------
36
37	module wrf_data
38
39	integer , parameter :: FATAL = 1
40	integer , parameter :: WARN = 1
41	integer , parameter :: WrfDataHandleMax = 99
42	integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS
43	integer , parameter :: MaxVars = 2000
44	integer , parameter :: MaxTimes = 900000
45	integer , parameter :: DateStrLen = 19
46	integer , parameter :: VarNameLen = 31
47	integer , parameter :: NO_DIM = 0
48	integer , parameter :: NVarDims = 4
49	integer , parameter :: NMDVarDims = 2
50	character (8) , parameter :: NO_NAME = 'NULL'
51	character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00'
52
53	#include "wrf_io_flags.h"
54
55	character (256) :: msg
56	logical :: WrfIOnotInitialized = .true.
57
58	type :: wrf_data_handle
59	character (255) :: FileName
60	integer :: FileStatus
61	integer :: Comm
62	integer :: NCID
63	logical :: Free
64	logical :: Write
65	character (5) :: TimesName
66	integer :: TimeIndex
67	integer :: CurrentTime !Only used for read
68	integer :: NumberTimes !Only used for read
69	character (DateStrLen), pointer :: Times(:)
70	integer :: TimesVarID
71	integer , pointer :: DimLengths(:)
72	integer , pointer :: DimIDs(:)
73	character (31) , pointer :: DimNames(:)
74	integer :: DimUnlimID
75	character (9) :: DimUnlimName
76	integer , dimension(NVarDims) :: DimID
77	integer , dimension(NVarDims) :: Dimension
78	integer , pointer :: MDVarIDs(:)
79	integer , pointer :: MDVarDimLens(:)
80	character (80) , pointer :: MDVarNames(:)
81	integer , pointer :: VarIDs(:)
82	integer , pointer :: VarDimLens(:,:)
83	character (VarNameLen), pointer :: VarNames(:)
84	integer :: CurrentVariable !Only used for read
85	integer :: NumVars
86	! first_operation is set to .TRUE. when a new handle is allocated
87	! or when open-for-write or open-for-read are committed. It is set
88	! to .FALSE. when the first field is read or written.
89	logical :: first_operation
90	logical :: R4OnOutput
91	end type wrf_data_handle
92	type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax)
93	end module wrf_data
94
95	module ext_ncd_support_routines
96
97	implicit none
98
99	CONTAINS
100
101	subroutine allocHandle(DataHandle,DH,Comm,Status)
102	use wrf_data
103	include 'wrf_status_codes.h'
104	integer ,intent(out) :: DataHandle
105	type(wrf_data_handle),pointer :: DH
106	integer ,intent(IN) :: Comm
107	integer ,intent(out) :: Status
108	integer :: i
109	integer :: stat
110
111	do i=1,WrfDataHandleMax
112	if(WrfDataHandles(i)%Free) then
113	DH => WrfDataHandles(i)
114	DataHandle = i
115	allocate(DH%Times(MaxTimes), STAT=stat)
116	if(stat/= 0) then
117	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
118	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
119	call wrf_debug ( FATAL , msg)
120	return
121	endif
122	allocate(DH%DimLengths(MaxDims), STAT=stat)
123	if(stat/= 0) then
124	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
125	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
126	call wrf_debug ( FATAL , msg)
127	return
128	endif
129	allocate(DH%DimIDs(MaxDims), STAT=stat)
130	if(stat/= 0) then
131	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
132	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
133	call wrf_debug ( FATAL , msg)
134	return
135	endif
136	allocate(DH%DimNames(MaxDims), STAT=stat)
137	if(stat/= 0) then
138	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
139	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
140	call wrf_debug ( FATAL , msg)
141	return
142	endif
143	allocate(DH%MDVarIDs(MaxVars), STAT=stat)
144	if(stat/= 0) then
145	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
146	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
147	call wrf_debug ( FATAL , msg)
148	return
149	endif
150	allocate(DH%MDVarDimLens(MaxVars), STAT=stat)
151	if(stat/= 0) then
152	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
153	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
154	call wrf_debug ( FATAL , msg)
155	return
156	endif
157	allocate(DH%MDVarNames(MaxVars), STAT=stat)
158	if(stat/= 0) then
159	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
160	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
161	call wrf_debug ( FATAL , msg)
162	return
163	endif
164	allocate(DH%VarIDs(MaxVars), STAT=stat)
165	if(stat/= 0) then
166	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
167	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
168	call wrf_debug ( FATAL , msg)
169	return
170	endif
171	allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat)
172	if(stat/= 0) then
173	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
174	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
175	call wrf_debug ( FATAL , msg)
176	return
177	endif
178	allocate(DH%VarNames(MaxVars), STAT=stat)
179	if(stat/= 0) then
180	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
181	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
182	call wrf_debug ( FATAL , msg)
183	return
184	endif
185	exit
186	endif
187	if(i==WrfDataHandleMax) then
188	Status = WRF_WARN_TOO_MANY_FILES
189	write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__
190	call wrf_debug ( WARN , TRIM(msg))
191	write(msg,*) 'Did you call ext_ncd_ioinit?'
192	call wrf_debug ( WARN , TRIM(msg))
193	return
194	endif
195	enddo
196	DH%Free =.false.
197	DH%Comm = Comm
198	DH%Write =.false.
199	DH%first_operation = .TRUE.
200	DH%R4OnOutput = .false.
201	Status = WRF_NO_ERR
202	end subroutine allocHandle
203
204	subroutine deallocHandle(DataHandle, Status)
205	use wrf_data
206	include 'wrf_status_codes.h'
207	integer ,intent(in) :: DataHandle
208	integer ,intent(out) :: Status
209	type(wrf_data_handle),pointer :: DH
210	integer :: i
211	integer :: stat
212
213	IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN
214	if(.NOT. WrfDataHandles(DataHandle)%Free) then
215	DH => WrfDataHandles(DataHandle)
216	deallocate(DH%Times, STAT=stat)
217	if(stat/= 0) then
218	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
219	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
220	call wrf_debug ( FATAL , msg)
221	return
222	endif
223	deallocate(DH%DimLengths, STAT=stat)
224	if(stat/= 0) then
225	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
226	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
227	call wrf_debug ( FATAL , msg)
228	return
229	endif
230	deallocate(DH%DimIDs, STAT=stat)
231	if(stat/= 0) then
232	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
233	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
234	call wrf_debug ( FATAL , msg)
235	return
236	endif
237	deallocate(DH%DimNames, STAT=stat)
238	if(stat/= 0) then
239	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
240	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
241	call wrf_debug ( FATAL , msg)
242	return
243	endif
244	deallocate(DH%MDVarIDs, STAT=stat)
245	if(stat/= 0) then
246	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
247	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
248	call wrf_debug ( FATAL , msg)
249	return
250	endif
251	deallocate(DH%MDVarDimLens, STAT=stat)
252	if(stat/= 0) then
253	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
254	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
255	call wrf_debug ( FATAL , msg)
256	return
257	endif
258	deallocate(DH%MDVarNames, STAT=stat)
259	if(stat/= 0) then
260	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
261	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
262	call wrf_debug ( FATAL , msg)
263	return
264	endif
265	deallocate(DH%VarIDs, STAT=stat)
266	if(stat/= 0) then
267	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
268	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
269	call wrf_debug ( FATAL , msg)
270	return
271	endif
272	deallocate(DH%VarDimLens, STAT=stat)
273	if(stat/= 0) then
274	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
275	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
276	call wrf_debug ( FATAL , msg)
277	return
278	endif
279	deallocate(DH%VarNames, STAT=stat)
280	if(stat/= 0) then
281	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
282	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
283	call wrf_debug ( FATAL , msg)
284	return
285	endif
286	DH%Free =.TRUE.
287	endif
288	ENDIF
289	Status = WRF_NO_ERR
290	end subroutine deallocHandle
291
292	subroutine GetDH(DataHandle,DH,Status)
293	use wrf_data
294	include 'wrf_status_codes.h'
295	integer ,intent(in) :: DataHandle
296	type(wrf_data_handle) ,pointer :: DH
297	integer ,intent(out) :: Status
298
299	if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then
300	Status = WRF_WARN_BAD_DATA_HANDLE
301	return
302	endif
303	DH => WrfDataHandles(DataHandle)
304	if(DH%Free) then
305	Status = WRF_WARN_BAD_DATA_HANDLE
306	return
307	endif
308	Status = WRF_NO_ERR
309	return
310	end subroutine GetDH
311
312	subroutine DateCheck(Date,Status)
313	use wrf_data
314	include 'wrf_status_codes.h'
315	character() ,intent(in) :: Date
316	integer ,intent(out) :: Status
317
318	if(len(Date) /= DateStrLen) then
319	Status = WRF_WARN_DATESTR_BAD_LENGTH
320	else
321	Status = WRF_NO_ERR
322	endif
323	return
324	end subroutine DateCheck
325
326	subroutine GetName(Element,Var,Name,Status)
327	use wrf_data
328	include 'wrf_status_codes.h'
329	character() ,intent(in) :: Element
330	character() ,intent(in) :: Var
331	character() ,intent(out) :: Name
332	integer ,intent(out) :: Status
333	character (VarNameLen) :: VarName
334	character (1) :: c
335	integer :: i
336	integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A')
337
338	VarName = Var
339	Name = 'MD___'//trim(Element)//VarName
340	do i=1,len(Name)
341	c=Name(i:i)
342	if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower)
343	if(c=='-'.or.c==':') Name(i:i)='_'
344	enddo
345	Status = WRF_NO_ERR
346	return
347	end subroutine GetName
348
349	subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
350	use wrf_data
351	include 'wrf_status_codes.h'
352	include 'netcdf.inc'
353	character (*) ,intent(in) :: IO
354	integer ,intent(in) :: DataHandle
355	character() ,intent(in) :: DateStr
356	integer ,intent(out) :: TimeIndex
357	integer ,intent(out) :: Status
358	type(wrf_data_handle) ,pointer :: DH
359	integer :: VStart(2)
360	integer :: VCount(2)
361	integer :: stat
362	integer :: i
363
364	DH => WrfDataHandles(DataHandle)
365	call DateCheck(DateStr,Status)
366	if(Status /= WRF_NO_ERR) then
367	Status = WRF_WARN_DATESTR_ERROR
368	write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
369	call wrf_debug ( WARN , TRIM(msg))
370	return
371	endif
372	if(IO == 'write') then
373	TimeIndex = DH%TimeIndex
374	if(TimeIndex <= 0) then
375	TimeIndex = 1
376	elseif(DateStr == DH%Times(TimeIndex)) then
377	Status = WRF_NO_ERR
378	return
379	else
380	TimeIndex = TimeIndex +1
381	if(TimeIndex > MaxTimes) then
382	Status = WRF_WARN_TIME_EOF
383	write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__
384	call wrf_debug ( WARN , TRIM(msg))
385	return
386	endif
387	endif
388	DH%TimeIndex = TimeIndex
389	DH%Times(TimeIndex) = DateStr
390	VStart(1) = 1
391	VStart(2) = TimeIndex
392	VCount(1) = DateStrLen
393	VCount(2) = 1
394	stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr)
395	call netcdf_err(stat,Status)
396	if(Status /= WRF_NO_ERR) then
397	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
398	call wrf_debug ( WARN , TRIM(msg))
399	return
400	endif
401	else
402	do i=1,MaxTimes
403	if(DH%Times(i)==DateStr) then
404	Status = WRF_NO_ERR
405	TimeIndex = i
406	exit
407	endif
408	if(i==MaxTimes) then
409	Status = WRF_WARN_TIME_NF
410	write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__
411	call wrf_debug ( WARN , TRIM(msg))
412	return
413	endif
414	enddo
415	endif
416	return
417	end subroutine GetTimeIndex
418
419	subroutine GetDim(MemoryOrder,NDim,Status)
420	include 'wrf_status_codes.h'
421	character() ,intent(in) :: MemoryOrder
422	integer ,intent(out) :: NDim
423	integer ,intent(out) :: Status
424	character*3 :: MemOrd
425
426	call LowerCase(MemoryOrder,MemOrd)
427	select case (MemOrd)
428	case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez')
429	NDim = 3
430	case ('xy','yx','xs','xe','ys','ye','cc')
431	NDim = 2
432	case ('z','c')
433	NDim = 1
434	case ('0') ! NDim=0 for scalars. TBH: 20060502
435	NDim = 0
436	case default
437	Status = WRF_WARN_BAD_MEMORYORDER
438	return
439	end select
440	Status = WRF_NO_ERR
441	return
442	end subroutine GetDim
443
444	subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2)
445	integer ,intent(in) :: NDim
446	integer ,dimension(*),intent(in) :: Start,End
447	integer ,intent(out) :: i1,i2,j1,j2,k1,k2
448
449	i1=1
450	i2=1
451	j1=1
452	j2=1
453	k1=1
454	k2=1
455	if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502
456	i1 = Start(1)
457	i2 = End (1)
458	if(NDim == 1) return
459	j1 = Start(2)
460	j2 = End (2)
461	if(NDim == 2) return
462	k1 = Start(3)
463	k2 = End (3)
464	return
465	end subroutine GetIndices
466
467	subroutine ExtOrder(MemoryOrder,Vector,Status)
468	use wrf_data
469	include 'wrf_status_codes.h'
470	character() ,intent(in) :: MemoryOrder
471	integer,dimension(*) ,intent(inout) :: Vector
472	integer ,intent(out) :: Status
473	integer :: NDim
474	integer,dimension(NVarDims) :: temp
475	character*3 :: MemOrd
476
477	call GetDim(MemoryOrder,NDim,Status)
478	temp(1:NDim) = Vector(1:NDim)
479	call LowerCase(MemoryOrder,MemOrd)
480	select case (MemOrd)
481
482	case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
483	continue
484	case ('0')
485	continue ! NDim=0 for scalars. TBH: 20060502
486	case ('xzy')
487	Vector(2) = temp(3)
488	Vector(3) = temp(2)
489	case ('yxz')
490	Vector(1) = temp(2)
491	Vector(2) = temp(1)
492	case ('yzx')
493	Vector(1) = temp(3)
494	Vector(2) = temp(1)
495	Vector(3) = temp(2)
496	case ('zxy')
497	Vector(1) = temp(2)
498	Vector(2) = temp(3)
499	Vector(3) = temp(1)
500	case ('zyx')
501	Vector(1) = temp(3)
502	Vector(3) = temp(1)
503	case ('yx')
504	Vector(1) = temp(2)
505	Vector(2) = temp(1)
506	case default
507	Status = WRF_WARN_BAD_MEMORYORDER
508	return
509	end select
510	Status = WRF_NO_ERR
511	return
512	end subroutine ExtOrder
513
514	subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status)
515	use wrf_data
516	include 'wrf_status_codes.h'
517	character() ,intent(in) :: MemoryOrder
518	character(),dimension(*) ,intent(in) :: Vector
519	character(80),dimension(NVarDims),intent(out) :: ROVector
520	integer ,intent(out) :: Status
521	integer :: NDim
522	character*3 :: MemOrd
523
524	call GetDim(MemoryOrder,NDim,Status)
525	ROVector(1:NDim) = Vector(1:NDim)
526	call LowerCase(MemoryOrder,MemOrd)
527	select case (MemOrd)
528
529	case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
530	continue
531	case ('0')
532	continue ! NDim=0 for scalars. TBH: 20060502
533	case ('xzy')
534	ROVector(2) = Vector(3)
535	ROVector(3) = Vector(2)
536	case ('yxz')
537	ROVector(1) = Vector(2)
538	ROVector(2) = Vector(1)
539	case ('yzx')
540	ROVector(1) = Vector(3)
541	ROVector(2) = Vector(1)
542	ROVector(3) = Vector(2)
543	case ('zxy')
544	ROVector(1) = Vector(2)
545	ROVector(2) = Vector(3)
546	ROVector(3) = Vector(1)
547	case ('zyx')
548	ROVector(1) = Vector(3)
549	ROVector(3) = Vector(1)
550	case ('yx')
551	ROVector(1) = Vector(2)
552	ROVector(2) = Vector(1)
553	case default
554	Status = WRF_WARN_BAD_MEMORYORDER
555	return
556	end select
557	Status = WRF_NO_ERR
558	return
559	end subroutine ExtOrderStr
560
561
562	subroutine LowerCase(MemoryOrder,MemOrd)
563	character() ,intent(in) :: MemoryOrder
564	character() ,intent(out) :: MemOrd
565	character*1 :: c
566	integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A')
567	integer :: i,N
568
569	MemOrd = ' '
570	N = len(MemoryOrder)
571	MemOrd(1:N) = MemoryOrder(1:N)
572	do i=1,N
573	c = MemoryOrder(i:i)
574	if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
575	enddo
576	return
577	end subroutine LowerCase
578
579	subroutine UpperCase(MemoryOrder,MemOrd)
580	character() ,intent(in) :: MemoryOrder
581	character() ,intent(out) :: MemOrd
582	character*1 :: c
583	integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a')
584	integer :: i,N
585
586	MemOrd = ' '
587	N = len(MemoryOrder)
588	MemOrd(1:N) = MemoryOrder(1:N)
589	do i=1,N
590	c = MemoryOrder(i:i)
591	if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper)
592	enddo
593	return
594	end subroutine UpperCase
595
596	subroutine netcdf_err(err,Status)
597	use wrf_data
598	include 'wrf_status_codes.h'
599	include 'netcdf.inc'
600	integer ,intent(in) :: err
601	integer ,intent(out) :: Status
602	character(len=80) :: errmsg
603	integer :: stat
604
605	if( err==NF_NOERR )then
606	Status = WRF_NO_ERR
607	else
608	errmsg = NF_STRERROR(err)
609	write(msg,*) 'NetCDF error: ',errmsg
610	call wrf_debug ( WARN , TRIM(msg))
611	Status = WRF_WARN_NETCDF
612	endif
613	return
614	end subroutine netcdf_err
615
616	subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder &
617	,FieldType,NCID,VarID,XField,Status)
618	use wrf_data
619	include 'wrf_status_codes.h'
620	include 'netcdf.inc'
621	character (*) ,intent(in) :: IO
622	integer ,intent(in) :: DataHandle
623	character() ,intent(in) :: DateStr
624	integer,dimension(NVarDims),intent(in) :: Length
625	character() ,intent(in) :: MemoryOrder
626	integer ,intent(in) :: FieldType
627	integer ,intent(in) :: NCID
628	integer ,intent(in) :: VarID
629	integer,dimension(*) ,intent(inout) :: XField
630	integer ,intent(out) :: Status
631	integer :: TimeIndex
632	integer :: NDim
633	integer,dimension(NVarDims) :: VStart
634	integer,dimension(NVarDims) :: VCount
635
636	call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
637	if(Status /= WRF_NO_ERR) then
638	write(msg,*) 'Warning in ',__FILE__,', line', __LINE__
639	call wrf_debug ( WARN , TRIM(msg))
640	write(msg,*) ' Bad time index for DateStr = ',DateStr
641	call wrf_debug ( WARN , TRIM(msg))
642	return
643	endif
644	call GetDim(MemoryOrder,NDim,Status)
645	VStart(:) = 1
646	VCount(:) = 1
647	VStart(1:NDim) = 1
648	VCount(1:NDim) = Length(1:NDim)
649	VStart(NDim+1) = TimeIndex
650	VCount(NDim+1) = 1
651
652	! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
653	IF (FieldType == WRF_REAL) THEN
654	call ext_ncd_RealFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status)
655	ELSE IF (FieldType == WRF_DOUBLE) THEN
656	call ext_ncd_DoubleFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status)
657	ELSE IF (FieldType == WRF_INTEGER) THEN
658	call ext_ncd_IntFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status)
659	ELSE IF (FieldType == WRF_LOGICAL) THEN
660	call ext_ncd_LogicalFieldIO (IO,NCID,VarID,VStart,VCount,XField,Status)
661	if(Status /= WRF_NO_ERR) return
662	ELSE
663	!for wrf_complex, double_complex
664	Status = WRF_WARN_DATA_TYPE_NOT_FOUND
665	write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
666	call wrf_debug ( WARN , TRIM(msg))
667	return
668	END IF
669
670	return
671	end subroutine FieldIO
672
673	subroutine Transpose(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
674	,XField,x1,x2,y1,y2,z1,z2 &
675	,i1,i2,j1,j2,k1,k2 )
676	character() ,intent(in) :: IO
677	character() ,intent(in) :: MemoryOrder
678	integer ,intent(in) :: l1,l2,m1,m2,n1,n2
679	integer ,intent(in) :: di
680	integer ,intent(in) :: x1,x2,y1,y2,z1,z2
681	integer ,intent(in) :: i1,i2,j1,j2,k1,k2
682	integer ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2)
683	!jm 010827 integer ,intent(inout) :: XField(di,x1:x2,y1:y2,z1:z2)
684	integer ,intent(inout) :: XField(di,(i2-i1+1)(j2-j1+1)(k2-k1+1))
685	character*3 :: MemOrd
686	character*3 :: MemO
687	integer ,parameter :: MaxUpperCase=IACHAR('Z')
688	integer :: i,j,k,ix,jx,kx
689
690	call LowerCase(MemoryOrder,MemOrd)
691	select case (MemOrd)
692
693	!#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))
694	! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)(($2-``$2''1)+($3-``$3''1)(``$2''2-``$2''1+1))))
695
696	case ('xzy')
697	#undef DFIELD
698	#define DFIELD XField(1:di,XDEX(i,k,j))
699	#include "transpose.code"
700	case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
701	#undef DFIELD
702	#define DFIELD XField(1:di,XDEX(i,j,k))
703	#include "transpose.code"
704	case ('yxz')
705	#undef DFIELD
706	#define DFIELD XField(1:di,XDEX(j,i,k))
707	#include "transpose.code"
708	case ('zxy')
709	#undef DFIELD
710	#define DFIELD XField(1:di,XDEX(k,i,j))
711	#include "transpose.code"
712	case ('yzx')
713	#undef DFIELD
714	#define DFIELD XField(1:di,XDEX(j,k,i))
715	#include "transpose.code"
716	case ('zyx')
717	#undef DFIELD
718	#define DFIELD XField(1:di,XDEX(k,j,i))
719	#include "transpose.code"
720	case ('yx')
721	#undef DFIELD
722	#define DFIELD XField(1:di,XDEX(j,i,k))
723	#include "transpose.code"
724	end select
725	return
726	end subroutine Transpose
727
728	subroutine reorder (MemoryOrder,MemO)
729	character() ,intent(in) :: MemoryOrder
730	character*3 ,intent(out) :: MemO
731	character*3 :: MemOrd
732	integer :: N,i,i1,i2,i3
733
734	MemO = MemoryOrder
735	N = len_trim(MemoryOrder)
736	if(N == 1) return
737	call lowercase(MemoryOrder,MemOrd)
738	! never invert the boundary codes
739	select case ( MemOrd )
740	case ( 'xsz','xez','ysz','yez' )
741	return
742	case default
743	continue
744	end select
745	i1 = 1
746	i3 = 1
747	do i=2,N
748	if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i
749	if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i
750	enddo
751	if(N == 2) then
752	i2=i3
753	else
754	i2 = 6-i1-i3
755	endif
756	MemO(1:1) = MemoryOrder(i1:i1)
757	MemO(2:2) = MemoryOrder(i2:i2)
758	if(N == 3) MemO(3:3) = MemoryOrder(i3:i3)
759	if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then
760	MemO(1:N-1) = MemO(2:N)
761	MemO(N:N ) = MemoryOrder(i1:i1)
762	endif
763	return
764	end subroutine reorder
765
766	! Returns .TRUE. iff it is OK to write time-independent domain metadata to the
767	! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is
768	! returned.
769	LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle )
770	USE wrf_data
771	include 'wrf_status_codes.h'
772	INTEGER, INTENT(IN) :: DataHandle
773	CHARACTER*80 :: fname
774	INTEGER :: filestate
775	INTEGER :: Status
776	LOGICAL :: dryrun, first_output, retval
777	call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status )
778	IF ( Status /= WRF_NO_ERR ) THEN
779	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
780	', line', __LINE__
781	call wrf_debug ( WARN , TRIM(msg) )
782	retval = .FALSE.
783	ELSE
784	dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
785	first_output = ncd_is_first_operation( DataHandle )
786	retval = .NOT. dryrun .AND. first_output
787	ENDIF
788	ncd_ok_to_put_dom_ti = retval
789	RETURN
790	END FUNCTION ncd_ok_to_put_dom_ti
791
792	! Returns .TRUE. iff it is OK to read time-independent domain metadata from the
793	! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is
794	! returned.
795	LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle )
796	USE wrf_data
797	include 'wrf_status_codes.h'
798	INTEGER, INTENT(IN) :: DataHandle
799	CHARACTER*80 :: fname
800	INTEGER :: filestate
801	INTEGER :: Status
802	LOGICAL :: dryrun, retval
803	call ext_ncd_inquire_filename( DataHandle, fname, filestate, Status )
804	IF ( Status /= WRF_NO_ERR ) THEN
805	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
806	', line', __LINE__
807	call wrf_debug ( WARN , TRIM(msg) )
808	retval = .FALSE.
809	ELSE
810	dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED )
811	retval = .NOT. dryrun
812	ENDIF
813	ncd_ok_to_get_dom_ti = retval
814	RETURN
815	END FUNCTION ncd_ok_to_get_dom_ti
816
817	! Returns .TRUE. iff nothing has been read from or written to the file
818	! referenced by DataHandle. If DataHandle is invalid, .FALSE. is returned.
819	LOGICAL FUNCTION ncd_is_first_operation( DataHandle )
820	USE wrf_data
821	INCLUDE 'wrf_status_codes.h'
822	INTEGER, INTENT(IN) :: DataHandle
823	TYPE(wrf_data_handle) ,POINTER :: DH
824	INTEGER :: Status
825	LOGICAL :: retval
826	CALL GetDH( DataHandle, DH, Status )
827	IF ( Status /= WRF_NO_ERR ) THEN
828	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, &
829	', line', __LINE__
830	call wrf_debug ( WARN , TRIM(msg) )
831	retval = .FALSE.
832	ELSE
833	retval = DH%first_operation
834	ENDIF
835	ncd_is_first_operation = retval
836	RETURN
837	END FUNCTION ncd_is_first_operation
838
839	end module ext_ncd_support_routines
840
841	subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
842	,XField,x1,x2,y1,y2,z1,z2 &
843	,i1,i2,j1,j2,k1,k2 )
844
845	use ext_ncd_support_routines
846
847	character() ,intent(in) :: IO
848	character() ,intent(in) :: MemoryOrder
849	integer ,intent(in) :: l1,l2,m1,m2,n1,n2
850	integer ,intent(in) :: di
851	integer ,intent(in) :: x1,x2,y1,y2,z1,z2
852	integer ,intent(in) :: i1,i2,j1,j2,k1,k2
853	real*8 ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2)
854	real4 ,intent(inout) :: XField(di,(i2-i1+1)(j2-j1+1)*(k2-k1+1))
855	character*3 :: MemOrd
856	character*3 :: MemO
857	integer ,parameter :: MaxUpperCase=IACHAR('Z')
858	integer :: i,j,k,ix,jx,kx
859
860	call LowerCase(MemoryOrder,MemOrd)
861	select case (MemOrd)
862
863	!#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))
864	! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)(($2-``$2''1)+($3-``$3''1)(``$2''2-``$2''1+1))))
865
866	case ('xzy')
867	#undef DFIELD
868	#define DFIELD XField(1:di,XDEX(i,k,j))
869	#include "transpose.code"
870	case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
871	#undef DFIELD
872	#define DFIELD XField(1:di,XDEX(i,j,k))
873	#include "transpose.code"
874	case ('yxz')
875	#undef DFIELD
876	#define DFIELD XField(1:di,XDEX(j,i,k))
877	#include "transpose.code"
878	case ('zxy')
879	#undef DFIELD
880	#define DFIELD XField(1:di,XDEX(k,i,j))
881	#include "transpose.code"
882	case ('yzx')
883	#undef DFIELD
884	#define DFIELD XField(1:di,XDEX(j,k,i))
885	#include "transpose.code"
886	case ('zyx')
887	#undef DFIELD
888	#define DFIELD XField(1:di,XDEX(k,j,i))
889	#include "transpose.code"
890	case ('yx')
891	#undef DFIELD
892	#define DFIELD XField(1:di,XDEX(j,i,k))
893	#include "transpose.code"
894	end select
895	return
896	end subroutine TransposeToR4
897
898	subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status)
899	use wrf_data
900	use ext_ncd_support_routines
901	implicit none
902	include 'wrf_status_codes.h'
903	include 'netcdf.inc'
904	character (), INTENT(IN) :: DatasetName
905	integer , INTENT(IN) :: Comm1, Comm2
906	character (), INTENT(IN) :: SysDepInfo
907	integer , INTENT(OUT) :: DataHandle
908	integer , INTENT(OUT) :: Status
909	DataHandle = 0 ! dummy setting to quiet warning message
910	CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status )
911	IF ( Status .EQ. WRF_NO_ERR ) THEN
912	CALL ext_ncd_open_for_read_commit( DataHandle, Status )
913	ENDIF
914	return
915	end subroutine ext_ncd_open_for_read
916
917	!ends training phase; switches internal flag to enable input
918	!must be paired with call to ext_ncd_open_for_read_begin
919	subroutine ext_ncd_open_for_read_commit(DataHandle, Status)
920	use wrf_data
921	use ext_ncd_support_routines
922	implicit none
923	include 'wrf_status_codes.h'
924	include 'netcdf.inc'
925	integer, intent(in) :: DataHandle
926	integer, intent(out) :: Status
927	type(wrf_data_handle) ,pointer :: DH
928
929	if(WrfIOnotInitialized) then
930	Status = WRF_IO_NOT_INITIALIZED
931	write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
932	call wrf_debug ( FATAL , msg)
933	return
934	endif
935	call GetDH(DataHandle,DH,Status)
936	if(Status /= WRF_NO_ERR) then
937	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
938	call wrf_debug ( WARN , TRIM(msg))
939	return
940	endif
941	DH%FileStatus = WRF_FILE_OPENED_FOR_READ
942	DH%first_operation = .TRUE.
943	Status = WRF_NO_ERR
944	return
945	end subroutine ext_ncd_open_for_read_commit
946
947	subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status)
948	use wrf_data
949	use ext_ncd_support_routines
950	implicit none
951	include 'wrf_status_codes.h'
952	include 'netcdf.inc'
953	character() ,intent(IN) :: FileName
954	integer ,intent(IN) :: Comm
955	integer ,intent(IN) :: IOComm
956	character() ,intent(in) :: SysDepInfo
957	integer ,intent(out) :: DataHandle
958	integer ,intent(out) :: Status
959	type(wrf_data_handle) ,pointer :: DH
960	integer :: XType
961	integer :: stat
962	integer ,allocatable :: Buffer(:)
963	integer :: VarID
964	integer :: StoredDim
965	integer :: NAtts
966	integer :: DimIDs(2)
967	integer :: VStart(2)
968	integer :: VLen(2)
969	integer :: TotalNumVars
970	integer :: NumVars
971	integer :: i
972	character (NF_MAX_NAME) :: Name
973
974	if(WrfIOnotInitialized) then
975	Status = WRF_IO_NOT_INITIALIZED
976	write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
977	call wrf_debug ( FATAL , msg)
978	return
979	endif
980	call allocHandle(DataHandle,DH,Comm,Status)
981	if(Status /= WRF_NO_ERR) then
982	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
983	call wrf_debug ( WARN , TRIM(msg))
984	return
985	endif
986	stat = NF_OPEN(FileName, NF_NOWRITE, DH%NCID)
987	call netcdf_err(stat,Status)
988	if(Status /= WRF_NO_ERR) then
989	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
990	call wrf_debug ( WARN , TRIM(msg))
991	return
992	endif
993	stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID)
994	call netcdf_err(stat,Status)
995	if(Status /= WRF_NO_ERR) then
996	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
997	call wrf_debug ( WARN , TRIM(msg))
998	return
999	endif
1000	stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts)
1001	call netcdf_err(stat,Status)
1002	if(Status /= WRF_NO_ERR) then
1003	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1004	call wrf_debug ( WARN , TRIM(msg))
1005	return
1006	endif
1007	if(XType/=NF_CHAR) then
1008	Status = WRF_WARN_TYPE_MISMATCH
1009	write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1010	call wrf_debug ( WARN , TRIM(msg))
1011	return
1012	endif
1013	stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1))
1014	call netcdf_err(stat,Status)
1015	if(Status /= WRF_NO_ERR) then
1016	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1017	call wrf_debug ( WARN , TRIM(msg))
1018	return
1019	endif
1020	if(VLen(1) /= DateStrLen) then
1021	Status = WRF_WARN_DATESTR_BAD_LENGTH
1022	write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__
1023	call wrf_debug ( WARN , TRIM(msg))
1024	return
1025	endif
1026	stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2))
1027	call netcdf_err(stat,Status)
1028	if(Status /= WRF_NO_ERR) then
1029	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1030	call wrf_debug ( WARN , TRIM(msg))
1031	return
1032	endif
1033	if(VLen(2) > MaxTimes) then
1034	Status = WRF_ERR_FATAL_TOO_MANY_TIMES
1035	write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__
1036	call wrf_debug ( FATAL , TRIM(msg))
1037	return
1038	endif
1039	VStart(1) = 1
1040	VStart(2) = 1
1041	stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times)
1042	call netcdf_err(stat,Status)
1043	if(Status /= WRF_NO_ERR) then
1044	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1045	call wrf_debug ( WARN , TRIM(msg))
1046	return
1047	endif
1048	stat = NF_INQ_NVARS(DH%NCID,TotalNumVars)
1049	call netcdf_err(stat,Status)
1050	if(Status /= WRF_NO_ERR) then
1051	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1052	call wrf_debug ( WARN , TRIM(msg))
1053	return
1054	endif
1055	NumVars = 0
1056	do i=1,TotalNumVars
1057	stat = NF_INQ_VARNAME(DH%NCID,i,Name)
1058	call netcdf_err(stat,Status)
1059	if(Status /= WRF_NO_ERR) then
1060	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1061	call wrf_debug ( WARN , TRIM(msg))
1062	return
1063	elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then
1064	NumVars = NumVars+1
1065	DH%VarNames(NumVars) = Name
1066	DH%VarIDs(NumVars) = i
1067	endif
1068	enddo
1069	DH%NumVars = NumVars
1070	DH%NumberTimes = VLen(2)
1071	DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
1072	DH%FileName = FileName
1073	DH%CurrentVariable = 0
1074	DH%CurrentTime = 0
1075	DH%TimesVarID = VarID
1076	DH%TimeIndex = 0
1077	return
1078	end subroutine ext_ncd_open_for_read_begin
1079
1080	subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status)
1081	use wrf_data
1082	use ext_ncd_support_routines
1083	implicit none
1084	include 'wrf_status_codes.h'
1085	include 'netcdf.inc'
1086	character() ,intent(IN) :: FileName
1087	integer ,intent(IN) :: Comm
1088	integer ,intent(IN) :: IOComm
1089	character() ,intent(in) :: SysDepInfo
1090	integer ,intent(out) :: DataHandle
1091	integer ,intent(out) :: Status
1092	type(wrf_data_handle) ,pointer :: DH
1093	integer :: XType
1094	integer :: stat
1095	integer ,allocatable :: Buffer(:)
1096	integer :: VarID
1097	integer :: StoredDim
1098	integer :: NAtts
1099	integer :: DimIDs(2)
1100	integer :: VStart(2)
1101	integer :: VLen(2)
1102	integer :: TotalNumVars
1103	integer :: NumVars
1104	integer :: i
1105	character (NF_MAX_NAME) :: Name
1106
1107	if(WrfIOnotInitialized) then
1108	Status = WRF_IO_NOT_INITIALIZED
1109	write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1110	call wrf_debug ( FATAL , msg)
1111	return
1112	endif
1113	call allocHandle(DataHandle,DH,Comm,Status)
1114	if(Status /= WRF_NO_ERR) then
1115	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
1116	call wrf_debug ( WARN , TRIM(msg))
1117	return
1118	endif
1119	stat = NF_OPEN(FileName, NF_WRITE, DH%NCID)
1120	call netcdf_err(stat,Status)
1121	if(Status /= WRF_NO_ERR) then
1122	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1123	call wrf_debug ( WARN , TRIM(msg))
1124	return
1125	endif
1126	stat = NF_INQ_VARID(DH%NCID,DH%TimesName,VarID)
1127	call netcdf_err(stat,Status)
1128	if(Status /= WRF_NO_ERR) then
1129	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1130	call wrf_debug ( WARN , TRIM(msg))
1131	return
1132	endif
1133	stat = NF_INQ_VAR(DH%NCID,VarID,DH%TimesName, XType, StoredDim, DimIDs, NAtts)
1134	call netcdf_err(stat,Status)
1135	if(Status /= WRF_NO_ERR) then
1136	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1137	call wrf_debug ( WARN , TRIM(msg))
1138	return
1139	endif
1140	if(XType/=NF_CHAR) then
1141	Status = WRF_WARN_TYPE_MISMATCH
1142	write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
1143	call wrf_debug ( WARN , TRIM(msg))
1144	return
1145	endif
1146	stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(1),VLen(1))
1147	call netcdf_err(stat,Status)
1148	if(Status /= WRF_NO_ERR) then
1149	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1150	call wrf_debug ( WARN , TRIM(msg))
1151	return
1152	endif
1153	if(VLen(1) /= DateStrLen) then
1154	Status = WRF_WARN_DATESTR_BAD_LENGTH
1155	write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__
1156	call wrf_debug ( WARN , TRIM(msg))
1157	return
1158	endif
1159	stat = NF_INQ_DIMLEN(DH%NCID,DimIDs(2),VLen(2))
1160	call netcdf_err(stat,Status)
1161	if(Status /= WRF_NO_ERR) then
1162	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1163	call wrf_debug ( WARN , TRIM(msg))
1164	return
1165	endif
1166	if(VLen(2) > MaxTimes) then
1167	Status = WRF_ERR_FATAL_TOO_MANY_TIMES
1168	write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__
1169	call wrf_debug ( FATAL , TRIM(msg))
1170	return
1171	endif
1172	VStart(1) = 1
1173	VStart(2) = 1
1174	stat = NF_GET_VARA_TEXT(DH%NCID,VarID,VStart,VLen,DH%Times)
1175	call netcdf_err(stat,Status)
1176	if(Status /= WRF_NO_ERR) then
1177	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1178	call wrf_debug ( WARN , TRIM(msg))
1179	return
1180	endif
1181	stat = NF_INQ_NVARS(DH%NCID,TotalNumVars)
1182	call netcdf_err(stat,Status)
1183	if(Status /= WRF_NO_ERR) then
1184	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1185	call wrf_debug ( WARN , TRIM(msg))
1186	return
1187	endif
1188	NumVars = 0
1189	do i=1,TotalNumVars
1190	stat = NF_INQ_VARNAME(DH%NCID,i,Name)
1191	call netcdf_err(stat,Status)
1192	if(Status /= WRF_NO_ERR) then
1193	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1194	call wrf_debug ( WARN , TRIM(msg))
1195	return
1196	elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then
1197	NumVars = NumVars+1
1198	DH%VarNames(NumVars) = Name
1199	DH%VarIDs(NumVars) = i
1200	endif
1201	enddo
1202	DH%NumVars = NumVars
1203	DH%NumberTimes = VLen(2)
1204	DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE
1205	DH%FileName = FileName
1206	DH%CurrentVariable = 0
1207	DH%CurrentTime = 0
1208	DH%TimesVarID = VarID
1209	DH%TimeIndex = 0
1210	return
1211	end subroutine ext_ncd_open_for_update
1212
1213
1214	SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHandle,Status)
1215	use wrf_data
1216	use ext_ncd_support_routines
1217	implicit none
1218	include 'wrf_status_codes.h'
1219	include 'netcdf.inc'
1220	character() ,intent(in) :: FileName
1221	integer ,intent(in) :: Comm
1222	integer ,intent(in) :: IOComm
1223	character() ,intent(in) :: SysDepInfo
1224	integer ,intent(out) :: DataHandle
1225	integer ,intent(out) :: Status
1226	type(wrf_data_handle),pointer :: DH
1227	integer :: i
1228	integer :: stat
1229	character (7) :: Buffer
1230	integer :: VDimIDs(2)
1231	integer , external :: bit_or
1232
1233	if(WrfIOnotInitialized) then
1234	Status = WRF_IO_NOT_INITIALIZED
1235	write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1236	call wrf_debug ( FATAL , msg)
1237	return
1238	endif
1239	call allocHandle(DataHandle,DH,Comm,Status)
1240	if(Status /= WRF_NO_ERR) then
1241	write(msg,*) 'Fatal ALLOCATION ERROR in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1242	call wrf_debug ( FATAL , TRIM(msg))
1243	return
1244	endif
1245	DH%TimeIndex = 0
1246	DH%Times = ZeroDate
1247	#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
1248	stat = NF_CREATE(FileName, bit_or(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
1249	#else
1250	stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
1251	#endif
1252	call netcdf_err(stat,Status)
1253	if(Status /= WRF_NO_ERR) then
1254	write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1255	call wrf_debug ( WARN , TRIM(msg))
1256	return
1257	endif
1258	DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
1259	DH%FileName = FileName
1260	stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID)
1261	call netcdf_err(stat,Status)
1262	if(Status /= WRF_NO_ERR) then
1263	write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1264	call wrf_debug ( WARN , TRIM(msg))
1265	return
1266	endif
1267	DH%VarNames (1:MaxVars) = NO_NAME
1268	DH%MDVarNames(1:MaxVars) = NO_NAME
1269	do i=1,MaxDims
1270	write(Buffer,FMT="('DIM',i4.4)") i
1271	DH%DimNames (i) = Buffer
1272	DH%DimLengths(i) = NO_DIM
1273	enddo
1274	DH%DimNames(1) = 'DateStrLen'
1275	stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1))
1276	call netcdf_err(stat,Status)
1277	if(Status /= WRF_NO_ERR) then
1278	write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1279	call wrf_debug ( WARN , TRIM(msg))
1280	return
1281	endif
1282	VDimIDs(1) = DH%DimIDs(1)
1283	VDimIDs(2) = DH%DimUnlimID
1284	stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID)
1285	call netcdf_err(stat,Status)
1286	if(Status /= WRF_NO_ERR) then
1287	write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
1288	call wrf_debug ( WARN , TRIM(msg))
1289	return
1290	endif
1291	DH%DimLengths(1) = DateStrLen
1292
1293	if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then
1294	DH%R4OnOutput = .true.
1295	end if
1296
1297	return
1298	end subroutine ext_ncd_open_for_write_begin
1299
1300	!stub
1301	!opens a file for writing or coupler datastream for sending messages.
1302	!no training phase for this version of the open stmt.
1303	subroutine ext_ncd_open_for_write (DatasetName, Comm1, Comm2, &
1304	SysDepInfo, DataHandle, Status)
1305	use wrf_data
1306	use ext_ncd_support_routines
1307	implicit none
1308	include 'wrf_status_codes.h'
1309	include 'netcdf.inc'
1310	character (), intent(in) ::DatasetName
1311	integer , intent(in) ::Comm1, Comm2
1312	character (), intent(in) ::SysDepInfo
1313	integer , intent(out) :: DataHandle
1314	integer , intent(out) :: Status
1315	Status=WRF_WARN_NOOP
1316	DataHandle = 0 ! dummy setting to quiet warning message
1317	return
1318	end subroutine ext_ncd_open_for_write
1319
1320	SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status)
1321	use wrf_data
1322	use ext_ncd_support_routines
1323	implicit none
1324	include 'wrf_status_codes.h'
1325	include 'netcdf.inc'
1326	integer ,intent(in) :: DataHandle
1327	integer ,intent(out) :: Status
1328	type(wrf_data_handle),pointer :: DH
1329	integer :: i
1330	integer :: stat
1331
1332	if(WrfIOnotInitialized) then
1333	Status = WRF_IO_NOT_INITIALIZED
1334	write(msg,*) 'ext_ncd_open_for_write_commit: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1335	call wrf_debug ( FATAL , msg)
1336	return
1337	endif
1338	call GetDH(DataHandle,DH,Status)
1339	if(Status /= WRF_NO_ERR) then
1340	write(msg,*) 'Warning Status = ',Status,' in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__
1341	call wrf_debug ( WARN , TRIM(msg))
1342	return
1343	endif
1344	stat = NF_ENDDEF(DH%NCID)
1345	call netcdf_err(stat,Status)
1346	if(Status /= WRF_NO_ERR) then
1347	write(msg,*) 'NetCDF error in ext_ncd_open_for_write_commit ',__FILE__,', line', __LINE__
1348	call wrf_debug ( WARN , TRIM(msg))
1349	return
1350	endif
1351	DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE
1352	DH%first_operation = .TRUE.
1353	return
1354	end subroutine ext_ncd_open_for_write_commit
1355
1356	subroutine ext_ncd_ioclose(DataHandle, Status)
1357	use wrf_data
1358	use ext_ncd_support_routines
1359	implicit none
1360	include 'wrf_status_codes.h'
1361	include 'netcdf.inc'
1362	integer ,intent(in) :: DataHandle
1363	integer ,intent(out) :: Status
1364	type(wrf_data_handle),pointer :: DH
1365	integer :: stat
1366
1367	call GetDH(DataHandle,DH,Status)
1368	if(Status /= WRF_NO_ERR) then
1369	write(msg,*) 'Warning Status = ',Status,' in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1370	call wrf_debug ( WARN , TRIM(msg))
1371	return
1372	endif
1373	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1374	Status = WRF_WARN_FILE_NOT_OPENED
1375	write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1376	call wrf_debug ( WARN , TRIM(msg))
1377	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1378	Status = WRF_WARN_DRYRUN_CLOSE
1379	write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1380	call wrf_debug ( WARN , TRIM(msg))
1381	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1382	continue
1383	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1384	continue
1385	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
1386	continue
1387	else
1388	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1389	write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1390	call wrf_debug ( FATAL , TRIM(msg))
1391	return
1392	endif
1393
1394	stat = NF_CLOSE(DH%NCID)
1395	call netcdf_err(stat,Status)
1396	if(Status /= WRF_NO_ERR) then
1397	write(msg,*) 'NetCDF error in ext_ncd_ioclose ',__FILE__,', line', __LINE__
1398	call wrf_debug ( WARN , TRIM(msg))
1399	return
1400	endif
1401	CALL deallocHandle( DataHandle, Status )
1402	DH%Free=.true.
1403	return
1404	end subroutine ext_ncd_ioclose
1405
1406	subroutine ext_ncd_iosync( DataHandle, Status)
1407	use wrf_data
1408	use ext_ncd_support_routines
1409	implicit none
1410	include 'wrf_status_codes.h'
1411	include 'netcdf.inc'
1412	integer ,intent(in) :: DataHandle
1413	integer ,intent(out) :: Status
1414	type(wrf_data_handle),pointer :: DH
1415	integer :: stat
1416
1417	call GetDH(DataHandle,DH,Status)
1418	if(Status /= WRF_NO_ERR) then
1419	write(msg,*) 'Warning Status = ',Status,' in ext_ncd_iosync ',__FILE__,', line', __LINE__
1420	call wrf_debug ( WARN , TRIM(msg))
1421	return
1422	endif
1423	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1424	Status = WRF_WARN_FILE_NOT_OPENED
1425	write(msg,*) 'Warning FILE NOT OPENED in ext_ncd_iosync ',__FILE__,', line', __LINE__
1426	call wrf_debug ( WARN , TRIM(msg))
1427	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1428	Status = WRF_WARN_FILE_NOT_COMMITTED
1429	write(msg,*) 'Warning FILE NOT COMMITTED in ext_ncd_iosync ',__FILE__,', line', __LINE__
1430	call wrf_debug ( WARN , TRIM(msg))
1431	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1432	continue
1433	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1434	continue
1435	else
1436	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1437	write(msg,*) 'Fatal error BAD FILE STATUS in ext_ncd_iosync ',__FILE__,', line', __LINE__
1438	call wrf_debug ( FATAL , TRIM(msg))
1439	return
1440	endif
1441	stat = NF_SYNC(DH%NCID)
1442	call netcdf_err(stat,Status)
1443	if(Status /= WRF_NO_ERR) then
1444	write(msg,*) 'NetCDF error in ext_ncd_iosync ',__FILE__,', line', __LINE__
1445	call wrf_debug ( WARN , TRIM(msg))
1446	return
1447	endif
1448	return
1449	end subroutine ext_ncd_iosync
1450
1451
1452
1453	subroutine ext_ncd_redef( DataHandle, Status)
1454	use wrf_data
1455	use ext_ncd_support_routines
1456	implicit none
1457	include 'wrf_status_codes.h'
1458	include 'netcdf.inc'
1459	integer ,intent(in) :: DataHandle
1460	integer ,intent(out) :: Status
1461	type(wrf_data_handle),pointer :: DH
1462	integer :: stat
1463
1464	call GetDH(DataHandle,DH,Status)
1465	if(Status /= WRF_NO_ERR) then
1466	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1467	call wrf_debug ( WARN , TRIM(msg))
1468	return
1469	endif
1470	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1471	Status = WRF_WARN_FILE_NOT_OPENED
1472	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1473	call wrf_debug ( WARN , TRIM(msg))
1474	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1475	Status = WRF_WARN_FILE_NOT_COMMITTED
1476	write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1477	call wrf_debug ( WARN , TRIM(msg))
1478	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1479	continue
1480	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1481	Status = WRF_WARN_FILE_OPEN_FOR_READ
1482	write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
1483	call wrf_debug ( WARN , TRIM(msg))
1484	else
1485	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1486	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1487	call wrf_debug ( FATAL , TRIM(msg))
1488	return
1489	endif
1490	stat = NF_REDEF(DH%NCID)
1491	call netcdf_err(stat,Status)
1492	if(Status /= WRF_NO_ERR) then
1493	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1494	call wrf_debug ( WARN , TRIM(msg))
1495	return
1496	endif
1497	DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED
1498	return
1499	end subroutine ext_ncd_redef
1500
1501	subroutine ext_ncd_enddef( DataHandle, Status)
1502	use wrf_data
1503	use ext_ncd_support_routines
1504	implicit none
1505	include 'wrf_status_codes.h'
1506	include 'netcdf.inc'
1507	integer ,intent(in) :: DataHandle
1508	integer ,intent(out) :: Status
1509	type(wrf_data_handle),pointer :: DH
1510	integer :: stat
1511
1512	call GetDH(DataHandle,DH,Status)
1513	if(Status /= WRF_NO_ERR) then
1514	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
1515	call wrf_debug ( WARN , TRIM(msg))
1516	return
1517	endif
1518	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
1519	Status = WRF_WARN_FILE_NOT_OPENED
1520	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
1521	call wrf_debug ( WARN , TRIM(msg))
1522	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
1523	Status = WRF_WARN_FILE_NOT_COMMITTED
1524	write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
1525	call wrf_debug ( WARN , TRIM(msg))
1526	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
1527	continue
1528	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
1529	Status = WRF_WARN_FILE_OPEN_FOR_READ
1530	write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
1531	call wrf_debug ( WARN , TRIM(msg))
1532	else
1533	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1534	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
1535	call wrf_debug ( FATAL , TRIM(msg))
1536	return
1537	endif
1538	stat = NF_ENDDEF(DH%NCID)
1539	call netcdf_err(stat,Status)
1540	if(Status /= WRF_NO_ERR) then
1541	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
1542	call wrf_debug ( WARN , TRIM(msg))
1543	return
1544	endif
1545	DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE
1546	return
1547	end subroutine ext_ncd_enddef
1548
1549	subroutine ext_ncd_ioinit(SysDepInfo, Status)
1550	use wrf_data
1551	implicit none
1552	include 'wrf_status_codes.h'
1553	CHARACTER(), INTENT(IN) :: SysDepInfo
1554	INTEGER ,INTENT(INOUT) :: Status
1555
1556	WrfIOnotInitialized = .false.
1557	WrfDataHandles(1:WrfDataHandleMax)%Free = .true.
1558	WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times'
1559	WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time'
1560	WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED
1561	Status = WRF_NO_ERR
1562	return
1563	end subroutine ext_ncd_ioinit
1564
1565
1566	subroutine ext_ncd_inquiry (Inquiry, Result, Status)
1567	use wrf_data
1568	implicit none
1569	include 'wrf_status_codes.h'
1570	character (), INTENT(IN) :: Inquiry
1571	character (), INTENT(OUT) :: Result
1572	integer ,INTENT(INOUT) :: Status
1573	SELECT CASE (Inquiry)
1574	CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ")
1575	Result='ALLOW'
1576	CASE ("OPEN_READ","OPEN_COMMIT_WRITE")
1577	Result='REQUIRE'
1578	CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO")
1579	Result='NO'
1580	CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS")
1581	Result='YES'
1582	CASE ("MEDIUM")
1583	Result ='FILE'
1584	CASE DEFAULT
1585	Result = 'No Result for that inquiry!'
1586	END SELECT
1587	Status=WRF_NO_ERR
1588	return
1589	end subroutine ext_ncd_inquiry
1590
1591
1592
1593
1594	subroutine ext_ncd_ioexit(Status)
1595	use wrf_data
1596	use ext_ncd_support_routines
1597	implicit none
1598	include 'wrf_status_codes.h'
1599	include 'netcdf.inc'
1600	integer , INTENT(INOUT) ::Status
1601	integer :: error
1602	type(wrf_data_handle),pointer :: DH
1603	integer :: i
1604	integer :: stat
1605	if(WrfIOnotInitialized) then
1606	Status = WRF_IO_NOT_INITIALIZED
1607	write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
1608	call wrf_debug ( FATAL , msg)
1609	return
1610	endif
1611	do i=1,WrfDataHandleMax
1612	CALL deallocHandle( i , stat )
1613	enddo
1614	return
1615	end subroutine ext_ncd_ioexit
1616
1617	subroutine ext_ncd_get_dom_ti_real(DataHandle,Element,Data,Count,OutCount,Status)
1618	#define ROUTINE_TYPE 'REAL'
1619	#define TYPE_DATA real,intent(out) :: Data(*)
1620	#define TYPE_COUNT integer,intent(in) :: Count
1621	#define TYPE_OUTCOUNT integer,intent(out) :: OutCOunt
1622	#define TYPE_BUFFER real,allocatable :: Buffer(:)
1623	#define NF_TYPE NF_FLOAT
1624	#define NF_ROUTINE NF_GET_ATT_REAL
1625	#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1626	#include "ext_ncd_get_dom_ti.code"
1627	end subroutine ext_ncd_get_dom_ti_real
1628
1629	subroutine ext_ncd_get_dom_ti_integer(DataHandle,Element,Data,Count,OutCount,Status)
1630	#undef ROUTINE_TYPE
1631	#undef TYPE_DATA
1632	#undef TYPE_BUFFER
1633	#undef NF_TYPE
1634	#undef NF_ROUTINE
1635	#undef COPY
1636	#define ROUTINE_TYPE 'INTEGER'
1637	#define TYPE_DATA integer,intent(out) :: Data(*)
1638	#define TYPE_BUFFER integer,allocatable :: Buffer(:)
1639	#define NF_TYPE NF_INT
1640	#define NF_ROUTINE NF_GET_ATT_INT
1641	#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1642	#include "ext_ncd_get_dom_ti.code"
1643	end subroutine ext_ncd_get_dom_ti_integer
1644
1645	subroutine ext_ncd_get_dom_ti_double(DataHandle,Element,Data,Count,OutCount,Status)
1646	#undef ROUTINE_TYPE
1647	#undef TYPE_DATA
1648	#undef TYPE_BUFFER
1649	#undef NF_TYPE
1650	#undef NF_ROUTINE
1651	#undef COPY
1652	#define ROUTINE_TYPE 'DOUBLE'
1653	#define TYPE_DATA real8,intent(out) :: Data()
1654	#define TYPE_BUFFER real*8,allocatable :: Buffer(:)
1655	#define NF_TYPE NF_DOUBLE
1656	#define NF_ROUTINE NF_GET_ATT_DOUBLE
1657	#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))
1658	#include "ext_ncd_get_dom_ti.code"
1659	end subroutine ext_ncd_get_dom_ti_double
1660
1661	subroutine ext_ncd_get_dom_ti_logical(DataHandle,Element,Data,Count,OutCount,Status)
1662	#undef ROUTINE_TYPE
1663	#undef TYPE_DATA
1664	#undef TYPE_BUFFER
1665	#undef NF_TYPE
1666	#undef NF_ROUTINE
1667	#undef COPY
1668	#define ROUTINE_TYPE 'LOGICAL'
1669	#define TYPE_DATA logical,intent(out) :: Data(*)
1670	#define TYPE_BUFFER integer,allocatable :: Buffer(:)
1671	#define NF_TYPE NF_INT
1672	#define NF_ROUTINE NF_GET_ATT_INT
1673	#define COPY Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1
1674	#include "ext_ncd_get_dom_ti.code"
1675	end subroutine ext_ncd_get_dom_ti_logical
1676
1677	subroutine ext_ncd_get_dom_ti_char(DataHandle,Element,Data,Status)
1678	#undef ROUTINE_TYPE
1679	#undef TYPE_DATA
1680	#undef TYPE_COUNT
1681	#undef TYPE_OUTCOUNT
1682	#undef TYPE_BUFFER
1683	#undef NF_TYPE
1684	#define ROUTINE_TYPE 'CHAR'
1685	#define TYPE_DATA character(),intent(out) :: Data
1686	#define TYPE_COUNT
1687	#define TYPE_OUTCOUNT
1688	#define TYPE_BUFFER
1689	#define NF_TYPE NF_CHAR
1690	#define CHAR_TYPE
1691	#include "ext_ncd_get_dom_ti.code"
1692	#undef CHAR_TYPE
1693	end subroutine ext_ncd_get_dom_ti_char
1694
1695	subroutine ext_ncd_put_dom_ti_real(DataHandle,Element,Data,Count,Status)
1696	#undef ROUTINE_TYPE
1697	#undef TYPE_DATA
1698	#undef TYPE_COUNT
1699	#undef NF_ROUTINE
1700	#undef ARGS
1701	#undef LOG
1702	#define ROUTINE_TYPE 'REAL'
1703	#define TYPE_DATA real ,intent(in) :: Data(*)
1704	#define TYPE_COUNT integer,intent(in) :: Count
1705	#define NF_ROUTINE NF_PUT_ATT_REAL
1706	#define ARGS NF_FLOAT,Count,Data
1707	#include "ext_ncd_put_dom_ti.code"
1708	end subroutine ext_ncd_put_dom_ti_real
1709
1710	subroutine ext_ncd_put_dom_ti_integer(DataHandle,Element,Data,Count,Status)
1711	#undef ROUTINE_TYPE
1712	#undef TYPE_DATA
1713	#undef TYPE_COUNT
1714	#undef NF_ROUTINE
1715	#undef ARGS
1716	#undef LOG
1717	#define ROUTINE_TYPE 'INTEGER'
1718	#define TYPE_DATA integer,intent(in) :: Data(*)
1719	#define TYPE_COUNT integer,intent(in) :: Count
1720	#define NF_ROUTINE NF_PUT_ATT_INT
1721	#define ARGS NF_INT,Count,Data
1722	#include "ext_ncd_put_dom_ti.code"
1723	end subroutine ext_ncd_put_dom_ti_integer
1724
1725	subroutine ext_ncd_put_dom_ti_double(DataHandle,Element,Data,Count,Status)
1726	#undef ROUTINE_TYPE
1727	#undef TYPE_DATA
1728	#undef TYPE_COUNT
1729	#undef NF_ROUTINE
1730	#undef ARGS
1731	#undef LOG
1732	#define ROUTINE_TYPE 'DOUBLE'
1733	#define TYPE_DATA real8 ,intent(in) :: Data()
1734	#define TYPE_COUNT integer,intent(in) :: Count
1735	#define NF_ROUTINE NF_PUT_ATT_DOUBLE
1736	#define ARGS NF_DOUBLE,Count,Data
1737	#include "ext_ncd_put_dom_ti.code"
1738	end subroutine ext_ncd_put_dom_ti_double
1739
1740	subroutine ext_ncd_put_dom_ti_logical(DataHandle,Element,Data,Count,Status)
1741	#undef ROUTINE_TYPE
1742	#undef TYPE_DATA
1743	#undef TYPE_COUNT
1744	#undef NF_ROUTINE
1745	#undef ARGS
1746	#define ROUTINE_TYPE 'LOGICAL'
1747	#define TYPE_DATA logical,intent(in) :: Data(*)
1748	#define TYPE_COUNT integer,intent(in) :: Count
1749	#define NF_ROUTINE NF_PUT_ATT_INT
1750	#define ARGS NF_INT,Count,Buffer
1751	#define LOG
1752	#include "ext_ncd_put_dom_ti.code"
1753	end subroutine ext_ncd_put_dom_ti_logical
1754
1755	subroutine ext_ncd_put_dom_ti_char(DataHandle,Element,Data,Status)
1756	#undef ROUTINE_TYPE
1757	#undef TYPE_DATA
1758	#undef TYPE_COUNT
1759	#undef NF_ROUTINE
1760	#undef ARGS
1761	#undef LOG
1762	#define ROUTINE_TYPE 'CHAR'
1763	#define TYPE_DATA character(),intent(in) :: Data
1764	#define TYPE_COUNT integer,parameter :: Count=1
1765	#define NF_ROUTINE NF_PUT_ATT_TEXT
1766	#define ARGS len_trim(Data),Data
1767	#include "ext_ncd_put_dom_ti.code"
1768	end subroutine ext_ncd_put_dom_ti_char
1769
1770	subroutine ext_ncd_put_var_ti_real(DataHandle,Element,Var,Data,Count,Status)
1771	#undef ROUTINE_TYPE
1772	#undef TYPE_DATA
1773	#undef TYPE_COUNT
1774	#undef NF_ROUTINE
1775	#undef ARGS
1776	#undef LOG
1777	#define ROUTINE_TYPE 'REAL'
1778	#define TYPE_DATA real ,intent(in) :: Data(*)
1779	#define TYPE_COUNT integer ,intent(in) :: Count
1780	#define NF_ROUTINE NF_PUT_ATT_REAL
1781	#define ARGS NF_FLOAT,Count,Data
1782	#include "ext_ncd_put_var_ti.code"
1783	end subroutine ext_ncd_put_var_ti_real
1784
1785	subroutine ext_ncd_put_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,Status)
1786	#undef ROUTINE_TYPE
1787	#undef TYPE_DATA
1788	#undef TYPE_COUNT
1789	#undef NF_ROUTINE
1790	#undef NF_TYPE
1791	#undef LENGTH
1792	#undef ARG
1793	#undef LOG
1794	#define ROUTINE_TYPE 'REAL'
1795	#define TYPE_DATA real ,intent(in) :: Data(*)
1796	#define TYPE_COUNT integer ,intent(in) :: Count
1797	#define NF_ROUTINE NF_PUT_VARA_REAL
1798	#define NF_TYPE NF_FLOAT
1799	#define LENGTH Count
1800	#define ARG
1801	#include "ext_ncd_put_var_td.code"
1802	end subroutine ext_ncd_put_var_td_real
1803
1804	subroutine ext_ncd_put_var_ti_double(DataHandle,Element,Var,Data,Count,Status)
1805	#undef ROUTINE_TYPE
1806	#undef TYPE_DATA
1807	#undef TYPE_COUNT
1808	#undef NF_ROUTINE
1809	#undef ARGS
1810	#undef LOG
1811	#define ROUTINE_TYPE 'DOUBLE'
1812	#define TYPE_DATA real8 ,intent(in) :: Data()
1813	#define TYPE_COUNT integer ,intent(in) :: Count
1814	#define NF_ROUTINE NF_PUT_ATT_DOUBLE
1815	#define ARGS NF_DOUBLE,Count,Data
1816	#include "ext_ncd_put_var_ti.code"
1817	end subroutine ext_ncd_put_var_ti_double
1818
1819	subroutine ext_ncd_put_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,Status)
1820	#undef ROUTINE_TYPE
1821	#undef TYPE_DATA
1822	#undef TYPE_COUNT
1823	#undef NF_ROUTINE
1824	#undef NF_TYPE
1825	#undef LENGTH
1826	#undef ARG
1827	#undef LOG
1828	#define ROUTINE_TYPE 'DOUBLE'
1829	#define TYPE_DATA real8,intent(in) :: Data()
1830	#define TYPE_COUNT integer ,intent(in) :: Count
1831	#define NF_ROUTINE NF_PUT_VARA_DOUBLE
1832	#define NF_TYPE NF_DOUBLE
1833	#define LENGTH Count
1834	#define ARG
1835	#include "ext_ncd_put_var_td.code"
1836	end subroutine ext_ncd_put_var_td_double
1837
1838	subroutine ext_ncd_put_var_ti_integer(DataHandle,Element,Var,Data,Count,Status)
1839	#undef ROUTINE_TYPE
1840	#undef TYPE_DATA
1841	#undef TYPE_COUNT
1842	#undef NF_ROUTINE
1843	#undef ARGS
1844	#undef LOG
1845	#define ROUTINE_TYPE 'INTEGER'
1846	#define TYPE_DATA integer ,intent(in) :: Data(*)
1847	#define TYPE_COUNT integer ,intent(in) :: Count
1848	#define NF_ROUTINE NF_PUT_ATT_INT
1849	#define ARGS NF_INT,Count,Data
1850	#include "ext_ncd_put_var_ti.code"
1851	end subroutine ext_ncd_put_var_ti_integer
1852
1853	subroutine ext_ncd_put_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,Status)
1854	#undef ROUTINE_TYPE
1855	#undef TYPE_DATA
1856	#undef TYPE_COUNT
1857	#undef NF_ROUTINE
1858	#undef NF_TYPE
1859	#undef LENGTH
1860	#undef ARG
1861	#undef LOG
1862	#define ROUTINE_TYPE 'INTEGER'
1863	#define TYPE_DATA integer ,intent(in) :: Data(*)
1864	#define TYPE_COUNT integer ,intent(in) :: Count
1865	#define NF_ROUTINE NF_PUT_VARA_INT
1866	#define NF_TYPE NF_INT
1867	#define LENGTH Count
1868	#define ARG
1869	#include "ext_ncd_put_var_td.code"
1870	end subroutine ext_ncd_put_var_td_integer
1871
1872	subroutine ext_ncd_put_var_ti_logical(DataHandle,Element,Var,Data,Count,Status)
1873	#undef ROUTINE_TYPE
1874	#undef TYPE_DATA
1875	#undef TYPE_COUNT
1876	#undef NF_ROUTINE
1877	#undef ARGS
1878	#define ROUTINE_TYPE 'LOGICAL'
1879	#define TYPE_DATA logical ,intent(in) :: Data(*)
1880	#define TYPE_COUNT integer ,intent(in) :: Count
1881	#define NF_ROUTINE NF_PUT_ATT_INT
1882	#define LOG
1883	#define ARGS NF_INT,Count,Buffer
1884	#include "ext_ncd_put_var_ti.code"
1885	end subroutine ext_ncd_put_var_ti_logical
1886
1887	subroutine ext_ncd_put_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,Status)
1888	#undef ROUTINE_TYPE
1889	#undef TYPE_DATA
1890	#undef TYPE_COUNT
1891	#undef NF_ROUTINE
1892	#undef NF_TYPE
1893	#undef LENGTH
1894	#undef ARG
1895	#define ROUTINE_TYPE 'LOGICAL'
1896	#define TYPE_DATA logical ,intent(in) :: Data(*)
1897	#define TYPE_COUNT integer ,intent(in) :: Count
1898	#define NF_ROUTINE NF_PUT_VARA_INT
1899	#define NF_TYPE NF_INT
1900	#define LOG
1901	#define LENGTH Count
1902	#define ARG
1903	#include "ext_ncd_put_var_td.code"
1904	end subroutine ext_ncd_put_var_td_logical
1905
1906	subroutine ext_ncd_put_var_ti_char(DataHandle,Element,Var,Data,Status)
1907	#undef ROUTINE_TYPE
1908	#undef TYPE_DATA
1909	#undef TYPE_COUNT
1910	#undef NF_ROUTINE
1911	#undef ARGS
1912	#undef LOG
1913	#define ROUTINE_TYPE 'CHAR'
1914	#define TYPE_DATA character() ,intent(in) :: Data
1915	#define TYPE_COUNT
1916	#define NF_ROUTINE NF_PUT_ATT_TEXT
1917	#define ARGS len_trim(Data),trim(Data)
1918	#define CHAR_TYPE
1919	#include "ext_ncd_put_var_ti.code"
1920	#undef CHAR_TYPE
1921	end subroutine ext_ncd_put_var_ti_char
1922
1923	subroutine ext_ncd_put_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
1924	#undef ROUTINE_TYPE
1925	#undef TYPE_DATA
1926	#undef TYPE_COUNT
1927	#undef NF_ROUTINE
1928	#undef NF_TYPE
1929	#undef LENGTH
1930	#undef ARG
1931	#undef LOG
1932	#define ROUTINE_TYPE 'CHAR'
1933	#define TYPE_DATA character() ,intent(in) :: Data
1934	#define TYPE_COUNT
1935	#define NF_ROUTINE NF_PUT_VARA_TEXT
1936	#define NF_TYPE NF_CHAR
1937	#define LENGTH len(Data)
1938	#include "ext_ncd_put_var_td.code"
1939	end subroutine ext_ncd_put_var_td_char
1940
1941	subroutine ext_ncd_get_var_ti_real(DataHandle,Element,Var,Data,Count,OutCount,Status)
1942	#undef ROUTINE_TYPE
1943	#undef TYPE_DATA
1944	#undef TYPE_BUFFER
1945	#undef TYPE_COUNT
1946	#undef TYPE_OUTCOUNT
1947	#undef NF_TYPE
1948	#undef NF_ROUTINE
1949	#undef COPY
1950	#define ROUTINE_TYPE 'REAL'
1951	#define TYPE_DATA real ,intent(out) :: Data(*)
1952	#define TYPE_BUFFER real ,allocatable :: Buffer(:)
1953	#define TYPE_COUNT integer,intent(in) :: Count
1954	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1955	#define NF_TYPE NF_FLOAT
1956	#define NF_ROUTINE NF_GET_ATT_REAL
1957	#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
1958	#include "ext_ncd_get_var_ti.code"
1959	end subroutine ext_ncd_get_var_ti_real
1960
1961	subroutine ext_ncd_get_var_td_real(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
1962	#undef ROUTINE_TYPE
1963	#undef TYPE_DATA
1964	#undef TYPE_BUFFER
1965	#undef TYPE_COUNT
1966	#undef TYPE_OUTCOUNT
1967	#undef NF_TYPE
1968	#undef NF_ROUTINE
1969	#undef LENGTH
1970	#undef COPY
1971	#define ROUTINE_TYPE 'REAL'
1972	#define TYPE_DATA real ,intent(out) :: Data(*)
1973	#define TYPE_BUFFER real
1974	#define TYPE_COUNT integer,intent(in) :: Count
1975	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1976	#define NF_TYPE NF_FLOAT
1977	#define NF_ROUTINE NF_GET_VARA_REAL
1978	#define LENGTH min(Count,Len1)
1979	#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
1980	#include "ext_ncd_get_var_td.code"
1981	end subroutine ext_ncd_get_var_td_real
1982
1983	subroutine ext_ncd_get_var_ti_double(DataHandle,Element,Var,Data,Count,OutCount,Status)
1984	#undef ROUTINE_TYPE
1985	#undef TYPE_DATA
1986	#undef TYPE_BUFFER
1987	#undef TYPE_COUNT
1988	#undef TYPE_OUTCOUNT
1989	#undef NF_TYPE
1990	#undef NF_ROUTINE
1991	#undef COPY
1992	#define ROUTINE_TYPE 'DOUBLE'
1993	#define TYPE_DATA real8 ,intent(out) :: Data()
1994	#define TYPE_BUFFER real*8 ,allocatable :: Buffer(:)
1995	#define TYPE_COUNT integer,intent(in) :: Count
1996	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
1997	#define NF_TYPE NF_DOUBLE
1998	#define NF_ROUTINE NF_GET_ATT_DOUBLE
1999	#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
2000	#include "ext_ncd_get_var_ti.code"
2001	end subroutine ext_ncd_get_var_ti_double
2002
2003	subroutine ext_ncd_get_var_td_double(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2004	#undef ROUTINE_TYPE
2005	#undef TYPE_DATA
2006	#undef TYPE_BUFFER
2007	#undef TYPE_COUNT
2008	#undef TYPE_OUTCOUNT
2009	#undef NF_TYPE
2010	#undef NF_ROUTINE
2011	#undef LENGTH
2012	#undef COPY
2013	#define ROUTINE_TYPE 'DOUBLE'
2014	#define TYPE_DATA real8 ,intent(out) :: Data()
2015	#define TYPE_BUFFER real*8
2016	#define TYPE_COUNT integer,intent(in) :: Count
2017	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2018	#define NF_TYPE NF_DOUBLE
2019	#define NF_ROUTINE NF_GET_VARA_DOUBLE
2020	#define LENGTH min(Count,Len1)
2021	#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
2022	#include "ext_ncd_get_var_td.code"
2023	end subroutine ext_ncd_get_var_td_double
2024
2025	subroutine ext_ncd_get_var_ti_integer(DataHandle,Element,Var,Data,Count,OutCount,Status)
2026	#undef ROUTINE_TYPE
2027	#undef TYPE_DATA
2028	#undef TYPE_BUFFER
2029	#undef TYPE_COUNT
2030	#undef TYPE_OUTCOUNT
2031	#undef NF_TYPE
2032	#undef NF_ROUTINE
2033	#undef COPY
2034	#define ROUTINE_TYPE 'INTEGER'
2035	#define TYPE_DATA integer,intent(out) :: Data(*)
2036	#define TYPE_BUFFER integer,allocatable :: Buffer(:)
2037	#define TYPE_COUNT integer,intent(in) :: Count
2038	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2039	#define NF_TYPE NF_INT
2040	#define NF_ROUTINE NF_GET_ATT_INT
2041	#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))
2042	#include "ext_ncd_get_var_ti.code"
2043	end subroutine ext_ncd_get_var_ti_integer
2044
2045	subroutine ext_ncd_get_var_td_integer(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2046	#undef ROUTINE_TYPE
2047	#undef TYPE_DATA
2048	#undef TYPE_BUFFER
2049	#undef TYPE_COUNT
2050	#undef TYPE_OUTCOUNT
2051	#undef NF_TYPE
2052	#undef NF_ROUTINE
2053	#undef LENGTH
2054	#undef COPY
2055	#define ROUTINE_TYPE 'INTEGER'
2056	#define TYPE_DATA integer,intent(out) :: Data(*)
2057	#define TYPE_BUFFER integer
2058	#define TYPE_COUNT integer,intent(in) :: Count
2059	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2060	#define NF_TYPE NF_INT
2061	#define NF_ROUTINE NF_GET_VARA_INT
2062	#define LENGTH min(Count,Len1)
2063	#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))
2064	#include "ext_ncd_get_var_td.code"
2065	end subroutine ext_ncd_get_var_td_integer
2066
2067	subroutine ext_ncd_get_var_ti_logical(DataHandle,Element,Var,Data,Count,OutCount,Status)
2068	#undef ROUTINE_TYPE
2069	#undef TYPE_DATA
2070	#undef TYPE_BUFFER
2071	#undef TYPE_COUNT
2072	#undef TYPE_OUTCOUNT
2073	#undef NF_TYPE
2074	#undef NF_ROUTINE
2075	#undef COPY
2076	#define ROUTINE_TYPE 'LOGICAL'
2077	#define TYPE_DATA logical,intent(out) :: Data(*)
2078	#define TYPE_BUFFER integer,allocatable :: Buffer(:)
2079	#define TYPE_COUNT integer,intent(in) :: Count
2080	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2081	#define NF_TYPE NF_INT
2082	#define NF_ROUTINE NF_GET_ATT_INT
2083	#define COPY Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1
2084	#include "ext_ncd_get_var_ti.code"
2085	end subroutine ext_ncd_get_var_ti_logical
2086
2087	subroutine ext_ncd_get_var_td_logical(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status)
2088	#undef ROUTINE_TYPE
2089	#undef TYPE_DATA
2090	#undef TYPE_BUFFER
2091	#undef TYPE_COUNT
2092	#undef TYPE_OUTCOUNT
2093	#undef NF_TYPE
2094	#undef NF_ROUTINE
2095	#undef LENGTH
2096	#undef COPY
2097	#define ROUTINE_TYPE 'LOGICAL'
2098	#define TYPE_DATA logical,intent(out) :: Data(*)
2099	#define TYPE_BUFFER integer
2100	#define TYPE_COUNT integer,intent(in) :: Count
2101	#define TYPE_OUTCOUNT integer,intent(out) :: OutCount
2102	#define NF_TYPE NF_INT
2103	#define NF_ROUTINE NF_GET_VARA_INT
2104	#define LENGTH min(Count,Len1)
2105	#define COPY Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1
2106	#include "ext_ncd_get_var_td.code"
2107	end subroutine ext_ncd_get_var_td_logical
2108
2109	subroutine ext_ncd_get_var_ti_char(DataHandle,Element,Var,Data,Status)
2110	#undef ROUTINE_TYPE
2111	#undef TYPE_DATA
2112	#undef TYPE_BUFFER
2113	#undef TYPE_COUNT
2114	#undef TYPE_OUTCOUNT
2115	#undef NF_TYPE
2116	#undef NF_ROUTINE
2117	#undef COPY
2118	#define ROUTINE_TYPE 'CHAR'
2119	#define TYPE_DATA character() ,intent(out) :: Data
2120	#define TYPE_BUFFER
2121	#define TYPE_COUNT integer :: Count = 1
2122	#define TYPE_OUTCOUNT
2123	#define NF_TYPE NF_CHAR
2124	#define NF_ROUTINE NF_GET_ATT_TEXT
2125	#define COPY
2126	#define CHAR_TYPE
2127	#include "ext_ncd_get_var_ti.code"
2128	#undef CHAR_TYPE
2129	end subroutine ext_ncd_get_var_ti_char
2130
2131	subroutine ext_ncd_get_var_td_char(DataHandle,Element,DateStr,Var,Data,Status)
2132	#undef ROUTINE_TYPE
2133	#undef TYPE_DATA
2134	#undef TYPE_BUFFER
2135	#undef TYPE_COUNT
2136	#undef TYPE_OUTCOUNT
2137	#undef NF_TYPE
2138	#undef NF_ROUTINE
2139	#undef LENGTH
2140	#define ROUTINE_TYPE 'CHAR'
2141	#define TYPE_DATA character() ,intent(out) :: Data
2142	#define TYPE_BUFFER character (80)
2143	#define TYPE_COUNT integer :: Count = 1
2144	#define TYPE_OUTCOUNT
2145	#define NF_TYPE NF_CHAR
2146	#define NF_ROUTINE NF_GET_VARA_TEXT
2147	#define LENGTH Len1
2148	#define CHAR_TYPE
2149	#include "ext_ncd_get_var_td.code"
2150	#undef CHAR_TYPE
2151	end subroutine ext_ncd_get_var_td_char
2152
2153	subroutine ext_ncd_put_dom_td_real(DataHandle,Element,DateStr,Data,Count,Status)
2154	integer ,intent(in) :: DataHandle
2155	character() ,intent(in) :: Element
2156	character() ,intent(in) :: DateStr
2157	real ,intent(in) :: Data(*)
2158	integer ,intent(in) :: Count
2159	integer ,intent(out) :: Status
2160
2161	call ext_ncd_put_var_td_real(DataHandle,Element,DateStr, &
2162	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status)
2163	return
2164	end subroutine ext_ncd_put_dom_td_real
2165
2166	subroutine ext_ncd_put_dom_td_integer(DataHandle,Element,DateStr,Data,Count,Status)
2167	integer ,intent(in) :: DataHandle
2168	character() ,intent(in) :: Element
2169	character() ,intent(in) :: DateStr
2170	integer ,intent(in) :: Data(*)
2171	integer ,intent(in) :: Count
2172	integer ,intent(out) :: Status
2173
2174	call ext_ncd_put_var_td_integer(DataHandle,Element,DateStr, &
2175	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status)
2176	return
2177	end subroutine ext_ncd_put_dom_td_integer
2178
2179	subroutine ext_ncd_put_dom_td_double(DataHandle,Element,DateStr,Data,Count,Status)
2180	integer ,intent(in) :: DataHandle
2181	character() ,intent(in) :: Element
2182	character() ,intent(in) :: DateStr
2183	real8 ,intent(in) :: Data()
2184	integer ,intent(in) :: Count
2185	integer ,intent(out) :: Status
2186
2187	call ext_ncd_put_var_td_double(DataHandle,Element,DateStr, &
2188	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status)
2189	return
2190	end subroutine ext_ncd_put_dom_td_double
2191
2192	subroutine ext_ncd_put_dom_td_logical(DataHandle,Element,DateStr,Data,Count,Status)
2193	integer ,intent(in) :: DataHandle
2194	character() ,intent(in) :: Element
2195	character() ,intent(in) :: DateStr
2196	logical ,intent(in) :: Data(*)
2197	integer ,intent(in) :: Count
2198	integer ,intent(out) :: Status
2199
2200	call ext_ncd_put_var_td_logical(DataHandle,Element,DateStr, &
2201	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status)
2202	return
2203	end subroutine ext_ncd_put_dom_td_logical
2204
2205	subroutine ext_ncd_put_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2206	integer ,intent(in) :: DataHandle
2207	character() ,intent(in) :: Element
2208	character() ,intent(in) :: DateStr
2209	character() ,intent(in) :: Data
2210	integer ,intent(out) :: Status
2211
2212	call ext_ncd_put_var_td_char(DataHandle,Element,DateStr, &
2213	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status)
2214	return
2215	end subroutine ext_ncd_put_dom_td_char
2216
2217	subroutine ext_ncd_get_dom_td_real(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2218	integer ,intent(in) :: DataHandle
2219	character() ,intent(in) :: Element
2220	character() ,intent(in) :: DateStr
2221	real ,intent(out) :: Data(*)
2222	integer ,intent(in) :: Count
2223	integer ,intent(out) :: OutCount
2224	integer ,intent(out) :: Status
2225	call ext_ncd_get_var_td_real(DataHandle,Element,DateStr, &
2226	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status)
2227	return
2228	end subroutine ext_ncd_get_dom_td_real
2229
2230	subroutine ext_ncd_get_dom_td_integer(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2231	integer ,intent(in) :: DataHandle
2232	character() ,intent(in) :: Element
2233	character() ,intent(in) :: DateStr
2234	integer ,intent(out) :: Data(*)
2235	integer ,intent(in) :: Count
2236	integer ,intent(out) :: OutCount
2237	integer ,intent(out) :: Status
2238	call ext_ncd_get_var_td_integer(DataHandle,Element,DateStr, &
2239	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status)
2240	return
2241	end subroutine ext_ncd_get_dom_td_integer
2242
2243	subroutine ext_ncd_get_dom_td_double(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2244	integer ,intent(in) :: DataHandle
2245	character() ,intent(in) :: Element
2246	character() ,intent(in) :: DateStr
2247	real8 ,intent(out) :: Data()
2248	integer ,intent(in) :: Count
2249	integer ,intent(out) :: OutCount
2250	integer ,intent(out) :: Status
2251	call ext_ncd_get_var_td_double(DataHandle,Element,DateStr, &
2252	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status)
2253	return
2254	end subroutine ext_ncd_get_dom_td_double
2255
2256	subroutine ext_ncd_get_dom_td_logical(DataHandle,Element,DateStr,Data,Count,OutCount,Status)
2257	integer ,intent(in) :: DataHandle
2258	character() ,intent(in) :: Element
2259	character() ,intent(in) :: DateStr
2260	logical ,intent(out) :: Data(*)
2261	integer ,intent(in) :: Count
2262	integer ,intent(out) :: OutCount
2263	integer ,intent(out) :: Status
2264	call ext_ncd_get_var_td_logical(DataHandle,Element,DateStr, &
2265	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status)
2266	return
2267	end subroutine ext_ncd_get_dom_td_logical
2268
2269	subroutine ext_ncd_get_dom_td_char(DataHandle,Element,DateStr,Data,Status)
2270	integer ,intent(in) :: DataHandle
2271	character() ,intent(in) :: Element
2272	character() ,intent(in) :: DateStr
2273	character() ,intent(out) :: Data
2274	integer ,intent(out) :: Status
2275	call ext_ncd_get_var_td_char(DataHandle,Element,DateStr, &
2276	'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status)
2277	return
2278	end subroutine ext_ncd_get_dom_td_char
2279
2280
2281	subroutine ext_ncd_write_field(DataHandle,DateStr,Var,Field,FieldTypeIn, &
2282	Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, &
2283	DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
2284	use wrf_data
2285	use ext_ncd_support_routines
2286	implicit none
2287	include 'wrf_status_codes.h'
2288	include 'netcdf.inc'
2289	integer ,intent(in) :: DataHandle
2290	character() ,intent(in) :: DateStr
2291	character() ,intent(in) :: Var
2292	integer ,intent(inout) :: Field(*)
2293	integer ,intent(in) :: FieldTypeIn
2294	integer ,intent(inout) :: Comm
2295	integer ,intent(inout) :: IOComm
2296	integer ,intent(in) :: DomainDesc
2297	character() ,intent(in) :: MemoryOrdIn
2298	character() ,intent(in) :: Stagger ! Dummy for now
2299	character() ,dimension(*) ,intent(in) :: DimNames
2300	integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
2301	integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
2302	integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
2303	integer ,intent(out) :: Status
2304	integer :: FieldType
2305	character (3) :: MemoryOrder
2306	type(wrf_data_handle) ,pointer :: DH
2307	integer :: NCID
2308	integer :: NDim
2309	character (VarNameLen) :: VarName
2310	character (3) :: MemO
2311	character (3) :: UCMemO
2312	integer :: VarID
2313	integer ,dimension(NVarDims) :: Length
2314	integer ,dimension(NVarDims) :: VDimIDs
2315	character(80),dimension(NVarDims) :: RODimNames
2316	integer ,dimension(NVarDims) :: StoredStart
2317	integer ,dimension(:,:,:,:),allocatable :: XField
2318	integer :: stat
2319	integer :: NVar
2320	integer :: i,j
2321	integer :: i1,i2,j1,j2,k1,k2
2322	integer :: x1,x2,y1,y2,z1,z2
2323	integer :: l1,l2,m1,m2,n1,n2
2324	integer :: XType
2325	integer :: di
2326	character (80) :: NullName
2327	logical :: NotFound
2328
2329	MemoryOrder = trim(adjustl(MemoryOrdIn))
2330	NullName=char(0)
2331	call GetDim(MemoryOrder,NDim,Status)
2332	if(Status /= WRF_NO_ERR) then
2333	write(msg,*) 'Warning BAD MEMORY ORDER \|',MemoryOrder,'\| in ',__FILE__,', line', __LINE__
2334	call wrf_debug ( WARN , TRIM(msg))
2335	return
2336	endif
2337	call DateCheck(DateStr,Status)
2338	if(Status /= WRF_NO_ERR) then
2339	write(msg,*) 'Warning DATE STRING ERROR \|',DateStr,'\| in ',__FILE__,', line', __LINE__
2340	call wrf_debug ( WARN , TRIM(msg))
2341	return
2342	endif
2343	VarName = Var
2344	call GetDH(DataHandle,DH,Status)
2345	if(Status /= WRF_NO_ERR) then
2346	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2347	call wrf_debug ( WARN , TRIM(msg))
2348	return
2349	endif
2350	NCID = DH%NCID
2351
2352	if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then
2353	FieldType = WRF_REAL
2354	else
2355	FieldType = FieldTypeIn
2356	end if
2357
2358	write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var)
2359
2360	!jm 010827 Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
2361
2362	Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
2363
2364	call ExtOrder(MemoryOrder,Length,Status)
2365	call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status)
2366	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2367	Status = WRF_WARN_FILE_NOT_OPENED
2368	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2369	call wrf_debug ( WARN , TRIM(msg))
2370	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2371	Status = WRF_WARN_WRITE_RONLY_FILE
2372	write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__
2373	call wrf_debug ( WARN , TRIM(msg))
2374	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2375	do NVar=1,MaxVars
2376	if(DH%VarNames(NVar) == VarName ) then
2377	Status = WRF_WARN_2DRYRUNS_1VARIABLE
2378	write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__
2379	call wrf_debug ( WARN , TRIM(msg))
2380	return
2381	elseif(DH%VarNames(NVar) == NO_NAME) then
2382	DH%VarNames(NVar) = VarName
2383	DH%NumVars = NVar
2384	exit
2385	elseif(NVar == MaxVars) then
2386	Status = WRF_WARN_TOO_MANY_VARIABLES
2387	write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__
2388	call wrf_debug ( WARN , TRIM(msg))
2389	return
2390	endif
2391	enddo
2392	do j = 1,NDim
2393	if(RODimNames(j) == NullName .or. RODimNames(j) == '') then
2394	do i=1,MaxDims
2395	if(DH%DimLengths(i) == Length(j)) then
2396	exit
2397	elseif(DH%DimLengths(i) == NO_DIM) then
2398	stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i))
2399	call netcdf_err(stat,Status)
2400	if(Status /= WRF_NO_ERR) then
2401	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2402	call wrf_debug ( WARN , TRIM(msg))
2403	return
2404	endif
2405	DH%DimLengths(i) = Length(j)
2406	exit
2407	elseif(i == MaxDims) then
2408	Status = WRF_WARN_TOO_MANY_DIMS
2409	write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__
2410	call wrf_debug ( WARN , TRIM(msg))
2411	return
2412	endif
2413	enddo
2414	else !look for input name and check if already defined
2415	NotFound = .true.
2416	do i=1,MaxDims
2417	if (DH%DimNames(i) == RODimNames(j)) then
2418	if (DH%DimLengths(i) == Length(j)) then
2419	NotFound = .false.
2420	exit
2421	else
2422	Status = WRF_WARN_DIMNAME_REDEFINED
2423	write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDIFINED by var ', &
2424	TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__
2425	call wrf_debug ( WARN , TRIM(msg))
2426	return
2427	endif
2428	endif
2429	enddo
2430	if (NotFound) then
2431	do i=1,MaxDims
2432	if (DH%DimLengths(i) == NO_DIM) then
2433	DH%DimNames(i) = RODimNames(j)
2434	stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i))
2435	call netcdf_err(stat,Status)
2436	if(Status /= WRF_NO_ERR) then
2437	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2438	call wrf_debug ( WARN , TRIM(msg))
2439	return
2440	endif
2441	DH%DimLengths(i) = Length(j)
2442	exit
2443	elseif(i == MaxDims) then
2444	Status = WRF_WARN_TOO_MANY_DIMS
2445	write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__
2446	call wrf_debug ( WARN , TRIM(msg))
2447	return
2448	endif
2449	enddo
2450	endif
2451	endif
2452	VDimIDs(j) = DH%DimIDs(i)
2453	DH%VarDimLens(j,NVar) = Length(j)
2454	enddo
2455	VDimIDs(NDim+1) = DH%DimUnlimID
2456
2457	! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
2458	IF (FieldType == WRF_REAL) THEN
2459	XType = NF_FLOAT
2460	ELSE IF (FieldType == WRF_DOUBLE) THEN
2461	Xtype = NF_DOUBLE
2462	ELSE IF (FieldType == WRF_INTEGER) THEN
2463	XType = NF_INT
2464	ELSE IF (FieldType == WRF_LOGICAL) THEN
2465	XType = NF_INT
2466	ELSE
2467	Status = WRF_WARN_DATA_TYPE_NOT_FOUND
2468	write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
2469	call wrf_debug ( WARN , TRIM(msg))
2470	return
2471	END IF
2472
2473	stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID)
2474	call netcdf_err(stat,Status)
2475	if(Status /= WRF_NO_ERR) then
2476	write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
2477	call wrf_debug ( WARN , TRIM(msg))
2478	return
2479	endif
2480	DH%VarIDs(NVar) = VarID
2481	stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType)
2482	call netcdf_err(stat,Status)
2483	if(Status /= WRF_NO_ERR) then
2484	write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__
2485	call wrf_debug ( WARN , TRIM(msg))
2486	return
2487	endif
2488	call reorder(MemoryOrder,MemO)
2489	call uppercase(MemO,UCMemO)
2490	stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO)
2491	call netcdf_err(stat,Status)
2492	if(Status /= WRF_NO_ERR) then
2493	write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__
2494	call wrf_debug ( WARN , TRIM(msg))
2495	return
2496	endif
2497	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
2498	do NVar=1,DH%NumVars
2499	if(DH%VarNames(NVar) == VarName) then
2500	exit
2501	elseif(NVar == DH%NumVars) then
2502	Status = WRF_WARN_VAR_NF
2503	write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__
2504	call wrf_debug ( WARN , TRIM(msg))
2505	return
2506	endif
2507	enddo
2508	VarID = DH%VarIDs(NVar)
2509	do j=1,NDim
2510	if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then
2511	Status = WRF_WARN_WRTLEN_NE_DRRUNLEN
2512	write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for \|', &
2513	VarName,'\| dim ',j,' in ',__FILE__,', line', __LINE__
2514	call wrf_debug ( WARN , TRIM(msg))
2515	write(msg,*) ' LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar)
2516	call wrf_debug ( WARN , TRIM(msg))
2517	return
2518	!jm 010825 elseif(DomainStart(j) < MemoryStart(j)) then
2519	elseif(PatchStart(j) < MemoryStart(j)) then
2520	Status = WRF_WARN_DIMENSION_ERROR
2521	write(msg,*) 'Warning DIMENSION ERROR for \|',VarName, &
2522	'\| in ',__FILE__,', line', __LINE__
2523	call wrf_debug ( WARN , TRIM(msg))
2524	return
2525	endif
2526	enddo
2527	StoredStart = 1
2528	call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
2529	call GetIndices(NDim,StoredStart,Length ,x1,x2,y1,y2,z1,z2)
2530	call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
2531	di=1
2532	if(FieldType == WRF_DOUBLE) di=2
2533	allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
2534	if(stat/= 0) then
2535	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
2536	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
2537	call wrf_debug ( FATAL , TRIM(msg))
2538	return
2539	endif
2540	if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then
2541	call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2542	,XField,x1,x2,y1,y2,z1,z2 &
2543	,i1,i2,j1,j2,k1,k2 )
2544	else
2545	call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2546	,XField,x1,x2,y1,y2,z1,z2 &
2547	,i1,i2,j1,j2,k1,k2 )
2548	end if
2549	call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, &
2550	FieldType,NCID,VarID,XField,Status)
2551	if(Status /= WRF_NO_ERR) then
2552	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2553	call wrf_debug ( WARN , TRIM(msg))
2554	return
2555	endif
2556	deallocate(XField, STAT=stat)
2557	if(stat/= 0) then
2558	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
2559	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
2560	call wrf_debug ( FATAL , TRIM(msg))
2561	return
2562	endif
2563	else
2564	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2565	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2566	call wrf_debug ( FATAL , TRIM(msg))
2567	endif
2568	DH%first_operation = .FALSE.
2569	return
2570	end subroutine ext_ncd_write_field
2571
2572	subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm, &
2573	IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames, &
2574	DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
2575	use wrf_data
2576	use ext_ncd_support_routines
2577	implicit none
2578	include 'wrf_status_codes.h'
2579	include 'netcdf.inc'
2580	integer ,intent(in) :: DataHandle
2581	character() ,intent(in) :: DateStr
2582	character() ,intent(in) :: Var
2583	integer ,intent(out) :: Field(*)
2584	integer ,intent(in) :: FieldType
2585	integer ,intent(inout) :: Comm
2586	integer ,intent(inout) :: IOComm
2587	integer ,intent(in) :: DomainDesc
2588	character() ,intent(in) :: MemoryOrdIn
2589	character() ,intent(in) :: Stagger ! Dummy for now
2590	character() , dimension (*) ,intent(in) :: DimNames
2591	integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd
2592	integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd
2593	integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd
2594	integer ,intent(out) :: Status
2595	character (3) :: MemoryOrder
2596	character (NF_MAX_NAME) :: dimname
2597	type(wrf_data_handle) ,pointer :: DH
2598	integer :: NDim
2599	integer :: NCID
2600	character (VarNameLen) :: VarName
2601	integer :: VarID
2602	integer ,dimension(NVarDims) :: VCount
2603	integer ,dimension(NVarDims) :: VStart
2604	integer ,dimension(NVarDims) :: Length
2605	integer ,dimension(NVarDims) :: VDimIDs
2606	integer ,dimension(NVarDims) :: MemS
2607	integer ,dimension(NVarDims) :: MemE
2608	integer ,dimension(NVarDims) :: StoredStart
2609	integer ,dimension(NVarDims) :: StoredLen
2610	integer ,dimension(:,:,:,:) ,allocatable :: XField
2611	integer :: NVar
2612	integer :: j
2613	integer :: i1,i2,j1,j2,k1,k2
2614	integer :: x1,x2,y1,y2,z1,z2
2615	integer :: l1,l2,m1,m2,n1,n2
2616	character (VarNameLen) :: Name
2617	integer :: XType
2618	integer :: StoredDim
2619	integer :: NAtts
2620	integer :: Len
2621	integer :: stat
2622	integer :: di
2623	integer :: FType
2624
2625	MemoryOrder = trim(adjustl(MemoryOrdIn))
2626	call GetDim(MemoryOrder,NDim,Status)
2627	if(Status /= WRF_NO_ERR) then
2628	write(msg,*) 'Warning BAD MEMORY ORDER \|',TRIM(MemoryOrder),'\| for \|', &
2629	TRIM(Var),'\| in ext_ncd_read_field ',__FILE__,', line', __LINE__
2630	call wrf_debug ( WARN , TRIM(msg))
2631	return
2632	endif
2633	call DateCheck(DateStr,Status)
2634	if(Status /= WRF_NO_ERR) then
2635	write(msg,*) 'Warning DATE STRING ERROR \|',TRIM(DateStr),'\| for \|',TRIM(Var), &
2636	'\| in ext_ncd_read_field ',__FILE__,', line', __LINE__
2637	call wrf_debug ( WARN , TRIM(msg))
2638	return
2639	endif
2640	VarName = Var
2641	call GetDH(DataHandle,DH,Status)
2642	if(Status /= WRF_NO_ERR) then
2643	write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__
2644	call wrf_debug ( WARN , TRIM(msg))
2645	return
2646	endif
2647	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2648	Status = WRF_WARN_FILE_NOT_OPENED
2649	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2650	call wrf_debug ( WARN , TRIM(msg))
2651	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2652	! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return.
2653	! Status = WRF_WARN_DRYRUN_READ
2654	! write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2655	! call wrf_debug ( WARN , TRIM(msg))
2656	Status = WRF_NO_ERR
2657	RETURN
2658	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2659	Status = WRF_WARN_READ_WONLY_FILE
2660	write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2661	call wrf_debug ( WARN , TRIM(msg))
2662	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
2663	NCID = DH%NCID
2664
2665	!jm Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
2666	Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
2667	call ExtOrder(MemoryOrder,Length,Status)
2668	stat = NF_INQ_VARID(NCID,VarName,VarID)
2669	call netcdf_err(stat,Status)
2670	if(Status /= WRF_NO_ERR) then
2671	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname
2672	call wrf_debug ( WARN , TRIM(msg))
2673	return
2674	endif
2675	stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts)
2676	call netcdf_err(stat,Status)
2677	if(Status /= WRF_NO_ERR) then
2678	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2679	call wrf_debug ( WARN , TRIM(msg))
2680	return
2681	endif
2682	stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType)
2683	call netcdf_err(stat,Status)
2684	if(Status /= WRF_NO_ERR) then
2685	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2686	call wrf_debug ( WARN , TRIM(msg))
2687	return
2688	endif
2689	! allow coercion between double and single prec real
2690	!jm if(FieldType /= Ftype) then
2691	if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then
2692	if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then
2693	Status = WRF_WARN_TYPE_MISMATCH
2694	write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
2695	call wrf_debug ( WARN , TRIM(msg))
2696	return
2697	endif
2698	else if(FieldType /= Ftype) then
2699	Status = WRF_WARN_TYPE_MISMATCH
2700	write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
2701	call wrf_debug ( WARN , TRIM(msg))
2702	return
2703	endif
2704
2705	! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
2706	IF (FieldType == WRF_REAL) THEN
2707	! allow coercion between double and single prec real
2708	if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then
2709	Status = WRF_WARN_TYPE_MISMATCH
2710	write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
2711	endif
2712	ELSE IF (FieldType == WRF_DOUBLE) THEN
2713	! allow coercion between double and single prec real
2714	if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) ) then
2715	Status = WRF_WARN_TYPE_MISMATCH
2716	write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__
2717	endif
2718	ELSE IF (FieldType == WRF_INTEGER) THEN
2719	if(XType /= NF_INT) then
2720	Status = WRF_WARN_TYPE_MISMATCH
2721	write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__
2722	endif
2723	ELSE IF (FieldType == WRF_LOGICAL) THEN
2724	if(XType /= NF_INT) then
2725	Status = WRF_WARN_TYPE_MISMATCH
2726	write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
2727	endif
2728	ELSE
2729	Status = WRF_WARN_DATA_TYPE_NOT_FOUND
2730	write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
2731	END IF
2732
2733	if(Status /= WRF_NO_ERR) then
2734	call wrf_debug ( WARN , TRIM(msg))
2735	return
2736	endif
2737	! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502
2738	IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN
2739	stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname)
2740	call netcdf_err(stat,Status)
2741	if(Status /= WRF_NO_ERR) then
2742	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2743	call wrf_debug ( WARN , TRIM(msg))
2744	return
2745	endif
2746	IF ( dimname(1:10) == 'ext_scalar' ) THEN
2747	NDim = 1
2748	Length(1) = 1
2749	ENDIF
2750	ENDIF
2751	if(StoredDim /= NDim+1) then
2752	Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM
2753	write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr)
2754	call wrf_debug ( FATAL , msg)
2755	write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1
2756	call wrf_debug ( FATAL , msg)
2757	return
2758	endif
2759	do j=1,NDim
2760	stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j))
2761	call netcdf_err(stat,Status)
2762	if(Status /= WRF_NO_ERR) then
2763	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
2764	call wrf_debug ( WARN , TRIM(msg))
2765	return
2766	endif
2767	if(Length(j) > StoredLen(j)) then
2768	Status = WRF_WARN_READ_PAST_EOF
2769	write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j)
2770	call wrf_debug ( WARN , TRIM(msg))
2771	return
2772	elseif(Length(j) <= 0) then
2773	Status = WRF_WARN_ZERO_LENGTH_READ
2774	write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__
2775	call wrf_debug ( WARN , TRIM(msg))
2776	return
2777	elseif(DomainStart(j) < MemoryStart(j)) then
2778	Status = WRF_WARN_DIMENSION_ERROR
2779	write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), &
2780	') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__
2781	call wrf_debug ( WARN , TRIM(msg))
2782	! return
2783	endif
2784	enddo
2785
2786	StoredStart = 1
2787	call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
2788	call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2)
2789	!jm call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2)
2790	call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2)
2791
2792	di=1
2793	if(FieldType == WRF_DOUBLE) di=2
2794	allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
2795	if(stat/= 0) then
2796	Status = WRF_ERR_FATAL_ALLOCATION_ERROR
2797	write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
2798	call wrf_debug ( FATAL , msg)
2799	return
2800	endif
2801	call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, &
2802	FieldType,NCID,VarID,XField,Status)
2803	if(Status /= WRF_NO_ERR) then
2804	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2805	call wrf_debug ( WARN , TRIM(msg))
2806	return
2807	endif
2808	call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
2809	,XField,x1,x2,y1,y2,z1,z2 &
2810	,i1,i2,j1,j2,k1,k2 )
2811	deallocate(XField, STAT=stat)
2812	if(stat/= 0) then
2813	Status = WRF_ERR_FATAL_DEALLOCATION_ERR
2814	write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
2815	call wrf_debug ( FATAL , msg)
2816	return
2817	endif
2818	else
2819	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2820	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2821	call wrf_debug ( FATAL , msg)
2822	endif
2823	DH%first_operation = .FALSE.
2824	return
2825	end subroutine ext_ncd_read_field
2826
2827	subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status )
2828	use wrf_data
2829	use ext_ncd_support_routines
2830	implicit none
2831	include 'wrf_status_codes.h'
2832	integer ,intent(in) :: DataHandle
2833	character() ,intent(in) :: FileName
2834	integer ,intent(out) :: FileStatus
2835	integer ,intent(out) :: Status
2836	type(wrf_data_handle) ,pointer :: DH
2837
2838	call GetDH(DataHandle,DH,Status)
2839	if(Status /= WRF_NO_ERR) then
2840	FileStatus = WRF_FILE_NOT_OPENED
2841	return
2842	endif
2843	if(FileName /= DH%FileName) then
2844	FileStatus = WRF_FILE_NOT_OPENED
2845	else
2846	FileStatus = DH%FileStatus
2847	endif
2848	Status = WRF_NO_ERR
2849	return
2850	end subroutine ext_ncd_inquire_opened
2851
2852	subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status )
2853	use wrf_data
2854	use ext_ncd_support_routines
2855	implicit none
2856	include 'wrf_status_codes.h'
2857	integer ,intent(in) :: DataHandle
2858	character() ,intent(out) :: FileName
2859	integer ,intent(out) :: FileStatus
2860	integer ,intent(out) :: Status
2861	type(wrf_data_handle) ,pointer :: DH
2862	FileStatus = WRF_FILE_NOT_OPENED
2863	call GetDH(DataHandle,DH,Status)
2864	if(Status /= WRF_NO_ERR) then
2865	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2866	call wrf_debug ( WARN , TRIM(msg))
2867	return
2868	endif
2869	FileName = DH%FileName
2870	FileStatus = DH%FileStatus
2871	Status = WRF_NO_ERR
2872	return
2873	end subroutine ext_ncd_inquire_filename
2874
2875	subroutine ext_ncd_set_time(DataHandle, DateStr, Status)
2876	use wrf_data
2877	use ext_ncd_support_routines
2878	implicit none
2879	include 'wrf_status_codes.h'
2880	integer ,intent(in) :: DataHandle
2881	character() ,intent(in) :: DateStr
2882	integer ,intent(out) :: Status
2883	type(wrf_data_handle) ,pointer :: DH
2884	integer :: i
2885
2886	call DateCheck(DateStr,Status)
2887	if(Status /= WRF_NO_ERR) then
2888	write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__
2889	call wrf_debug ( WARN , TRIM(msg))
2890	return
2891	endif
2892	call GetDH(DataHandle,DH,Status)
2893	if(Status /= WRF_NO_ERR) then
2894	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2895	call wrf_debug ( WARN , TRIM(msg))
2896	return
2897	endif
2898	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2899	Status = WRF_WARN_FILE_NOT_OPENED
2900	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2901	call wrf_debug ( WARN , TRIM(msg))
2902	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2903	Status = WRF_WARN_FILE_NOT_COMMITTED
2904	write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__
2905	call wrf_debug ( WARN , TRIM(msg))
2906	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2907	Status = WRF_WARN_READ_WONLY_FILE
2908	write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2909	call wrf_debug ( WARN , TRIM(msg))
2910	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
2911	do i=1,MaxTimes
2912	if(DH%Times(i)==DateStr) then
2913	DH%CurrentTime = i
2914	exit
2915	endif
2916	if(i==MaxTimes) then
2917	Status = WRF_WARN_TIME_NF
2918	return
2919	endif
2920	enddo
2921	DH%CurrentVariable = 0
2922	Status = WRF_NO_ERR
2923	else
2924	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2925	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2926	call wrf_debug ( FATAL , msg)
2927	endif
2928	return
2929	end subroutine ext_ncd_set_time
2930
2931	subroutine ext_ncd_get_next_time(DataHandle, DateStr, Status)
2932	use wrf_data
2933	use ext_ncd_support_routines
2934	implicit none
2935	include 'wrf_status_codes.h'
2936	integer ,intent(in) :: DataHandle
2937	character() ,intent(out) :: DateStr
2938	integer ,intent(out) :: Status
2939	type(wrf_data_handle) ,pointer :: DH
2940
2941	call GetDH(DataHandle,DH,Status)
2942	if(Status /= WRF_NO_ERR) then
2943	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2944	call wrf_debug ( WARN , TRIM(msg))
2945	return
2946	endif
2947	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2948	Status = WRF_WARN_FILE_NOT_OPENED
2949	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2950	call wrf_debug ( WARN , TRIM(msg))
2951	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2952	Status = WRF_WARN_DRYRUN_READ
2953	write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2954	call wrf_debug ( WARN , TRIM(msg))
2955	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
2956	Status = WRF_WARN_READ_WONLY_FILE
2957	write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
2958	call wrf_debug ( WARN , TRIM(msg))
2959	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
2960	if(DH%CurrentTime >= DH%NumberTimes) then
2961	Status = WRF_WARN_TIME_EOF
2962	return
2963	endif
2964	DH%CurrentTime = DH%CurrentTime +1
2965	DateStr = DH%Times(DH%CurrentTime)
2966	DH%CurrentVariable = 0
2967	Status = WRF_NO_ERR
2968	else
2969	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2970	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
2971	call wrf_debug ( FATAL , msg)
2972	endif
2973	return
2974	end subroutine ext_ncd_get_next_time
2975
2976	subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status)
2977	use wrf_data
2978	use ext_ncd_support_routines
2979	implicit none
2980	include 'wrf_status_codes.h'
2981	integer ,intent(in) :: DataHandle
2982	character() ,intent(out) :: DateStr
2983	integer ,intent(out) :: Status
2984	type(wrf_data_handle) ,pointer :: DH
2985
2986	call GetDH(DataHandle,DH,Status)
2987	if(Status /= WRF_NO_ERR) then
2988	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
2989	call wrf_debug ( WARN , TRIM(msg))
2990	return
2991	endif
2992	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
2993	Status = WRF_WARN_FILE_NOT_OPENED
2994	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
2995	call wrf_debug ( WARN , TRIM(msg))
2996	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
2997	Status = WRF_WARN_DRYRUN_READ
2998	write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
2999	call wrf_debug ( WARN , TRIM(msg))
3000	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3001	Status = WRF_WARN_READ_WONLY_FILE
3002	write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3003	call wrf_debug ( WARN , TRIM(msg))
3004	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
3005	if(DH%CurrentTime.GT.0) then
3006	DH%CurrentTime = DH%CurrentTime -1
3007	endif
3008	DateStr = DH%Times(DH%CurrentTime)
3009	DH%CurrentVariable = 0
3010	Status = WRF_NO_ERR
3011	else
3012	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3013	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3014	call wrf_debug ( FATAL , msg)
3015	endif
3016	return
3017	end subroutine ext_ncd_get_previous_time
3018
3019	subroutine ext_ncd_get_next_var(DataHandle, VarName, Status)
3020	use wrf_data
3021	use ext_ncd_support_routines
3022	implicit none
3023	include 'wrf_status_codes.h'
3024	include 'netcdf.inc'
3025	integer ,intent(in) :: DataHandle
3026	character() ,intent(out) :: VarName
3027	integer ,intent(out) :: Status
3028	type(wrf_data_handle) ,pointer :: DH
3029	integer :: stat
3030	character (80) :: Name
3031
3032	call GetDH(DataHandle,DH,Status)
3033	if(Status /= WRF_NO_ERR) then
3034	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3035	call wrf_debug ( WARN , TRIM(msg))
3036	return
3037	endif
3038	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3039	Status = WRF_WARN_FILE_NOT_OPENED
3040	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3041	call wrf_debug ( WARN , TRIM(msg))
3042	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3043	Status = WRF_WARN_DRYRUN_READ
3044	write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3045	call wrf_debug ( WARN , TRIM(msg))
3046	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3047	Status = WRF_WARN_READ_WONLY_FILE
3048	write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3049	call wrf_debug ( WARN , TRIM(msg))
3050	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
3051
3052	DH%CurrentVariable = DH%CurrentVariable +1
3053	if(DH%CurrentVariable > DH%NumVars) then
3054	Status = WRF_WARN_VAR_EOF
3055	return
3056	endif
3057	VarName = DH%VarNames(DH%CurrentVariable)
3058	Status = WRF_NO_ERR
3059	else
3060	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3061	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3062	call wrf_debug ( FATAL , msg)
3063	endif
3064	return
3065	end subroutine ext_ncd_get_next_var
3066
3067	subroutine ext_ncd_end_of_frame(DataHandle, Status)
3068	use wrf_data
3069	use ext_ncd_support_routines
3070	implicit none
3071	include 'netcdf.inc'
3072	include 'wrf_status_codes.h'
3073	integer ,intent(in) :: DataHandle
3074	integer ,intent(out) :: Status
3075	type(wrf_data_handle) ,pointer :: DH
3076
3077	call GetDH(DataHandle,DH,Status)
3078	return
3079	end subroutine ext_ncd_end_of_frame
3080
3081	! NOTE: For scalar variables NDim is set to zero and DomainStart and
3082	! NOTE: DomainEnd are left unmodified.
3083	subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status)
3084	use wrf_data
3085	use ext_ncd_support_routines
3086	implicit none
3087	include 'netcdf.inc'
3088	include 'wrf_status_codes.h'
3089	integer ,intent(in) :: DataHandle
3090	character() ,intent(in) :: Name
3091	integer ,intent(out) :: NDim
3092	character() ,intent(out) :: MemoryOrder
3093	character() :: Stagger ! Dummy for now
3094	integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd
3095	integer ,intent(out) :: WrfType
3096	integer ,intent(out) :: Status
3097	type(wrf_data_handle) ,pointer :: DH
3098	integer :: VarID
3099	integer ,dimension(NVarDims) :: VDimIDs
3100	integer :: j
3101	integer :: stat
3102	integer :: XType
3103
3104	call GetDH(DataHandle,DH,Status)
3105	if(Status /= WRF_NO_ERR) then
3106	write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
3107	call wrf_debug ( WARN , TRIM(msg))
3108	return
3109	endif
3110	if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
3111	Status = WRF_WARN_FILE_NOT_OPENED
3112	write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__
3113	call wrf_debug ( WARN , TRIM(msg))
3114	return
3115	elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
3116	Status = WRF_WARN_DRYRUN_READ
3117	write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__
3118	call wrf_debug ( WARN , TRIM(msg))
3119	return
3120	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
3121	Status = WRF_WARN_READ_WONLY_FILE
3122	write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__
3123	call wrf_debug ( WARN , TRIM(msg))
3124	return
3125	elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
3126	stat = NF_INQ_VARID(DH%NCID,Name,VarID)
3127	call netcdf_err(stat,Status)
3128	if(Status /= WRF_NO_ERR) then
3129	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3130	call wrf_debug ( WARN , TRIM(msg))
3131	return
3132	endif
3133	stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType)
3134	call netcdf_err(stat,Status)
3135	if(Status /= WRF_NO_ERR) then
3136	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3137	call wrf_debug ( WARN , TRIM(msg))
3138	return
3139	endif
3140	stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType)
3141	call netcdf_err(stat,Status)
3142	if(Status /= WRF_NO_ERR) then
3143	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3144	call wrf_debug ( WARN , TRIM(msg))
3145	return
3146	endif
3147	select case (XType)
3148	case (NF_BYTE)
3149	Status = WRF_WARN_BAD_DATA_TYPE
3150	write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3151	call wrf_debug ( WARN , TRIM(msg))
3152	return
3153	case (NF_CHAR)
3154	Status = WRF_WARN_BAD_DATA_TYPE
3155	write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3156	call wrf_debug ( WARN , TRIM(msg))
3157	return
3158	case (NF_SHORT)
3159	Status = WRF_WARN_BAD_DATA_TYPE
3160	write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__
3161	call wrf_debug ( WARN , TRIM(msg))
3162	return
3163	case (NF_INT)
3164	if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then
3165	Status = WRF_WARN_BAD_DATA_TYPE
3166	write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3167	call wrf_debug ( WARN , TRIM(msg))
3168	return
3169	endif
3170	case (NF_FLOAT)
3171	if(WrfType /= WRF_REAL) then
3172	Status = WRF_WARN_BAD_DATA_TYPE
3173	write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3174	call wrf_debug ( WARN , TRIM(msg))
3175	return
3176	endif
3177	case (NF_DOUBLE)
3178	if(WrfType /= WRF_DOUBLE) then
3179	Status = WRF_WARN_BAD_DATA_TYPE
3180	write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__
3181	call wrf_debug ( WARN , TRIM(msg))
3182	return
3183	endif
3184	case default
3185	Status = WRF_WARN_DATA_TYPE_NOT_FOUND
3186	write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
3187	call wrf_debug ( WARN , TRIM(msg))
3188	return
3189	end select
3190
3191	stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder)
3192	call netcdf_err(stat,Status)
3193	if(Status /= WRF_NO_ERR) then
3194	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3195	call wrf_debug ( WARN , TRIM(msg))
3196	return
3197	endif
3198	call GetDim(MemoryOrder,NDim,Status)
3199	if(Status /= WRF_NO_ERR) then
3200	write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__
3201	call wrf_debug ( WARN , TRIM(msg))
3202	return
3203	endif
3204	stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs)
3205	call netcdf_err(stat,Status)
3206	if(Status /= WRF_NO_ERR) then
3207	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3208	call wrf_debug ( WARN , TRIM(msg))
3209	return
3210	endif
3211	do j = 1, NDim
3212	DomainStart(j) = 1
3213	stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j))
3214	call netcdf_err(stat,Status)
3215	if(Status /= WRF_NO_ERR) then
3216	write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
3217	call wrf_debug ( WARN , TRIM(msg))
3218	return
3219	endif
3220	enddo
3221	else
3222	Status = WRF_ERR_FATAL_BAD_FILE_STATUS
3223	write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__
3224	call wrf_debug ( FATAL , msg)
3225	endif
3226	return
3227	end subroutine ext_ncd_get_var_info
3228
3229	subroutine ext_ncd_warning_str( Code, ReturnString, Status)
3230	use wrf_data
3231	use ext_ncd_support_routines
3232	implicit none
3233	include 'netcdf.inc'
3234	include 'wrf_status_codes.h'
3235
3236	integer , intent(in) ::Code
3237	character (), intent(out) :: ReturnString
3238	integer, intent(out) ::Status
3239
3240	SELECT CASE (Code)
3241	CASE (0)
3242	ReturnString='No error'
3243	Status=WRF_NO_ERR
3244	return
3245	CASE (-1)
3246	ReturnString= 'File not found (or file is incomplete)'
3247	Status=WRF_NO_ERR
3248	return
3249	CASE (-2)
3250	ReturnString='Metadata not found'
3251	Status=WRF_NO_ERR
3252	return
3253	CASE (-3)
3254	ReturnString= 'Timestamp not found'
3255	Status=WRF_NO_ERR
3256	return
3257	CASE (-4)
3258	ReturnString= 'No more timestamps'
3259	Status=WRF_NO_ERR
3260	return
3261	CASE (-5)
3262	ReturnString= 'Variable not found'
3263	Status=WRF_NO_ERR
3264	return
3265	CASE (-6)
3266	ReturnString= 'No more variables for the current time'
3267	Status=WRF_NO_ERR
3268	return
3269	CASE (-7)
3270	ReturnString= 'Too many open files'
3271	Status=WRF_NO_ERR
3272	return
3273	CASE (-8)
3274	ReturnString= 'Data type mismatch'
3275	Status=WRF_NO_ERR
3276	return
3277	CASE (-9)
3278	ReturnString= 'Attempt to write read-only file'
3279	Status=WRF_NO_ERR
3280	return
3281	CASE (-10)
3282	ReturnString= 'Attempt to read write-only file'
3283	Status=WRF_NO_ERR
3284	return
3285	CASE (-11)
3286	ReturnString= 'Attempt to access unopened file'
3287	Status=WRF_NO_ERR
3288	return
3289	CASE (-12)
3290	ReturnString= 'Attempt to do 2 trainings for 1 variable'
3291	Status=WRF_NO_ERR
3292	return
3293	CASE (-13)
3294	ReturnString= 'Attempt to read past EOF'
3295	Status=WRF_NO_ERR
3296	return
3297	CASE (-14)
3298	ReturnString= 'Bad data handle'
3299	Status=WRF_NO_ERR
3300	return
3301	CASE (-15)
3302	ReturnString= 'Write length not equal to training length'
3303	Status=WRF_NO_ERR
3304	return
3305	CASE (-16)
3306	ReturnString= 'More dimensions requested than training'
3307	Status=WRF_NO_ERR
3308	return
3309	CASE (-17)
3310	ReturnString= 'Attempt to read more data than exists'
3311	Status=WRF_NO_ERR
3312	return
3313	CASE (-18)
3314	ReturnString= 'Input dimensions inconsistent'
3315	Status=WRF_NO_ERR
3316	return
3317	CASE (-19)
3318	ReturnString= 'Input MemoryOrder not recognized'
3319	Status=WRF_NO_ERR
3320	return
3321	CASE (-20)
3322	ReturnString= 'A dimension name with 2 different lengths'
3323	Status=WRF_NO_ERR
3324	return
3325	CASE (-21)
3326	ReturnString= 'String longer than provided storage'
3327	Status=WRF_NO_ERR
3328	return
3329	CASE (-22)
3330	ReturnString= 'Function not supportable'
3331	Status=WRF_NO_ERR
3332	return
3333	CASE (-23)
3334	ReturnString= 'Package implements this routine as NOOP'
3335	Status=WRF_NO_ERR
3336	return
3337
3338	!netcdf-specific warning messages
3339	CASE (-1007)
3340	ReturnString= 'Bad data type'
3341	Status=WRF_NO_ERR
3342	return
3343	CASE (-1008)
3344	ReturnString= 'File not committed'
3345	Status=WRF_NO_ERR
3346	return
3347	CASE (-1009)
3348	ReturnString= 'File is opened for reading'
3349	Status=WRF_NO_ERR
3350	return
3351	CASE (-1011)
3352	ReturnString= 'Attempt to write metadata after open commit'
3353	Status=WRF_NO_ERR
3354	return
3355	CASE (-1010)
3356	ReturnString= 'I/O not initialized'
3357	Status=WRF_NO_ERR
3358	return
3359	CASE (-1012)
3360	ReturnString= 'Too many variables requested'
3361	Status=WRF_NO_ERR
3362	return
3363	CASE (-1013)
3364	ReturnString= 'Attempt to close file during a dry run'
3365	Status=WRF_NO_ERR
3366	return
3367	CASE (-1014)
3368	ReturnString= 'Date string not 19 characters in length'
3369	Status=WRF_NO_ERR
3370	return
3371	CASE (-1015)
3372	ReturnString= 'Attempt to read zero length words'
3373	Status=WRF_NO_ERR
3374	return
3375	CASE (-1016)
3376	ReturnString= 'Data type not found'
3377	Status=WRF_NO_ERR
3378	return
3379	CASE (-1017)
3380	ReturnString= 'Badly formatted date string'
3381	Status=WRF_NO_ERR
3382	return
3383	CASE (-1018)
3384	ReturnString= 'Attempt at read during a dry run'
3385	Status=WRF_NO_ERR
3386	return
3387	CASE (-1019)
3388	ReturnString= 'Attempt to get zero words'
3389	Status=WRF_NO_ERR
3390	return
3391	CASE (-1020)
3392	ReturnString= 'Attempt to put zero length words'
3393	Status=WRF_NO_ERR
3394	return
3395	CASE (-1021)
3396	ReturnString= 'NetCDF error'
3397	Status=WRF_NO_ERR
3398	return
3399	CASE (-1022)
3400	ReturnString= 'Requested length <= 1'
3401	Status=WRF_NO_ERR
3402	return
3403	CASE (-1023)
3404	ReturnString= 'More data available than requested'
3405	Status=WRF_NO_ERR
3406	return
3407	CASE (-1024)
3408	ReturnString= 'New date less than previous date'
3409	Status=WRF_NO_ERR
3410	return
3411
3412	CASE DEFAULT
3413	ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. &
3414	& Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need &
3415	& to be calling a package-specific routine to return a message for this warning code.'
3416	Status=WRF_NO_ERR
3417	END SELECT
3418
3419	return
3420	end subroutine ext_ncd_warning_str
3421
3422	!returns integer bitwise OR of two input integers
3423	integer function bit_or ( Input1 , Input2 ) result ( BWOr )
3424	implicit none
3425	integer, intent(in) :: Input1 , Input2
3426	! A C function is called. We do not want to rely on a return value from C, so we
3427	! wrap the bitwise_or function and hide a Fortran subr call.
3428	call bitwise_or ( Input1, Input2, BWOr )
3429	end function bit_or
3430
3431	!returns message string for all WRF and netCDF warning/error status codes
3432	!Other i/o packages must provide their own routines to return their own status messages
3433	subroutine ext_ncd_error_str( Code, ReturnString, Status)
3434	use wrf_data
3435	use ext_ncd_support_routines
3436	implicit none
3437	include 'netcdf.inc'
3438	include 'wrf_status_codes.h'
3439
3440	integer , intent(in) ::Code
3441	character (), intent(out) :: ReturnString
3442	integer, intent(out) ::Status
3443
3444	SELECT CASE (Code)
3445	CASE (-100)
3446	ReturnString= 'Allocation Error'
3447	Status=WRF_NO_ERR
3448	return
3449	CASE (-101)
3450	ReturnString= 'Deallocation Error'
3451	Status=WRF_NO_ERR
3452	return
3453	CASE (-102)
3454	ReturnString= 'Bad File Status'
3455	Status=WRF_NO_ERR
3456	return
3457	CASE (-1004)
3458	ReturnString= 'Variable on disk is not 3D'
3459	Status=WRF_NO_ERR
3460	return
3461	CASE (-1005)
3462	ReturnString= 'Metadata on disk is not 1D'
3463	Status=WRF_NO_ERR
3464	return
3465	CASE (-1006)
3466	ReturnString= 'Time dimension too small'
3467	Status=WRF_NO_ERR
3468	return
3469	CASE DEFAULT
3470	ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. &
3471	& Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need &
3472	& to be calling a package-specific routine to return a message for this error code.'
3473	Status=WRF_NO_ERR
3474	END SELECT
3475
3476	return
3477	end subroutine ext_ncd_error_str

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

Download in other formats:

Original Format