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