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