/[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.9 by edhill, Sun Jan 18 23:23:15 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,
73         I     units,
74         I     vtype )
75    
76          implicit none
77    #include "netcdf.inc"
78    #include "mnc_common.h"
79    #include "EEPARAMS.h"
80    
81    C     Arguments
82          integer myThid
83          character*(*) fname,gname,vname,units
84          integer vtype
85    
86    C     Functions
87          integer ILNBLNK
88    
89    C     Local Variables
90          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
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     Check that the file is open
103          CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
104          IF (indf .LT. 1) THEN
105            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname,
106         &       ''' must be opened first'
107            CALL print_error(msgbuf, mythid)
108            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
109          ENDIF
110          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,       I     vname,
265       I     fillval )       I     atname,
266         I     atype, cs,len,dv,rv,iv )
267    
268        implicit none        implicit none
269    #include "netcdf.inc"
270  #include "mnc_common.h"  #include "mnc_common.h"
271  #include "EEPARAMS.h"  #include "EEPARAMS.h"
272    
273  C     Arguments  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,0,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,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        integer myThid
377        character*(*) fname        character*(*) fname,vname
378        character*(*) gname        integer var(*)
379        character*(*) vname  
380        _RL fillval        CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,0,0.0D0,0.0,var)
381          RETURN
382          END
383    
384    C==================================================================
385    
386          SUBROUTINE MNC_VAR_APPEND_DBL(
387         I     myThid,
388         I     fname,
389         I     vname,
390         I     var,
391         I     append )
392    
393          implicit none
394    C     Arguments
395          integer myThid, append
396          character*(*) fname,vname
397          REAL*8 var(*)
398    
399          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,append,var,0.0,0)
400          RETURN
401          END
402    
403    C==================================================================
404    
405          SUBROUTINE MNC_VAR_APPEND_REAL(
406         I     myThid,
407         I     fname,
408         I     vname,
409         I     var,
410         I     append )
411    
412          implicit none
413    C     Arguments
414          integer myThid, append
415          character*(*) fname,vname
416          REAL*4 var(*)
417    
418          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,append,0.0D0,var,0)
419          RETURN
420          END
421    
422    C==================================================================
423    
424          SUBROUTINE MNC_VAR_APPEND_INT(
425         I     myThid,
426         I     fname,
427         I     vname,
428         I     var,
429         I     append )
430    
431          implicit none
432    C     Arguments
433          integer myThid, append
434          character*(*) fname,vname
435          integer var(*)
436    
437          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,append,0.0D0,0.0,var)
438          RETURN
439          END
440    
441    C==================================================================
442    
443          SUBROUTINE MNC_VAR_WRITE_ANY(
444         I     myThid,
445         I     fname,
446         I     vname,
447         I     vtype,
448         I     append,
449         I     dv,
450         I     rv,
451         I     iv )
452    
453          implicit none
454    #include "netcdf.inc"
455    #include "mnc_common.h"
456    #include "EEPARAMS.h"
457    
458    C     Arguments
459          integer myThid, vtype
460          character*(*) fname,vname
461          REAL*8 dv(*)
462          REAL*4 rv(*)
463          integer iv(*)
464          integer append
465    
466  C     Functions  C     Functions
467        integer ILNBLNK        integer ILNBLNK
468    
469  C     Local Variables  C     Local Variables
470        integer i, ind, fid        integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
471        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
472          integer lenf,lenv, lend
473          integer vstart(100), vcount(100)
474    
475    C     Strip trailing spaces
476          lenf = ILNBLNK(fname)
477          lenv = ILNBLNK(vname)
478    
479          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
480          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
481            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
482         &       ''' is not open or does not contain variable ''',
483         &       vname(1:lenv), ''''
484            CALL print_error(msgbuf, mythid)
485            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
486          ENDIF
487          fid = mnc_f_info(indf,2)
488          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
489    
490    C     Get the lengths from the dim IDs
491          ig = mnc_fv_ids(indf,(ind_fv_ids+2))
492          ds = mnc_f_info(indf,ig+1)
493          de = mnc_f_info(indf,ig+2)
494          k = 0
495          DO i = ds,de
496            k = k + 1
497            vstart(k) = 1
498            vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
499          ENDDO
500    
501  C     Is the file open?  C     Check for the unlimited dimension
502        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        j = mnc_d_size( mnc_fd_ind(indf,de) )
503        IF ( ind .GT. 0 ) THEN        IF (j .LT. 1) THEN
504          write(msgbuf,'(3a)') 'MNC ERROR: file ''',          did = mnc_fg_ids(indf,de)
505       &       fname, ''' must be opened first'          err = NF_INQ_DIMLEN(fid, did, lend)
506          CALL print_error( msgbuf, mythid )          write(msgbuf,'(a)') 'reading current length of unlimited dim'
507          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
508            IF (append .GT. 0) THEN
509              lend = lend + append
510            ENDIF
511            IF (lend .LT. 1) lend = 1
512            vstart(k) = lend
513            vcount(k) = 1
514        ENDIF        ENDIF
515        fid = mnc_f_info(ind,2)  
516          CALL MNC_FILE_ENDDEF(myThid, fname)
517          IF (vtype .EQ. 1) THEN
518            err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
519          ELSEIF (vtype .EQ. 2) THEN
520            err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
521          ELSEIF (vtype .EQ. 3) THEN
522            err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
523          ELSE
524            write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
525         &       ''' is invalid--must be: [1|2|3]'
526            n = ILNBLNK(msgbuf)
527            CALL print_error(msgbuf(1:n), mythid)
528            stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
529          ENDIF  
530          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
531         &     ''' to file ''', fname(1:lenf), ''''
532          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
533    
534        RETURN        RETURN
535        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.9
  ViewVC Help
Powered by ViewVC 1.1.22