pkg/mnc/mnc_var.F

C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.14 2004/03/29 03:33:52 edhill Exp $
C $Name:  $
      
#include "MNC_OPTIONS.h"
      
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_INIT_DBL

C     !INTERFACE:
      SUBROUTINE MNC_VAR_INIT_DBL( 
     I     fname, 
     I     gname, 
     I     vname, 
     I     myThid )

C     !DESCRIPTION:
C     Create a double-precision real variable within a NetCDF file
C     context.
      
C     !USES:
      implicit none
#include "netcdf.inc"

C     !INPUT PARAMETERS:
      integer myThid
      character*(*) fname,gname,vname
CEOP

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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_INIT_REAL

C     !INTERFACE:
      SUBROUTINE MNC_VAR_INIT_REAL( 
     I     fname, 
     I     gname, 
     I     vname, 
     I     myThid )

C     !DESCRIPTION:
C     Create a single-precision real variable within a NetCDF file
C     context.
      
C     !USES:
      implicit none
#include "netcdf.inc"

C     !INPUT PARAMETERS:
      integer myThid
      character*(*) fname,gname,vname
CEOP

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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_INIT_INT

C     !INTERFACE:
      SUBROUTINE MNC_VAR_INIT_INT( 
     I     fname, 
     I     gname, 
     I     vname, 
     I     myThid )

C     !DESCRIPTION:
C     Create an integer variable within a NetCDF file context.
  
C     !USES:
      implicit none
#include "netcdf.inc"

C     !INPUT PARAMETERS:
      integer myThid
      character*(*) fname,gname,vname
CEOP

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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_INIT_ANY

C     !INTERFACE:
      SUBROUTINE MNC_VAR_INIT_ANY( 
     I     fname, 
     I     gname, 
     I     vname, 
     I     vtype, 
     I     myThid )

C     !DESCRIPTION:
C     General function for creating variables within a NetCDF file
C     context.
      
C     !USES:
      implicit none
#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

C     !INPUT PARAMETERS:
      integer myThid
      character*(*) fname,gname,vname
      integer vtype

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
CEOP
C     Functions
      integer ILNBLNK

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

C     Check that the file is open
      CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
      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(fname, myThid)
      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(err, msgbuf, myThid)

C     Success, so save the variable info
      CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID,mnc_v_names,indv, myThid)
      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-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_ADD_ATTR_STR

C     !INTERFACE:
      SUBROUTINE MNC_VAR_ADD_ATTR_STR( 
     I     fname, 
     I     vname, 
     I     atname, 
     I     sval, 
     I     myThid )

C     !DESCRIPTION:
C     Subroutine for adding a character string attribute to a NetCDF
C     file.
      
C     !USES:
      implicit none

C     !INPUT PARAMETERS:
      integer myThid
      character*(*) fname,vname,atname,sval
CEOP

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

C     !INTERFACE:
      SUBROUTINE MNC_VAR_ADD_ATTR_DBL( 
     I     fname, 
     I     vname, 
     I     atname, 
     I     nv, 
     I     dval, 
     I     myThid )

C     !DESCRIPTION:
C     Subroutine for adding a double-precision real attribute to a
C     NetCDF file.
   
C     !USES:
      implicit none

C     !INPUT PARAMETERS:
      integer myThid,nv
      character*(*) fname,vname,atname
      REAL*8 dval(*)
CEOP

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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_ADD_ATTR_REAL

C     !INTERFACE:
      SUBROUTINE MNC_VAR_ADD_ATTR_REAL( 
     I     fname, 
     I     vname, 
     I     atname, 
     I     nv, 
     I     rval, 
     I     myThid )

C     !DESCRIPTION:
C     Subroutine for adding a single-precision real attribute to a
C     NetCDF file.
   
C     !USES:
      implicit none

C     !INPUT PARAMETERS:
      integer myThid,nv
      character*(*) fname,vname,atname
      REAL*4 rval(*)
CEOP

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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_ADD_ATTR_INT

C     !INTERFACE:
      SUBROUTINE MNC_VAR_ADD_ATTR_INT( 
     I     fname, 
     I     vname, 
     I     atname, 
     I     nv, 
     I     ival, 
     I     myThid )

C     !DESCRIPTION:
C     Subroutine for adding an integer attribute to a
C     NetCDF file.
      
C     !USES:
      implicit none

C     !INPUT PARAMETERS:
      integer myThid,nv
      character*(*) fname,vname,atname
      integer ival(*)
CEOP

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

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP
C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY

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

C     !DESCRIPTION:
C     General subroutine for adding attributes to a NetCDF file.
      
C     !USES:
      implicit none
#include "netcdf.inc"
#include "mnc_common.h"
#include "EEPARAMS.h"

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

C     !LOCAL VARIABLES:
      integer n, indf,ind_fv_ids, fid,vid, err
      character*(MAX_LEN_MBUF) msgbuf
      integer lenf,lenv,lenat,lens
CEOP
C     Functions
      integer ILNBLNK

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

      CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
      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(fname, myThid)
      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(err, msgbuf, myThid)

      RETURN
      END

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      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(fname, vname, indf, ind_fv_ids, myThid)
      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(err, msgbuf, myThid)
        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(fname, myThid)
      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(err, msgbuf, myThid)

      RETURN
      END

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

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