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