/[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.17 by jmc, Thu Sep 23 16:17:57 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"
5          
6    C--  File mnc_var.F: Handle NetCDF variables (definition,description & writing)
7    C--   Contents
8    C--   o MNC_VAR_INIT_DBL
9    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-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
26  CBOP 1  CBOP 1
27  C     !ROUTINE: MNC_VAR_INIT_DBL  C     !ROUTINE: MNC_VAR_INIT_DBL
28    
29  C     !INTERFACE:  C     !INTERFACE:
30        SUBROUTINE MNC_VAR_INIT_DBL(        SUBROUTINE MNC_VAR_INIT_DBL(
31       I     fname,       I     fname,
32       I     gname,       I     gname,
33       I     vname,       I     vname,
34         I     irv,
35       I     myThid )       I     myThid )
36    
37  C     !DESCRIPTION:  C     !DESCRIPTION:
38  C     Create a double-precision real variable within a NetCDF file  C     Create a double-precision real variable within a NetCDF file context.
39  C     context.  
         
40  C     !USES:  C     !USES:
41        implicit none        IMPLICIT NONE
42  #include "netcdf.inc"  #include "netcdf.inc"
43    
44  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
45        integer myThid        CHARACTER*(*) fname,gname,vname
46        character*(*) fname,gname,vname        INTEGER irv,myThid
47  CEOP  CEOP
48    
49        CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_DOUBLE, myThid)        CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_DOUBLE, irv,myThid )
50    
51        RETURN        RETURN
52        END        END
53    
# Line 36  CBOP 1 Line 56  CBOP 1
56  C     !ROUTINE: MNC_VAR_INIT_REAL  C     !ROUTINE: MNC_VAR_INIT_REAL
57    
58  C     !INTERFACE:  C     !INTERFACE:
59        SUBROUTINE MNC_VAR_INIT_REAL(        SUBROUTINE MNC_VAR_INIT_REAL(
60       I     fname,       I     fname,
61       I     gname,       I     gname,
62       I     vname,       I     vname,
63         I     irv,
64       I     myThid )       I     myThid )
65    
66  C     !DESCRIPTION:  C     !DESCRIPTION:
67  C     Create a single-precision real variable within a NetCDF file  C     Create a single-precision real variable within a NetCDF file context.
68  C     context.  
         
69  C     !USES:  C     !USES:
70        implicit none        IMPLICIT NONE
71  #include "netcdf.inc"  #include "netcdf.inc"
72    
73  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
74        integer myThid        CHARACTER*(*) fname,gname,vname
75        character*(*) fname,gname,vname        INTEGER irv,myThid
76  CEOP  CEOP
77    
78        CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_FLOAT, myThid)        CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_FLOAT, irv,myThid )
79    
80        RETURN        RETURN
81        END        END
82    
# Line 64  CBOP 1 Line 85  CBOP 1
85  C     !ROUTINE: MNC_VAR_INIT_INT  C     !ROUTINE: MNC_VAR_INIT_INT
86    
87  C     !INTERFACE:  C     !INTERFACE:
88        SUBROUTINE MNC_VAR_INIT_INT(        SUBROUTINE MNC_VAR_INIT_INT(
89       I     fname,       I     fname,
90       I     gname,       I     gname,
91       I     vname,       I     vname,
92         I     irv,
93       I     myThid )       I     myThid )
94    
95  C     !DESCRIPTION:  C     !DESCRIPTION:
96  C     Create an integer variable within a NetCDF file context.  C     Create an integer variable within a NetCDF file context.
97      
98  C     !USES:  C     !USES:
99        implicit none        IMPLICIT NONE
100  #include "netcdf.inc"  #include "netcdf.inc"
101    
102  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
103        integer myThid        CHARACTER*(*) fname,gname,vname
104        character*(*) fname,gname,vname        INTEGER irv,myThid
105  CEOP  CEOP
106    
107        CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_INT, myThid)        CALL MNC_VAR_INIT_ANY( fname,gname,vname, NF_INT, irv,myThid )
108    
109        RETURN        RETURN
110        END        END
111    
# Line 91  CBOP 1 Line 114  CBOP 1
114  C     !ROUTINE: MNC_VAR_INIT_ANY  C     !ROUTINE: MNC_VAR_INIT_ANY
115    
116  C     !INTERFACE:  C     !INTERFACE:
117        SUBROUTINE MNC_VAR_INIT_ANY(        SUBROUTINE MNC_VAR_INIT_ANY(
118       I     fname,       I     fname,
119       I     gname,       I     gname,
120       I     vname,       I     vname,
121       I     vtype,       I     vtype,
122         I     irv,
123       I     myThid )       I     myThid )
124    
125  C     !DESCRIPTION:  C     !DESCRIPTION:
126  C     General function for creating variables within a NetCDF file  C     General function for creating variables within a NetCDF file context.
127  C     context.  
         
128  C     !USES:  C     !USES:
129        implicit none        IMPLICIT NONE
130  #include "netcdf.inc"  #include "MNC_COMMON.h"
 #include "mnc_common.h"  
131  #include "EEPARAMS.h"  #include "EEPARAMS.h"
132    #include "netcdf.inc"
133    
134  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
135        integer myThid        CHARACTER*(*) fname,gname,vname
136        character*(*) fname,gname,vname        INTEGER vtype
137        integer vtype        INTEGER irv,myThid
138  CEOP  CEOP
139    
 C     !LOCAL VARIABLES:  
       integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err  
       integer vid, nv, ind_g_finfo, needed, nvar  
       character*(MAX_LEN_MBUF) msgbuf  
       integer ids(20)  
       integer lenf,leng,lenv  
   
140  C     Functions  C     Functions
141        integer ILNBLNK        INTEGER  ILNBLNK
142          EXTERNAL ILNBLNK
143    
144    C     !LOCAL VARIABLES:
145          INTEGER i,j,k, n, nf, indf,indv, fid, nd, ngrid, is,ie, err
146          INTEGER vid, nv, ind_g_finfo, needed, nvar
147          CHARACTER*(MAX_LEN_MBUF) msgBuf
148          INTEGER ids(20)
149          INTEGER lenf,leng,lenv
150    
151  C     Strip trailing spaces  C     Strip trailing spaces
152        lenf = ILNBLNK(fname)        lenf = ILNBLNK(fname)
# Line 130  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(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)        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_COMMON.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 174  C     Get the grid information Line 199  C     Get the grid information
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  C     Check if the variable is already defined
# Line 187  C     Check if the variable is already d Line 212  C     Check if the variable is already d
212          IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN          IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN
213            k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))            k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))
214            IF (mnc_g_names(k) .NE. gname) THEN            IF (mnc_g_names(k) .NE. gname) THEN
215              write(msgbuf,'(5a)') 'MNC ERROR: variable ''',              WRITE(msgBuf,'(5A)') 'MNC ERROR: variable ''',
216       &           vname(1:lenv), ''' is already defined in file ''',       &           vname(1:lenv), ''' is already defined in file ''',
217       &           fname(1:lenf), ''' but using a different grid shape'       &           fname(1:lenf), ''' but using a different grid shape'
218              CALL print_error(msgbuf, mythid)              CALL print_error(msgBuf, myThid)
219              stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'              STOP 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
220            ELSE            ELSE
221  C           Its OK, the variable and grid names are the same  C           Its OK, the variable and grid names are the same
222                irv = 0
223              RETURN              RETURN
224            ENDIF            ENDIF
225          ENDIF          ENDIF
226        ENDDO        ENDDO
227    
228          irv = 1
229    
230  C     Add the variable definition  C     Add the variable definition
231        CALL MNC_FILE_REDEF(fname, myThid)        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(err, msgbuf, myThid)          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(MNC_MAX_ID,mnc_v_names,indv, myThid)        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
# Line 224  CBOP 1 Line 264  CBOP 1
264  C     !ROUTINE: MNC_VAR_ADD_ATTR_STR  C     !ROUTINE: MNC_VAR_ADD_ATTR_STR
265    
266  C     !INTERFACE:  C     !INTERFACE:
267        SUBROUTINE MNC_VAR_ADD_ATTR_STR(        SUBROUTINE MNC_VAR_ADD_ATTR_STR(
268       I     fname,       I     fname,
269       I     vname,       I     vname,
270       I     atname,       I     atname,
271       I     sval,       I     sval,
272       I     myThid )       I     myThid )
273    
274  C     !DESCRIPTION:  C     !DESCRIPTION:
275  C     Subroutine for adding a character string attribute to a NetCDF  C     Subroutine for adding a character string attribute to a NetCDF file.
276  C     file.  
         
277  C     !USES:  C     !USES:
278        implicit none        IMPLICIT NONE
279    
280  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
281        integer myThid        CHARACTER*(*) fname,vname,atname,sval
282        character*(*) fname,vname,atname,sval        INTEGER myThid
283  CEOP  CEOP
284        real*8 dZero(1)        real*8 dZero(1)
285        real*4 sZero(1)        real*4 sZero(1)
286        integer iZero(1)        INTEGER iZero(1)
287        dZero(1) = 0.0D0        dZero(1) = 0.0D0
288        sZero(1) = 0.0        sZero(1) = 0.0
289        iZero(1) = 0        iZero(1) = 0
290    
291        CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,        CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
292       &     1, sval, 0, dZero, sZero, iZero, myThid)       &     1, sval, 0, dZero, sZero, iZero, myThid )
293    
294        RETURN        RETURN
295        END        END
296  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
# Line 258  CBOP 1 Line 298  CBOP 1
298  C     !ROUTINE: MNC_VAR_ADD_ATTR_DBL  C     !ROUTINE: MNC_VAR_ADD_ATTR_DBL
299    
300  C     !INTERFACE:  C     !INTERFACE:
301        SUBROUTINE MNC_VAR_ADD_ATTR_DBL(        SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
302       I     fname,       I     fname,
303       I     vname,       I     vname,
304       I     atname,       I     atname,
305       I     nv,       I     nv,
306       I     dval,       I     dval,
307       I     myThid )       I     myThid )
308    
309  C     !DESCRIPTION:  C     !DESCRIPTION:
310  C     Subroutine for adding a double-precision real attribute to a  C     Subroutine for adding a double-precision real attribute to a NetCDF file.
311  C     NetCDF file.  
     
312  C     !USES:  C     !USES:
313        implicit none        IMPLICIT NONE
314    
315  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
316        integer myThid,nv        CHARACTER*(*) fname,vname,atname
317        character*(*) fname,vname,atname        INTEGER nv
318        REAL*8 dval(*)        Real*8 dval(*)
319          INTEGER myThid
320  CEOP  CEOP
321        real*4 sZero(1)        real*4 sZero(1)
322        integer iZero(1)        INTEGER iZero(1)
323        sZero(1) = 0.0        sZero(1) = 0.0
324        iZero(1) = 0        iZero(1) = 0
325    
326        CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,        CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
327       &     2, ' ', nv, dval, sZero, iZero, myThid)       &     2, ' ', nv, dval, sZero, iZero, myThid )
328    
329        RETURN        RETURN
330        END        END
331    
# Line 293  CBOP 1 Line 334  CBOP 1
334  C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL  C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL
335    
336  C     !INTERFACE:  C     !INTERFACE:
337        SUBROUTINE MNC_VAR_ADD_ATTR_REAL(        SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
338       I     fname,       I     fname,
339       I     vname,       I     vname,
340       I     atname,       I     atname,
341       I     nv,       I     nv,
342       I     rval,       I     rval,
343       I     myThid )       I     myThid )
344    
345  C     !DESCRIPTION:  C     !DESCRIPTION:
346  C     Subroutine for adding a single-precision real attribute to a  C     Subroutine for adding a single-precision real attribute to a NetCDF file.
347  C     NetCDF file.  
     
348  C     !USES:  C     !USES:
349        implicit none        IMPLICIT NONE
350    
351  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
352        integer myThid,nv        CHARACTER*(*) fname,vname,atname
353        character*(*) fname,vname,atname        INTEGER nv
354        REAL*4 rval(*)        Real*4 rval(*)
355          INTEGER myThid
356  CEOP  CEOP
357        real*8 dZero(1)        real*8 dZero(1)
358        integer iZero(1)        INTEGER iZero(1)
359        dZero(1) = 0.0D0        dZero(1) = 0.0D0
360        iZero(1) = 0        iZero(1) = 0
361    
362        CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,        CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
363       &     3, ' ', nv, dZero, rval, iZero, myThid)       &     3, ' ', nv, dZero, rval, iZero, myThid )
364        RETURN        RETURN
365        END        END
366    
# Line 328  CBOP 1 Line 369  CBOP 1
369  C     !ROUTINE: MNC_VAR_ADD_ATTR_INT  C     !ROUTINE: MNC_VAR_ADD_ATTR_INT
370    
371  C     !INTERFACE:  C     !INTERFACE:
372        SUBROUTINE MNC_VAR_ADD_ATTR_INT(        SUBROUTINE MNC_VAR_ADD_ATTR_INT(
373       I     fname,       I     fname,
374       I     vname,       I     vname,
375       I     atname,       I     atname,
376       I     nv,       I     nv,
377       I     ival,       I     ival,
378       I     myThid )       I     myThid )
379    
380  C     !DESCRIPTION:  C     !DESCRIPTION:
381  C     Subroutine for adding an integer attribute to a  C     Subroutine for adding an integer attribute to a NetCDF file.
382  C     NetCDF file.  
         
383  C     !USES:  C     !USES:
384        implicit none        IMPLICIT NONE
385    
386  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
387        integer myThid,nv        CHARACTER*(*) fname,vname,atname
388        character*(*) fname,vname,atname        INTEGER nv
389        integer ival(*)        INTEGER ival(*)
390          INTEGER myThid
391  CEOP  CEOP
392        real*8 dZero(1)        real*8 dZero(1)
393        real*4 sZero(1)        real*4 sZero(1)
394        dZero(1) = 0.0D0        dZero(1) = 0.0D0
395        sZero(1) = 0.0        sZero(1) = 0.0
396    
397        CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,        CALL MNC_VAR_ADD_ATTR_ANY( fname,vname,atname,
398       &     4, ' ', nv, dZero, sZero, ival, myThid)       &     4, ' ', nv, dZero, sZero, ival, myThid )
399    
400        RETURN        RETURN
401        END        END
402    
# Line 363  CBOP 1 Line 405  CBOP 1
405  C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY  C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY
406    
407  C     !INTERFACE:  C     !INTERFACE:
408        SUBROUTINE MNC_VAR_ADD_ATTR_ANY(        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 )       I     myThid )
414    
415  C     !DESCRIPTION:  C     !DESCRIPTION:
416  C     General subroutine for adding attributes to a NetCDF file.  C     General SUBROUTINE for adding attributes to a NetCDF file.
417          
418  C     !USES:  C     !USES:
419        implicit none        IMPLICIT NONE
420  #include "netcdf.inc"  #include "MNC_COMMON.h"
 #include "mnc_common.h"  
421  #include "EEPARAMS.h"  #include "EEPARAMS.h"
422    #include "netcdf.inc"
423    
424  C     !INPUT PARAMETERS:  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  CEOP
434    
 C     !LOCAL VARIABLES:  
       integer n, indf,ind_fv_ids, fid,vid, err  
       character*(MAX_LEN_MBUF) msgbuf  
       integer lenf,lenv,lenat,lens  
   
435  C     Functions  C     Functions
436        integer ILNBLNK        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  C     Strip trailing spaces
445        lenf = ILNBLNK(fname)        lenf = ILNBLNK(fname)
# Line 404  C     Strip trailing spaces Line 449  C     Strip trailing spaces
449    
450        CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)        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))
# Line 424  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(err, msgbuf, myThid)        CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
481    
482        RETURN        RETURN
483        END        END
484    
485  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
486    
487        SUBROUTINE MNC_VAR_WRITE_DBL(        SUBROUTINE MNC_VAR_WRITE_DBL(
488       I     fname,       I     fname,
489       I     vname,       I     vname,
490       I     var,       I     var,
491       I     myThid )       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(fname,vname,1,0,var,0.0,0, myThid)  
509        RETURN        RETURN
510        END        END
511    
512  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
513    
514        SUBROUTINE MNC_VAR_WRITE_REAL(        SUBROUTINE MNC_VAR_WRITE_REAL(
515       I     fname,       I     fname,
516       I     vname,       I     vname,
517       I     var,       I     var,
518       I     myThid )       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(fname,vname,2,0,0.0D0,var,0, myThid)  
536        RETURN        RETURN
537        END        END
538    
539  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
540    
541        SUBROUTINE MNC_VAR_WRITE_INT(        SUBROUTINE MNC_VAR_WRITE_INT(
542       I     fname,       I     fname,
543       I     vname,       I     vname,
544       I     var,       I     var,
545       I     myThid )       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    
       CALL MNC_VAR_WRITE_ANY(fname,vname,3,0,0.0D0,0.0,var, myThid)  
563        RETURN        RETURN
564        END        END
565    
566  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
567    
568        SUBROUTINE MNC_VAR_APPEND_DBL(        SUBROUTINE MNC_VAR_APPEND_DBL(
569       I     fname,       I     fname,
570       I     vname,       I     vname,
571       I     var,       I     var,
572       I     append,       I     append,
573       I     myThid )       I     myThid )
574    
575        implicit none        IMPLICIT NONE
576  C     Arguments  C     Arguments
577        integer myThid, append        CHARACTER*(*) fname, vname
578        character*(*) fname,vname        Real*8 var(*)
579        REAL*8 var(*)        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    
       CALL MNC_VAR_WRITE_ANY(fname,vname,1,append,var,0.0,0, myThid)  
591        RETURN        RETURN
592        END        END
593    
594  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
595    
596        SUBROUTINE MNC_VAR_APPEND_REAL(        SUBROUTINE MNC_VAR_APPEND_REAL(
597       I     fname,       I     fname,
598       I     vname,       I     vname,
599       I     var,       I     var,
600       I     append,       I     append,
601       I     myThid )       I     myThid )
602    
603        implicit none        IMPLICIT NONE
604  C     Arguments  C     Arguments
605        integer myThid, append        CHARACTER*(*) fname, vname
606        character*(*) fname,vname        Real*4 var(*)
607        REAL*4 var(*)        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    
       CALL MNC_VAR_WRITE_ANY(fname,vname,2,append,0.0D0,var,0,myThid)  
619        RETURN        RETURN
620        END        END
621    
622  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
623    
624        SUBROUTINE MNC_VAR_APPEND_INT(        SUBROUTINE MNC_VAR_APPEND_INT(
625       I     fname,       I     fname,
626       I     vname,       I     vname,
627       I     var,       I     var,
628       I     append,       I     append,
629       I     myThid )       I     myThid )
630    
631        implicit none        IMPLICIT NONE
632  C     Arguments  C     Arguments
633        integer myThid, append        CHARACTER*(*) fname, vname
634        character*(*) fname,vname        INTEGER var(*)
635        integer var(*)        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(fname,vname,3,append,0.0D0,0.0,var,myThid)  
647        RETURN        RETURN
648        END        END
649    
650  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
651    
652        SUBROUTINE MNC_VAR_WRITE_ANY(        SUBROUTINE MNC_VAR_WRITE_ANY(
653       I     fname,       I     fname,
654       I     vname,       I     vname,
655       I     vtype,       I     vtype,
656       I     append,       I     append,
657       I     dv,       I     dv,
658       I     rv,       I     rv,
659       I     iv,       I     iv,
660       I     myThid )       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 append        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)
# Line 588  C     Strip trailing spaces Line 688  C     Strip trailing spaces
688    
689        CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)        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 613  C     Check for the unlimited dimension Line 713  C     Check for the unlimited dimension
713        IF (j .LT. 1) THEN        IF (j .LT. 1) THEN
714          did = mnc_d_ids( mnc_fd_ind(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(err, msgbuf, myThid)          CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
718          IF (append .GT. 0) THEN          IF (append .GT. 0) THEN
719            lend = lend + append            lend = lend + append
720          ENDIF          ENDIF
# Line 631  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(err, msgbuf, myThid)        CALL MNC_HANDLE_ERR(err, msgBuf, myThid)
743    
744        RETURN        RETURN
745        END        END
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.25
  ViewVC Help
Powered by ViewVC 1.1.22