/[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.6 by edhill, Thu Jan 8 07:34:01 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
92        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
93          integer rids(10), ids(10)
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_DBL'
109        ENDIF        ENDIF
110        fid = mnc_f_info(ind,2)        fid = mnc_f_info(indf,2)
111    
112    C     Get the grid information
113          ngrid = mnc_f_info(indf,3)
114          IF (ngrid .LT. 1) THEN
115            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),
116         &       ''' contains NO grids'
117            CALL print_error(msgbuf, mythid)
118            stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
119          ENDIF
120          DO i = 1,ngrid
121            j = 4 + (i-1)*3
122            k = mnc_f_info(indf,j)
123            n = ILNBLNK(mnc_g_names(k))
124            IF ((leng .EQ. n)
125         &       .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
126              ind_g_finfo = j
127              is = mnc_f_info(indf,(j+1))
128              ie = mnc_f_info(indf,(j+2))
129              nd = 0
130              DO k = is,ie
131                nd = nd + 1
132                ids(nd) = mnc_fg_ids(indf,k)
133              ENDDO
134              GOTO 10
135            ENDIF
136          ENDDO
137          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
138         &     ''' does not contain grid ''', gname(1:leng), ''''
139          CALL print_error(msgbuf, mythid)
140          stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
141     10   CONTINUE
142    
143    C     Add the variable definition
144          CALL MNC_FILE_REDEF(myThid, fname)
145          err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid)
146          write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
147         &     ''' in file ''', fname(1:lenf), ''''
148          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
149    
150    C     Success, so save the variable info
151          CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv)
152          mnc_v_names(indv)(1:lenv) = vname(1:lenv)
153          nv = mnc_fv_ids(indf,1)
154          i = 2 + nv*3
155          j = i + 1
156          k = i + 2
157          mnc_fv_ids(indf,i) = indv
158          mnc_fv_ids(indf,j) = vid
159          mnc_fv_ids(indf,k) = ind_g_finfo
160          mnc_fv_ids(indf,1) = nv + 1
161    
162    C     Add the units
163          CALL MNC_VAR_ADD_ATTR_STR(myThid, fname, vname, 'units', units)
164    
165          RETURN
166          END
167    
168    C==================================================================
169    
170          SUBROUTINE MNC_VAR_ADD_ATTR_STR(
171         I     myThid,
172         I     fname,
173         I     vname,
174         I     atname,
175         I     sval )
176    
177          implicit none
178    C     Arguments
179          integer myThid
180          character*(*) fname,vname,atname,sval
181    
182          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
183         &     1, sval, 0, 0.0D0, 0.0, 0)
184          RETURN
185          END
186    C==================================================================
187    
188          SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
189         I     myThid,
190         I     fname,
191         I     vname,
192         I     atname,
193         I     nv,
194         I     dval )
195    
196          implicit none
197    C     Arguments
198          integer myThid,nv
199          character*(*) fname,vname,atname
200          _RL dval(*)
201    
202          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
203         &     2, ' ', nv, dval, 0.0, 0)
204          RETURN
205          END
206    
207    C==================================================================
208    
209          SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
210         I     myThid,
211         I     fname,
212         I     vname,
213         I     atname,
214         I     nv,
215         I     rval )
216    
217          implicit none
218    C     Arguments
219          integer myThid,nv
220          character*(*) fname,vname,atname
221          _RS rval(*)
222    
223          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
224         &     3, ' ', nv, 0.0D0, rval, 0)
225          RETURN
226          END
227    
228    C==================================================================
229    
230          SUBROUTINE MNC_VAR_ADD_ATTR_INT(
231         I     myThid,
232         I     fname,
233         I     vname,
234         I     atname,
235         I     nv,
236         I     ival )
237    
238          implicit none
239    C     Arguments
240          integer myThid,nv
241          character*(*) fname,vname,atname
242          integer ival(*)
243    
244          CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
245         &     4, ' ', nv, 0.0D0, 0.0, ival)
246          RETURN
247          END
248    
249    C==================================================================
250    
251          SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
252         I     myThid,
253         I     fname,
254         I     vname,
255         I     atname,
256         I     atype, cs,len,dv,rv,iv )
257    
258          implicit none
259    #include "netcdf.inc"
260    #include "mnc_common.h"
261    #include "EEPARAMS.h"
262    
263    C     Arguments
264          integer myThid,atype,len
265          character*(*) fname,vname,atname
266          character*(*) cs
267          _RL dv(*)
268          _RS rv(*)
269          integer iv(*)
270    
271    C     Functions
272          integer ILNBLNK
273    
274    C     Local Variables
275          integer i,j,k, n, nv, indf,ind_fv_ids, fid,vid, err
276          character*(MAX_LEN_MBUF) msgbuf
277          integer lenf,lenv,lenat,lens
278    
279    C     Strip trailing spaces
280          lenf = ILNBLNK(fname)
281          lenv = ILNBLNK(vname)
282          lenat = ILNBLNK(atname)
283          lens = ILNBLNK(cs)
284    
285          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
286          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
287            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
288         &       ''' is not open or does not contain variable ''',
289         &       vname(1:lenv), ''''
290            CALL print_error(msgbuf, mythid)
291            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
292          ENDIF
293          fid = mnc_f_info(indf,2)
294          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
295    
296    C     Set the attribute
297          CALL MNC_FILE_REDEF(myThid, fname)
298          IF (atype .EQ. 1) THEN
299            err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
300          ELSEIF (atype .EQ. 2) THEN
301            err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
302          ELSEIF (atype .EQ. 3) THEN
303            err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
304          ELSEIF (atype .EQ. 4) THEN
305            err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
306          ELSE
307            write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
308         &       ''' is invalid--must be: [1-4]'
309            n = ILNBLNK(msgbuf)
310            CALL print_error(msgbuf(1:n), mythid)
311            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
312          ENDIF
313          write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
314         &     ''' to file ''', fname(1:lenf), ''''
315          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
316    
317          RETURN
318          END
319    
320    C==================================================================
321    
322          SUBROUTINE MNC_VAR_WRITE_DBL(
323         I     myThid,
324         I     fname,
325         I     vname,
326         I     var )
327    
328          implicit none
329    C     Arguments
330          integer myThid
331          character*(*) fname,vname
332          _RL var(*)
333    
334          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 1, var, 0.0, 0 )
335          RETURN
336          END
337    
338    C==================================================================
339    
340          SUBROUTINE MNC_VAR_WRITE_REAL(
341         I     myThid,
342         I     fname,
343         I     vname,
344         I     var )
345    
346          implicit none
347    C     Arguments
348          integer myThid
349          character*(*) fname,vname
350          _RS var(*)
351    
352          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 2, 0.0D0, var, 0 )
353          RETURN
354          END
355    
356    C==================================================================
357    
358          SUBROUTINE MNC_VAR_WRITE_INT(
359         I     myThid,
360         I     fname,
361         I     vname,
362         I     var )
363    
364          implicit none
365    C     Arguments
366          integer myThid
367          character*(*) fname,vname
368          integer var(*)
369    
370          CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 3, 0.0D0, 0.0, var )
371          RETURN
372          END
373    
374    C==================================================================
375    
376          SUBROUTINE MNC_VAR_WRITE_ANY(
377         I     myThid,
378         I     fname,
379         I     vname,
380         I     vtype,
381         I     dv,
382         I     rv,
383         I     iv )
384    
385          implicit none
386    #include "netcdf.inc"
387    #include "mnc_common.h"
388    #include "EEPARAMS.h"
389    
390    C     Arguments
391          integer myThid, vtype
392          character*(*) fname,vname
393          _RL dv(*)
394          _RS rv(*)
395          integer iv(*)
396    
397    C     Functions
398          integer ILNBLNK
399    
400    C     Local Variables
401          integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
402          character*(MAX_LEN_MBUF) msgbuf
403          integer lenf,lenv, lend
404          integer vstart(100), vcount(100)
405          integer rvstart(100), rvcount(100)
406    
407    C     Strip trailing spaces
408          lenf = ILNBLNK(fname)
409          lenv = ILNBLNK(vname)
410    
411          CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
412          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
413            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
414         &       ''' is not open or does not contain variable ''',
415         &       vname(1:lenv), ''''
416            CALL print_error(msgbuf, mythid)
417            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
418          ENDIF
419          fid = mnc_f_info(indf,2)
420          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
421    
422    C     Get the lengths from the dim IDs
423          ig = mnc_fv_ids(indf,(ind_fv_ids+2))
424          ds = mnc_f_info(indf,ig+1)
425          de = mnc_f_info(indf,ig+2)
426          k = 0
427          DO i = ds,de
428            k = k + 1
429            vstart(k) = 1
430            vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
431          ENDDO
432    
433    C     Check for the unlimited dimension
434          j = mnc_d_size( mnc_fd_ind(indf,de) )
435          IF (j .LT. 1) THEN
436            did = mnc_fg_ids(indf,de)
437            err = NF_INQ_DIMLEN(fid, did, lend)
438            write(msgbuf,'(a)') 'reading current length of unlimited dim'
439            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
440            IF (lend .LT. 1)  lend = lend + 1
441            vstart(k) = lend
442            vcount(k) = 1
443          ENDIF
444    
445          CALL MNC_FILE_ENDDEF(myThid, fname)
446          IF (vtype .EQ. 1) THEN
447            err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
448          ELSEIF (vtype .EQ. 2) THEN
449            err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
450          ELSEIF (vtype .EQ. 3) THEN
451            err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
452          ELSE
453            write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
454         &       ''' is invalid--must be: [1|2|3]'
455            n = ILNBLNK(msgbuf)
456            CALL print_error(msgbuf(1:n), mythid)
457            stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
458          ENDIF  
459          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
460         &     ''' to file ''', fname(1:lenf), ''''
461          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
462    
463          RETURN
464        END        END
465    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22