| blob | 544f190a8e319e108fd6ba3f226bf630bbda31fd |
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_pnc
38 use ext_pnc_support_routines
39 implicit none
40 include 'wrf_status_codes.h'
41 # include "pnetcdf.inc"
42 integer ,intent(in) :: DataHandle
43 character*(*) ,intent(in) :: Element
44 character*(*) ,intent(in) :: DateStr
45 character*(*) ,intent(in) :: Var
46 TYPE_DATA
47 TYPE_COUNT
48 integer ,intent(out) :: Status
49 type(wrf_data_handle) ,pointer :: DH
50 character (VarNameLen) :: VarName
51 character (40+len(Element)) :: Name
52 integer :: stat
53 integer :: stat2
54 integer ,allocatable :: Buffer(:)
55 integer :: i
56 integer :: VDims (2)
57 integer(KIND=MPI_OFFSET_KIND) :: VStart(2)
58 integer(KIND=MPI_OFFSET_KIND) :: VCount(2)
59 integer :: NVar
60 integer :: TimeIndex
61 integer :: NCID
63 VarName = Var
64 call DateCheck(DateStr,Status)
65 if(Status /= WRF_NO_ERR) then
66 write(msg,*) &
67 'Warning DATE STRING ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
68 call wrf_debug ( WARN , msg)
69 return
70 endif
71 call GetDH(DataHandle,DH,Status)
72 if(Status /= WRF_NO_ERR) then
73 write(msg,*) &
74 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
75 call wrf_debug ( WARN , msg)
76 return
77 endif
78 NCID = DH%NCID
79 call GetName(Element, VarName, Name, Status)
80 if(Status /= WRF_NO_ERR) then
81 write(msg,*) &
82 'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
83 call wrf_debug ( WARN , msg)
84 return
85 endif
86 if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
87 Status = WRF_WARN_FILE_NOT_OPENED
88 write(msg,*) &
89 'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
90 call wrf_debug ( WARN , msg)
91 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
92 Status = WRF_WARN_WRITE_RONLY_FILE
93 write(msg,*) &
94 'Warning WRITE READ ONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
95 call wrf_debug ( WARN , msg)
96 elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
97 if(LENGTH < 1) then
98 Status = WRF_WARN_ZERO_LENGTH_PUT
99 return
100 endif
101 do NVar=1,MaxVars
102 if(DH%MDVarNames(NVar) == Name) then
103 Status = WRF_WARN_2DRYRUNS_1VARIABLE
104 return
105 elseif(DH%MDVarNames(NVar) == NO_NAME) then
106 DH%MDVarNames(NVar) = Name
107 exit
108 elseif(NVar == MaxVars) then
109 Status = WRF_WARN_TOO_MANY_VARIABLES
110 write(msg,*) &
111 'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
112 call wrf_debug ( WARN , msg)
113 return
114 endif
115 enddo
116 do i=1,MaxDims
117 if(DH%DimLengths(i) == LENGTH) then
118 exit
119 elseif(DH%DimLengths(i) == NO_DIM) then
120 stat = NFMPI_DEF_DIM(NCID,DH%DimNames(i),i2offset(LENGTH),DH%DimIDs(i))
121 call netcdf_err(stat,Status)
122 if(Status /= WRF_NO_ERR) then
123 write(msg,*) &
124 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
125 call wrf_debug ( WARN , msg)
126 return
127 endif
128 DH%DimLengths(i) = LENGTH
129 exit
130 elseif(i == MaxDims) then
131 Status = WRF_WARN_TOO_MANY_DIMS
132 write(msg,*) &
133 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
134 call wrf_debug ( WARN , msg)
135 return
136 endif
137 enddo
138 DH%MDVarDimLens(NVar) = LENGTH
139 VDims(1) = DH%DimIDs(i)
140 VDims(2) = DH%DimUnlimID
141 stat = NFMPI_DEF_VAR(NCID,Name,NF_TYPE,2,VDims,DH%MDVarIDs(NVar))
142 call netcdf_err(stat,Status)
143 if(Status /= WRF_NO_ERR) then
144 write(msg,*) &
145 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
146 call wrf_debug ( WARN , msg)
147 return
148 endif
149 elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
150 do NVar=1,MaxVars
151 if(DH%MDVarNames(NVar) == Name) then
152 exit
153 elseif(DH%MDVarNames(NVar) == NO_NAME) then
154 Status = WRF_WARN_MD_NF
155 write(msg,*) &
156 'Warning METADATA NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
157 call wrf_debug ( WARN , msg)
158 return
159 elseif(NVar == MaxVars) then
160 Status = WRF_WARN_TOO_MANY_VARIABLES
161 write(msg,*) &
162 'Warning TOO MANY VARIABLES in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
163 call wrf_debug ( WARN , msg)
164 return
165 endif
166 enddo
167 if(LENGTH > DH%MDVarDimLens(NVar)) then
168 Status = WRF_WARN_COUNT_TOO_LONG
169 write(msg,*) &
170 'Warning COUNT TOO LONG in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
171 call wrf_debug ( WARN , msg)
172 return
173 elseif(LENGTH < 1) then
174 Status = WRF_WARN_ZERO_LENGTH_PUT
175 write(msg,*) &
176 'Warning ZERO LENGTH PUT in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
177 call wrf_debug ( WARN , msg)
178 return
179 endif
180 call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status)
181 if(Status /= WRF_NO_ERR) then
182 write(msg,*) &
183 'Warning in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
184 call wrf_debug ( WARN , msg)
185 return
186 endif
187 VStart(1) = 1
188 VStart(2) = TimeIndex
189 VCount(1) = LENGTH
190 VCount(2) = 1
191 #ifdef LOG
192 allocate(Buffer(LENGTH), STAT=stat)
193 if(stat/= 0) then
194 Status = WRF_ERR_FATAL_ALLOCATION_ERROR
195 write(msg,*) &
196 'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
197 call wrf_debug ( FATAL , msg)
198 return
199 endif
200 do i=1,Count
201 if(data(i)) then
202 Buffer(i)=1
203 else
204 Buffer(i)=0
205 endif
206 enddo
207 stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Buffer)
208 deallocate(Buffer, STAT=stat2)
209 if(stat2/= 0) then
210 Status = WRF_ERR_FATAL_DEALLOCATION_ERR
211 write(msg,*) &
212 'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
213 call wrf_debug ( FATAL , msg)
214 return
215 endif
216 #else
217 stat = NF_ROUTINE (NCID,DH%MDVarIDs(NVar),VStart,VCount,Data)
218 #endif
219 call netcdf_err(stat,Status)
220 if(Status /= WRF_NO_ERR) then
221 write(msg,*) &
222 'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
223 call wrf_debug ( WARN , msg)
224 return
225 endif
226 else
227 Status = WRF_ERR_FATAL_BAD_FILE_STATUS
228 write(msg,*) &
229 'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
230 call wrf_debug ( FATAL , msg)
231 return
232 endif
233 return