Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

wrf_io.F90 @ 429

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

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

Download in other formats:

Original Format