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

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

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

revision 1.2 by edhill, Tue Jan 6 23:19:27 2004 UTC revision 1.8 by edhill, Sat Jan 17 13:55:49 2004 UTC
# Line 9  C======================================= Line 9  C=======================================
9       I     myThid,       I     myThid,
10       I     fname,       I     fname,
11       I     gname,       I     gname,
12         I     vname,
13         I     units )
14    
15          implicit none
16    #include "netcdf.inc"
17    
18    C     Arguments
19          integer myThid
20          character*(*) fname,gname,vname,units
21    
22          CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_DOUBLE)
23          RETURN
24          END
25    
26    C==================================================================
27    
28          SUBROUTINE MNC_VAR_INIT_REAL(
29         I     myThid,
30         I     fname,
31         I     gname,
32         I     vname,
33         I     units )
34    
35          implicit none
36    #include "netcdf.inc"
37    
38    C     Arguments
39          integer myThid
40          character*(*) fname,gname,vname,units
41    
42          CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_FLOAT)
43          RETURN
44          END
45    
46    C==================================================================
47    
48          SUBROUTINE MNC_VAR_INIT_INT(
49         I     myThid,
50         I     fname,
51         I     gname,
52         I     vname,
53         I     units )
54    
55          implicit none
56    #include "netcdf.inc"
57    
58    C     Arguments
59          integer myThid
60          character*(*) fname,gname,vname,units
61    
62          CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_INT)
63          RETURN
64          END
65    
66    C==================================================================
67    
68          SUBROUTINE MNC_VAR_INIT_ANY(
69         I     myThid,
70         I     fname,
71         I     gname,
72       I     vname,       I     vname,
73       I     fillval )       I     units,
74         I     vtype )
75    
76        implicit none        implicit none
77    #include "netcdf.inc"
78  #include "mnc_common.h"  #include "mnc_common.h"
79  #include "EEPARAMS.h"  #include "EEPARAMS.h"
80    
81  C     Arguments  C     Arguments
82        integer myThid        integer myThid
83        character*(*) fname        character*(*) fname,gname,vname,units
84        character*(*) gname        integer vtype
       character*(*) vname  
       _RL fillval  
85    
86  C     Functions  C     Functions
87        integer ILNBLNK        integer ILNBLNK
88    
89  C     Local Variables  C     Local Variables
90        integer i, ind, fid        integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err
91          integer vid, nv, ind_g_finfo, needed
92        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
93          integer ids(20)
94          integer lenf,leng,lenv,lenu
95    
96    C     Strip trailing spaces
97          lenf = ILNBLNK(fname)
98          leng = ILNBLNK(gname)
99          lenv = ILNBLNK(vname)
100          lenu = ILNBLNK(units)
101    
102  C     Is the file open?  C     Check that the file is open
103        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
104        IF ( ind .GT. 0 ) THEN        IF (indf .LT. 1) THEN
105          write(msgbuf,'(3a)') 'MNC ERROR: file ''',          write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname,
106       &       fname, ''' must be opened first'       &       ''' must be opened first'
107          CALL print_error( msgbuf, mythid )          CALL print_error(msgbuf, mythid)
108          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'          stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
109        ENDIF        ENDIF
110        fid = mnc_f_info(ind,2)        fid = mnc_f_info(indf,2)
111    
112    C     Check for sufficient storage space in mnc_fv_ids
113          needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
114          IF (needed .GE. MNC_MAX_INFO) THEN
115            write(msgbuf,'(2a,i7,a)') 'MNC ERROR: MNC_MAX_INFO exceeded',
116         &       ': please increase it to ', 2*MNC_MAX_INFO,
117         &       ' in the file ''pkg/mnc/mnc_common.h'''
118            CALL print_error(msgbuf, mythid)
119            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
120          ENDIF
121    
122    C     Get the grid information
123          ngrid = mnc_f_info(indf,3)
124          IF (ngrid .LT. 1) THEN
125            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),
126         &       ''' contains NO grids'
127            CALL print_error(msgbuf, mythid)
128            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
129          ENDIF
130          DO i = 1,ngrid
131            j = 4 + (i-1)*3
132            k = mnc_f_info(indf,j)
133            n = ILNBLNK(mnc_g_names(k))
134            IF ((leng .EQ. n)
135         &       .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
136              ind_g_finfo = j
137              is = mnc_f_info(indf,(j+1))
138              ie = mnc_f_info(indf,(j+2))
139              nd = 0
140              DO k = is,ie
141                nd = nd + 1
142                ids(nd) = mnc_fg_ids(indf,k)
143              ENDDO
144              GOTO 10
145            ENDIF
146          ENDDO
147          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
148         &     ''' does not contain grid ''', gname(1:leng), ''''
149          CALL print_error(msgbuf, mythid)
150          stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
151     10   CONTINUE
152    
153    C     Add the variable definition
154          CALL MNC_FILE_REDEF(myThid, fname)
155          err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid)
156          write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
157         &     ''' in file ''', fname(1:lenf), ''''
158          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
159    
160    C     Success, so save the variable info
161          CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv)
162          mnc_v_names(indv)(1:lenv) = vname(1:lenv)
163          nv = mnc_fv_ids(indf,1)
164          i = 2 + nv*3
165          j = i + 1
166          k = i + 2
167          mnc_fv_ids(indf,i) = indv
168          mnc_fv_ids(indf,j) = vid
169          mnc_fv_ids(indf,k) = ind_g_finfo
170          mnc_fv_ids(indf,1) = nv + 1
171    
172    C     Add the units
173          CALL MNC_VAR_ADD_ATTR_STR(myThid, fname, vname, 'units', units)
174    
175          RETURN
176          END
177    
178    C==================================================================
179    
180          SUBROUTINE MNC_VAR_ADD_ATTR_STR(
181         I     myThid,
182         I     fname,
183         I     vname,
184         I     atname,
185         I     sval )
186    
187          implicit none
188    C     Arguments
189          integer myThid
190          character*(*) fname,vname,atname,sval
191    
192          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
193         &     1, sval, 0, 0.0D0, 0.0, 0)
194          RETURN
195          END
196    C==================================================================
197    
198          SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
199         I     myThid,
200         I     fname,
201         I     vname,
202         I     atname,
203         I     nv,
204         I     dval )
205    
206          implicit none
207    C     Arguments
208          integer myThid,nv
209          character*(*) fname,vname,atname
210          REAL*8 dval(*)
211    
212          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
213         &     2, ' ', nv, dval, 0.0, 0)
214          RETURN
215          END
216    
217    C==================================================================
218    
219          SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
220         I     myThid,
221         I     fname,
222         I     vname,
223         I     atname,
224         I     nv,
225         I     rval )
226    
227          implicit none
228    C     Arguments
229          integer myThid,nv
230          character*(*) fname,vname,atname
231          REAL*4 rval(*)
232    
233          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
234         &     3, ' ', nv, 0.0D0, rval, 0)
235          RETURN
236          END
237    
238    C==================================================================
239    
240          SUBROUTINE MNC_VAR_ADD_ATTR_INT(
241         I     myThid,
242         I     fname,
243         I     vname,
244         I     atname,
245         I     nv,
246         I     ival )
247    
248          implicit none
249    C     Arguments
250          integer myThid,nv
251          character*(*) fname,vname,atname
252          integer ival(*)
253    
254          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
255         &     4, ' ', nv, 0.0D0, 0.0, ival)
256          RETURN
257          END
258    
259    C==================================================================
260    
261          SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
262         I     myThid,
263         I     fname,
264         I     vname,
265         I     atname,
266         I     atype, cs,len,dv,rv,iv )
267    
268          implicit none
269    #include "netcdf.inc"
270    #include "mnc_common.h"
271    #include "EEPARAMS.h"
272    
273    C     Arguments
274          integer myThid,atype,len
275          character*(*) fname,vname,atname
276          character*(*) cs
277          REAL*8 dv(*)
278          REAL*4 rv(*)
279          integer iv(*)
280    
281    C     Functions
282          integer ILNBLNK
283    
284    C     Local Variables
285          integer n, indf,ind_fv_ids, fid,vid, err
286          character*(MAX_LEN_MBUF) msgbuf
287          integer lenf,lenv,lenat,lens
288    
289    C     Strip trailing spaces
290          lenf = ILNBLNK(fname)
291          lenv = ILNBLNK(vname)
292          lenat = ILNBLNK(atname)
293          lens = ILNBLNK(cs)
294    
295          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
296          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
297            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
298         &       ''' is not open or does not contain variable ''',
299         &       vname(1:lenv), ''''
300            CALL print_error(msgbuf, mythid)
301            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
302          ENDIF
303          fid = mnc_f_info(indf,2)
304          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
305    
306    C     Set the attribute
307          CALL MNC_FILE_REDEF(myThid, fname)
308          IF (atype .EQ. 1) THEN
309            err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
310          ELSEIF (atype .EQ. 2) THEN
311            err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
312          ELSEIF (atype .EQ. 3) THEN
313            err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
314          ELSEIF (atype .EQ. 4) THEN
315            err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
316          ELSE
317            write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
318         &       ''' is invalid--must be: [1-4]'
319            n = ILNBLNK(msgbuf)
320            CALL print_error(msgbuf(1:n), mythid)
321            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
322          ENDIF
323          write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
324         &     ''' to file ''', fname(1:lenf), ''''
325          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
326    
327          RETURN
328          END
329    
330    C==================================================================
331    
332          SUBROUTINE MNC_VAR_WRITE_DBL(
333         I     myThid,
334         I     fname,
335         I     vname,
336         I     var )
337    
338          implicit none
339    C     Arguments
340          integer myThid
341          character*(*) fname,vname
342          REAL*8 var(*)
343    
344          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 1, var, 0.0, 0 )
345          RETURN
346          END
347    
348    C==================================================================
349    
350          SUBROUTINE MNC_VAR_WRITE_REAL(
351         I     myThid,
352         I     fname,
353         I     vname,
354         I     var )
355    
356          implicit none
357    C     Arguments
358          integer myThid
359          character*(*) fname,vname
360          REAL*4 var(*)
361    
362          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 2, 0.0D0, var, 0 )
363          RETURN
364          END
365    
366    C==================================================================
367    
368          SUBROUTINE MNC_VAR_WRITE_INT(
369         I     myThid,
370         I     fname,
371         I     vname,
372         I     var )
373    
374          implicit none
375    C     Arguments
376          integer myThid
377          character*(*) fname,vname
378          integer var(*)
379    
380          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 3, 0.0D0, 0.0, var )
381          RETURN
382          END
383    
384    C==================================================================
385    
386          SUBROUTINE MNC_VAR_WRITE_ANY(
387         I     myThid,
388         I     fname,
389         I     vname,
390         I     vtype,
391         I     dv,
392         I     rv,
393         I     iv )
394    
395          implicit none
396    #include "netcdf.inc"
397    #include "mnc_common.h"
398    #include "EEPARAMS.h"
399    
400    C     Arguments
401          integer myThid, vtype
402          character*(*) fname,vname
403          REAL*8 dv(*)
404          REAL*4 rv(*)
405          integer iv(*)
406    
407    C     Functions
408          integer ILNBLNK
409    
410    C     Local Variables
411          integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
412          character*(MAX_LEN_MBUF) msgbuf
413          integer lenf,lenv, lend
414          integer vstart(100), vcount(100)
415    
416    C     Strip trailing spaces
417          lenf = ILNBLNK(fname)
418          lenv = ILNBLNK(vname)
419    
420          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
421          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
422            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
423         &       ''' is not open or does not contain variable ''',
424         &       vname(1:lenv), ''''
425            CALL print_error(msgbuf, mythid)
426            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
427          ENDIF
428          fid = mnc_f_info(indf,2)
429          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
430    
431    C     Get the lengths from the dim IDs
432          ig = mnc_fv_ids(indf,(ind_fv_ids+2))
433          ds = mnc_f_info(indf,ig+1)
434          de = mnc_f_info(indf,ig+2)
435          k = 0
436          DO i = ds,de
437            k = k + 1
438            vstart(k) = 1
439            vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
440          ENDDO
441    
442    C     Check for the unlimited dimension
443          j = mnc_d_size( mnc_fd_ind(indf,de) )
444          IF (j .LT. 1) THEN
445            did = mnc_fg_ids(indf,de)
446            err = NF_INQ_DIMLEN(fid, did, lend)
447            write(msgbuf,'(a)') 'reading current length of unlimited dim'
448            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
449            IF (lend .LT. 1)  lend = lend + 1
450            vstart(k) = lend
451            vcount(k) = 1
452          ENDIF
453    
454          CALL MNC_FILE_ENDDEF(myThid, fname)
455          IF (vtype .EQ. 1) THEN
456            err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
457          ELSEIF (vtype .EQ. 2) THEN
458            err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
459          ELSEIF (vtype .EQ. 3) THEN
460            err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
461          ELSE
462            write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
463         &       ''' is invalid--must be: [1|2|3]'
464            n = ILNBLNK(msgbuf)
465            CALL print_error(msgbuf(1:n), mythid)
466            stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
467          ENDIF  
468          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
469         &     ''' to file ''', fname(1:lenf), ''''
470          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
471    
472        RETURN        RETURN
473        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.8
  ViewVC Help
Powered by ViewVC 1.1.22