pkg/mnc/mnc_var.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.11 2004/01/27 05:47:33 edhill Exp $
C $Name:  $
      
#include "MNC_OPTIONS.h"
      
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

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

      implicit none
#include "netcdf.inc"

C     Arguments
      integer myThid
      character*(*) fname,gname,vname

      CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname, NF_DOUBLE)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_INIT_REAL( 
     I     myThid, 
     I     fname, 
     I     gname, 
     I     vname )

      implicit none
#include "netcdf.inc"

C     Arguments
      integer myThid
      character*(*) fname,gname,vname

      CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname, NF_FLOAT)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_INIT_INT( 
     I     myThid, 
     I     fname, 
     I     gname, 
     I     vname )

      implicit none
#include "netcdf.inc"

C     Arguments
      integer myThid
      character*(*) fname,gname,vname

      CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname, NF_INT)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_INIT_ANY( 
     I     myThid, 
     I     fname, 
     I     gname, 
     I     vname, 
     I     vtype )

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

C     Arguments
      integer myThid
      character*(*) fname,gname,vname
      integer vtype

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, needed, nvar
      character*(MAX_LEN_MBUF) msgbuf
      integer ids(20)
      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_ANY'
      ENDIF
      fid = mnc_f_info(indf,2)

C     Check for sufficient storage space in mnc_fv_ids
      needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
      IF (needed .GE. MNC_MAX_INFO) THEN
        write(msgbuf,'(2a,i7,a)') 'MNC ERROR: MNC_MAX_INFO exceeded', 
     &       ': please increase it to ', 2*MNC_MAX_INFO, 
     &       ' in the file ''pkg/mnc/mnc_common.h'''
        CALL print_error(msgbuf, mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
      ENDIF

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_ANY'
      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_d_ids(mnc_fd_ind(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_ANY'
 10   CONTINUE

C     Check if the variable is already defined
      nvar = mnc_fv_ids(indf,1)
      DO i = 1,nvar
        j = 2 + 3*(i-1)
        IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN
          k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))
          IF (mnc_g_names(k) .NE. gname) THEN
            write(msgbuf,'(5a)') 'MNC ERROR: variable ''', 
     &           vname(1:lenv), ''' is already defined in file ''', 
     &           fname(1:lenf), ''' but using a different grid shape'
            CALL print_error(msgbuf, mythid)
            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
          ELSE
C           Its OK, the variable and grid names are the same
            RETURN
          ENDIF
        ENDIF
      ENDDO

C     Add the variable definition
      CALL MNC_FILE_REDEF(myThid, fname)
      err = NF_DEF_VAR(fid, vname, vtype, 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*3
      mnc_fv_ids(indf,i)   = indv
      mnc_fv_ids(indf,i+1) = vid
      mnc_fv_ids(indf,i+2) = ind_g_finfo
      mnc_fv_ids(indf,1) = nv + 1

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

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

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

      CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, 
     &     1, sval, 0, 0.0D0, 0.0, 0)
      RETURN
      END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_ADD_ATTR_DBL( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     atname, 
     I     nv, 
     I     dval )

      implicit none
C     Arguments
      integer myThid,nv
      character*(*) fname,vname,atname
      REAL*8 dval(*)

      CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, 
     &     2, ' ', nv, dval, 0.0, 0)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_ADD_ATTR_REAL( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     atname, 
     I     nv, 
     I     rval )

      implicit none
C     Arguments
      integer myThid,nv
      character*(*) fname,vname,atname
      REAL*4 rval(*)

      CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, 
     &     3, ' ', nv, 0.0D0, rval, 0)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_ADD_ATTR_INT( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     atname, 
     I     nv, 
     I     ival )

      implicit none
C     Arguments
      integer myThid,nv
      character*(*) fname,vname,atname
      integer ival(*)

      CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname, 
     &     4, ' ', nv, 0.0D0, 0.0, ival)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_ADD_ATTR_ANY( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     atname, 
     I     atype, cs,len,dv,rv,iv )

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

C     Arguments
      integer myThid,atype,len
      character*(*) fname,vname,atname
      character*(*) cs
      REAL*8 dv(*)
      REAL*4 rv(*)
      integer iv(*)

C     Functions
      integer ILNBLNK

C     Local Variables
      integer n, 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(cs)

      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)
      IF (atype .EQ. 1) THEN
        err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
      ELSEIF (atype .EQ. 2) THEN
        err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
      ELSEIF (atype .EQ. 3) THEN
        err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
      ELSEIF (atype .EQ. 4) THEN
        err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
      ELSE
        write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype, 
     &       ''' is invalid--must be: [1-4]'
        n = ILNBLNK(msgbuf)
        CALL print_error(msgbuf(1:n), mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
      ENDIF
      write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
     &     ''' to file ''', fname(1:lenf), ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

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

      implicit none
C     Arguments
      integer myThid
      character*(*) fname,vname
      REAL*8 var(*)

      CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,0,var,0.0,0)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

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

      implicit none
C     Arguments
      integer myThid
      character*(*) fname,vname
      REAL*4 var(*)

      CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,0,0.0D0,var,0)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

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

      implicit none
C     Arguments
      integer myThid
      character*(*) fname,vname
      integer var(*)

      CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,0,0.0D0,0.0,var)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_APPEND_DBL( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     var, 
     I     append )

      implicit none
C     Arguments
      integer myThid, append
      character*(*) fname,vname
      REAL*8 var(*)

      CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,append,var,0.0,0)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_APPEND_REAL( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     var, 
     I     append )

      implicit none
C     Arguments
      integer myThid, append
      character*(*) fname,vname
      REAL*4 var(*)

      CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,append,0.0D0,var,0)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_APPEND_INT( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     var, 
     I     append )

      implicit none
C     Arguments
      integer myThid, append
      character*(*) fname,vname
      integer var(*)

      CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,append,0.0D0,0.0,var)
      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE MNC_VAR_WRITE_ANY( 
     I     myThid, 
     I     fname, 
     I     vname, 
     I     vtype,
     I     append,
     I     dv,
     I     rv,
     I     iv )

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

C     Arguments
      integer myThid, vtype
      character*(*) fname,vname
      REAL*8 dv(*)
      REAL*4 rv(*)
      integer iv(*)
      integer append

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)

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_d_ids( mnc_fd_ind(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 (append .GT. 0) THEN
          lend = lend + append
        ENDIF
        IF (lend .LT. 1) lend = 1
        vstart(k) = lend
        vcount(k) = 1
      ENDIF

      CALL MNC_FILE_ENDDEF(myThid, fname)
      IF (vtype .EQ. 1) THEN
        err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
      ELSEIF (vtype .EQ. 2) THEN
        err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
      ELSEIF (vtype .EQ. 3) THEN
        err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
      ELSE
        write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype, 
     &       ''' is invalid--must be: [1|2|3]'
        n = ILNBLNK(msgbuf)
        CALL print_error(msgbuf(1:n), mythid)
        stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
      ENDIF  
      write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
     &     ''' to file ''', fname(1:lenf), ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

      RETURN
      END

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

1	edhill	1.12	C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.11 2004/01/27 05:47:33 edhill Exp $
2	edhill	1.1	C $Name: $
3
4			#include "MNC_OPTIONS.h"
5
6	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
7	edhill	1.1
8			SUBROUTINE MNC_VAR_INIT_DBL(
9			I myThid,
10			I fname,
11			I gname,
12	edhill	1.12	I vname )
13	edhill	1.5
14			implicit none
15			#include "netcdf.inc"
16
17			C Arguments
18			integer myThid
19	edhill	1.12	character() fname,gname,vname
20	edhill	1.5
21	edhill	1.12	CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname, NF_DOUBLE)
22	edhill	1.5	RETURN
23			END
24
25	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
26	edhill	1.5
27			SUBROUTINE MNC_VAR_INIT_REAL(
28			I myThid,
29			I fname,
30			I gname,
31	edhill	1.12	I vname )
32	edhill	1.5
33			implicit none
34			#include "netcdf.inc"
35
36			C Arguments
37			integer myThid
38	edhill	1.12	character() fname,gname,vname
39	edhill	1.5
40	edhill	1.12	CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname, NF_FLOAT)
41	edhill	1.5	RETURN
42			END
43
44	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
45	edhill	1.5
46			SUBROUTINE MNC_VAR_INIT_INT(
47			I myThid,
48			I fname,
49			I gname,
50	edhill	1.12	I vname )
51	edhill	1.5
52			implicit none
53			#include "netcdf.inc"
54
55			C Arguments
56			integer myThid
57	edhill	1.12	character() fname,gname,vname
58	edhill	1.5
59	edhill	1.12	CALL MNC_VAR_INIT_ANY(myThid,fname,gname,vname, NF_INT)
60	edhill	1.5	RETURN
61			END
62
63	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
64	edhill	1.5
65			SUBROUTINE MNC_VAR_INIT_ANY(
66			I myThid,
67			I fname,
68			I gname,
69	edhill	1.1	I vname,
70	edhill	1.5	I vtype )
71	edhill	1.1
72			implicit none
73	edhill	1.3	#include "netcdf.inc"
74	edhill	1.1	#include "mnc_common.h"
75			#include "EEPARAMS.h"
76
77			C Arguments
78			integer myThid
79	edhill	1.12	character() fname,gname,vname
80	edhill	1.5	integer vtype
81	edhill	1.1
82			C Functions
83			integer ILNBLNK
84
85			C Local Variables
86	edhill	1.3	integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err
87	edhill	1.12	integer vid, nv, ind_g_finfo, needed, nvar
88	edhill	1.1	character*(MAX_LEN_MBUF) msgbuf
89	edhill	1.8	integer ids(20)
90	edhill	1.12	integer lenf,leng,lenv
91	edhill	1.1
92	edhill	1.3	C Strip trailing spaces
93			lenf = ILNBLNK(fname)
94			leng = ILNBLNK(gname)
95			lenv = ILNBLNK(vname)
96
97			C Check that the file is open
98			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
99			IF (indf .LT. 1) THEN
100			write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname,
101			& ''' must be opened first'
102			CALL print_error(msgbuf, mythid)
103	edhill	1.7	stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
104	edhill	1.1	ENDIF
105	edhill	1.3	fid = mnc_f_info(indf,2)
106
107	edhill	1.8	C Check for sufficient storage space in mnc_fv_ids
108			needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
109			IF (needed .GE. MNC_MAX_INFO) THEN
110			write(msgbuf,'(2a,i7,a)') 'MNC ERROR: MNC_MAX_INFO exceeded',
111			& ': please increase it to ', 2*MNC_MAX_INFO,
112			& ' in the file ''pkg/mnc/mnc_common.h'''
113			CALL print_error(msgbuf, mythid)
114			stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
115			ENDIF
116
117	edhill	1.3	C Get the grid information
118			ngrid = mnc_f_info(indf,3)
119			IF (ngrid .LT. 1) THEN
120			write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),
121			& ''' contains NO grids'
122			CALL print_error(msgbuf, mythid)
123	edhill	1.7	stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
124	edhill	1.3	ENDIF
125			DO i = 1,ngrid
126			j = 4 + (i-1)*3
127			k = mnc_f_info(indf,j)
128			n = ILNBLNK(mnc_g_names(k))
129			IF ((leng .EQ. n)
130			& .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
131	edhill	1.4	ind_g_finfo = j
132	edhill	1.3	is = mnc_f_info(indf,(j+1))
133			ie = mnc_f_info(indf,(j+2))
134			nd = 0
135			DO k = is,ie
136			nd = nd + 1
137	edhill	1.10	ids(nd) = mnc_d_ids(mnc_fd_ind(indf,k))
138	edhill	1.3	ENDDO
139			GOTO 10
140			ENDIF
141			ENDDO
142			write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
143			& ''' does not contain grid ''', gname(1:leng), ''''
144			CALL print_error(msgbuf, mythid)
145	edhill	1.7	stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
146	edhill	1.3	10 CONTINUE
147
148	edhill	1.12	C Check if the variable is already defined
149			nvar = mnc_fv_ids(indf,1)
150			DO i = 1,nvar
151			j = 2 + 3*(i-1)
152			IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN
153			k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))
154			IF (mnc_g_names(k) .NE. gname) THEN
155			write(msgbuf,'(5a)') 'MNC ERROR: variable ''',
156			& vname(1:lenv), ''' is already defined in file ''',
157			& fname(1:lenf), ''' but using a different grid shape'
158			CALL print_error(msgbuf, mythid)
159			stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
160			ELSE
161			C Its OK, the variable and grid names are the same
162			RETURN
163			ENDIF
164			ENDIF
165			ENDDO
166
167	edhill	1.3	C Add the variable definition
168			CALL MNC_FILE_REDEF(myThid, fname)
169	edhill	1.5	err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid)
170	edhill	1.3	write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
171			& ''' in file ''', fname(1:lenf), ''''
172			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
173
174			C Success, so save the variable info
175			CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_v_names, indv)
176			mnc_v_names(indv)(1:lenv) = vname(1:lenv)
177			nv = mnc_fv_ids(indf,1)
178	edhill	1.5	i = 2 + nv*3
179	edhill	1.10	mnc_fv_ids(indf,i) = indv
180			mnc_fv_ids(indf,i+1) = vid
181			mnc_fv_ids(indf,i+2) = ind_g_finfo
182	edhill	1.3	mnc_fv_ids(indf,1) = nv + 1
183	edhill	1.5
184	edhill	1.3	RETURN
185			END
186
187	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
188	edhill	1.3
189			SUBROUTINE MNC_VAR_ADD_ATTR_STR(
190			I myThid,
191			I fname,
192			I vname,
193			I atname,
194			I sval )
195
196			implicit none
197	edhill	1.5	C Arguments
198			integer myThid
199			character() fname,vname,atname,sval
200
201			CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
202			& 1, sval, 0, 0.0D0, 0.0, 0)
203			RETURN
204			END
205	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
206	edhill	1.5
207			SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
208			I myThid,
209			I fname,
210			I vname,
211			I atname,
212			I nv,
213			I dval )
214
215			implicit none
216			C Arguments
217			integer myThid,nv
218			character() fname,vname,atname
219	edhill	1.8	REAL8 dval()
220	edhill	1.5
221			CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
222			& 2, ' ', nv, dval, 0.0, 0)
223			RETURN
224			END
225
226	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
227	edhill	1.5
228			SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
229			I myThid,
230			I fname,
231			I vname,
232			I atname,
233			I nv,
234			I rval )
235
236			implicit none
237			C Arguments
238			integer myThid,nv
239			character() fname,vname,atname
240	edhill	1.8	REAL4 rval()
241	edhill	1.5
242			CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
243			& 3, ' ', nv, 0.0D0, rval, 0)
244			RETURN
245			END
246
247	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
248	edhill	1.5
249			SUBROUTINE MNC_VAR_ADD_ATTR_INT(
250			I myThid,
251			I fname,
252			I vname,
253			I atname,
254			I nv,
255			I ival )
256
257			implicit none
258			C Arguments
259			integer myThid,nv
260			character() fname,vname,atname
261			integer ival(*)
262
263			CALL MNC_VAR_ADD_ATTR_ANY(myThid,fname,vname,atname,
264			& 4, ' ', nv, 0.0D0, 0.0, ival)
265			RETURN
266			END
267
268	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
269	edhill	1.5
270			SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
271			I myThid,
272			I fname,
273			I vname,
274			I atname,
275			I atype, cs,len,dv,rv,iv )
276
277			implicit none
278	edhill	1.3	#include "netcdf.inc"
279			#include "mnc_common.h"
280			#include "EEPARAMS.h"
281
282			C Arguments
283	edhill	1.5	integer myThid,atype,len
284			character() fname,vname,atname
285			character() cs
286	edhill	1.8	REAL8 dv()
287			REAL4 rv()
288	edhill	1.5	integer iv(*)
289	edhill	1.3
290			C Functions
291			integer ILNBLNK
292
293			C Local Variables
294	edhill	1.8	integer n, indf,ind_fv_ids, fid,vid, err
295	edhill	1.3	character*(MAX_LEN_MBUF) msgbuf
296			integer lenf,lenv,lenat,lens
297
298			C Strip trailing spaces
299			lenf = ILNBLNK(fname)
300			lenv = ILNBLNK(vname)
301			lenat = ILNBLNK(atname)
302	edhill	1.5	lens = ILNBLNK(cs)
303	edhill	1.3
304	edhill	1.4	CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
305			IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
306			write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
307			& ''' is not open or does not contain variable ''',
308			& vname(1:lenv), ''''
309	edhill	1.3	CALL print_error(msgbuf, mythid)
310			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
311			ENDIF
312			fid = mnc_f_info(indf,2)
313	edhill	1.4	vid = mnc_fv_ids(indf,(ind_fv_ids+1))
314	edhill	1.3
315			C Set the attribute
316			CALL MNC_FILE_REDEF(myThid, fname)
317	edhill	1.5	IF (atype .EQ. 1) THEN
318			err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
319			ELSEIF (atype .EQ. 2) THEN
320			err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
321			ELSEIF (atype .EQ. 3) THEN
322			err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
323			ELSEIF (atype .EQ. 4) THEN
324			err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
325			ELSE
326			write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
327			& ''' is invalid--must be: [1-4]'
328			n = ILNBLNK(msgbuf)
329			CALL print_error(msgbuf(1:n), mythid)
330			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
331			ENDIF
332	edhill	1.3	write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
333	edhill	1.4	& ''' to file ''', fname(1:lenf), ''''
334			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
335
336			RETURN
337			END
338
339	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
340	edhill	1.4
341			SUBROUTINE MNC_VAR_WRITE_DBL(
342			I myThid,
343			I fname,
344			I vname,
345			I var )
346
347			implicit none
348	edhill	1.5	C Arguments
349			integer myThid
350			character() fname,vname
351	edhill	1.8	REAL8 var()
352	edhill	1.5
353	edhill	1.9	CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,0,var,0.0,0)
354	edhill	1.5	RETURN
355			END
356
357	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
358	edhill	1.5
359			SUBROUTINE MNC_VAR_WRITE_REAL(
360			I myThid,
361			I fname,
362			I vname,
363			I var )
364
365			implicit none
366			C Arguments
367			integer myThid
368			character() fname,vname
369	edhill	1.8	REAL4 var()
370	edhill	1.5
371	edhill	1.9	CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,0,0.0D0,var,0)
372	edhill	1.5	RETURN
373			END
374
375	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
376	edhill	1.5
377			SUBROUTINE MNC_VAR_WRITE_INT(
378			I myThid,
379			I fname,
380			I vname,
381			I var )
382
383			implicit none
384			C Arguments
385			integer myThid
386			character() fname,vname
387			integer var(*)
388
389	edhill	1.9	CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,0,0.0D0,0.0,var)
390			RETURN
391			END
392
393	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
394	edhill	1.9
395			SUBROUTINE MNC_VAR_APPEND_DBL(
396			I myThid,
397			I fname,
398			I vname,
399			I var,
400			I append )
401
402			implicit none
403			C Arguments
404			integer myThid, append
405			character() fname,vname
406			REAL8 var()
407
408			CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,1,append,var,0.0,0)
409			RETURN
410			END
411
412	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
413	edhill	1.9
414			SUBROUTINE MNC_VAR_APPEND_REAL(
415			I myThid,
416			I fname,
417			I vname,
418			I var,
419			I append )
420
421			implicit none
422			C Arguments
423			integer myThid, append
424			character() fname,vname
425			REAL4 var()
426
427			CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,2,append,0.0D0,var,0)
428			RETURN
429			END
430
431	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
432	edhill	1.9
433			SUBROUTINE MNC_VAR_APPEND_INT(
434			I myThid,
435			I fname,
436			I vname,
437			I var,
438			I append )
439
440			implicit none
441			C Arguments
442			integer myThid, append
443			character() fname,vname
444			integer var(*)
445
446			CALL MNC_VAR_WRITE_ANY(myThid,fname,vname,3,append,0.0D0,0.0,var)
447	edhill	1.5	RETURN
448			END
449
450	edhill	1.11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
451	edhill	1.5
452			SUBROUTINE MNC_VAR_WRITE_ANY(
453			I myThid,
454			I fname,
455			I vname,
456			I vtype,
457	edhill	1.9	I append,
458	edhill	1.5	I dv,
459			I rv,
460			I iv )
461
462			implicit none
463	edhill	1.4	#include "netcdf.inc"
464			#include "mnc_common.h"
465			#include "EEPARAMS.h"
466
467			C Arguments
468	edhill	1.5	integer myThid, vtype
469			character() fname,vname
470	edhill	1.8	REAL8 dv()
471			REAL4 rv()
472	edhill	1.5	integer iv(*)
473	edhill	1.9	integer append
474	edhill	1.4
475			C Functions
476			integer ILNBLNK
477
478			C Local Variables
479			integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
480			character*(MAX_LEN_MBUF) msgbuf
481			integer lenf,lenv, lend
482			integer vstart(100), vcount(100)
483
484			C Strip trailing spaces
485			lenf = ILNBLNK(fname)
486			lenv = ILNBLNK(vname)
487
488			CALL MNC_GET_FVINDS(myThid, fname, vname, indf, ind_fv_ids)
489			IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
490			write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
491			& ''' is not open or does not contain variable ''',
492			& vname(1:lenv), ''''
493			CALL print_error(msgbuf, mythid)
494			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
495			ENDIF
496			fid = mnc_f_info(indf,2)
497			vid = mnc_fv_ids(indf,(ind_fv_ids+1))
498
499			C Get the lengths from the dim IDs
500			ig = mnc_fv_ids(indf,(ind_fv_ids+2))
501			ds = mnc_f_info(indf,ig+1)
502			de = mnc_f_info(indf,ig+2)
503			k = 0
504			DO i = ds,de
505			k = k + 1
506			vstart(k) = 1
507			vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
508			ENDDO
509
510			C Check for the unlimited dimension
511			j = mnc_d_size( mnc_fd_ind(indf,de) )
512			IF (j .LT. 1) THEN
513	edhill	1.10	did = mnc_d_ids( mnc_fd_ind(indf,de) )
514	edhill	1.4	err = NF_INQ_DIMLEN(fid, did, lend)
515			write(msgbuf,'(a)') 'reading current length of unlimited dim'
516			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
517	edhill	1.9	IF (append .GT. 0) THEN
518			lend = lend + append
519			ENDIF
520			IF (lend .LT. 1) lend = 1
521	edhill	1.4	vstart(k) = lend
522			vcount(k) = 1
523			ENDIF
524
525			CALL MNC_FILE_ENDDEF(myThid, fname)
526	edhill	1.5	IF (vtype .EQ. 1) THEN
527			err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
528			ELSEIF (vtype .EQ. 2) THEN
529			err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
530			ELSEIF (vtype .EQ. 3) THEN
531			err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
532			ELSE
533			write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
534			& ''' is invalid--must be: [1\|2\|3]'
535			n = ILNBLNK(msgbuf)
536			CALL print_error(msgbuf(1:n), mythid)
537			stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
538			ENDIF
539	edhill	1.4	write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
540	edhill	1.3	& ''' to file ''', fname(1:lenf), ''''
541			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
542	edhill	1.1
543	edhill	1.2	RETURN
544	edhill	1.1	END
545	edhill	1.11
546			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
547	edhill	1.1