pkg/mnc/mnc_var.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.3 2004/01/07 07:29:13 edhill Exp $
C $Name:  $
      
#include "MNC_OPTIONS.h"
      
C==================================================================

      SUBROUTINE MNC_VAR_INIT_DBL( 
     I     myThid, 
     I     fname, 
     I     gname, 
     I     vname, 
     I     fillval )

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

C     Arguments
      integer myThid
      character*(*) fname
      character*(*) gname
      character*(*) vname
      _RL fillval

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err
      integer vid, nv, ind_g_finfo
      character*(MAX_LEN_MBUF) msgbuf
      integer rids(10), ids(10)
      integer lenf,leng,lenv

C     Strip trailing spaces
      lenf = ILNBLNK(fname)
      leng = ILNBLNK(gname)
      lenv = ILNBLNK(vname)

C     Check that the file is open
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
      IF (indf .LT. 1) THEN
        write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname, 
     &       ''' must be opened first'
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
      ENDIF
      fid = mnc_f_info(indf,2)

C     Get the grid information
      ngrid = mnc_f_info(indf,3)
      IF (ngrid .LT. 1) THEN
        write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf), 
     &       ''' contains NO grids'
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
      ENDIF
      DO i = 1,ngrid
        j = 4 + (i-1)*3
        k = mnc_f_info(indf,j)
        n = ILNBLNK(mnc_g_names(k))
        IF ((leng .EQ. n) 
     &       .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
          ind_g_finfo = j
          is = mnc_f_info(indf,(j+1))
          ie = mnc_f_info(indf,(j+2))
          nd = 0
          DO k = is,ie
            nd = nd + 1
            ids(nd) = mnc_fg_ids(indf,k)
          ENDDO
          GOTO 10
        ENDIF
      ENDDO
      write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf), 
     &     ''' does not contain grid ''', gname(1:leng), ''''
      CALL print_error(msgbuf, mythid)
      stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
 10   CONTINUE

C     Add the variable definition
      CALL MNC_FILE_REDEF(myThid, fname)
      err = NF_DEF_VAR(fid, vname, NF_DOUBLE, nd, ids, vid)
      write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
     &     ''' in file ''', fname(1:lenf), ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

C     Success, so save the variable info
      CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv)
      mnc_v_names(indv)(1:lenv) = vname(1:lenv)
      nv = mnc_fv_ids(indf,1)
      i = 2 + nv*2
      j = i + 1
      k = i + 2
      mnc_fv_ids(indf,i) = indv
      mnc_fv_ids(indf,j) = vid
      mnc_fv_ids(indf,k) = ind_g_finfo
      mnc_fv_ids(indf,1) = nv + 1

      RETURN
      END

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

      SUBROUTINE MNC_VAR_ADD_ATTR_STR( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     atname, 
     I     sval )

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

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

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i,j,k, n, nv, indf,ind_fv_ids, fid,vid, err
      character*(MAX_LEN_MBUF) msgbuf
      integer lenf,lenv,lenat,lens

C     Strip trailing spaces
      lenf = ILNBLNK(fname)
      lenv = ILNBLNK(vname)
      lenat = ILNBLNK(atname)
      lens = ILNBLNK(sval)

      CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
      IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
        write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf), 
     &       ''' is not open or does not contain variable ''', 
     &       vname(1:lenv), ''''
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
      ENDIF
      fid = mnc_f_info(indf,2)
      vid = mnc_fv_ids(indf,(ind_fv_ids+1))

C     Set the attribute
      CALL MNC_FILE_REDEF(myThid, fname)
      err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, sval)
      write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
     &     ''' to file ''', fname(1:lenf), ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

      RETURN
      END

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

      SUBROUTINE MNC_VAR_WRITE_DBL( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     var )

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

C     Arguments
      integer myThid
      character*(*) fname
      character*(*) vname
      _RL var(*)

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
      character*(MAX_LEN_MBUF) msgbuf
      integer lenf,lenv, lend
      integer vstart(100), vcount(100)
      integer rvstart(100), rvcount(100)

C     Strip trailing spaces
      lenf = ILNBLNK(fname)
      lenv = ILNBLNK(vname)

      CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
      IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
        write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf), 
     &       ''' is not open or does not contain variable ''', 
     &       vname(1:lenv), ''''
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
      ENDIF
      fid = mnc_f_info(indf,2)
      vid = mnc_fv_ids(indf,(ind_fv_ids+1))

C     Get the lengths from the dim IDs
      ig = mnc_fv_ids(indf,(ind_fv_ids+2))
      ds = mnc_f_info(indf,ig+1)
      de = mnc_f_info(indf,ig+2)
      k = 0
      DO i = ds,de
        k = k + 1
        vstart(k) = 1
        vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
      ENDDO

C     Check for the unlimited dimension
      j = mnc_d_size( mnc_fd_ind(indf,de) )
      IF (j .LT. 1) THEN
        did = mnc_fg_ids(indf,de)
        err = NF_INQ_DIMLEN(fid, did, lend)
        write(msgbuf,'(a)') 'reading current length of unlimited dim'
        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
        IF (lend .LT. 1)  lend = lend + 1
        vstart(k) = lend
        vcount(k) = 1
      ENDIF

      CALL MNC_FILE_ENDDEF(myThid, fname)
      err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, var)
      write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
     &     ''' to file ''', fname(1:lenf), ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

      RETURN
      END

1	edhill	1.4	C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.3 2004/01/07 07:29:13 edhill Exp $
2	edhill	1.1	C $Name: $
3
4			#include "MNC_OPTIONS.h"
5
6			C==================================================================
7
8			SUBROUTINE MNC_VAR_INIT_DBL(
9			I myThid,
10			I fname,
11			I gname,
12			I vname,
13			I fillval )
14
15			implicit none
16	edhill	1.3	#include "netcdf.inc"
17	edhill	1.1	#include "mnc_common.h"
18			#include "EEPARAMS.h"
19
20			C Arguments
21			integer myThid
22			character() fname
23			character() gname
24			character() vname
25			_RL fillval
26
27			C Functions
28			integer ILNBLNK
29
30			C Local Variables
31	edhill	1.3	integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err
32	edhill	1.4	integer vid, nv, ind_g_finfo
33	edhill	1.1	character*(MAX_LEN_MBUF) msgbuf
34	edhill	1.3	integer rids(10), ids(10)
35			integer lenf,leng,lenv
36	edhill	1.1
37	edhill	1.3	C Strip trailing spaces
38			lenf = ILNBLNK(fname)
39			leng = ILNBLNK(gname)
40			lenv = ILNBLNK(vname)
41
42			C Check that the file is open
43			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
44			IF (indf .LT. 1) THEN
45			write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname,
46			& ''' must be opened first'
47			CALL print_error(msgbuf, mythid)
48			stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
49	edhill	1.1	ENDIF
50	edhill	1.3	fid = mnc_f_info(indf,2)
51
52			C Get the grid information
53			ngrid = mnc_f_info(indf,3)
54			IF (ngrid .LT. 1) THEN
55			write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),
56			& ''' contains NO grids'
57			CALL print_error(msgbuf, mythid)
58			stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
59			ENDIF
60			DO i = 1,ngrid
61			j = 4 + (i-1)*3
62			k = mnc_f_info(indf,j)
63			n = ILNBLNK(mnc_g_names(k))
64			IF ((leng .EQ. n)
65			& .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
66	edhill	1.4	ind_g_finfo = j
67	edhill	1.3	is = mnc_f_info(indf,(j+1))
68			ie = mnc_f_info(indf,(j+2))
69			nd = 0
70			DO k = is,ie
71			nd = nd + 1
72			ids(nd) = mnc_fg_ids(indf,k)
73			ENDDO
74			GOTO 10
75			ENDIF
76			ENDDO
77			write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
78			& ''' does not contain grid ''', gname(1:leng), ''''
79			CALL print_error(msgbuf, mythid)
80			stop 'ABNORMAL END: S/R MNC_VAR_INIT_DBL'
81			10 CONTINUE
82
83			C Add the variable definition
84			CALL MNC_FILE_REDEF(myThid, fname)
85			err = NF_DEF_VAR(fid, vname, NF_DOUBLE, nd, ids, vid)
86			write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
87			& ''' in file ''', fname(1:lenf), ''''
88			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
89
90			C Success, so save the variable info
91			CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv)
92			mnc_v_names(indv)(1:lenv) = vname(1:lenv)
93			nv = mnc_fv_ids(indf,1)
94			i = 2 + nv*2
95			j = i + 1
96	edhill	1.4	k = i + 2
97	edhill	1.3	mnc_fv_ids(indf,i) = indv
98			mnc_fv_ids(indf,j) = vid
99	edhill	1.4	mnc_fv_ids(indf,k) = ind_g_finfo
100	edhill	1.3	mnc_fv_ids(indf,1) = nv + 1
101
102			RETURN
103			END
104
105			C==================================================================
106
107			SUBROUTINE MNC_VAR_ADD_ATTR_STR(
108			I myThid,
109			I fname,
110			I vname,
111			I atname,
112			I sval )
113
114			implicit none
115			#include "netcdf.inc"
116			#include "mnc_common.h"
117			#include "EEPARAMS.h"
118
119			C Arguments
120			integer myThid
121			character() fname
122			character() vname
123			character() atname
124			character() sval
125
126			C Functions
127			integer ILNBLNK
128
129			C Local Variables
130	edhill	1.4	integer i,j,k, n, nv, indf,ind_fv_ids, fid,vid, err
131	edhill	1.3	character*(MAX_LEN_MBUF) msgbuf
132			integer lenf,lenv,lenat,lens
133
134			C Strip trailing spaces
135			lenf = ILNBLNK(fname)
136			lenv = ILNBLNK(vname)
137			lenat = ILNBLNK(atname)
138			lens = ILNBLNK(sval)
139
140	edhill	1.4	CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
141			IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
142			write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
143			& ''' is not open or does not contain variable ''',
144			& vname(1:lenv), ''''
145	edhill	1.3	CALL print_error(msgbuf, mythid)
146			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
147			ENDIF
148			fid = mnc_f_info(indf,2)
149	edhill	1.4	vid = mnc_fv_ids(indf,(ind_fv_ids+1))
150	edhill	1.3
151			C Set the attribute
152			CALL MNC_FILE_REDEF(myThid, fname)
153			err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, sval)
154			write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
155	edhill	1.4	& ''' to file ''', fname(1:lenf), ''''
156			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
157
158			RETURN
159			END
160
161			C==================================================================
162
163			SUBROUTINE MNC_VAR_WRITE_DBL(
164			I myThid,
165			I fname,
166			I vname,
167			I var )
168
169			implicit none
170			#include "netcdf.inc"
171			#include "mnc_common.h"
172			#include "EEPARAMS.h"
173
174			C Arguments
175			integer myThid
176			character() fname
177			character() vname
178			_RL var(*)
179
180			C Functions
181			integer ILNBLNK
182
183			C Local Variables
184			integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
185			character*(MAX_LEN_MBUF) msgbuf
186			integer lenf,lenv, lend
187			integer vstart(100), vcount(100)
188			integer rvstart(100), rvcount(100)
189
190			C Strip trailing spaces
191			lenf = ILNBLNK(fname)
192			lenv = ILNBLNK(vname)
193
194			CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
195			IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
196			write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
197			& ''' is not open or does not contain variable ''',
198			& vname(1:lenv), ''''
199			CALL print_error(msgbuf, mythid)
200			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
201			ENDIF
202			fid = mnc_f_info(indf,2)
203			vid = mnc_fv_ids(indf,(ind_fv_ids+1))
204
205			C Get the lengths from the dim IDs
206			ig = mnc_fv_ids(indf,(ind_fv_ids+2))
207			ds = mnc_f_info(indf,ig+1)
208			de = mnc_f_info(indf,ig+2)
209			k = 0
210			DO i = ds,de
211			k = k + 1
212			vstart(k) = 1
213			vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
214			ENDDO
215
216			C Check for the unlimited dimension
217			j = mnc_d_size( mnc_fd_ind(indf,de) )
218			IF (j .LT. 1) THEN
219			did = mnc_fg_ids(indf,de)
220			err = NF_INQ_DIMLEN(fid, did, lend)
221			write(msgbuf,'(a)') 'reading current length of unlimited dim'
222			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
223			IF (lend .LT. 1) lend = lend + 1
224			vstart(k) = lend
225			vcount(k) = 1
226			ENDIF
227
228			CALL MNC_FILE_ENDDEF(myThid, fname)
229			err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, var)
230			write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
231	edhill	1.3	& ''' to file ''', fname(1:lenf), ''''
232			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
233	edhill	1.1
234	edhill	1.2	RETURN
235	edhill	1.1	END
236