/[MITgcm]/MITgcm/pkg/mnc/mnc_file.F
ViewVC logotype

Diff of /MITgcm/pkg/mnc/mnc_file.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.1 by edhill, Mon Jan 5 06:20:07 2004 UTC revision 1.5 by edhill, Thu Jan 8 07:24:47 2004 UTC
# Line 5  C $Name$ Line 5  C $Name$
5    
6  C==================================================================  C==================================================================
7    
8          SUBROUTINE MNC_FILE_CREATE(
9         I     myThid,
10         I     fname )
11    
12          implicit none
13    
14    C     Arguments
15          integer myThid
16          character*(*) fname
17    
18          CALL MNC_FILE_OPEN(myThid, fname, 0)
19    
20          RETURN
21          END
22    
23    C==================================================================
24    
25        SUBROUTINE MNC_FILE_OPEN(        SUBROUTINE MNC_FILE_OPEN(
26       I     myThid,       I     myThid,
27       I     fname,       I     fname,
# Line 21  C     Arguments Line 38  C     Arguments
38        integer itype        integer itype
39  C     itype => [ 0=new | 1=append ]  C     itype => [ 0=new | 1=append ]
40    
41    C     Functions
42          integer ILNBLNK
43    
44  C     Local Variables  C     Local Variables
45        integer i, err, fid, ind        integer i,n, err, fid, ind
46        character*(MNC_MAX_CHAR) aname        character*(MNC_MAX_CHAR) aname
47        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
48    
# Line 35  C     Is the file already open? Line 55  C     Is the file already open?
55          stop 'ABNORMAL END: package MNC'          stop 'ABNORMAL END: package MNC'
56        ENDIF        ENDIF
57    
58          write(msgbuf,'(3a)') 'opening ''', fname, ''''
59        IF ( itype .EQ. 0 ) THEN        IF ( itype .EQ. 0 ) THEN
60  C       Create new file  C       Create new file
61          err = NF_CREATE( fname, NF_CLOBBER, fid )          err = NF_CREATE( fname, NF_CLOBBER, fid )
62          IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
63        ELSEIF ( itype .EQ. 1 ) THEN        ELSEIF ( itype .EQ. 1 ) THEN
64  C       Append to existing file  C       Append to existing file
65          err = NF_OPEN( fname, NF_WRITE, fid )          err = NF_OPEN( fname, NF_WRITE, fid )
66          IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
67        ELSE        ELSE
68  C       Error  C       Error
69          write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype,          write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype,
70       &       ''' is not defined--should be: [0|1]'       &       ''' is not defined--should be: [0|1]'
71            CALL print_error( msgbuf, mythid )
72            stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
73        ENDIF        ENDIF
74    
75        CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_f_names, ind)        CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_f_names, ind)
76        mnc_f_names(ind) = fname        n = ILNBLNK(fname)
77          mnc_f_names(ind)(1:n) = fname(1:n)
78        mnc_f_info(ind,1) = 1        mnc_f_info(ind,1) = 1
79        mnc_f_info(ind,1) = fid        mnc_f_info(ind,2) = fid
80          mnc_f_info(ind,3) = 0
81          mnc_fv_ids(ind,1) = 0
82    
83          RETURN
84        END        END
85    
86  C==================================================================  C==================================================================
# Line 65  C======================================= Line 92  C=======================================
92       I     sval )       I     sval )
93    
94        implicit none        implicit none
95    C     Arguments
96          integer myThid, len
97          character*(*) fname, atname, sval
98    
99          CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 1,
100         &     sval, 0, 0.0D0, 0.0, 0 )
101          RETURN
102          END
103    
104    C==================================================================
105    
106          SUBROUTINE MNC_FILE_ADD_ATTR_DBL(
107         I     myThid,
108         I     fname,
109         I     atname,
110         I     len,
111         I     dval )
112    
113          implicit none
114    C     Arguments
115          integer myThid, len
116          character*(*) fname, atname
117          _RL dval
118    
119          CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 2,
120         &     ' ', len, dval, 0.0, 0 )
121          RETURN
122          END
123    
124    C==================================================================
125    
126          SUBROUTINE MNC_FILE_ADD_ATTR_REAL(
127         I     myThid,
128         I     fname,
129         I     atname,
130         I     len,
131         I     rval )
132    
133          implicit none
134    C     Arguments
135          integer myThid, len
136          character*(*) fname, atname
137          _RS rval
138    
139          CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 3,
140         &     ' ', len, 0.0D0, rval, 0 )
141          RETURN
142          END
143    
144    C==================================================================
145    
146          SUBROUTINE MNC_FILE_ADD_ATTR_INT(
147         I     myThid,
148         I     fname,
149         I     atname,
150         I     len,
151         I     ival )
152    
153          implicit none
154    C     Arguments
155          integer myThid, len, ival
156          character*(*) fname, atname
157    
158          CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 4,
159         &     ' ', len, 0.0D0, 0.0, ival )
160          RETURN
161          END
162    
163    C==================================================================
164    
165          SUBROUTINE MNC_FILE_ADD_ATTR_ANY(
166         I     myThid,
167         I     fname,
168         I     atname,
169         I     atype, sv, len,dv,rv,iv )
170    
171          implicit none
172  #include "netcdf.inc"  #include "netcdf.inc"
173  #include "mnc_common.h"  #include "mnc_common.h"
174  #include "EEPARAMS.h"  #include "EEPARAMS.h"
175    
176  C     Arguments  C     Arguments
177        integer myThid        integer myThid, atype, len, iv
178        character*(*) fname        character*(*) fname, atname, sv
179        character*(*) atname        _RL dv
180        character*(*) sval        _RS rv
181          
182  C     Functions  C     Functions
183        integer ILNBLNK        integer ILNBLNK
184    
185  C     Local Variables  C     Local Variables
186        integer i, err, fid, ind, n1,n2        integer i, n, err, fid, ind, n1,n2, lens
187        character*(MNC_MAX_CHAR) s1, s2        character*(MNC_MAX_CHAR) s1
188        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
189          
190  C     Is the file open?  C     Verify that the file is open
191        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
192        IF ( ind .GT. 0 ) THEN        IF (ind .LT. 0) THEN
193          write(msgbuf,'(3a)') 'MNC ERROR: file ''',          write(msgbuf,'(3a)') 'MNC ERROR: file ''',
194       &       fname, ''' must be opened first'       &       fname, ''' must be opened first'
195          CALL print_error( msgbuf, mythid )          CALL print_error( msgbuf, mythid )
196          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
197        ENDIF        ENDIF
198        fid = mnc_f_info(ind,2)        fid = mnc_f_info(ind,2)
199    
200  C     Enter define mode  C     Enter define mode
201        err = NF_REDEF(fid)        CALL MNC_FILE_REDEF(myThid, fname)
       IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)  
202    
203        s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)        s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
       s2(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)  
204        n1 = ILNBLNK(atname)        n1 = ILNBLNK(atname)
       n2 = ILNBLNK(sval)  
205        s1(1:n1) = atname(1:n1)        s1(1:n1) = atname(1:n1)
       s2(1:n2) = sval(1:n2)  
206    
207        err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, n2, s2)        IF (atype .EQ. 1) THEN
208        IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)          lens = ILNBLNK(sv)
209            err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, lens, sv)
210          ELSEIF (atype .EQ. 2) THEN
211            err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, len, dv)
212          ELSEIF (atype .EQ. 3) THEN
213            err = NF_PUT_ATT_REAL(fid, NF_GLOBAL, s1, NF_FLOAT, len, rv)
214          ELSEIF (atype .EQ. 4) THEN
215            err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, len, iv)
216          ELSE
217            write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
218         &       ''' is invalid--must be: [1-4]'
219            n = ILNBLNK(msgbuf)
220            CALL print_error(msgbuf(1:n), mythid)
221            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
222          ENDIF
223          CALL MNC_HANDLE_ERR(myThid, err,
224         &     'adding attribute in S/R MNC_FILE_ADD_ATTR_DBL')
225    
226          RETURN
227        END        END
228    
229  C==================================================================  C==================================================================
230    
231        SUBROUTINE MNC_FILE_ADD_ATTR_INT(        SUBROUTINE MNC_FILE_CLOSE(
232       I     myThid,       I     myThid,
233       I     fname,       I     fname )
      I     atname,  
      I     ival )  
234    
235        implicit none        implicit none
236  #include "netcdf.inc"  #include "netcdf.inc"
# Line 124  C======================================= Line 239  C=======================================
239    
240  C     Arguments  C     Arguments
241        integer myThid        integer myThid
242        character*(*) fname, atname        character*(*) fname
243        integer ival  
244    C     Local Variables
245          integer i,j,k,n, err, fid, ind
246          character*(MAX_LEN_MBUF) msgbuf
247    
248    C     Check that the file is open
249          CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
250          IF (ind .LT. 1) THEN
251            write(msgbuf,'(3a)') 'MNC Warning: file ''', fname,
252         &       ''' is already closed'
253            CALL print_error( msgbuf, mythid )
254            RETURN
255          ENDIF
256          fid = mnc_f_info(ind,2)
257          err = NF_CLOSE(fid)
258          write(msgbuf,'(3a)') ' cannot close file ''', fname, ''''
259          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
260    
261    C     Clear all the file, grid, and variable names and refs
262          n = mnc_fv_ids(ind,1)
263          IF (n .GE. 1) THEN
264            DO i = 1,n
265              j = 2*i
266              k = mnc_fv_ids(ind,j)
267              mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
268            ENDDO
269          ENDIF
270          DO i = 1,3
271            mnc_f_info(ind,i) = 0
272          ENDDO
273          mnc_f_names(ind)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
274    
275          RETURN
276          END
277    
278    C==================================================================
279    
280          SUBROUTINE MNC_FILE_REDEF(
281         I     myThid,
282         I     fname )
283    
284          implicit none
285    #include "netcdf.inc"
286    #include "mnc_common.h"
287    #include "EEPARAMS.h"
288    
289    C     Arguments
290          integer myThid
291          character*(*) fname
292    
293  C     Functions  C     Functions
294        integer ILNBLNK        integer ILNBLNK
295    
296  C     Local Variables  C     Local Variables
297        integer i, err, fid, ind, n1,n2        integer ind, fid, def, err
       character*(MNC_MAX_CHAR) s1  
298        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
299    
300  C     Is the file open?  C     Verify that the file is open
301        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
302        IF ( ind .GT. 0 ) THEN        IF (ind .LT. 0) THEN
303          write(msgbuf,'(3a)') 'MNC ERROR: file ''',          write(msgbuf,'(3a)') 'MNC ERROR: file ''',
304       &       fname, ''' must be opened first'       &       fname, ''' must be opened first'
305          CALL print_error( msgbuf, mythid )          CALL print_error( msgbuf, mythid )
306          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'          stop 'ABNORMAL END: S/R MNC_FILE_REDEF'
307        ENDIF        ENDIF
308          def = mnc_f_info(ind,1)
309        fid = mnc_f_info(ind,2)        fid = mnc_f_info(ind,2)
310    
311  C     Enter define mode        IF (def .NE. 1) THEN
312        err = NF_REDEF(fid)  C       Enter define mode
313        IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)          err = NF_REDEF(fid)
314            CALL MNC_HANDLE_ERR(myThid, err,
315        s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)       &       'entering define mode in S/R MNC_FILE_REDEF')
316        n1 = ILNBLNK(atname)          mnc_f_info(ind,1) = 1
317        s1(1:n1) = atname(1:n1)        ENDIF
   
       err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, ival)  
       IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)  
318    
319          RETURN
320        END        END
321    
322  C==================================================================  C==================================================================
323    
324        SUBROUTINE MNC_FILE_ADD_ATTR_DBL(        SUBROUTINE MNC_FILE_ENDDEF(
325       I     myThid,       I     myThid,
326       I     fname,       I     fname )
      I     atname,  
      I     dval )  
327    
328          implicit none
329  #include "netcdf.inc"  #include "netcdf.inc"
330  #include "mnc_common.h"  #include "mnc_common.h"
331  #include "EEPARAMS.h"  #include "EEPARAMS.h"
332    
333  C     Arguments  C     Arguments
334        integer myThid        integer myThid
335        character*(*) fname, atname        character*(*) fname
       _RL dval  
336    
337  C     Functions  C     Functions
338        integer ILNBLNK        integer ILNBLNK
339    
340  C     Local Variables  C     Local Variables
341        integer i, err, fid, ind, n1,n2        integer ind, fid, def, err
       character*(MNC_MAX_CHAR) s1  
342        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
         
343    
344  C     Is the file open?  C     Verify that the file is open
345        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
346        IF ( ind .GT. 0 ) THEN        IF (ind .LT. 0) THEN
347          write(msgbuf,'(3a)') 'MNC ERROR: file ''',          write(msgbuf,'(3a)') 'MNC ERROR: file ''',
348       &       fname, ''' must be opened first'       &       fname, ''' must be opened first'
349          CALL print_error( msgbuf, mythid )          CALL print_error( msgbuf, mythid )
350          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'          stop 'ABNORMAL END: S/R MNC_FILE_REDEF'
351        ENDIF        ENDIF
352        fid = mnc_fids(ind,2)        def = mnc_f_info(ind,1)
353          fid = mnc_f_info(ind,2)
 C     Enter define mode  
       err = NF_REDEF(fid)  
       IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)  
   
       s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)  
       n1 = ILNBLNK(atname)  
       s1(1:n1) = atname(1:n1)  
354    
355        err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, ival)        IF (def .NE. 2) THEN
356        IF (err .NE. NF_NOERR) CALL MNC_HANDLE_ERR(myThid, err)  C       Enter define mode
357            err = NF_ENDDEF(fid)
358            CALL MNC_HANDLE_ERR(myThid, err,
359         &       'ending define mode in S/R MNC_FILE_ENDDEF')
360            mnc_f_info(ind,1) = 2
361          ENDIF
362    
363          RETURN
364        END        END
365    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.5
  ViewVC Help
Powered by ViewVC 1.1.22