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