/[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.16 by edhill, Fri Apr 2 16:12:48 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),        write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
206       &     ''' in file ''', fname(1:lenf), ''''       &     ''' in file ''', fname(1:lenf), ''''
207        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
208    
209  C     Success, so save the variable info  C     Success, so save the variable info
210        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)
211        mnc_v_names(indv)(1:lenv) = vname(1:lenv)        mnc_v_names(indv)(1:lenv) = vname(1:lenv)
212        nv = mnc_fv_ids(indf,1)        nv = mnc_fv_ids(indf,1)
213        i = 2 + nv*2        i = 2 + nv*3
214        j = i + 1        mnc_fv_ids(indf,i)   = indv
215        mnc_fv_ids(indf,i) = indv        mnc_fv_ids(indf,i+1) = vid
216        mnc_fv_ids(indf,j) = vid        mnc_fv_ids(indf,i+2) = ind_g_finfo
217        mnc_fv_ids(indf,1) = nv + 1        mnc_fv_ids(indf,1) = nv + 1
218    
219        RETURN        RETURN
220        END        END
221    
222  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
223    CBOP 1
224    C     !ROUTINE: MNC_VAR_ADD_ATTR_STR
225    
226    C     !INTERFACE:
227        SUBROUTINE MNC_VAR_ADD_ATTR_STR(        SUBROUTINE MNC_VAR_ADD_ATTR_STR(
      I     myThid,  
228       I     fname,       I     fname,
229       I     vname,       I     vname,
230       I     atname,       I     atname,
231       I     sval )       I     sval,
232         I     myThid )
233    
234    C     !DESCRIPTION:
235    C     Subroutine for adding a character string attribute to a NetCDF
236    C     file.
237          
238    C     !USES:
239          implicit none
240    
241    C     !INPUT PARAMETERS:
242          integer myThid
243          character*(*) fname,vname,atname,sval
244    CEOP
245    
246          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
247         &     1, sval, 0, 0.0D0, 0.0, 0, myThid)
248          RETURN
249          END
250    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
251    CBOP 1
252    C     !ROUTINE: MNC_VAR_ADD_ATTR_DBL
253    
254    C     !INTERFACE:
255          SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
256         I     fname,
257         I     vname,
258         I     atname,
259         I     nv,
260         I     dval,
261         I     myThid )
262    
263    C     !DESCRIPTION:
264    C     Subroutine for adding a double-precision real attribute to a
265    C     NetCDF file.
266      
267    C     !USES:
268          implicit none
269    
270    C     !INPUT PARAMETERS:
271          integer myThid,nv
272          character*(*) fname,vname,atname
273          REAL*8 dval(*)
274    CEOP
275    
276          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
277         &     2, ' ', nv, dval, 0.0, 0, myThid)
278          RETURN
279          END
280    
281    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
282    CBOP 1
283    C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL
284    
285    C     !INTERFACE:
286          SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
287         I     fname,
288         I     vname,
289         I     atname,
290         I     nv,
291         I     rval,
292         I     myThid )
293    
294    C     !DESCRIPTION:
295    C     Subroutine for adding a single-precision real attribute to a
296    C     NetCDF file.
297      
298    C     !USES:
299          implicit none
300    
301    C     !INPUT PARAMETERS:
302          integer myThid,nv
303          character*(*) fname,vname,atname
304          REAL*4 rval(*)
305    CEOP
306    
307          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
308         &     3, ' ', nv, 0.0D0, rval, 0, myThid)
309          RETURN
310          END
311    
312    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
313    CBOP 1
314    C     !ROUTINE: MNC_VAR_ADD_ATTR_INT
315    
316    C     !INTERFACE:
317          SUBROUTINE MNC_VAR_ADD_ATTR_INT(
318         I     fname,
319         I     vname,
320         I     atname,
321         I     nv,
322         I     ival,
323         I     myThid )
324    
325    C     !DESCRIPTION:
326    C     Subroutine for adding an integer attribute to a
327    C     NetCDF file.
328          
329    C     !USES:
330          implicit none
331    
332    C     !INPUT PARAMETERS:
333          integer myThid,nv
334          character*(*) fname,vname,atname
335          integer ival(*)
336    CEOP
337    
338          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
339         &     4, ' ', nv, 0.0D0, 0.0, ival, myThid)
340          RETURN
341          END
342    
343    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
344    CBOP 1
345    C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY
346    
347    C     !INTERFACE:
348          SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
349         I     fname,
350         I     vname,
351         I     atname,
352         I     atype, cs,len,dv,rv,iv,
353         I     myThid )
354    
355    C     !DESCRIPTION:
356    C     General subroutine for adding attributes to a NetCDF file.
357          
358    C     !USES:
359        implicit none        implicit none
360  #include "netcdf.inc"  #include "netcdf.inc"
361  #include "mnc_common.h"  #include "mnc_common.h"
362  #include "EEPARAMS.h"  #include "EEPARAMS.h"
363    
364    C     !INPUT PARAMETERS:
365          integer myThid,atype,len
366          character*(*) fname,vname,atname
367          character*(*) cs
368          REAL*8 dv(*)
369          REAL*4 rv(*)
370          integer iv(*)
371    CEOP
372    
373    C     !LOCAL VARIABLES:
374          integer n, indf,ind_fv_ids, fid,vid, err
375          character*(MAX_LEN_MBUF) msgbuf
376          integer lenf,lenv,lenat,lens
377    
378    C     Functions
379          integer ILNBLNK
380    
381    C     Strip trailing spaces
382          lenf = ILNBLNK(fname)
383          lenv = ILNBLNK(vname)
384          lenat = ILNBLNK(atname)
385          lens = ILNBLNK(cs)
386    
387          CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
388          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
389            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
390         &       ''' is not open or does not contain variable ''',
391         &       vname(1:lenv), ''''
392            CALL print_error(msgbuf, mythid)
393            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
394          ENDIF
395          fid = mnc_f_info(indf,2)
396          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
397    
398    C     Set the attribute
399          CALL MNC_FILE_REDEF(fname, myThid)
400          IF (atype .EQ. 1) THEN
401            err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
402          ELSEIF (atype .EQ. 2) THEN
403            err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
404          ELSEIF (atype .EQ. 3) THEN
405            err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
406          ELSEIF (atype .EQ. 4) THEN
407            err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
408          ELSE
409            write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
410         &       ''' is invalid--must be: [1-4]'
411            n = ILNBLNK(msgbuf)
412            CALL print_error(msgbuf(1:n), mythid)
413            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
414          ENDIF
415          write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
416         &     ''' to file ''', fname(1:lenf), ''''
417          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
418    
419          RETURN
420          END
421    
422    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
423    
424          SUBROUTINE MNC_VAR_WRITE_DBL(
425         I     fname,
426         I     vname,
427         I     var,
428         I     myThid )
429    
430          implicit none
431    C     Arguments
432          integer myThid
433          character*(*) fname,vname
434          REAL*8 var(*)
435    
436          CALL MNC_VAR_WRITE_ANY(fname,vname,1,0,var,0.0,0, myThid)
437          RETURN
438          END
439    
440    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
441    
442          SUBROUTINE MNC_VAR_WRITE_REAL(
443         I     fname,
444         I     vname,
445         I     var,
446         I     myThid )
447    
448          implicit none
449  C     Arguments  C     Arguments
450        integer myThid        integer myThid
451        character*(*) fname        character*(*) fname,vname
452        character*(*) vname        REAL*4 var(*)
453        character*(*) atname  
454        character*(*) sval        CALL MNC_VAR_WRITE_ANY(fname,vname,2,0,0.0D0,var,0, myThid)
455          RETURN
456          END
457    
458    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
459    
460          SUBROUTINE MNC_VAR_WRITE_INT(
461         I     fname,
462         I     vname,
463         I     var,
464         I     myThid )
465    
466          implicit none
467    C     Arguments
468          integer myThid
469          character*(*) fname,vname
470          integer var(*)
471    
472          CALL MNC_VAR_WRITE_ANY(fname,vname,3,0,0.0D0,0.0,var, myThid)
473          RETURN
474          END
475    
476    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
477    
478          SUBROUTINE MNC_VAR_APPEND_DBL(
479         I     fname,
480         I     vname,
481         I     var,
482         I     append,
483         I     myThid )
484    
485          implicit none
486    C     Arguments
487          integer myThid, append
488          character*(*) fname,vname
489          REAL*8 var(*)
490    
491          CALL MNC_VAR_WRITE_ANY(fname,vname,1,append,var,0.0,0, myThid)
492          RETURN
493          END
494    
495    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
496    
497          SUBROUTINE MNC_VAR_APPEND_REAL(
498         I     fname,
499         I     vname,
500         I     var,
501         I     append,
502         I     myThid )
503    
504          implicit none
505    C     Arguments
506          integer myThid, append
507          character*(*) fname,vname
508          REAL*4 var(*)
509    
510          CALL MNC_VAR_WRITE_ANY(fname,vname,2,append,0.0D0,var,0,myThid)
511          RETURN
512          END
513    
514    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
515    
516          SUBROUTINE MNC_VAR_APPEND_INT(
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          integer var(*)
528    
529          CALL MNC_VAR_WRITE_ANY(fname,vname,3,append,0.0D0,0.0,var,myThid)
530          RETURN
531          END
532    
533    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
534    
535          SUBROUTINE MNC_VAR_WRITE_ANY(
536         I     fname,
537         I     vname,
538         I     vtype,
539         I     append,
540         I     dv,
541         I     rv,
542         I     iv,
543         I     myThid )
544    
545          implicit none
546    #include "netcdf.inc"
547    #include "mnc_common.h"
548    #include "EEPARAMS.h"
549    
550    C     Arguments
551          integer myThid, vtype
552          character*(*) fname,vname
553          REAL*8 dv(*)
554          REAL*4 rv(*)
555          integer iv(*)
556          integer append
557    
558  C     Functions  C     Functions
559        integer ILNBLNK        integer ILNBLNK
560    
561  C     Local Variables  C     Local Variables
562        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
563        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
564        integer lenf,lenv,lenat,lens        integer lenf,lenv, lend
565          integer vstart(100), vcount(100)
566    
567  C     Strip trailing spaces  C     Strip trailing spaces
568        lenf = ILNBLNK(fname)        lenf = ILNBLNK(fname)
569        lenv = ILNBLNK(vname)        lenv = ILNBLNK(vname)
       lenat = ILNBLNK(atname)  
       lens = ILNBLNK(sval)  
570    
571  C     Check that the file is open        CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
572        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)        IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
573        IF (indf .LT. 1) THEN          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
574          write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),       &       ''' is not open or does not contain variable ''',
575       &       ''' must be opened first'       &       vname(1:lenv), ''''
576          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
577          stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'          stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
578        ENDIF        ENDIF
579        fid = mnc_f_info(indf,2)        fid = mnc_f_info(indf,2)
580          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
581    
582  C     Find the vID  C     Get the lengths from the dim IDs
583        nv = mnc_fv_ids(indf,1)        ig = mnc_fv_ids(indf,(ind_fv_ids+2))
584        DO i = 1,nv        ds = mnc_f_info(indf,ig+1)
585          k = 2*i        de = mnc_f_info(indf,ig+2)
586          j = mnc_fv_ids(indf,k)        k = 0
587          n = ILNBLNK(mnc_v_names(j))        DO i = ds,de
588          IF ((n .EQ. lenv)          k = k + 1
589       &       .AND. (mnc_v_names(j)(1:n) .EQ. vname(1:n))) THEN          vstart(k) = 1
590            k = k + 1          vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
           vid = mnc_fv_ids(indf,k)  
           GOTO 10  
         ENDIF  
591        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  
592    
593  C     Set the attribute  C     Check for the unlimited dimension
594        CALL MNC_FILE_REDEF(myThid, fname)        j = mnc_d_size( mnc_fd_ind(indf,de) )
595        err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, sval)        IF (j .LT. 1) THEN
596        write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),          did = mnc_d_ids( mnc_fd_ind(indf,de) )
597            err = NF_INQ_DIMLEN(fid, did, lend)
598            write(msgbuf,'(a)') 'reading current length of unlimited dim'
599            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
600            IF (append .GT. 0) THEN
601              lend = lend + append
602            ENDIF
603            IF (lend .LT. 1) lend = 1
604            vstart(k) = lend
605            vcount(k) = 1
606          ENDIF
607    
608          CALL MNC_FILE_ENDDEF(fname, myThid)
609          IF (vtype .EQ. 1) THEN
610            err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
611          ELSEIF (vtype .EQ. 2) THEN
612            err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
613          ELSEIF (vtype .EQ. 3) THEN
614            err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
615          ELSE
616            write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
617         &       ''' is invalid--must be: [1|2|3]'
618            n = ILNBLNK(msgbuf)
619            CALL print_error(msgbuf(1:n), mythid)
620            stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
621          ENDIF  
622          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
623       &     ''' to file ''', fname(1:lenf), ''''       &     ''' to file ''', fname(1:lenf), ''''
624        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
625    
626        RETURN        RETURN
627        END        END
628    
629    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
630    
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.16
  ViewVC Help
Powered by ViewVC 1.1.22