Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

wrf_io.F90 @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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

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

Download in other formats:

Original Format