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