1 |
C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.3 2004/01/06 23:19:27 edhill Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "MNC_OPTIONS.h" |
5 |
|
6 |
C================================================================== |
7 |
|
8 |
SUBROUTINE MNC_FILE_CREATE( |
9 |
I myThid, |
10 |
I fname ) |
11 |
|
12 |
implicit none |
13 |
|
14 |
C Arguments |
15 |
integer myThid |
16 |
character*(*) fname |
17 |
|
18 |
CALL MNC_FILE_OPEN(myThid, fname, 0) |
19 |
|
20 |
RETURN |
21 |
END |
22 |
|
23 |
C================================================================== |
24 |
|
25 |
SUBROUTINE MNC_FILE_OPEN( |
26 |
I myThid, |
27 |
I fname, |
28 |
I itype ) |
29 |
|
30 |
implicit none |
31 |
#include "netcdf.inc" |
32 |
#include "mnc_common.h" |
33 |
#include "EEPARAMS.h" |
34 |
|
35 |
C Arguments |
36 |
integer myThid |
37 |
character*(*) fname |
38 |
integer itype |
39 |
C itype => [ 0=new | 1=append ] |
40 |
|
41 |
C Functions |
42 |
integer ILNBLNK |
43 |
|
44 |
C Local Variables |
45 |
integer i,n, err, fid, ind |
46 |
character*(MNC_MAX_CHAR) aname |
47 |
character*(MAX_LEN_MBUF) msgbuf |
48 |
|
49 |
C Is the file already open? |
50 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
51 |
IF ( ind .GT. 0 ) THEN |
52 |
write(msgbuf,'(3a)') 'MNC_FILE_OPEN ERROR: ''', fname, |
53 |
& ''' is already open -- cannot open twice' |
54 |
CALL print_error( msgbuf, mythid ) |
55 |
stop 'ABNORMAL END: package MNC' |
56 |
ENDIF |
57 |
|
58 |
write(msgbuf,'(3a)') 'opening ''', fname, '''' |
59 |
IF ( itype .EQ. 0 ) THEN |
60 |
C Create new file |
61 |
err = NF_CREATE( fname, NF_CLOBBER, fid ) |
62 |
CALL MNC_HANDLE_ERR(myThid, err, msgbuf) |
63 |
ELSEIF ( itype .EQ. 1 ) THEN |
64 |
C Append to existing file |
65 |
err = NF_OPEN( fname, NF_WRITE, fid ) |
66 |
CALL MNC_HANDLE_ERR(myThid, err, msgbuf) |
67 |
ELSE |
68 |
C Error |
69 |
write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype, |
70 |
& ''' is not defined--should be: [0|1]' |
71 |
CALL print_error( msgbuf, mythid ) |
72 |
stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR' |
73 |
ENDIF |
74 |
|
75 |
CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_f_names, ind) |
76 |
n = ILNBLNK(fname) |
77 |
mnc_f_names(ind)(1:n) = fname(1:n) |
78 |
mnc_f_info(ind,1) = 1 |
79 |
mnc_f_info(ind,2) = fid |
80 |
mnc_f_info(ind,3) = 0 |
81 |
mnc_fv_ids(ind,1) = 0 |
82 |
|
83 |
RETURN |
84 |
END |
85 |
|
86 |
C================================================================== |
87 |
|
88 |
SUBROUTINE MNC_FILE_ADD_ATTR_STR( |
89 |
I myThid, |
90 |
I fname, |
91 |
I atname, |
92 |
I sval ) |
93 |
|
94 |
implicit none |
95 |
#include "netcdf.inc" |
96 |
#include "mnc_common.h" |
97 |
#include "EEPARAMS.h" |
98 |
|
99 |
C Arguments |
100 |
integer myThid |
101 |
character*(*) fname |
102 |
character*(*) atname |
103 |
character*(*) sval |
104 |
|
105 |
C Functions |
106 |
integer ILNBLNK |
107 |
|
108 |
C Local Variables |
109 |
integer i, err, fid, ind, n1,n2 |
110 |
character*(MNC_MAX_CHAR) s1, s2 |
111 |
character*(MAX_LEN_MBUF) msgbuf |
112 |
character*(MAX_LEN_MBUF) name |
113 |
|
114 |
C Is the file open? |
115 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
116 |
IF (ind .LT. 1) THEN |
117 |
write(msgbuf,'(3a)') 'MNC ERROR: file ''', |
118 |
& fname, ''' must be opened first' |
119 |
CALL print_error( msgbuf, mythid ) |
120 |
stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR' |
121 |
ENDIF |
122 |
fid = mnc_f_info(ind,2) |
123 |
|
124 |
C Enter define mode |
125 |
CALL MNC_FILE_REDEF(myThid, fname) |
126 |
|
127 |
s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR) |
128 |
s2(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR) |
129 |
n1 = ILNBLNK(atname) |
130 |
n2 = ILNBLNK(sval) |
131 |
s1(1:n1) = atname(1:n1) |
132 |
s2(1:n2) = sval(1:n2) |
133 |
|
134 |
err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, n2, s2) |
135 |
CALL MNC_HANDLE_ERR(myThid, err, |
136 |
& 'adding attribute in S/R MNC_FILE_ADD_ATTR_STR') |
137 |
|
138 |
RETURN |
139 |
END |
140 |
|
141 |
C================================================================== |
142 |
|
143 |
SUBROUTINE MNC_FILE_ADD_ATTR_INT( |
144 |
I myThid, |
145 |
I fname, |
146 |
I atname, |
147 |
I ival ) |
148 |
|
149 |
implicit none |
150 |
#include "netcdf.inc" |
151 |
#include "mnc_common.h" |
152 |
#include "EEPARAMS.h" |
153 |
|
154 |
C Arguments |
155 |
integer myThid |
156 |
character*(*) fname, atname |
157 |
integer ival |
158 |
|
159 |
C Functions |
160 |
integer ILNBLNK |
161 |
|
162 |
C Local Variables |
163 |
integer i, err, fid, ind, n1,n2 |
164 |
character*(MNC_MAX_CHAR) s1 |
165 |
character*(MAX_LEN_MBUF) msgbuf |
166 |
|
167 |
C Is the file open? |
168 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
169 |
IF ( ind .GT. 0 ) THEN |
170 |
write(msgbuf,'(3a)') 'MNC ERROR: file ''', |
171 |
& fname, ''' must be opened first' |
172 |
CALL print_error( msgbuf, mythid ) |
173 |
stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT' |
174 |
ENDIF |
175 |
fid = mnc_f_info(ind,2) |
176 |
|
177 |
C Enter define mode |
178 |
CALL MNC_FILE_REDEF(myThid, fname) |
179 |
|
180 |
s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR) |
181 |
n1 = ILNBLNK(atname) |
182 |
s1(1:n1) = atname(1:n1) |
183 |
|
184 |
err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, ival) |
185 |
CALL MNC_HANDLE_ERR(myThid, err, |
186 |
& 'adding attribute in S/R MNC_FILE_ADD_ATTR_INT') |
187 |
|
188 |
RETURN |
189 |
END |
190 |
|
191 |
C================================================================== |
192 |
|
193 |
SUBROUTINE MNC_FILE_ADD_ATTR_DBL( |
194 |
I myThid, |
195 |
I fname, |
196 |
I atname, |
197 |
I dval ) |
198 |
|
199 |
#include "netcdf.inc" |
200 |
#include "mnc_common.h" |
201 |
#include "EEPARAMS.h" |
202 |
|
203 |
C Arguments |
204 |
integer myThid |
205 |
character*(*) fname, atname |
206 |
_RL dval |
207 |
|
208 |
C Functions |
209 |
integer ILNBLNK |
210 |
|
211 |
C Local Variables |
212 |
integer i, err, fid, ind, n1,n2 |
213 |
character*(MNC_MAX_CHAR) s1 |
214 |
character*(MAX_LEN_MBUF) msgbuf |
215 |
|
216 |
C Verify that the file is open |
217 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
218 |
IF (ind .LT. 0) THEN |
219 |
write(msgbuf,'(3a)') 'MNC ERROR: file ''', |
220 |
& fname, ''' must be opened first' |
221 |
CALL print_error( msgbuf, mythid ) |
222 |
stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT' |
223 |
ENDIF |
224 |
fid = mnc_f_info(ind,2) |
225 |
|
226 |
C Enter define mode |
227 |
CALL MNC_FILE_REDEF(myThid, fname) |
228 |
|
229 |
s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR) |
230 |
n1 = ILNBLNK(atname) |
231 |
s1(1:n1) = atname(1:n1) |
232 |
|
233 |
err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, ival) |
234 |
CALL MNC_HANDLE_ERR(myThid, err, |
235 |
& 'adding attribute in S/R MNC_FILE_ADD_ATTR_DBL') |
236 |
|
237 |
RETURN |
238 |
END |
239 |
|
240 |
C================================================================== |
241 |
|
242 |
SUBROUTINE MNC_FILE_CLOSE( |
243 |
I myThid, |
244 |
I fname ) |
245 |
|
246 |
implicit none |
247 |
#include "netcdf.inc" |
248 |
#include "mnc_common.h" |
249 |
#include "EEPARAMS.h" |
250 |
|
251 |
C Arguments |
252 |
integer myThid |
253 |
character*(*) fname |
254 |
|
255 |
C Local Variables |
256 |
integer i,j,k,n, err, fid, ind |
257 |
character*(MAX_LEN_MBUF) msgbuf |
258 |
|
259 |
C Check that the file is open |
260 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
261 |
IF (ind .LT. 1) THEN |
262 |
write(msgbuf,'(3a)') 'MNC Warning: file ''', fname, |
263 |
& ''' is already closed' |
264 |
CALL print_error( msgbuf, mythid ) |
265 |
RETURN |
266 |
ENDIF |
267 |
fid = mnc_f_info(ind,2) |
268 |
err = NF_CLOSE(fid) |
269 |
write(msgbuf,'(3a)') ' cannot close file ''', fname, '''' |
270 |
CALL MNC_HANDLE_ERR(myThid, err, msgbuf) |
271 |
|
272 |
C Clear all the file, grid, and variable names and refs |
273 |
n = mnc_fv_ids(ind,1) |
274 |
IF (n .GE. 1) THEN |
275 |
DO i = 1,n |
276 |
j = 2*i |
277 |
k = mnc_fv_ids(ind,j) |
278 |
mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR) |
279 |
ENDDO |
280 |
ENDIF |
281 |
DO i = 1,3 |
282 |
mnc_f_info(ind,i) = 0 |
283 |
ENDDO |
284 |
mnc_f_names(ind)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR) |
285 |
|
286 |
RETURN |
287 |
END |
288 |
|
289 |
C================================================================== |
290 |
|
291 |
SUBROUTINE MNC_FILE_REDEF( |
292 |
I myThid, |
293 |
I fname ) |
294 |
|
295 |
implicit none |
296 |
#include "netcdf.inc" |
297 |
#include "mnc_common.h" |
298 |
#include "EEPARAMS.h" |
299 |
|
300 |
C Arguments |
301 |
integer myThid |
302 |
character*(*) fname |
303 |
|
304 |
C Functions |
305 |
integer ILNBLNK |
306 |
|
307 |
C Local Variables |
308 |
integer ind, fid, def, err |
309 |
character*(MAX_LEN_MBUF) msgbuf |
310 |
|
311 |
C Verify that the file is open |
312 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
313 |
IF (ind .LT. 0) THEN |
314 |
write(msgbuf,'(3a)') 'MNC ERROR: file ''', |
315 |
& fname, ''' must be opened first' |
316 |
CALL print_error( msgbuf, mythid ) |
317 |
stop 'ABNORMAL END: S/R MNC_FILE_REDEF' |
318 |
ENDIF |
319 |
def = mnc_f_info(ind,1) |
320 |
fid = mnc_f_info(ind,2) |
321 |
|
322 |
IF (def .NE. 1) THEN |
323 |
C Enter define mode |
324 |
err = NF_REDEF(fid) |
325 |
CALL MNC_HANDLE_ERR(myThid, err, |
326 |
& 'entering define mode in S/R MNC_FILE_REDEF') |
327 |
mnc_f_info(ind,1) = 1 |
328 |
ENDIF |
329 |
|
330 |
RETURN |
331 |
END |
332 |
|
333 |
C================================================================== |
334 |
|
335 |
SUBROUTINE MNC_FILE_ENDDEF( |
336 |
I myThid, |
337 |
I fname ) |
338 |
|
339 |
implicit none |
340 |
#include "netcdf.inc" |
341 |
#include "mnc_common.h" |
342 |
#include "EEPARAMS.h" |
343 |
|
344 |
C Arguments |
345 |
integer myThid |
346 |
character*(*) fname |
347 |
|
348 |
C Functions |
349 |
integer ILNBLNK |
350 |
|
351 |
C Local Variables |
352 |
integer ind, fid, def, err |
353 |
character*(MAX_LEN_MBUF) msgbuf |
354 |
|
355 |
C Verify that the file is open |
356 |
CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind) |
357 |
IF (ind .LT. 0) THEN |
358 |
write(msgbuf,'(3a)') 'MNC ERROR: file ''', |
359 |
& fname, ''' must be opened first' |
360 |
CALL print_error( msgbuf, mythid ) |
361 |
stop 'ABNORMAL END: S/R MNC_FILE_REDEF' |
362 |
ENDIF |
363 |
def = mnc_f_info(ind,1) |
364 |
fid = mnc_f_info(ind,2) |
365 |
|
366 |
IF (def .NE. 2) THEN |
367 |
C Enter define mode |
368 |
err = NF_ENDDEF(fid) |
369 |
CALL MNC_HANDLE_ERR(myThid, err, |
370 |
& 'ending define mode in S/R MNC_FILE_ENDDEF') |
371 |
mnc_f_info(ind,1) = 2 |
372 |
ENDIF |
373 |
|
374 |
RETURN |
375 |
END |
376 |
|