/[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.8 by edhill, Sat Jan 17 13:55:49 2004 UTC revision 1.26 by jahn, Mon Aug 1 16:00:17 2011 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    C--   o MNC_VAR_INIT_INT
11    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,       I     vname,
34       I     units )       I     irv,
35         I     myThid )
36    
37    C     !DESCRIPTION:
38    C     Create a double-precision real variable within a NetCDF file context.
39    
40        implicit none  C     !USES:
41          IMPLICIT NONE
42  #include "netcdf.inc"  #include "netcdf.inc"
43    
44  C     Arguments  C     !INPUT PARAMETERS:
45        integer myThid        CHARACTER*(*) fname,gname,vname
46        character*(*) fname,gname,vname,units        INTEGER irv,myThid
47    CEOP
48    
49          CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_DOUBLE, irv,myThid )
50    
       CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_DOUBLE)  
51        RETURN        RETURN
52        END        END
53    
54  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
55    CBOP 1
56    C     !ROUTINE: MNC_VAR_INIT_REAL
57    
58        SUBROUTINE MNC_VAR_INIT_REAL(  C     !INTERFACE:
59       I     myThid,        SUBROUTINE MNC_VAR_INIT_REAL(
60       I     fname,       I     fname,
61       I     gname,       I     gname,
62       I     vname,       I     vname,
63       I     units )       I     irv,
64         I     myThid )
65    
66    C     !DESCRIPTION:
67    C     Create a single-precision real variable within a NetCDF file context.
68    
69        implicit none  C     !USES:
70          IMPLICIT NONE
71  #include "netcdf.inc"  #include "netcdf.inc"
72    
73  C     Arguments  C     !INPUT PARAMETERS:
74        integer myThid        CHARACTER*(*) fname,gname,vname
75        character*(*) fname,gname,vname,units        INTEGER irv,myThid
76    CEOP
77    
78          CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_FLOAT, irv,myThid )
79    
       CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_FLOAT)  
80        RETURN        RETURN
81        END        END
82    
83  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
84    CBOP 1
85    C     !ROUTINE: MNC_VAR_INIT_INT
86    
87        SUBROUTINE MNC_VAR_INIT_INT(  C     !INTERFACE:
88       I     myThid,        SUBROUTINE MNC_VAR_INIT_INT(
89       I     fname,       I     fname,
90       I     gname,       I     gname,
91       I     vname,       I     vname,
92       I     units )       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    
102  C     Arguments  C     !INPUT PARAMETERS:
103        integer myThid        CHARACTER*(*) fname,gname,vname
104        character*(*) fname,gname,vname,units        INTEGER irv,myThid
105    CEOP
106    
107          CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_INT, irv,myThid )
108    
       CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname,units, NF_INT)  
109        RETURN        RETURN
110        END        END
111    
112  C==================================================================  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        SUBROUTINE MNC_VAR_INIT_ANY(  C     !DESCRIPTION:
126       I     myThid,  C     General function for creating variables within a NetCDF file context.
      I     fname,  
      I     gname,  
      I     vname,  
      I     units,  
      I     vtype )  
127    
128        implicit none  C     !USES:
129  #include "netcdf.inc"        IMPLICIT NONE
130  #include "mnc_common.h"  #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,gname,vname,units        INTEGER vtype
137        integer vtype        INTEGER irv,myThid
138    CEOP
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, ind_g_finfo, needed        INTEGER vid, nv, ind_g_finfo, needed, nvar
147        character*(MAX_LEN_MBUF) msgbuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
148        integer ids(20)        INTEGER ids(20)
149        integer lenf,leng,lenv,lenu        INTEGER lenf,leng,lenv
150    
151  C     Strip trailing spaces  C     Strip trailing spaces
152        lenf = ILNBLNK(fname)        lenf = ILNBLNK(fname)
153        leng = ILNBLNK(gname)        leng = ILNBLNK(gname)
154        lenv = ILNBLNK(vname)        lenv = ILNBLNK(vname)
       lenu = ILNBLNK(units)  
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_ANY'          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  C     Check for sufficient storage space in mnc_fv_ids
168        needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)        needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
169        IF (needed .GE. MNC_MAX_INFO) THEN        IF (needed .GE. MNC_MAX_INFO) THEN
170          write(msgbuf,'(2a,i7,a)') 'MNC ERROR: MNC_MAX_INFO exceeded',          WRITE(msgBuf,'(2A,I7,A)') 'MNC ERROR: MNC_MAX_INFO exceeded',
171       &       ': please increase it to ', 2*MNC_MAX_INFO,       &       ': please increase it to ', 2*MNC_MAX_INFO,
172       &       ' in the file ''pkg/mnc/mnc_common.h'''       &       ' in the file ''pkg/mnc/MNC_SIZE.h'''
173          CALL print_error(msgbuf, mythid)          CALL print_error(msgBuf, myThid)
174          stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'          STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
175        ENDIF        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_ANY'          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            ind_g_finfo = j
192            is = mnc_f_info(indf,(j+1))            is = mnc_f_info(indf,(j+1))
# Line 139  C     Get the grid information Line 194  C     Get the grid information
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_ANY'        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, vtype, 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*3        i = 2 + nv*3
254        j = i + 1        mnc_fv_ids(indf,i)   = indv
255        k = i + 2        mnc_fv_ids(indf,i+1) = vid
256        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  
257        mnc_fv_ids(indf,1) = nv + 1        mnc_fv_ids(indf,1) = nv + 1
258    
 C     Add the units  
       CALL MNC_VAR_ADD_ATTR_STR(myThid, fname, vname, 'units', units)  
   
259        RETURN        RETURN
260        END        END
261    
262  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
263    CBOP 1
264        SUBROUTINE MNC_VAR_ADD_ATTR_STR(  C     !ROUTINE: MNC_VAR_ADD_ATTR_STR
265       I     myThid,  
266       I     fname,  C     !INTERFACE:
267       I     vname,        SUBROUTINE MNC_VAR_ADD_ATTR_STR(
268       I     atname,       I     fname,
269       I     sval )       I     vname,
270         I     atname,
271        implicit none       I     sval,
272  C     Arguments       I     myThid )
273        integer myThid  
274        character*(*) fname,vname,atname,sval  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    
       CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,  
      &     1, sval, 0, 0.0D0, 0.0, 0)  
294        RETURN        RETURN
295        END        END
296  C==================================================================  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        SUBROUTINE MNC_VAR_ADD_ATTR_DBL(  C     !DESCRIPTION:
310       I     myThid,  C     Subroutine for adding a double-precision real attribute to a NetCDF file.
      I     fname,  
      I     vname,  
      I     atname,  
      I     nv,  
      I     dval )  
311    
312        implicit none  C     !USES:
313  C     Arguments        IMPLICIT NONE
       integer myThid,nv  
       character*(*) fname,vname,atname  
       REAL*8 dval(*)  
314    
315        CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,  C     !INPUT PARAMETERS:
316       &     2, ' ', nv, dval, 0.0, 0)        CHARACTER*(*) fname,vname,atname
317        RETURN        INTEGER nv
318        END        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  C==================================================================        CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
327         &     2, ' ', nv, dval, sZero, iZero, myThid )
328    
329        SUBROUTINE MNC_VAR_ADD_ATTR_REAL(        RETURN
330       I     myThid,        END
      I     fname,  
      I     vname,  
      I     atname,  
      I     nv,  
      I     rval )  
331    
332        implicit none  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
333  C     Arguments  CBOP 1
334        integer myThid,nv  C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL
       character*(*) fname,vname,atname  
       REAL*4 rval(*)  
335    
336        CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,  C     !INTERFACE:
337       &     3, ' ', nv, 0.0D0, rval, 0)        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        RETURN
365        END        END
366    
367  C==================================================================  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        SUBROUTINE MNC_VAR_ADD_ATTR_INT(  C     !USES:
384       I     myThid,        IMPLICIT NONE
      I     fname,  
      I     vname,  
      I     atname,  
      I     nv,  
      I     ival )  
385    
386        implicit none  C     !INPUT PARAMETERS:
387  C     Arguments        CHARACTER*(*) fname,vname,atname
388        integer myThid,nv        INTEGER nv
389        character*(*) fname,vname,atname        INTEGER ival(*)
390        integer ival(*)        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          CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
398         &     4, ' ', nv, dZero, sZero, ival, myThid )
399    
       CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,  
      &     4, ' ', nv, 0.0D0, 0.0, ival)  
400        RETURN        RETURN
401        END        END
402    
403  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
404    CBOP 1
405    C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY
406    
407        SUBROUTINE MNC_VAR_ADD_ATTR_ANY(  C     !INTERFACE:
408       I     myThid,        SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
409       I     fname,       I     fname,
410       I     vname,       I     vname,
411       I     atname,       I     atname,
412       I     atype, cs,len,dv,rv,iv )       I     atype, cs,len,dv,rv,iv,
413         I     myThid )
414        implicit none  
415  #include "netcdf.inc"  C     !DESCRIPTION:
416  #include "mnc_common.h"  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"  #include "EEPARAMS.h"
422    #include "netcdf.inc"
423    
424  C     Arguments  C     !INPUT PARAMETERS:
425        integer myThid,atype,len        CHARACTER*(*) fname,vname,atname
426        character*(*) fname,vname,atname        INTEGER atype
427        character*(*) cs        CHARACTER*(*) cs
428        REAL*8 dv(*)        INTEGER len
429        REAL*4 rv(*)        Real*8 dv(*)
430        integer iv(*)        Real*4 rv(*)
431          INTEGER iv(*)
432          INTEGER myThid
433    CEOP
434    
435  C     Functions  C     Functions
436        integer ILNBLNK        INTEGER  ILNBLNK
437          EXTERNAL ILNBLNK
438    
439  C     Local Variables  C     !LOCAL VARIABLES:
440        integer n, indf,ind_fv_ids, fid,vid, err        INTEGER n, indf,ind_fv_ids, fid,vid, err
441        character*(MAX_LEN_MBUF) msgbuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
442        integer lenf,lenv,lenat,lens        INTEGER lenf,lenv,lenat,lens
443    
444  C     Strip trailing spaces  C     Strip trailing spaces
445        lenf = ILNBLNK(fname)        lenf = ILNBLNK(fname)
# Line 292  C     Strip trailing spaces Line 447  C     Strip trailing spaces
447        lenat = ILNBLNK(atname)        lenat = ILNBLNK(atname)
448        lens = ILNBLNK(cs)        lens = ILNBLNK(cs)
449    
450        CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)        CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
451        IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN        IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
452          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),          WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
453       &       ''' is not open or does not contain variable ''',       &       ''' is not open or does not contain variable ''',
454       &       vname(1:lenv), ''''       &       vname(1:lenv), ''''
455          CALL print_error(msgbuf, mythid)          CALL print_error(msgBuf, myThid)
456          stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'          STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
457        ENDIF        ENDIF
458        fid = mnc_f_info(indf,2)        fid = mnc_f_info(indf,2)
459        vid = mnc_fv_ids(indf,(ind_fv_ids+1))        vid = mnc_fv_ids(indf,(ind_fv_ids+1))
460    
461  C     Set the attribute  C     Set the attribute
462        CALL MNC_FILE_REDEF(myThid, fname)        CALL MNC_FILE_REDEF(fname, myThid)
463        IF (atype .EQ. 1) THEN        IF (atype .EQ. 1) THEN
464          err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)          err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
465        ELSEIF (atype .EQ. 2) THEN        ELSEIF (atype .EQ. 2) THEN
# Line 314  C     Set the attribute Line 469  C     Set the attribute
469        ELSEIF (atype .EQ. 4) THEN        ELSEIF (atype .EQ. 4) THEN
470          err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)          err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
471        ELSE        ELSE
472          write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,          WRITE(msgBuf,'(A,I10,A)') 'MNC ERROR: atype = ''', atype,
473       &       ''' is invalid--must be: [1-4]'       &       ''' is invalid--must be: [1-4]'
474          n = ILNBLNK(msgbuf)          n = ILNBLNK(msgBuf)
475          CALL print_error(msgbuf(1:n), mythid)          CALL print_error(msgBuf(1:n), myThid)
476          stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'          STOP 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
477        ENDIF        ENDIF
478        write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),        WRITE(msgBuf,'(5A)') 'adding attribute ''', atname(1:lenat),
479       &     ''' to file ''', fname(1:lenf), ''''       &     ''' to file ''', fname(1:lenf), ''''
480        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)        CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
481    
482        RETURN        RETURN
483        END        END
484    
485  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
486    
487        SUBROUTINE MNC_VAR_WRITE_DBL(        SUBROUTINE MNC_VAR_WRITE_DBL(
488       I     myThid,       I     fname,
489       I     fname,       I     vname,
490       I     vname,       I     var,
491       I     var )       I     myThid )
492    
493        implicit none        IMPLICIT NONE
494  C     Arguments  C     Arguments
495        integer myThid        CHARACTER*(*) fname, vname
496        character*(*) fname,vname        Real*8 var(*)
497        REAL*8 var(*)        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    
       CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 1, var, 0.0, 0 )  
509        RETURN        RETURN
510        END        END
511    
512  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
513    
514        SUBROUTINE MNC_VAR_WRITE_REAL(        SUBROUTINE MNC_VAR_WRITE_REAL(
515       I     myThid,       I     fname,
516       I     fname,       I     vname,
517       I     vname,       I     var,
518       I     var )       I     myThid )
519    
520        implicit none        IMPLICIT NONE
521  C     Arguments  C     Arguments
522        integer myThid        CHARACTER*(*) fname, vname
523        character*(*) fname,vname        Real*4 var(*)
524        REAL*4 var(*)        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    
       CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 2, 0.0D0, var, 0 )  
536        RETURN        RETURN
537        END        END
538    
539  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
540    
541        SUBROUTINE MNC_VAR_WRITE_INT(        SUBROUTINE MNC_VAR_WRITE_INT(
542       I     myThid,       I     fname,
543       I     fname,       I     vname,
544       I     vname,       I     var,
545       I     var )       I     myThid )
546    
547        implicit none        IMPLICIT NONE
548  C     Arguments  C     Arguments
549        integer myThid        CHARACTER*(*) fname, vname
550        character*(*) fname,vname        INTEGER var(*)
551        integer var(*)        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    
       CALL MNC_VAR_WRITE_ANY(myThid,fname,vname, 3, 0.0D0, 0.0, var )  
647        RETURN        RETURN
648        END        END
649    
650  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
651    
652        SUBROUTINE MNC_VAR_WRITE_ANY(        SUBROUTINE MNC_VAR_WRITE_ANY(
653       I     myThid,       I     fname,
654       I     fname,       I     vname,
      I     vname,  
655       I     vtype,       I     vtype,
656         I     append,
657       I     dv,       I     dv,
658       I     rv,       I     rv,
659       I     iv )       I     iv,
660         I     myThid )
661    
662        implicit none        IMPLICIT NONE
663  #include "netcdf.inc"  #include "MNC_COMMON.h"
 #include "mnc_common.h"  
664  #include "EEPARAMS.h"  #include "EEPARAMS.h"
665    #include "netcdf.inc"
666    
667  C     Arguments  C     Arguments
668        integer myThid, vtype        CHARACTER*(*) fname, vname
669        character*(*) fname,vname        INTEGER vtype
670        REAL*8 dv(*)        INTEGER append
671        REAL*4 rv(*)        Real*8 dv(*)
672        integer iv(*)        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, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de        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, lend        INTEGER lenf,lenv, lend
683        integer vstart(100), vcount(100)        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)
688    
689        CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)        CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
690        IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN        IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
691          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),          WRITE(msgBuf,'(5A)') 'MNC ERROR: file ''', fname(1:lenf),
692       &       ''' is not open or does not contain variable ''',       &       ''' is not open or does not contain variable ''',
693       &       vname(1:lenv), ''''       &       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))        vid = mnc_fv_ids(indf,(ind_fv_ids+1))
# Line 442  C     Get the lengths from the dim IDs Line 711  C     Get the lengths from the dim IDs
711  C     Check for the unlimited dimension  C     Check for the unlimited dimension
712        j = mnc_d_size( mnc_fd_ind(indf,de) )        j = mnc_d_size( mnc_fd_ind(indf,de) )
713        IF (j .LT. 1) THEN        IF (j .LT. 1) THEN
714          did = mnc_fg_ids(indf,de)          did = mnc_d_ids( mnc_fd_ind(indf,de) )
715          err = NF_INQ_DIMLEN(fid, did, lend)          err = NF_INQ_DIMLEN(fid, did, lend)
716          write(msgbuf,'(a)') 'reading current length of unlimited dim'          WRITE(msgBuf,'(A)') 'reading current length of unlimited dim'
717          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)          CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
718          IF (lend .LT. 1)  lend = lend + 1          IF (append .GT. 0) THEN
719              lend = lend + append
720            ENDIF
721            IF (lend .LT. 1) lend = 1
722          vstart(k) = lend          vstart(k) = lend
723          vcount(k) = 1          vcount(k) = 1
724        ENDIF        ENDIF
725    
726        CALL MNC_FILE_ENDDEF(myThid, fname)        CALL MNC_FILE_ENDDEF(fname, myThid)
727        IF (vtype .EQ. 1) THEN        IF (vtype .EQ. 1) THEN
728          err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)          err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
729        ELSEIF (vtype .EQ. 2) THEN        ELSEIF (vtype .EQ. 2) THEN
# Line 459  C     Check for the unlimited dimension Line 731  C     Check for the unlimited dimension
731        ELSEIF (vtype .EQ. 3) THEN        ELSEIF (vtype .EQ. 3) THEN
732          err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)          err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
733        ELSE        ELSE
734          write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,          WRITE(msgBuf,'(A,I10,A)') 'MNC ERROR: vtype = ''', vtype,
735       &       ''' is invalid--must be: [1|2|3]'       &       ''' is invalid--must be: [1|2|3]'
736          n = ILNBLNK(msgbuf)          n = ILNBLNK(msgBuf)
737          CALL print_error(msgbuf(1:n), mythid)          CALL print_error(msgBuf(1:n), myThid)
738          stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'          STOP 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
739        ENDIF          ENDIF
740        write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),        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.8  
changed lines
  Added in v.1.26
  ViewVC Help
Powered by ViewVC 1.1.22