/[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.1 by edhill, Mon Jan 5 06:20:08 2004 UTC revision 1.10 by edhill, Sun Jan 25 00:22:57 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_d_ids(mnc_fd_ind(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          mnc_fv_ids(indf,i)   = indv
166          mnc_fv_ids(indf,i+1) = vid
167          mnc_fv_ids(indf,i+2) = ind_g_finfo
168          mnc_fv_ids(indf,1) = nv + 1
169    
170    C     Add the units
171          CALL MNC_VAR_ADD_ATTR_STR(myThid, fname, vname, 'units', units)
172    
173          RETURN
174          END
175    
176    C==================================================================
177    
178          SUBROUTINE MNC_VAR_ADD_ATTR_STR(
179         I     myThid,
180         I     fname,
181         I     vname,
182         I     atname,
183         I     sval )
184    
185          implicit none
186    C     Arguments
187          integer myThid
188          character*(*) fname,vname,atname,sval
189    
190          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
191         &     1, sval, 0, 0.0D0, 0.0, 0)
192          RETURN
193          END
194    C==================================================================
195    
196          SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
197         I     myThid,
198         I     fname,
199         I     vname,
200         I     atname,
201         I     nv,
202         I     dval )
203    
204          implicit none
205    C     Arguments
206          integer myThid,nv
207          character*(*) fname,vname,atname
208          REAL*8 dval(*)
209    
210          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
211         &     2, ' ', nv, dval, 0.0, 0)
212          RETURN
213          END
214    
215    C==================================================================
216    
217          SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
218         I     myThid,
219         I     fname,
220         I     vname,
221         I     atname,
222         I     nv,
223         I     rval )
224    
225          implicit none
226    C     Arguments
227          integer myThid,nv
228          character*(*) fname,vname,atname
229          REAL*4 rval(*)
230    
231          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
232         &     3, ' ', nv, 0.0D0, rval, 0)
233          RETURN
234          END
235    
236    C==================================================================
237    
238          SUBROUTINE MNC_VAR_ADD_ATTR_INT(
239         I     myThid,
240         I     fname,
241         I     vname,
242         I     atname,
243         I     nv,
244         I     ival )
245    
246          implicit none
247    C     Arguments
248          integer myThid,nv
249          character*(*) fname,vname,atname
250          integer ival(*)
251    
252          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
253         &     4, ' ', nv, 0.0D0, 0.0, ival)
254          RETURN
255          END
256    
257    C==================================================================
258    
259          SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
260         I     myThid,
261         I     fname,
262         I     vname,
263         I     atname,
264         I     atype, cs,len,dv,rv,iv )
265    
266          implicit none
267    #include "netcdf.inc"
268    #include "mnc_common.h"
269    #include "EEPARAMS.h"
270    
271    C     Arguments
272          integer myThid,atype,len
273          character*(*) fname,vname,atname
274          character*(*) cs
275          REAL*8 dv(*)
276          REAL*4 rv(*)
277          integer iv(*)
278    
279    C     Functions
280          integer ILNBLNK
281    
282    C     Local Variables
283          integer n, indf,ind_fv_ids, fid,vid, err
284          character*(MAX_LEN_MBUF) msgbuf
285          integer lenf,lenv,lenat,lens
286    
287    C     Strip trailing spaces
288          lenf = ILNBLNK(fname)
289          lenv = ILNBLNK(vname)
290          lenat = ILNBLNK(atname)
291          lens = ILNBLNK(cs)
292    
293          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
294          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
295            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
296         &       ''' is not open or does not contain variable ''',
297         &       vname(1:lenv), ''''
298            CALL print_error(msgbuf, mythid)
299            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
300          ENDIF
301          fid = mnc_f_info(indf,2)
302          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
303    
304    C     Set the attribute
305          CALL MNC_FILE_REDEF(myThid, fname)
306          IF (atype .EQ. 1) THEN
307            err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
308          ELSEIF (atype .EQ. 2) THEN
309            err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
310          ELSEIF (atype .EQ. 3) THEN
311            err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
312          ELSEIF (atype .EQ. 4) THEN
313            err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
314          ELSE
315            write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
316         &       ''' is invalid--must be: [1-4]'
317            n = ILNBLNK(msgbuf)
318            CALL print_error(msgbuf(1:n), mythid)
319            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
320          ENDIF
321          write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
322         &     ''' to file ''', fname(1:lenf), ''''
323          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
324    
325          RETURN
326          END
327    
328    C==================================================================
329    
330          SUBROUTINE MNC_VAR_WRITE_DBL(
331         I     myThid,
332         I     fname,
333         I     vname,
334         I     var )
335    
336          implicit none
337    C     Arguments
338          integer myThid
339          character*(*) fname,vname
340          REAL*8 var(*)
341    
342          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,0,var,0.0,0)
343          RETURN
344          END
345    
346    C==================================================================
347    
348          SUBROUTINE MNC_VAR_WRITE_REAL(
349         I     myThid,
350         I     fname,
351         I     vname,
352         I     var )
353    
354          implicit none
355    C     Arguments
356          integer myThid
357          character*(*) fname,vname
358          REAL*4 var(*)
359    
360          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,0,0.0D0,var,0)
361          RETURN
362          END
363    
364    C==================================================================
365    
366          SUBROUTINE MNC_VAR_WRITE_INT(
367         I     myThid,
368         I     fname,
369         I     vname,
370         I     var )
371    
372          implicit none
373    C     Arguments
374          integer myThid
375          character*(*) fname,vname
376          integer var(*)
377    
378          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,0,0.0D0,0.0,var)
379          RETURN
380          END
381    
382    C==================================================================
383    
384          SUBROUTINE MNC_VAR_APPEND_DBL(
385         I     myThid,
386         I     fname,
387         I     vname,
388         I     var,
389         I     append )
390    
391          implicit none
392    C     Arguments
393          integer myThid, append
394          character*(*) fname,vname
395          REAL*8 var(*)
396    
397          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,append,var,0.0,0)
398          RETURN
399          END
400    
401    C==================================================================
402    
403          SUBROUTINE MNC_VAR_APPEND_REAL(
404         I     myThid,
405         I     fname,
406         I     vname,
407         I     var,
408         I     append )
409    
410          implicit none
411    C     Arguments
412          integer myThid, append
413          character*(*) fname,vname
414          REAL*4 var(*)
415    
416          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,append,0.0D0,var,0)
417          RETURN
418          END
419    
420    C==================================================================
421    
422          SUBROUTINE MNC_VAR_APPEND_INT(
423         I     myThid,
424         I     fname,
425         I     vname,
426         I     var,
427         I     append )
428    
429          implicit none
430    C     Arguments
431          integer myThid, append
432          character*(*) fname,vname
433          integer var(*)
434    
435          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,append,0.0D0,0.0,var)
436          RETURN
437          END
438    
439    C==================================================================
440    
441          SUBROUTINE MNC_VAR_WRITE_ANY(
442         I     myThid,
443         I     fname,
444         I     vname,
445         I     vtype,
446         I     append,
447         I     dv,
448         I     rv,
449         I     iv )
450    
451          implicit none
452    #include "netcdf.inc"
453    #include "mnc_common.h"
454    #include "EEPARAMS.h"
455    
456    C     Arguments
457          integer myThid, vtype
458          character*(*) fname,vname
459          REAL*8 dv(*)
460          REAL*4 rv(*)
461          integer iv(*)
462          integer append
463    
464    C     Functions
465          integer ILNBLNK
466    
467    C     Local Variables
468          integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
469          character*(MAX_LEN_MBUF) msgbuf
470          integer lenf,lenv, lend
471          integer vstart(100), vcount(100)
472    
473    C     Strip trailing spaces
474          lenf = ILNBLNK(fname)
475          lenv = ILNBLNK(vname)
476    
477          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
478          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
479            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
480         &       ''' is not open or does not contain variable ''',
481         &       vname(1:lenv), ''''
482            CALL print_error(msgbuf, mythid)
483            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
484          ENDIF
485          fid = mnc_f_info(indf,2)
486          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
487    
488    C     Get the lengths from the dim IDs
489          ig = mnc_fv_ids(indf,(ind_fv_ids+2))
490          ds = mnc_f_info(indf,ig+1)
491          de = mnc_f_info(indf,ig+2)
492          k = 0
493          DO i = ds,de
494            k = k + 1
495            vstart(k) = 1
496            vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
497          ENDDO
498    
499    C     Check for the unlimited dimension
500          j = mnc_d_size( mnc_fd_ind(indf,de) )
501          IF (j .LT. 1) THEN
502            did = mnc_d_ids( mnc_fd_ind(indf,de) )
503            err = NF_INQ_DIMLEN(fid, did, lend)
504            write(msgbuf,'(a)') 'reading current length of unlimited dim'
505            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
506            IF (append .GT. 0) THEN
507              lend = lend + append
508            ENDIF
509            IF (lend .LT. 1) lend = 1
510            vstart(k) = lend
511            vcount(k) = 1
512          ENDIF
513    
514          CALL MNC_FILE_ENDDEF(myThid, fname)
515          IF (vtype .EQ. 1) THEN
516            err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
517          ELSEIF (vtype .EQ. 2) THEN
518            err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
519          ELSEIF (vtype .EQ. 3) THEN
520            err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
521          ELSE
522            write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
523         &       ''' is invalid--must be: [1|2|3]'
524            n = ILNBLNK(msgbuf)
525            CALL print_error(msgbuf(1:n), mythid)
526            stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
527          ENDIF  
528          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
529         &     ''' to file ''', fname(1:lenf), ''''
530          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
531    
532          RETURN
533        END        END
534    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.10
  ViewVC Help
Powered by ViewVC 1.1.22