/[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.4 by edhill, Wed Jan 7 19:50:52 2004 UTC
# Line 13  C======================================= Line 13  C=======================================
13       I     fillval )       I     fillval )
14    
15        implicit none        implicit none
16    #include "netcdf.inc"
17  #include "mnc_common.h"  #include "mnc_common.h"
18  #include "EEPARAMS.h"  #include "EEPARAMS.h"
19    
# Line 27  C     Functions Line 28  C     Functions
28        integer ILNBLNK        integer ILNBLNK
29    
30  C     Local Variables  C     Local Variables
31        integer i, ind, fid        integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err
32          integer vid, nv, ind_g_finfo
33        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
34          integer rids(10), ids(10)
35          integer lenf,leng,lenv
36    
37  C     Is the file open?  C     Strip trailing spaces
38        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        lenf = ILNBLNK(fname)
39        IF ( ind .GT. 0 ) THEN        leng = ILNBLNK(gname)
40          write(msgbuf,'(3a)') 'MNC ERROR: file ''',        lenv = ILNBLNK(vname)
41       &       fname, ''' must be opened first'  
42          CALL print_error( msgbuf, mythid )  C     Check that the file is open
43          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
44          IF (indf .LT. 1) THEN
45            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname,
46         &       ''' must be opened first'
47            CALL print_error(msgbuf, mythid)
48            stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
49        ENDIF        ENDIF
50        fid = mnc_f_info(ind,2)        fid = mnc_f_info(indf,2)
51    
52    C     Get the grid information
53          ngrid = mnc_f_info(indf,3)
54          IF (ngrid .LT. 1) THEN
55            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),
56         &       ''' contains NO grids'
57            CALL print_error(msgbuf, mythid)
58            stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
59          ENDIF
60          DO i = 1,ngrid
61            j = 4 + (i-1)*3
62            k = mnc_f_info(indf,j)
63            n = ILNBLNK(mnc_g_names(k))
64            IF ((leng .EQ. n)
65         &       .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
66              ind_g_finfo = j
67              is = mnc_f_info(indf,(j+1))
68              ie = mnc_f_info(indf,(j+2))
69              nd = 0
70              DO k = is,ie
71                nd = nd + 1
72                ids(nd) = mnc_fg_ids(indf,k)
73              ENDDO
74              GOTO 10
75            ENDIF
76          ENDDO
77          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
78         &     ''' does not contain grid ''', gname(1:leng), ''''
79          CALL print_error(msgbuf, mythid)
80          stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
81     10   CONTINUE
82    
83    C     Add the variable definition
84          CALL MNC_FILE_REDEF(myThid, fname)
85          err = NF_DEF_VAR(fid, vname, NF_DOUBLE, nd, ids, vid)
86          write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
87         &     ''' in file ''', fname(1:lenf), ''''
88          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
89    
90    C     Success, so save the variable info
91          CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv)
92          mnc_v_names(indv)(1:lenv) = vname(1:lenv)
93          nv = mnc_fv_ids(indf,1)
94          i = 2 + nv*2
95          j = i + 1
96          k = i + 2
97          mnc_fv_ids(indf,i) = indv
98          mnc_fv_ids(indf,j) = vid
99          mnc_fv_ids(indf,k) = ind_g_finfo
100          mnc_fv_ids(indf,1) = nv + 1
101    
102          RETURN
103          END
104    
105    C==================================================================
106    
107          SUBROUTINE MNC_VAR_ADD_ATTR_STR(
108         I     myThid,
109         I     fname,
110         I     vname,
111         I     atname,
112         I     sval )
113    
114          implicit none
115    #include "netcdf.inc"
116    #include "mnc_common.h"
117    #include "EEPARAMS.h"
118    
119    C     Arguments
120          integer myThid
121          character*(*) fname
122          character*(*) vname
123          character*(*) atname
124          character*(*) sval
125    
126    C     Functions
127          integer ILNBLNK
128    
129    C     Local Variables
130          integer i,j,k, n, nv, indf,ind_fv_ids, fid,vid, err
131          character*(MAX_LEN_MBUF) msgbuf
132          integer lenf,lenv,lenat,lens
133    
134    C     Strip trailing spaces
135          lenf = ILNBLNK(fname)
136          lenv = ILNBLNK(vname)
137          lenat = ILNBLNK(atname)
138          lens = ILNBLNK(sval)
139    
140          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
141          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
142            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
143         &       ''' is not open or does not contain variable ''',
144         &       vname(1:lenv), ''''
145            CALL print_error(msgbuf, mythid)
146            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
147          ENDIF
148          fid = mnc_f_info(indf,2)
149          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
150    
151    C     Set the attribute
152          CALL MNC_FILE_REDEF(myThid, fname)
153          err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, sval)
154          write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
155         &     ''' to file ''', fname(1:lenf), ''''
156          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
157    
158          RETURN
159          END
160    
161    C==================================================================
162    
163          SUBROUTINE MNC_VAR_WRITE_DBL(
164         I     myThid,
165         I     fname,
166         I     vname,
167         I     var )
168    
169          implicit none
170    #include "netcdf.inc"
171    #include "mnc_common.h"
172    #include "EEPARAMS.h"
173    
174    C     Arguments
175          integer myThid
176          character*(*) fname
177          character*(*) vname
178          _RL var(*)
179    
180    C     Functions
181          integer ILNBLNK
182    
183    C     Local Variables
184          integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
185          character*(MAX_LEN_MBUF) msgbuf
186          integer lenf,lenv, lend
187          integer vstart(100), vcount(100)
188          integer rvstart(100), rvcount(100)
189    
190    C     Strip trailing spaces
191          lenf = ILNBLNK(fname)
192          lenv = ILNBLNK(vname)
193    
194          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
195          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
196            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
197         &       ''' is not open or does not contain variable ''',
198         &       vname(1:lenv), ''''
199            CALL print_error(msgbuf, mythid)
200            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
201          ENDIF
202          fid = mnc_f_info(indf,2)
203          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
204    
205    C     Get the lengths from the dim IDs
206          ig = mnc_fv_ids(indf,(ind_fv_ids+2))
207          ds = mnc_f_info(indf,ig+1)
208          de = mnc_f_info(indf,ig+2)
209          k = 0
210          DO i = ds,de
211            k = k + 1
212            vstart(k) = 1
213            vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
214          ENDDO
215    
216    C     Check for the unlimited dimension
217          j = mnc_d_size( mnc_fd_ind(indf,de) )
218          IF (j .LT. 1) THEN
219            did = mnc_fg_ids(indf,de)
220            err = NF_INQ_DIMLEN(fid, did, lend)
221            write(msgbuf,'(a)') 'reading current length of unlimited dim'
222            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
223            IF (lend .LT. 1)  lend = lend + 1
224            vstart(k) = lend
225            vcount(k) = 1
226          ENDIF
227    
228          CALL MNC_FILE_ENDDEF(myThid, fname)
229          err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, var)
230          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
231         &     ''' to file ''', fname(1:lenf), ''''
232          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
233    
234          RETURN
235        END        END
236    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4
  ViewVC Help
Powered by ViewVC 1.1.22