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