pkg/mnc/mnc_var.F

C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_var.F,v 1.15 2004/04/02 05:13:33 edhill Exp $
C $Name:  $
      
#include "MNC_OPTIONS.h"
      
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
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 1
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 1
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 1
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
CEOP

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     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 1
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 1
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 1
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 1
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 1
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(*)
CEOP

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

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