/[MITgcm]/MITgcm/pkg/mnc/mnc_var.F
ViewVC logotype

Annotation of /MITgcm/pkg/mnc/mnc_var.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph

Revision 1.26 - (hide annotations) (download)
Mon Aug 1 16:00:17 2011 UTC (12 years, 9 months ago) by jahn
Branch: MAIN
CVS Tags: checkpoint64y, checkpoint64x, checkpoint64z, checkpoint64q, checkpoint64p, checkpoint64s, checkpoint64r, checkpoint64u, checkpoint64t, checkpoint64w, checkpoint64v, checkpoint64i, checkpoint64h, checkpoint64k, checkpoint64j, checkpoint64m, checkpoint64l, checkpoint64o, checkpoint64n, checkpoint64a, checkpoint64c, checkpoint64b, checkpoint64e, checkpoint64d, checkpoint64g, checkpoint64f, checkpoint63p, checkpoint63q, checkpoint63r, checkpoint63s, checkpoint63l, checkpoint63m, checkpoint63n, checkpoint63o, checkpoint63h, checkpoint63i, checkpoint63j, checkpoint63k, checkpoint63d, checkpoint63e, checkpoint63f, checkpoint63g, checkpoint63a, checkpoint63b, checkpoint63c, checkpoint64, checkpoint65, checkpoint66g, checkpoint66f, checkpoint66e, checkpoint66d, checkpoint66c, checkpoint66b, checkpoint66a, checkpoint66o, checkpoint66n, checkpoint66m, checkpoint66l, checkpoint66k, checkpoint66j, checkpoint66i, checkpoint66h, checkpoint65z, checkpoint65x, checkpoint65y, checkpoint65r, checkpoint65s, checkpoint65p, checkpoint65q, checkpoint65v, checkpoint65w, checkpoint65t, checkpoint65u, checkpoint65j, checkpoint65k, checkpoint65h, checkpoint65i, checkpoint65n, checkpoint65o, checkpoint65l, checkpoint65m, checkpoint65b, checkpoint65c, checkpoint65a, checkpoint65f, checkpoint65g, checkpoint65d, checkpoint65e, HEAD
Changes since 1.25: +2 -2 lines 
reflect new location of MNC_MAX_INFO in error message
1 jahn 1.26 C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.25 2009/08/03 14:26:49 jmc Exp $
2 edhill 1.1 C $Name: $
3 jmc 1.25
4 edhill 1.1 #include "MNC_OPTIONS.h"
5 jmc 1.25
6     C-- File mnc_var.F: Handle NetCDF variables (definition,description & writing)
7     C-- Contents
8     C-- o MNC_VAR_INIT_DBL
9     C-- o MNC_VAR_INIT_REAL
10     C-- o MNC_VAR_INIT_INT
11     C-- o MNC_VAR_INIT_ANY
12     C-- o MNC_VAR_ADD_ATTR_STR
13     C-- o MNC_VAR_ADD_ATTR_DBL
14     C-- o MNC_VAR_ADD_ATTR_REAL
15     C-- o MNC_VAR_ADD_ATTR_INT
16     C-- o MNC_VAR_ADD_ATTR_ANY
17     C-- o MNC_VAR_WRITE_DBL
18     C-- o MNC_VAR_WRITE_REAL
19     C-- o MNC_VAR_WRITE_INT
20     C-- o MNC_VAR_APPEND_DBL
21     C-- o MNC_VAR_APPEND_REAL
22     C-- o MNC_VAR_APPEND_INT
23     C-- o MNC_VAR_WRITE_ANY
24    
25 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
26 edhill 1.16 CBOP 1
27 edhill 1.14 C !ROUTINE: MNC_VAR_INIT_DBL
28 edhill 1.1
29 edhill 1.14 C !INTERFACE:
30 jmc 1.25 SUBROUTINE MNC_VAR_INIT_DBL(
31     I fname,
32     I gname,
33     I vname,
34 edhill 1.19 I irv,
35 edhill 1.13 I myThid )
36 edhill 1.5
37 edhill 1.14 C !DESCRIPTION:
38 jmc 1.25 C Create a double-precision real variable within a NetCDF file context.
39    
40 edhill 1.14 C !USES:
41 jmc 1.25 IMPLICIT NONE
42 edhill 1.5 #include "netcdf.inc"
43    
44 edhill 1.14 C !INPUT PARAMETERS:
45 jmc 1.25 CHARACTER*(*) fname,gname,vname
46     INTEGER irv,myThid
47 edhill 1.14 CEOP
48 edhill 1.5
49 jmc 1.25 CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_DOUBLE, irv,myThid )
50    
51 edhill 1.5 RETURN
52     END
53    
54 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
55 edhill 1.16 CBOP 1
56 edhill 1.14 C !ROUTINE: MNC_VAR_INIT_REAL
57 edhill 1.5
58 edhill 1.14 C !INTERFACE:
59 jmc 1.25 SUBROUTINE MNC_VAR_INIT_REAL(
60     I fname,
61     I gname,
62     I vname,
63 edhill 1.19 I irv,
64 edhill 1.13 I myThid )
65 edhill 1.5
66 edhill 1.14 C !DESCRIPTION:
67 jmc 1.25 C Create a single-precision real variable within a NetCDF file context.
68    
69 edhill 1.14 C !USES:
70 jmc 1.25 IMPLICIT NONE
71 edhill 1.5 #include "netcdf.inc"
72    
73 edhill 1.14 C !INPUT PARAMETERS:
74 jmc 1.25 CHARACTER*(*) fname,gname,vname
75     INTEGER irv,myThid
76 edhill 1.14 CEOP
77 edhill 1.5
78 jmc 1.25 CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_FLOAT, irv,myThid )
79    
80 edhill 1.5 RETURN
81     END
82    
83 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
84 edhill 1.16 CBOP 1
85 edhill 1.14 C !ROUTINE: MNC_VAR_INIT_INT
86 edhill 1.5
87 edhill 1.14 C !INTERFACE:
88 jmc 1.25 SUBROUTINE MNC_VAR_INIT_INT(
89     I fname,
90     I gname,
91     I vname,
92 edhill 1.19 I irv,
93 edhill 1.13 I myThid )
94 edhill 1.5
95 edhill 1.14 C !DESCRIPTION:
96     C Create an integer variable within a NetCDF file context.
97 jmc 1.25
98 edhill 1.14 C !USES:
99 jmc 1.25 IMPLICIT NONE
100 edhill 1.5 #include "netcdf.inc"
101    
102 edhill 1.14 C !INPUT PARAMETERS:
103 jmc 1.25 CHARACTER*(*) fname,gname,vname
104     INTEGER irv,myThid
105 edhill 1.14 CEOP
106 edhill 1.5
107 jmc 1.25 CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_INT, irv,myThid )
108    
109 edhill 1.5 RETURN
110     END
111    
112 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
113 edhill 1.16 CBOP 1
114 edhill 1.14 C !ROUTINE: MNC_VAR_INIT_ANY
115 edhill 1.5
116 edhill 1.14 C !INTERFACE:
117 jmc 1.25 SUBROUTINE MNC_VAR_INIT_ANY(
118     I fname,
119     I gname,
120     I vname,
121     I vtype,
122 edhill 1.19 I irv,
123 edhill 1.13 I myThid )
124 edhill 1.1
125 edhill 1.14 C !DESCRIPTION:
126 jmc 1.25 C General function for creating variables within a NetCDF file context.
127    
128 edhill 1.14 C !USES:
129 jmc 1.25 IMPLICIT NONE
130 mlosch 1.23 #include "MNC_COMMON.h"
131 edhill 1.1 #include "EEPARAMS.h"
132 utke 1.24 #include "netcdf.inc"
133 edhill 1.1
134 edhill 1.14 C !INPUT PARAMETERS:
135 jmc 1.25 CHARACTER*(*) fname,gname,vname
136     INTEGER vtype
137     INTEGER irv,myThid
138 edhill 1.16 CEOP
139 edhill 1.1
140 jmc 1.25 C Functions
141     INTEGER ILNBLNK
142     EXTERNAL ILNBLNK
143    
144 edhill 1.14 C !LOCAL VARIABLES:
145 jmc 1.25 INTEGER i,j,k, n, nf, indf,indv, fid, nd, ngrid, is,ie, err
146     INTEGER vid, nv, ind_g_finfo, needed, nvar
147     CHARACTER*(MAX_LEN_MBUF) msgBuf
148     INTEGER ids(20)
149     INTEGER lenf,leng,lenv
150 edhill 1.1
151 edhill 1.3 C Strip trailing spaces
152     lenf = ILNBLNK(fname)
153     leng = ILNBLNK(gname)
154     lenv = ILNBLNK(vname)
155    
156     C Check that the file is open
157 edhill 1.22 CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid)
158 edhill 1.3 IF (indf .LT. 1) THEN
159 edhill 1.21 nf = ILNBLNK( fname )
160 jmc 1.25 WRITE(msgBuf,'(3A)') 'MNC ERROR: file ''', fname(1:nf),
161 edhill 1.3 & ''' must be opened first'
162 jmc 1.25 CALL print_error(msgBuf, myThid)
163     STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
164 edhill 1.1 ENDIF
165 edhill 1.3 fid = mnc_f_info(indf,2)
166    
167 edhill 1.8 C Check for sufficient storage space in mnc_fv_ids
168     needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
169     IF (needed .GE. MNC_MAX_INFO) THEN
170 jmc 1.25 WRITE(msgBuf,'(2A,I7,A)') 'MNC ERROR: MNC_MAX_INFO exceeded',
171     & ': please increase it to ', 2*MNC_MAX_INFO,
172 jahn 1.26 & ' in the file ''pkg/mnc/MNC_SIZE.h'''
173 jmc 1.25 CALL print_error(msgBuf, myThid)
174     STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
175 edhill 1.8 ENDIF
176    
177 edhill 1.3 C Get the grid information
178     ngrid = mnc_f_info(indf,3)
179     IF (ngrid .LT. 1) THEN
180 jmc 1.25 WRITE(msgBuf,'(3A)') 'MNC ERROR: file ''', fname(1:lenf),
181 edhill 1.3 & ''' contains NO grids'
182 jmc 1.25 CALL print_error(msgBuf, myThid)
183     STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
184 edhill 1.3 ENDIF
185     DO i = 1,ngrid
186     j = 4 + (i-1)*3
187     k = mnc_f_info(indf,j)
188     n = ILNBLNK(mnc_g_names(k))
189 jmc 1.25 IF ((leng .EQ. n)
190 edhill 1.3 & .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
191 edhill 1.4 ind_g_finfo = j
192 edhill 1.3 is = mnc_f_info(indf,(j+1))
193     ie = mnc_f_info(indf,(j+2))
194     nd = 0
195     DO k = is,ie
196     nd = nd + 1
197 edhill 1.10 ids(nd) = mnc_d_ids(mnc_fd_ind(indf,k))
198 edhill 1.3 ENDDO
199     GOTO 10
200     ENDIF
201     ENDDO
202 jmc 1.25 WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
203 edhill 1.3 & ''' does not contain grid ''', gname(1:leng), ''''
204 jmc 1.25 CALL print_error(msgBuf, myThid)
205     STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
206 edhill 1.3 10 CONTINUE
207    
208 edhill 1.12 C Check if the variable is already defined
209     nvar = mnc_fv_ids(indf,1)
210     DO i = 1,nvar
211     j = 2 + 3*(i-1)
212     IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN
213     k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))
214     IF (mnc_g_names(k) .NE. gname) THEN
215 jmc 1.25 WRITE(msgBuf,'(5A)') 'MNC ERROR: variable ''',
216     & vname(1:lenv), ''' is already defined in file ''',
217 edhill 1.12 & fname(1:lenf), ''' but using a different grid shape'
218 jmc 1.25 CALL print_error(msgBuf, myThid)
219     STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
220 edhill 1.12 ELSE
221     C Its OK, the variable and grid names are the same
222 edhill 1.19 irv = 0
223 edhill 1.12 RETURN
224     ENDIF
225     ENDIF
226     ENDDO
227    
228 edhill 1.19 irv = 1
229    
230 edhill 1.3 C Add the variable definition
231 edhill 1.13 CALL MNC_FILE_REDEF(fname, myThid)
232 edhill 1.5 err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid)
233 edhill 1.18 IF ( err .NE. NF_NOERR ) THEN
234 jmc 1.25 WRITE(msgBuf,'(2A)') 'ERROR: MNC will not ',
235 edhill 1.18 & 'overwrite variables in existing NetCDF'
236     CALL PRINT_ERROR( msgBuf, myThid )
237 jmc 1.25 WRITE(msgBuf,'(2A)') ' files. Please',
238 edhill 1.18 & ' make sure that you are not trying to'
239     CALL PRINT_ERROR( msgBuf, myThid )
240 jmc 1.25 WRITE(msgBuf,'(2A)') ' overwrite output',
241 edhill 1.18 & 'files from a previous model run!'
242     CALL PRINT_ERROR( msgBuf, myThid )
243 jmc 1.25 WRITE(msgBuf,'(5A)') 'defining variable ''', vname(1:lenv),
244 edhill 1.3 & ''' in file ''', fname(1:lenf), ''''
245 jmc 1.25 CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
246 edhill 1.18 ENDIF
247 edhill 1.3
248     C Success, so save the variable info
249 edhill 1.20 CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID,mnc_v_names,'mnc_v_names',
250     & indv, myThid)
251 edhill 1.3 mnc_v_names(indv)(1:lenv) = vname(1:lenv)
252     nv = mnc_fv_ids(indf,1)
253 edhill 1.5 i = 2 + nv*3
254 edhill 1.10 mnc_fv_ids(indf,i) = indv
255     mnc_fv_ids(indf,i+1) = vid
256     mnc_fv_ids(indf,i+2) = ind_g_finfo
257 edhill 1.3 mnc_fv_ids(indf,1) = nv + 1
258 edhill 1.5
259 edhill 1.3 RETURN
260     END
261    
262 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
263 edhill 1.16 CBOP 1
264 edhill 1.14 C !ROUTINE: MNC_VAR_ADD_ATTR_STR
265 edhill 1.3
266 edhill 1.14 C !INTERFACE:
267 jmc 1.25 SUBROUTINE MNC_VAR_ADD_ATTR_STR(
268     I fname,
269     I vname,
270     I atname,
271     I sval,
272 edhill 1.13 I myThid )
273 edhill 1.3
274 edhill 1.14 C !DESCRIPTION:
275 jmc 1.25 C Subroutine for adding a character string attribute to a NetCDF file.
276    
277 edhill 1.14 C !USES:
278 jmc 1.25 IMPLICIT NONE
279 edhill 1.14
280     C !INPUT PARAMETERS:
281 jmc 1.25 CHARACTER*(*) fname,vname,atname,sval
282     INTEGER myThid
283 edhill 1.14 CEOP
284 jmc 1.17 real*8 dZero(1)
285     real*4 sZero(1)
286 jmc 1.25 INTEGER iZero(1)
287 jmc 1.17 dZero(1) = 0.0D0
288     sZero(1) = 0.0
289     iZero(1) = 0
290 edhill 1.5
291 jmc 1.25 CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
292     & 1, sval, 0, dZero, sZero, iZero, myThid )
293    
294 edhill 1.5 RETURN
295     END
296 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
297 edhill 1.16 CBOP 1
298 edhill 1.14 C !ROUTINE: MNC_VAR_ADD_ATTR_DBL
299 edhill 1.5
300 edhill 1.14 C !INTERFACE:
301 jmc 1.25 SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
302     I fname,
303     I vname,
304     I atname,
305     I nv,
306     I dval,
307 edhill 1.13 I myThid )
308 edhill 1.5
309 edhill 1.14 C !DESCRIPTION:
310 jmc 1.25 C Subroutine for adding a double-precision real attribute to a NetCDF file.
311    
312 edhill 1.14 C !USES:
313 jmc 1.25 IMPLICIT NONE
314 edhill 1.14
315     C !INPUT PARAMETERS:
316 jmc 1.25 CHARACTER*(*) fname,vname,atname
317     INTEGER nv
318     Real*8 dval(*)
319     INTEGER myThid
320 edhill 1.14 CEOP
321 jmc 1.17 real*4 sZero(1)
322 jmc 1.25 INTEGER iZero(1)
323 jmc 1.17 sZero(1) = 0.0
324     iZero(1) = 0
325 edhill 1.5
326 jmc 1.25 CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
327     & 2, ' ', nv, dval, sZero, iZero, myThid )
328    
329 edhill 1.5 RETURN
330     END
331    
332 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
333 edhill 1.16 CBOP 1
334 edhill 1.15 C !ROUTINE: MNC_VAR_ADD_ATTR_REAL
335 edhill 1.5
336 edhill 1.14 C !INTERFACE:
337 jmc 1.25 SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
338     I fname,
339     I vname,
340     I atname,
341     I nv,
342     I rval,
343 edhill 1.13 I myThid )
344 edhill 1.5
345 edhill 1.14 C !DESCRIPTION:
346 jmc 1.25 C Subroutine for adding a single-precision real attribute to a NetCDF file.
347    
348 edhill 1.14 C !USES:
349 jmc 1.25 IMPLICIT NONE
350 edhill 1.14
351     C !INPUT PARAMETERS:
352 jmc 1.25 CHARACTER*(*) fname,vname,atname
353     INTEGER nv
354     Real*4 rval(*)
355     INTEGER myThid
356 edhill 1.14 CEOP
357 jmc 1.17 real*8 dZero(1)
358 jmc 1.25 INTEGER iZero(1)
359 jmc 1.17 dZero(1) = 0.0D0
360     iZero(1) = 0
361 edhill 1.5
362 jmc 1.25 CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
363     & 3, ' ', nv, dZero, rval, iZero, myThid )
364 edhill 1.5 RETURN
365     END
366    
367 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
368 edhill 1.16 CBOP 1
369 edhill 1.14 C !ROUTINE: MNC_VAR_ADD_ATTR_INT
370 edhill 1.5
371 edhill 1.14 C !INTERFACE:
372 jmc 1.25 SUBROUTINE MNC_VAR_ADD_ATTR_INT(
373     I fname,
374     I vname,
375     I atname,
376     I nv,
377     I ival,
378 edhill 1.13 I myThid )
379 edhill 1.5
380 edhill 1.14 C !DESCRIPTION:
381 jmc 1.25 C Subroutine for adding an integer attribute to a NetCDF file.
382    
383 edhill 1.14 C !USES:
384 jmc 1.25 IMPLICIT NONE
385 edhill 1.14
386     C !INPUT PARAMETERS:
387 jmc 1.25 CHARACTER*(*) fname,vname,atname
388     INTEGER nv
389     INTEGER ival(*)
390     INTEGER myThid
391 edhill 1.14 CEOP
392 jmc 1.17 real*8 dZero(1)
393     real*4 sZero(1)
394     dZero(1) = 0.0D0
395     sZero(1) = 0.0
396 edhill 1.5
397 jmc 1.25 CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
398     & 4, ' ', nv, dZero, sZero, ival, myThid )
399    
400 edhill 1.5 RETURN
401     END
402    
403 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
404 edhill 1.16 CBOP 1
405 edhill 1.14 C !ROUTINE: MNC_VAR_ADD_ATTR_ANY
406 edhill 1.5
407 edhill 1.14 C !INTERFACE:
408 jmc 1.25 SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
409     I fname,
410     I vname,
411     I atname,
412     I atype, cs,len,dv,rv,iv,
413 edhill 1.13 I myThid )
414 edhill 1.5
415 edhill 1.14 C !DESCRIPTION:
416 jmc 1.25 C General SUBROUTINE for adding attributes to a NetCDF file.
417    
418 edhill 1.14 C !USES:
419 jmc 1.25 IMPLICIT NONE
420 mlosch 1.23 #include "MNC_COMMON.h"
421 edhill 1.3 #include "EEPARAMS.h"
422 utke 1.24 #include "netcdf.inc"
423 edhill 1.3
424 edhill 1.14 C !INPUT PARAMETERS:
425 jmc 1.25 CHARACTER*(*) fname,vname,atname
426     INTEGER atype
427     CHARACTER*(*) cs
428     INTEGER len
429     Real*8 dv(*)
430     Real*4 rv(*)
431     INTEGER iv(*)
432     INTEGER myThid
433 edhill 1.16 CEOP
434 edhill 1.3
435 jmc 1.25 C Functions
436     INTEGER ILNBLNK
437     EXTERNAL ILNBLNK
438    
439 edhill 1.14 C !LOCAL VARIABLES:
440 jmc 1.25 INTEGER n, indf,ind_fv_ids, fid,vid, err
441     CHARACTER*(MAX_LEN_MBUF) msgBuf
442     INTEGER lenf,lenv,lenat,lens
443 edhill 1.3
444     C Strip trailing spaces
445     lenf = ILNBLNK(fname)
446     lenv = ILNBLNK(vname)
447     lenat = ILNBLNK(atname)
448 edhill 1.5 lens = ILNBLNK(cs)
449 edhill 1.3
450 edhill 1.13 CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
451 edhill 1.4 IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
452 jmc 1.25 WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
453     & ''' is not open or does not contain variable ''',
454 edhill 1.4 & vname(1:lenv), ''''
455 jmc 1.25 CALL print_error(msgBuf, myThid)
456     STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
457 edhill 1.3 ENDIF
458     fid = mnc_f_info(indf,2)
459 edhill 1.4 vid = mnc_fv_ids(indf,(ind_fv_ids+1))
460 edhill 1.3
461     C Set the attribute
462 edhill 1.13 CALL MNC_FILE_REDEF(fname, myThid)
463 edhill 1.5 IF (atype .EQ. 1) THEN
464     err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
465     ELSEIF (atype .EQ. 2) THEN
466     err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
467     ELSEIF (atype .EQ. 3) THEN
468     err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
469     ELSEIF (atype .EQ. 4) THEN
470     err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
471     ELSE
472 jmc 1.25 WRITE(msgBuf,'(A,I10,A)') 'MNC ERROR: atype = ''', atype,
473 edhill 1.5 & ''' is invalid--must be: [1-4]'
474 jmc 1.25 n = ILNBLNK(msgBuf)
475     CALL print_error(msgBuf(1:n), myThid)
476     STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
477 edhill 1.5 ENDIF
478 jmc 1.25 WRITE(msgBuf,'(5A)') 'adding attribute ''', atname(1:lenat),
479 edhill 1.4 & ''' to file ''', fname(1:lenf), ''''
480 jmc 1.25 CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
481 edhill 1.4
482     RETURN
483     END
484    
485 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
486 edhill 1.4
487 jmc 1.25 SUBROUTINE MNC_VAR_WRITE_DBL(
488     I fname,
489     I vname,
490     I var,
491 edhill 1.13 I myThid )
492 edhill 1.4
493 jmc 1.25 IMPLICIT NONE
494 edhill 1.5 C Arguments
495 jmc 1.25 CHARACTER*(*) fname, vname
496     Real*8 var(*)
497     INTEGER myThid
498    
499     C Local Variables
500     Real*4 dummyR4(1)
501     INTEGER dummyI (1)
502    
503     DATA dummyR4 / 0. /
504     DATA dummyI / 0 /
505    
506     CALL MNC_VAR_WRITE_ANY( fname, vname, 1, 0,
507     & var, dummyR4, dummyI, myThid )
508 edhill 1.5
509     RETURN
510     END
511    
512 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
513 edhill 1.5
514 jmc 1.25 SUBROUTINE MNC_VAR_WRITE_REAL(
515     I fname,
516     I vname,
517     I var,
518 edhill 1.13 I myThid )
519 edhill 1.5
520 jmc 1.25 IMPLICIT NONE
521 edhill 1.5 C Arguments
522 jmc 1.25 CHARACTER*(*) fname, vname
523     Real*4 var(*)
524     INTEGER myThid
525    
526     C Local Variables
527     Real*8 dummyR8(1)
528     INTEGER dummyI (1)
529    
530     DATA dummyR8 / 0. _d 0 /
531     DATA dummyI / 0 /
532    
533     CALL MNC_VAR_WRITE_ANY( fname, vname, 2, 0,
534     & dummyR8, var, dummyI, myThid )
535 edhill 1.5
536     RETURN
537     END
538    
539 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
540 edhill 1.5
541 jmc 1.25 SUBROUTINE MNC_VAR_WRITE_INT(
542     I fname,
543     I vname,
544     I var,
545 edhill 1.13 I myThid )
546 edhill 1.5
547 jmc 1.25 IMPLICIT NONE
548 edhill 1.5 C Arguments
549 jmc 1.25 CHARACTER*(*) fname, vname
550     INTEGER var(*)
551     INTEGER myThid
552    
553     C Local Variables
554     Real*8 dummyR8(1)
555     Real*4 dummyR4(1)
556    
557     DATA dummyR8 / 0. _d 0 /
558     DATA dummyR4 / 0. /
559    
560     CALL MNC_VAR_WRITE_ANY( fname, vname, 3, 0,
561     & dummyR8, dummyR4, var, myThid )
562 edhill 1.5
563 edhill 1.9 RETURN
564     END
565    
566 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
567 edhill 1.9
568 jmc 1.25 SUBROUTINE MNC_VAR_APPEND_DBL(
569     I fname,
570     I vname,
571     I var,
572     I append,
573 edhill 1.13 I myThid )
574 edhill 1.9
575 jmc 1.25 IMPLICIT NONE
576 edhill 1.9 C Arguments
577 jmc 1.25 CHARACTER*(*) fname, vname
578     Real*8 var(*)
579     INTEGER append, myThid
580    
581     C Local Variables
582     Real*4 dummyR4(1)
583     INTEGER dummyI (1)
584    
585     DATA dummyR4 / 0. /
586     DATA dummyI / 0 /
587    
588     CALL MNC_VAR_WRITE_ANY( fname, vname, 1, append,
589     & var, dummyR4, dummyI, myThid )
590 edhill 1.9
591     RETURN
592     END
593    
594 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
595 edhill 1.9
596 jmc 1.25 SUBROUTINE MNC_VAR_APPEND_REAL(
597     I fname,
598     I vname,
599     I var,
600     I append,
601 edhill 1.13 I myThid )
602 edhill 1.9
603 jmc 1.25 IMPLICIT NONE
604 edhill 1.9 C Arguments
605 jmc 1.25 CHARACTER*(*) fname, vname
606     Real*4 var(*)
607     INTEGER append, myThid
608    
609     C Local Variables
610     Real*8 dummyR8(1)
611     INTEGER dummyI (1)
612    
613     DATA dummyR8 / 0. _d 0 /
614     DATA dummyI / 0 /
615    
616     CALL MNC_VAR_WRITE_ANY( fname, vname, 2, append,
617     & dummyR8, var, dummyI, myThid )
618 edhill 1.9
619     RETURN
620     END
621    
622 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
623 edhill 1.9
624 jmc 1.25 SUBROUTINE MNC_VAR_APPEND_INT(
625     I fname,
626     I vname,
627     I var,
628     I append,
629 edhill 1.13 I myThid )
630 edhill 1.9
631 jmc 1.25 IMPLICIT NONE
632 edhill 1.9 C Arguments
633 jmc 1.25 CHARACTER*(*) fname, vname
634     INTEGER var(*)
635     INTEGER append, myThid
636    
637     C Local Variables
638     Real*8 dummyR8(1)
639     Real*4 dummyR4(1)
640    
641     DATA dummyR8 / 0. _d 0 /
642     DATA dummyR4 / 0. /
643    
644     CALL MNC_VAR_WRITE_ANY( fname, vname, 3, append,
645     & dummyR8, dummyR4, var, myThid )
646 edhill 1.9
647 edhill 1.5 RETURN
648     END
649    
650 edhill 1.11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
651 edhill 1.5
652 jmc 1.25 SUBROUTINE MNC_VAR_WRITE_ANY(
653     I fname,
654     I vname,
655 edhill 1.5 I vtype,
656 edhill 1.9 I append,
657 edhill 1.5 I dv,
658     I rv,
659 jmc 1.25 I iv,
660 edhill 1.13 I myThid )
661 edhill 1.5
662 jmc 1.25 IMPLICIT NONE
663 mlosch 1.23 #include "MNC_COMMON.h"
664 edhill 1.4 #include "EEPARAMS.h"
665 utke 1.24 #include "netcdf.inc"
666 edhill 1.4
667     C Arguments
668 jmc 1.25 CHARACTER*(*) fname, vname
669     INTEGER vtype
670     INTEGER append
671     Real*8 dv(*)
672     Real*4 rv(*)
673     INTEGER iv(*)
674     INTEGER myThid
675 edhill 1.4
676     C Functions
677 jmc 1.25 INTEGER ILNBLNK
678 edhill 1.4
679     C Local Variables
680 jmc 1.25 INTEGER i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
681     CHARACTER*(MAX_LEN_MBUF) msgBuf
682     INTEGER lenf,lenv, lend
683     INTEGER vstart(100), vcount(100)
684 edhill 1.4
685     C Strip trailing spaces
686     lenf = ILNBLNK(fname)
687     lenv = ILNBLNK(vname)
688    
689 edhill 1.13 CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
690 edhill 1.4 IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
691 jmc 1.25 WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
692     & ''' is not open or does not contain variable ''',
693 edhill 1.4 & vname(1:lenv), ''''
694 jmc 1.25 CALL print_error(msgBuf, myThid)
695     STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
696 edhill 1.4 ENDIF
697     fid = mnc_f_info(indf,2)
698     vid = mnc_fv_ids(indf,(ind_fv_ids+1))
699    
700     C Get the lengths from the dim IDs
701     ig = mnc_fv_ids(indf,(ind_fv_ids+2))
702     ds = mnc_f_info(indf,ig+1)
703     de = mnc_f_info(indf,ig+2)
704     k = 0
705     DO i = ds,de
706     k = k + 1
707     vstart(k) = 1
708     vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
709     ENDDO
710    
711     C Check for the unlimited dimension
712     j = mnc_d_size( mnc_fd_ind(indf,de) )
713     IF (j .LT. 1) THEN
714 edhill 1.10 did = mnc_d_ids( mnc_fd_ind(indf,de) )
715 edhill 1.4 err = NF_INQ_DIMLEN(fid, did, lend)
716 jmc 1.25 WRITE(msgBuf,'(A)') 'reading current length of unlimited dim'
717     CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
718 edhill 1.9 IF (append .GT. 0) THEN
719     lend = lend + append
720     ENDIF
721     IF (lend .LT. 1) lend = 1
722 edhill 1.4 vstart(k) = lend
723     vcount(k) = 1
724     ENDIF
725    
726 edhill 1.13 CALL MNC_FILE_ENDDEF(fname, myThid)
727 edhill 1.5 IF (vtype .EQ. 1) THEN
728     err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
729     ELSEIF (vtype .EQ. 2) THEN
730     err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
731     ELSEIF (vtype .EQ. 3) THEN
732     err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
733     ELSE
734 jmc 1.25 WRITE(msgBuf,'(A,I10,A)') 'MNC ERROR: vtype = ''', vtype,
735 edhill 1.5 & ''' is invalid--must be: [1|2|3]'
736 jmc 1.25 n = ILNBLNK(msgBuf)
737     CALL print_error(msgBuf(1:n), myThid)
738     STOP 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
739     ENDIF
740     WRITE(msgBuf,'(5A)') 'writing variable ''', vname(1:lenv),
741 edhill 1.3 & ''' to file ''', fname(1:lenf), ''''
742 jmc 1.25 CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
743 edhill 1.1
744 edhill 1.2 RETURN
745 edhill 1.1 END
746 edhill 1.11
747     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
748 edhill 1.1
  ViewVC Help
Powered by ViewVC 1.1.22