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