/[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.12 by edhill, Wed Feb 4 05:45:09 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---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
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    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        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        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, NF_DOUBLE)  
51        RETURN        RETURN
52        END        END
53    
54  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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     irv,
64         I     myThid )
65    
66        implicit none  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"  #include "netcdf.inc"
72    
73  C     Arguments  C     !INPUT PARAMETERS:
74        integer myThid        CHARACTER*(*) fname,gname,vname
75        character*(*) fname,gname,vname        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, NF_FLOAT)  
80        RETURN        RETURN
81        END        END
82    
83  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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        SUBROUTINE MNC_VAR_INIT_INT(  C     !DESCRIPTION:
96       I     myThid,  C     Create an integer variable within a NetCDF file context.
      I     fname,  
      I     gname,  
      I     vname )  
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        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, NF_INT)  
109        RETURN        RETURN
110        END        END
111    
112  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
113    CBOP 1
114    C     !ROUTINE: MNC_VAR_INIT_ANY
115    
116        SUBROUTINE MNC_VAR_INIT_ANY(  C     !INTERFACE:
117       I     myThid,        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 )
124    
125        implicit none  C     !DESCRIPTION:
126  #include "netcdf.inc"  C     General function for creating variables within a NetCDF file context.
127  #include "mnc_common.h"  
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,gname,vname        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, nvar        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        INTEGER lenf,leng,lenv
150    
151  C     Strip trailing spaces  C     Strip trailing spaces
152        lenf = ILNBLNK(fname)        lenf = ILNBLNK(fname)
# Line 95  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_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 139  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 152  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(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
# Line 185  C     Success, so save the variable info Line 260  C     Success, so save the variable info
260        END        END
261    
262  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
263    CBOP 1
264    C     !ROUTINE: MNC_VAR_ADD_ATTR_STR
265    
266        SUBROUTINE MNC_VAR_ADD_ATTR_STR(  C     !INTERFACE:
267       I     myThid,        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 )
273    
274        implicit none  C     !DESCRIPTION:
275  C     Arguments  C     Subroutine for adding a character string attribute to a NetCDF file.
276        integer myThid  
277        character*(*) fname,vname,atname,sval  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---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
297    CBOP 1
298    C     !ROUTINE: MNC_VAR_ADD_ATTR_DBL
299    
300        SUBROUTINE MNC_VAR_ADD_ATTR_DBL(  C     !INTERFACE:
301       I     myThid,        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 )
308    
309        implicit none  C     !DESCRIPTION:
310  C     Arguments  C     Subroutine for adding a double-precision real attribute to a NetCDF file.
311        integer myThid,nv  
312        character*(*) fname,vname,atname  C     !USES:
313        REAL*8 dval(*)        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    
       CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,  
      &     2, ' ', nv, dval, 0.0, 0)  
329        RETURN        RETURN
330        END        END
331    
332  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
333    CBOP 1
334    C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL
335    
336        SUBROUTINE MNC_VAR_ADD_ATTR_REAL(  C     !INTERFACE:
337       I     myThid,        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 )
344    
345        implicit none  C     !DESCRIPTION:
346  C     Arguments  C     Subroutine for adding a single-precision real attribute to a NetCDF file.
347        integer myThid,nv  
348        character*(*) fname,vname,atname  C     !USES:
349        REAL*4 rval(*)        IMPLICIT NONE
350    
351        CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,  C     !INPUT PARAMETERS:
352       &     3, ' ', nv, 0.0D0, rval, 0)        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---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
368    CBOP 1
369    C     !ROUTINE: MNC_VAR_ADD_ATTR_INT
370    
371        SUBROUTINE MNC_VAR_ADD_ATTR_INT(  C     !INTERFACE:
372       I     myThid,        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 )
379    
380        implicit none  C     !DESCRIPTION:
381  C     Arguments  C     Subroutine for adding an integer attribute to a NetCDF file.
382        integer myThid,nv  
383        character*(*) fname,vname,atname  C     !USES:
384        integer ival(*)        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          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---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  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    
415        implicit none  C     !DESCRIPTION:
416  #include "netcdf.inc"  C     General SUBROUTINE for adding attributes to a NetCDF file.
417  #include "mnc_common.h"  
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 301  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 323  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---+----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     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,0,var,0.0,0)  
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     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,0.0D0,var,0)  
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     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    
       CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,0,0.0D0,0.0,var)  
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     myThid,       I     fname,
570       I     fname,       I     vname,
571       I     vname,       I     var,
572       I     var,       I     append,
573       I     append )       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(myThid,fname,vname,1,append,var,0.0,0)  
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     myThid,       I     fname,
598       I     fname,       I     vname,
599       I     vname,       I     var,
600       I     var,       I     append,
601       I     append )       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(myThid,fname,vname,2,append,0.0D0,var,0)  
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     myThid,       I     fname,
626       I     fname,       I     vname,
627       I     vname,       I     var,
628       I     var,       I     append,
629       I     append )       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(myThid,fname,vname,3,append,0.0D0,0.0,var)  
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     myThid,       I     fname,
654       I     fname,       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 )
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)
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 512  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(myThid, err, msgbuf)          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 522  C     Check for the unlimited dimension Line 723  C     Check for the unlimited dimension
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 530  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
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.25
  ViewVC Help
Powered by ViewVC 1.1.22