| blob | d6c6d63c48e0d0b760cffcc6bd0594e61300f915 |
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 !*----------------------------------------------------------------------------
37 use wrf_data_ncpar
38 use ext_ncdpar_support_routines
39 implicit none
40 include 'wrf_status_codes.h'
41 include 'netcdf.inc'
42 integer ,intent(in) :: DataHandle
43 character*(*) ,intent(in) :: Element
44 character*(*) ,intent(in) :: Var
45 TYPE_DATA
46 TYPE_COUNT
47 TYPE_OUTCOUNT
48 integer ,intent(out) :: Status
49 type(wrf_data_handle) ,pointer :: DH
50 integer :: XLen
51 TYPE_BUFFER
52 character (VarNameLen) :: VarName
53 integer :: stat
54 integer :: NVar
55 integer :: XType
57 if(Count <= 0) then
58 Status = WRF_WARN_ZERO_LENGTH_GET
59 write(msg,*) &
60 'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
61 call wrf_debug ( WARN , msg)
62 return
63 endif
64 VarName = Var
65 call GetDH(DataHandle,DH,Status)
66 if(Status /= WRF_NO_ERR) then
67 write(msg,*) &
68 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
69 call wrf_debug ( WARN , msg)
70 return
71 endif
72 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
73 Status = WRF_WARN_FILE_NOT_OPENED
74 write(msg,*) &
75 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
76 call wrf_debug ( WARN , msg)
77 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
78 Status = WRF_WARN_DRYRUN_READ
79 write(msg,*) &
80 'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
81 call wrf_debug ( WARN , msg)
82 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
83 Status = WRF_WARN_READ_WONLY_FILE
84 write(msg,*) &
85 'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
86 call wrf_debug ( WARN , msg)
87 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
88 do NVar=1,DH%NumVars
89 if(DH%VarNames(NVar) == VarName) then
90 exit
91 elseif(NVar == DH%NumVars) then
92 Status = WRF_WARN_VAR_NF
93 write(msg,*) &
94 'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
95 call wrf_debug ( WARN , msg)
96 return
97 endif
98 enddo
99 stat = NF_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen)
100 call netcdf_err(stat,Status)
101 if(Status /= WRF_NO_ERR) then
102 write(msg,*) &
103 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
104 call wrf_debug ( WARN , msg)
105 endif
106 if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
107 if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
108 Status = WRF_WARN_TYPE_MISMATCH
109 write(msg,*) &
110 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
111 call wrf_debug ( WARN , msg)
112 return
113 endif
114 else
115 if(XType /= NF_TYPE) then
116 Status = WRF_WARN_TYPE_MISMATCH
117 write(msg,*) &
118 'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
119 call wrf_debug ( WARN , msg)
120 return
121 endif
122 endif
123 #ifndef CHAR_TYPE
124 allocate(Buffer(XLen), STAT=stat)
125 if(stat/= 0) then
126 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
127 write(msg,*) &
128 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
129 call wrf_debug ( FATAL , msg)
130 return
131 endif
132 stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer )
133 #else
134 if(XLen > len(Data)) then
135 Status = WRF_WARN_CHARSTR_GT_LENDATA
136 write(msg,*) &
137 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
138 call wrf_debug ( WARN , msg)
139 return
140 endif
141 stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data )
142 #endif
143 call netcdf_err(stat,Status)
144 if(Status /= WRF_NO_ERR) then
145 write(msg,*) &
146 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
147 call wrf_debug ( WARN , msg)
148 endif
149 COPY
150 #ifndef CHAR_TYPE
151 deallocate(Buffer, STAT=stat)
152 if(stat/= 0) then
153 Status = WRF_ERR_FATAL_DEALLOCATION_ERR
154 write(msg,*) &
155 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
156 call wrf_debug ( FATAL , msg)
157 return
158 endif
159 if(XLen > Count) then
160 OutCount = Count
161 Status = WRF_WARN_MORE_DATA_IN_FILE
162 else
163 OutCount = XLen
164 Status = WRF_NO_ERR
165 endif
166 #endif
167 else
168 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
169 write(msg,*) &
170 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
171 call wrf_debug ( FATAL , msg)
172 return
173 endif
174 return