pkg/mnc/mnc_file.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.2 2004/01/05 21:38:27 edhill Exp $
C $Name:  $

#include "MNC_OPTIONS.h"

C==================================================================

      SUBROUTINE MNC_FILE_CREATE( 
     I     myThid,
     I     fname )

      implicit none

C     Arguments
      integer myThid
      character*(*) fname

      CALL MNC_FILE_OPEN(myThid, fname, 0)

      RETURN
      END

C==================================================================

      SUBROUTINE MNC_FILE_OPEN( 
     I     myThid,
     I     fname, 
     I     itype )

      implicit none
#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

C     Arguments
      integer myThid
      character*(*) fname
      integer itype
C     itype => [ 0=new | 1=append ]

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i,n, err, fid, ind
      character*(MNC_MAX_CHAR) aname
      character*(MAX_LEN_MBUF) msgbuf

C     Is the file already open?
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
      IF ( ind .GT. 0 ) THEN
        write(msgbuf,'(3a)') 'MNC_FILE_OPEN ERROR: ''', fname, 
     &       ''' is already open -- cannot open twice'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: package MNC'
      ENDIF

      write(msgbuf,'(3a)') 'opening ''', fname, ''''
      IF ( itype .EQ. 0 ) THEN
C       Create new file
        err = NF_CREATE( fname, NF_CLOBBER, fid )
        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
      ELSEIF ( itype .EQ. 1 ) THEN
C       Append to existing file
        err = NF_OPEN( fname, NF_WRITE, fid )
        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
      ELSE
C       Error
        write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype, 
     &       ''' is not defined--should be: [0|1]'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
      ENDIF

      CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_f_names, ind)
      n = ILNBLNK(fname)
      mnc_f_names(ind)(1:n) = fname(1:n)
      mnc_f_info(ind,1) = 1
      mnc_f_info(ind,2) = fid
      mnc_f_info(ind,3) = 0
      mnc_fv_ids(ind,1) = 0

      RETURN
      END

C==================================================================

      SUBROUTINE MNC_FILE_ADD_ATTR_STR( 
     I     myThid, 
     I     fname, 
     I     atname, 
     I     sval )

      implicit none
#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

C     Arguments
      integer myThid
      character*(*) fname
      character*(*) atname
      character*(*) sval

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i, err, fid, ind, n1,n2
      character*(MNC_MAX_CHAR) s1, s2
      character*(MAX_LEN_MBUF) msgbuf

C     Is the file open?
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
      IF ( ind .GT. 0 ) THEN
        write(msgbuf,'(3a)') 'MNC ERROR: file ''',
     &       fname, ''' must be opened first'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
      ENDIF
      fid = mnc_f_info(ind,2)

C     Enter define mode
      err = NF_REDEF(fid)
      CALL MNC_HANDLE_ERR(myThid, err, 
     &     'redefining in S/R MNC_FILE_ADD_ATTR_STR')

      s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
      s2(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
      n1 = ILNBLNK(atname)
      n2 = ILNBLNK(sval)
      s1(1:n1) = atname(1:n1)
      s2(1:n2) = sval(1:n2)

      err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, n2, s2)
      CALL MNC_HANDLE_ERR(myThid, err, 
     &     'adding attribute in S/R MNC_FILE_ADD_ATTR_STR')

      RETURN
      END

C==================================================================

      SUBROUTINE MNC_FILE_ADD_ATTR_INT( 
     I     myThid, 
     I     fname, 
     I     atname, 
     I     ival )

      implicit none
#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

C     Arguments
      integer myThid
      character*(*) fname, atname
      integer ival

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i, err, fid, ind, n1,n2
      character*(MNC_MAX_CHAR) s1
      character*(MAX_LEN_MBUF) msgbuf

C     Is the file open?
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
      IF ( ind .GT. 0 ) THEN
        write(msgbuf,'(3a)') 'MNC ERROR: file ''',
     &       fname, ''' must be opened first'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
      ENDIF
      fid = mnc_f_info(ind,2)

C     Enter define mode
      err = NF_REDEF(fid)
      CALL MNC_HANDLE_ERR(myThid, err, 
     &     'redefining in S/R MNC_FILE_ADD_ATTR_INT')

      s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
      n1 = ILNBLNK(atname)
      s1(1:n1) = atname(1:n1)

      err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, ival)
      CALL MNC_HANDLE_ERR(myThid, err,
     &     'adding attribute in S/R MNC_FILE_ADD_ATTR_INT')

      RETURN
      END

C==================================================================

      SUBROUTINE MNC_FILE_ADD_ATTR_DBL( 
     I     myThid, 
     I     fname, 
     I     atname, 
     I     dval )

#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

C     Arguments
      integer myThid
      character*(*) fname, atname
      _RL dval

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i, err, fid, ind, n1,n2
      character*(MNC_MAX_CHAR) s1
      character*(MAX_LEN_MBUF) msgbuf
      

C     Is the file open?
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
      IF (ind .GT. 0) THEN
        write(msgbuf,'(3a)') 'MNC ERROR: file ''',
     &       fname, ''' must be opened first'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
      ENDIF
      fid = mnc_f_info(ind,2)

C     Enter define mode
      err = NF_REDEF(fid)
      CALL MNC_HANDLE_ERR(myThid, err, 
     &     'redefining in S/R MNC_FILE_ADD_ATTR_DBL')

      s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
      n1 = ILNBLNK(atname)
      s1(1:n1) = atname(1:n1)

      err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, ival)
      CALL MNC_HANDLE_ERR(myThid, err,
     &     'adding attribute in S/R MNC_FILE_ADD_ATTR_DBL')

      RETURN
      END

C==================================================================

      SUBROUTINE MNC_FILE_CLOSE( 
     I     myThid,
     I     fname )

      implicit none
#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

C     Arguments
      integer myThid
      character*(*) fname

C     Local Variables
      integer i,j,k,n, err, fid, ind
      character*(MAX_LEN_MBUF) msgbuf

C     Check that the file is open
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
      IF (ind .LT. 1) THEN
        write(msgbuf,'(3a)') 'MNC Warning: file ''', fname, 
     &       ''' is already closed'
        CALL print_error( msgbuf, mythid )
        RETURN
      ENDIF
      fid = mnc_f_info(ind,2)
      err = NF_CLOSE(fid)
      write(msgbuf,'(3a)') ' cannot close file ''', fname, ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

C     Clear all the file, grid, and variable names and refs
      n = mnc_fv_ids(ind,1)
      IF (n .GE. 1) THEN
        DO i = 1,n
          j = 2*i
          k = mnc_fv_ids(ind,j)
          mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
          mnc_v_units(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
        ENDDO
      ENDIF
      DO i = 1,3
        mnc_f_info(ind,i) = 0
      ENDDO
      mnc_f_names(ind)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)

      RETURN
      END

1	edhill	1.3	C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.2 2004/01/05 21:38:27 edhill Exp $
2	edhill	1.1	C $Name: $
3
4			#include "MNC_OPTIONS.h"
5
6			C==================================================================
7
8	edhill	1.3	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	edhill	1.1	SUBROUTINE MNC_FILE_OPEN(
26			I myThid,
27			I fname,
28			I itype )
29
30			implicit none
31			#include "netcdf.inc"
32			#include "mnc_common.h"
33			#include "EEPARAMS.h"
34
35			C Arguments
36			integer myThid
37			character() fname
38			integer itype
39			C itype => [ 0=new \| 1=append ]
40
41	edhill	1.3	C Functions
42			integer ILNBLNK
43
44	edhill	1.1	C Local Variables
45	edhill	1.3	integer i,n, err, fid, ind
46	edhill	1.1	character*(MNC_MAX_CHAR) aname
47			character*(MAX_LEN_MBUF) msgbuf
48
49			C Is the file already open?
50			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
51			IF ( ind .GT. 0 ) THEN
52			write(msgbuf,'(3a)') 'MNC_FILE_OPEN ERROR: ''', fname,
53			& ''' is already open -- cannot open twice'
54			CALL print_error( msgbuf, mythid )
55			stop 'ABNORMAL END: package MNC'
56			ENDIF
57
58	edhill	1.3	write(msgbuf,'(3a)') 'opening ''', fname, ''''
59	edhill	1.1	IF ( itype .EQ. 0 ) THEN
60			C Create new file
61			err = NF_CREATE( fname, NF_CLOBBER, fid )
62	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
63	edhill	1.1	ELSEIF ( itype .EQ. 1 ) THEN
64			C Append to existing file
65			err = NF_OPEN( fname, NF_WRITE, fid )
66	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
67	edhill	1.1	ELSE
68			C Error
69			write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype,
70			& ''' is not defined--should be: [0\|1]'
71	edhill	1.3	CALL print_error( msgbuf, mythid )
72			stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
73	edhill	1.1	ENDIF
74
75			CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_f_names, ind)
76	edhill	1.3	n = ILNBLNK(fname)
77			mnc_f_names(ind)(1:n) = fname(1:n)
78	edhill	1.1	mnc_f_info(ind,1) = 1
79	edhill	1.3	mnc_f_info(ind,2) = fid
80			mnc_f_info(ind,3) = 0
81			mnc_fv_ids(ind,1) = 0
82	edhill	1.1
83	edhill	1.3	RETURN
84	edhill	1.1	END
85
86			C==================================================================
87
88			SUBROUTINE MNC_FILE_ADD_ATTR_STR(
89			I myThid,
90			I fname,
91			I atname,
92			I sval )
93
94			implicit none
95			#include "netcdf.inc"
96			#include "mnc_common.h"
97			#include "EEPARAMS.h"
98
99			C Arguments
100			integer myThid
101			character() fname
102			character() atname
103			character() sval
104
105			C Functions
106			integer ILNBLNK
107
108			C Local Variables
109			integer i, err, fid, ind, n1,n2
110			character*(MNC_MAX_CHAR) s1, s2
111			character*(MAX_LEN_MBUF) msgbuf
112
113			C Is the file open?
114			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
115			IF ( ind .GT. 0 ) THEN
116			write(msgbuf,'(3a)') 'MNC ERROR: file ''',
117			& fname, ''' must be opened first'
118			CALL print_error( msgbuf, mythid )
119			stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
120			ENDIF
121			fid = mnc_f_info(ind,2)
122
123			C Enter define mode
124			err = NF_REDEF(fid)
125	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err,
126			& 'redefining in S/R MNC_FILE_ADD_ATTR_STR')
127	edhill	1.1
128			s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
129			s2(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
130			n1 = ILNBLNK(atname)
131			n2 = ILNBLNK(sval)
132			s1(1:n1) = atname(1:n1)
133			s2(1:n2) = sval(1:n2)
134
135			err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, n2, s2)
136	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err,
137			& 'adding attribute in S/R MNC_FILE_ADD_ATTR_STR')
138	edhill	1.1
139	edhill	1.3	RETURN
140	edhill	1.1	END
141
142			C==================================================================
143
144			SUBROUTINE MNC_FILE_ADD_ATTR_INT(
145			I myThid,
146			I fname,
147			I atname,
148			I ival )
149
150			implicit none
151			#include "netcdf.inc"
152			#include "mnc_common.h"
153			#include "EEPARAMS.h"
154
155			C Arguments
156			integer myThid
157			character() fname, atname
158			integer ival
159
160			C Functions
161			integer ILNBLNK
162
163			C Local Variables
164			integer i, err, fid, ind, n1,n2
165			character*(MNC_MAX_CHAR) s1
166			character*(MAX_LEN_MBUF) msgbuf
167
168			C Is the file open?
169			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
170			IF ( ind .GT. 0 ) THEN
171			write(msgbuf,'(3a)') 'MNC ERROR: file ''',
172			& fname, ''' must be opened first'
173			CALL print_error( msgbuf, mythid )
174			stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
175			ENDIF
176			fid = mnc_f_info(ind,2)
177
178			C Enter define mode
179			err = NF_REDEF(fid)
180	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err,
181			& 'redefining in S/R MNC_FILE_ADD_ATTR_INT')
182	edhill	1.1
183			s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
184			n1 = ILNBLNK(atname)
185			s1(1:n1) = atname(1:n1)
186
187			err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, ival)
188	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err,
189			& 'adding attribute in S/R MNC_FILE_ADD_ATTR_INT')
190	edhill	1.1
191	edhill	1.3	RETURN
192	edhill	1.1	END
193
194			C==================================================================
195
196			SUBROUTINE MNC_FILE_ADD_ATTR_DBL(
197			I myThid,
198			I fname,
199			I atname,
200			I dval )
201
202			#include "netcdf.inc"
203			#include "mnc_common.h"
204			#include "EEPARAMS.h"
205
206			C Arguments
207			integer myThid
208			character() fname, atname
209			_RL dval
210
211			C Functions
212			integer ILNBLNK
213
214			C Local Variables
215			integer i, err, fid, ind, n1,n2
216			character*(MNC_MAX_CHAR) s1
217			character*(MAX_LEN_MBUF) msgbuf
218
219
220			C Is the file open?
221			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
222	edhill	1.3	IF (ind .GT. 0) THEN
223	edhill	1.1	write(msgbuf,'(3a)') 'MNC ERROR: file ''',
224			& fname, ''' must be opened first'
225			CALL print_error( msgbuf, mythid )
226			stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
227			ENDIF
228	edhill	1.2	fid = mnc_f_info(ind,2)
229	edhill	1.1
230			C Enter define mode
231			err = NF_REDEF(fid)
232	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err,
233			& 'redefining in S/R MNC_FILE_ADD_ATTR_DBL')
234	edhill	1.1
235			s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
236			n1 = ILNBLNK(atname)
237			s1(1:n1) = atname(1:n1)
238
239			err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, ival)
240	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err,
241			& 'adding attribute in S/R MNC_FILE_ADD_ATTR_DBL')
242
243			RETURN
244			END
245
246			C==================================================================
247
248			SUBROUTINE MNC_FILE_CLOSE(
249			I myThid,
250			I fname )
251
252			implicit none
253			#include "netcdf.inc"
254			#include "mnc_common.h"
255			#include "EEPARAMS.h"
256
257			C Arguments
258			integer myThid
259			character() fname
260
261			C Local Variables
262			integer i,j,k,n, err, fid, ind
263			character*(MAX_LEN_MBUF) msgbuf
264
265			C Check that the file is open
266			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
267			IF (ind .LT. 1) THEN
268			write(msgbuf,'(3a)') 'MNC Warning: file ''', fname,
269			& ''' is already closed'
270			CALL print_error( msgbuf, mythid )
271			RETURN
272			ENDIF
273			fid = mnc_f_info(ind,2)
274			err = NF_CLOSE(fid)
275			write(msgbuf,'(3a)') ' cannot close file ''', fname, ''''
276			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
277
278			C Clear all the file, grid, and variable names and refs
279			n = mnc_fv_ids(ind,1)
280			IF (n .GE. 1) THEN
281			DO i = 1,n
282			j = 2*i
283			k = mnc_fv_ids(ind,j)
284			mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
285			mnc_v_units(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
286			ENDDO
287			ENDIF
288			DO i = 1,3
289			mnc_f_info(ind,i) = 0
290			ENDDO
291			mnc_f_names(ind)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
292	edhill	1.1
293	edhill	1.3	RETURN
294	edhill	1.1	END
295