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