pkg/mnc/mnc_file.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.9 2004/01/25 00:22:57 edhill Exp $
C $Name:  $

#include "MNC_OPTIONS.h"

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

      SUBROUTINE MNC_FILE_CREATE( 
     I     myThid,
     I     fname )

      implicit none

C     Arguments
      integer myThid
      character*(*) fname

      CALL MNC_FILE_OPEN(myThid, fname, 0)

      RETURN
      END

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

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

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

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

C     Functions
      integer ILNBLNK

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

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

      write(msgbuf,'(3a)') 'opening ''', fname, ''''
      IF ( itype .EQ. 0 ) THEN

C       Create new file
        err = NF_CREATE(fname, NF_CLOBBER, fid)
        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

      ELSEIF ( itype .EQ. 1 ) THEN

C       Append to existing file
        CALL MNC_FILE_READALL(myThid, fname)

      ELSE
C       Error
        write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype, 
     &       ''' is not defined--should be: [0|1]'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
      ENDIF

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

      RETURN
      END

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

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

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

      CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 1, 
     &     sval, 0, 0.0D0, 0.0, 0 )
      RETURN
      END

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

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

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

      CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 2, 
     &     ' ', len, dval, 0.0, 0 )
      RETURN
      END

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

      SUBROUTINE MNC_FILE_ADD_ATTR_REAL( 
     I     myThid, 
     I     fname, 
     I     atname, 
     I     len, 
     I     rval )

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

      CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 3, 
     &     ' ', len, 0.0D0, rval, 0 )
      RETURN
      END

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

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

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

      CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 4, 
     &     ' ', len, 0.0D0, 0.0, ival )
      RETURN
      END

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

      SUBROUTINE MNC_FILE_ADD_ATTR_ANY( 
     I     myThid, 
     I     fname, 
     I     atname, 
     I     atype, sv, len,dv,rv,iv )

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

C     Arguments
      integer myThid, atype, len, iv
      character*(*) fname, atname, sv
      REAL*8 dv
      REAL*4 rv
      
C     Functions
      integer ILNBLNK

C     Local Variables
      integer n, err, fid, ind, n1, lens
      character*(MNC_MAX_CHAR) s1
      character*(MAX_LEN_MBUF) msgbuf
      
C     Verify that the file is open
      CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
      IF (ind .LT. 0) THEN
        write(msgbuf,'(3a)') 'MNC ERROR: file ''',
     &       fname, ''' must be opened first'
        CALL print_error( msgbuf, mythid )
        stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
      ENDIF
      fid = mnc_f_info(ind,2)

C     Enter define mode
      CALL MNC_FILE_REDEF(myThid, fname)

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

      IF (atype .EQ. 1) THEN
        lens = ILNBLNK(sv)
        err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, lens, sv)
        CALL MNC_HANDLE_ERR(myThid, err,
     &       'adding TEXT attribute in S/R MNC_FILE_ADD_ATTR_ANY')
      ELSEIF (atype .EQ. 2) THEN
        err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, len, dv)
        CALL MNC_HANDLE_ERR(myThid, err,
     &       'adding DOUBLE attribute in S/R MNC_FILE_ADD_ATTR_ANY')
      ELSEIF (atype .EQ. 3) THEN
        err = NF_PUT_ATT_REAL(fid, NF_GLOBAL, s1, NF_FLOAT, len, rv)
        CALL MNC_HANDLE_ERR(myThid, err,
     &       'adding REAL attribute in S/R MNC_FILE_ADD_ATTR_ANY')
      ELSEIF (atype .EQ. 4) THEN
        err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, len, iv)
        CALL MNC_HANDLE_ERR(myThid, err,
     &       'adding INT attribute in S/R MNC_FILE_ADD_ATTR_ANY')
      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

      RETURN
      END

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

      SUBROUTINE MNC_FILE_CLOSE( 
     I     myThid,
     I     fname )

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

C     Arguments
      integer myThid
      character*(*) fname

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

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

C     Clear all the info associated with this file
C     variables
      n = mnc_fv_ids(ind,1)
      IF (n .GE. 1) THEN
        DO i = 1,n
          j = 2 + 3*(i - 1)
          k = mnc_fv_ids(ind,j)
          mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
        ENDDO
        DO i = 1,(1 + 3*n)
          mnc_fv_ids(ind,i) = 0
        ENDDO
      ENDIF
C     dims
      n = mnc_f_alld(ind,1)
      mnc_f_alld(ind,1) = 0
      DO i = 1,n
        j = mnc_f_alld(ind,i+1)
        mnc_d_ids(j)  = 0
        mnc_d_size(j) = 0
        mnc_d_names(j)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
        mnc_f_alld(ind,i+1) = 0
      ENDDO
C     grids
      n = mnc_f_info(ind,3)
      IF (n .GT. 0) THEN
        DO i = 1,n
          j = 4 + 3*(i - 1)
          k = mnc_f_info(ind,j)
          mnc_g_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
        ENDDO
        DO i = 1,MNC_MAX_INFO
          mnc_fd_ind(ind,i) = 0
          mnc_f_info(ind,i) = 0
        ENDDO
      ENDIF
C     file name
      mnc_f_names(ind)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)

      RETURN
      END

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

      SUBROUTINE MNC_FILE_CLOSE_ALL_MATCHING( 
     I     myThid, 
     I     fname ) 

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

C     Arguments
      integer myThid
      character*(*) fname

C     Functions
      integer ILNBLNK

C     Local Variables
      integer i,n

      n = ILNBLNK(fname)
      DO i = 1,MNC_MAX_ID

C       Check that the file is open
        IF (fname(1:n) .EQ. mnc_f_names(i)(1:n)) THEN
          CALL MNC_FILE_CLOSE(myThid,mnc_f_names(i))
        ENDIF

      ENDDO

      RETURN
      END

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

      SUBROUTINE MNC_FILE_CLOSE_ALL( 
     I     myThid ) 

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

C     Arguments
      integer myThid

C     Local Variables
      integer i

      DO i = 1,MNC_MAX_ID

C       Check that the file is open
        IF (mnc_f_names(i)(1:MNC_MAX_CHAR) 
     &       .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
          CALL MNC_FILE_CLOSE(myThid,mnc_f_names(i))
        ENDIF

      ENDDO

      RETURN
      END

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

      SUBROUTINE MNC_FILE_REDEF( 
     I     myThid,
     I     fname )

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

C     Arguments
      integer myThid
      character*(*) fname

C     Functions
      integer ILNBLNK

C     Local Variables
      integer ind, fid, def, err, n
      character*(MAX_LEN_MBUF) msgbuf

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

      IF (def .NE. 1) THEN
C       Enter define mode
        err = NF_REDEF(fid)
        CALL MNC_HANDLE_ERR(myThid, err, 
     &       'entering define mode in S/R MNC_FILE_REDEF')
        mnc_f_info(ind,1) = 1
      ENDIF

      RETURN
      END

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

      SUBROUTINE MNC_FILE_ENDDEF( 
     I     myThid,
     I     fname )

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

C     Arguments
      integer myThid
      character*(*) fname

C     Functions
      integer ILNBLNK

C     Local Variables
      integer ind, fid, def, err, n
      character*(MAX_LEN_MBUF) msgbuf

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

      IF (def .NE. 2) THEN
C       Enter define mode
        err = NF_ENDDEF(fid)
        CALL MNC_HANDLE_ERR(myThid, err, 
     &       'ending define mode in S/R MNC_FILE_ENDDEF')
        mnc_f_info(ind,1) = 2
      ENDIF

      RETURN
      END

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

      SUBROUTINE MNC_FILE_READALL( 
     I     myThid, 
     I     fname ) 

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

C     Arguments
      integer myThid
      character*(*) fname

C     Functions
      integer IFNBLNK, ILNBLNK

C     Local Variables
      integer i,j,k, fid, err, ndim,nvar,ngat,unlimid
      integer dlen, id, indf, xtype, nat, nff,nlf, iv
      integer ndv, did, ns,ne, n1,n2, indg, indv
      character*(MAX_LEN_MBUF) msgbuf
      character*(NF_MAX_NAME) name
      integer idlist(NF_MAX_VAR_DIMS)
      character*(MNC_MAX_CHAR) dnames(20)

C     Open and save the filename and fID
      nff = IFNBLNK(fname)
      nlf = ILNBLNK(fname)
      err = NF_OPEN(fname, NF_WRITE, fid)
      write(msgbuf,'(3a)') 'MNC ERROR: cannot open file ''', 
     &     fname(nff:nlf), ''' for read/write access'
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
      CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_f_names,indf) 
      mnc_f_names(indf)(1:(nlf-nff+1)) = fname(nff:nlf)
      mnc_f_info(indf,2) = fid

C     Get the overall number of entities
      err = NF_INQ(fid, ndim, nvar, ngat, unlimid)
      write(msgbuf,'(4a)') 'MNC ERROR: cannot read number of dims',
     &     ' in file ''', fname(nff:nlf), ''''
      CALL MNC_HANDLE_ERR(myThid, err, msgbuf)

C     Read each dimension and save the information
      DO id = 1,ndim
        err = NF_INQ_DIM(fid, id, name, dlen)
        write(msgbuf,'(2a,i5,3a)') 'MNC ERROR: cannot read dimension',
     &       ' info for dim ''', id, ''' in file ''', 
     &       fname(nff:nlf), ''''
        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
        IF (id .EQ. unlimid) THEN
          dlen = -1
        ENDIF
        ns = IFNBLNK(name)
        ne = ILNBLNK(name)
        CALL MNC_DIM_INIT_ALL(myThid,fname,name(ns:ne),dlen,'N')
        DO i = 1,mnc_f_alld(indf,1)
          j = mnc_f_alld(indf,i+1)
          n1 = IFNBLNK(mnc_d_names(j))
          n2 = ILNBLNK(mnc_d_names(j))
          IF (((ne-ns) .EQ. (n2-n1)) 
     &         .AND. (mnc_d_names(j)(ns:ne) .EQ. name(ns:ne))) THEN
            mnc_d_ids(j) = id
            goto 10
          ENDIF
        ENDDO
 10     CONTINUE
      ENDDO

C     Read and save each variable
      DO id = 1,nvar
        err = NF_INQ_VAR(fid, id, name, xtype, ndv, idlist, nat)
        write(msgbuf,'(2a,i5,3a)') 'MNC ERROR: cannot read variable',
     &       ' info for variable ''', id, ''' in file ''', 
     &       fname(nff:nlf), ''''
        CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
        n1 = IFNBLNK(name)
        n2 = ILNBLNK(name)
        
C       Create a grid for this variable
        DO i = 1,ndv
          did = idlist(i)
          dnames(i)(1:MNC_MAX_CHAR) = mnc_d_names(did)(1:MNC_MAX_CHAR)
        ENDDO
        CALL MNC_GRID_INIT_ALL(myThid, fname, name, ndv, dnames, indg)

C       Update the tables
        CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_v_names,indv)
        mnc_v_names(indv)(1:(n2-n1+1)) = name(n1:n2)
        iv = 2 + 3*mnc_fv_ids(indf,1)
        mnc_fv_ids(indf,iv)   = indv
        mnc_fv_ids(indf,iv+1) = id
        DO i = 1,mnc_f_info(indf,3)
          j = 4 + 3*(i-1)
          k = mnc_f_info(indf,j)
          IF (k .EQ. indg) THEN
            mnc_fv_ids(indf,iv+2) = j
            GOTO 20
          ENDIF
        ENDDO
 20     CONTINUE
        mnc_fv_ids(indf,1) = mnc_fv_ids(indf,1) + 1
        
      ENDDO

      RETURN
      END

1	edhill	1.10	C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.9 2004/01/25 00:22:57 edhill Exp $
2	edhill	1.1	C $Name: $
3
4			#include "MNC_OPTIONS.h"
5
6	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
7	edhill	1.1
8	edhill	1.3	SUBROUTINE MNC_FILE_CREATE(
9			I myThid,
10			I fname )
11
12			implicit none
13
14			C Arguments
15			integer myThid
16			character() fname
17
18			CALL MNC_FILE_OPEN(myThid, fname, 0)
19
20			RETURN
21			END
22
23	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
24	edhill	1.3
25	edhill	1.1	SUBROUTINE MNC_FILE_OPEN(
26			I myThid,
27			I fname,
28			I itype )
29
30			implicit none
31			#include "netcdf.inc"
32			#include "mnc_common.h"
33			#include "EEPARAMS.h"
34
35			C Arguments
36			integer myThid
37			character() fname
38			integer itype
39			C itype => [ 0=new \| 1=append ]
40
41	edhill	1.3	C Functions
42			integer ILNBLNK
43
44	edhill	1.1	C Local Variables
45	edhill	1.7	integer n, err, fid, ind
46	edhill	1.1	character*(MAX_LEN_MBUF) msgbuf
47
48			C Is the file already open?
49			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
50			IF ( ind .GT. 0 ) THEN
51			write(msgbuf,'(3a)') 'MNC_FILE_OPEN ERROR: ''', fname,
52			& ''' is already open -- cannot open twice'
53			CALL print_error( msgbuf, mythid )
54			stop 'ABNORMAL END: package MNC'
55			ENDIF
56
57	edhill	1.3	write(msgbuf,'(3a)') 'opening ''', fname, ''''
58	edhill	1.1	IF ( itype .EQ. 0 ) THEN
59	edhill	1.9
60	edhill	1.1	C Create new file
61	edhill	1.9	err = NF_CREATE(fname, NF_CLOBBER, fid)
62	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
63	edhill	1.9
64	edhill	1.1	ELSEIF ( itype .EQ. 1 ) THEN
65	edhill	1.9
66	edhill	1.1	C Append to existing file
67	edhill	1.9	CALL MNC_FILE_READALL(myThid, fname)
68
69	edhill	1.1	ELSE
70			C Error
71			write(msgbuf,'(a,i5,a)') 'MNC_FILE_OPEN ERROR: ''', itype,
72			& ''' is not defined--should be: [0\|1]'
73	edhill	1.3	CALL print_error( msgbuf, mythid )
74			stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_STR'
75	edhill	1.1	ENDIF
76
77			CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_f_names, ind)
78	edhill	1.3	n = ILNBLNK(fname)
79			mnc_f_names(ind)(1:n) = fname(1:n)
80	edhill	1.1	mnc_f_info(ind,1) = 1
81	edhill	1.3	mnc_f_info(ind,2) = fid
82			mnc_f_info(ind,3) = 0
83			mnc_fv_ids(ind,1) = 0
84	edhill	1.7	mnc_f_alld(ind,1) = 0
85	edhill	1.1
86	edhill	1.3	RETURN
87	edhill	1.1	END
88
89	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
90	edhill	1.1
91			SUBROUTINE MNC_FILE_ADD_ATTR_STR(
92			I myThid,
93			I fname,
94			I atname,
95			I sval )
96
97			implicit none
98	edhill	1.5	C Arguments
99	edhill	1.7	integer myThid
100	edhill	1.5	character() fname, atname, sval
101
102			CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 1,
103			& sval, 0, 0.0D0, 0.0, 0 )
104			RETURN
105			END
106	edhill	1.1
107	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
108	edhill	1.1
109	edhill	1.5	SUBROUTINE MNC_FILE_ADD_ATTR_DBL(
110			I myThid,
111			I fname,
112			I atname,
113			I len,
114			I dval )
115	edhill	1.1
116	edhill	1.5	implicit none
117			C Arguments
118			integer myThid, len
119			character() fname, atname
120	edhill	1.7	REAL*8 dval
121	edhill	1.1
122	edhill	1.5	CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 2,
123			& ' ', len, dval, 0.0, 0 )
124			RETURN
125			END
126	edhill	1.1
127	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
128	edhill	1.1
129	edhill	1.5	SUBROUTINE MNC_FILE_ADD_ATTR_REAL(
130			I myThid,
131			I fname,
132			I atname,
133			I len,
134			I rval )
135	edhill	1.1
136	edhill	1.5	implicit none
137			C Arguments
138			integer myThid, len
139			character() fname, atname
140	edhill	1.7	REAL*4 rval
141	edhill	1.1
142	edhill	1.5	CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 3,
143			& ' ', len, 0.0D0, rval, 0 )
144	edhill	1.3	RETURN
145	edhill	1.1	END
146
147	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
148	edhill	1.1
149			SUBROUTINE MNC_FILE_ADD_ATTR_INT(
150			I myThid,
151			I fname,
152			I atname,
153	edhill	1.5	I len,
154	edhill	1.1	I ival )
155
156			implicit none
157			C Arguments
158	edhill	1.5	integer myThid, len, ival
159	edhill	1.1	character() fname, atname
160
161	edhill	1.5	CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 4,
162			& ' ', len, 0.0D0, 0.0, ival )
163	edhill	1.3	RETURN
164	edhill	1.1	END
165
166	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
167	edhill	1.1
168	edhill	1.5	SUBROUTINE MNC_FILE_ADD_ATTR_ANY(
169	edhill	1.1	I myThid,
170			I fname,
171			I atname,
172	edhill	1.5	I atype, sv, len,dv,rv,iv )
173	edhill	1.1
174	edhill	1.5	implicit none
175	edhill	1.1	#include "netcdf.inc"
176			#include "mnc_common.h"
177			#include "EEPARAMS.h"
178
179			C Arguments
180	edhill	1.5	integer myThid, atype, len, iv
181			character() fname, atname, sv
182	edhill	1.7	REAL*8 dv
183			REAL*4 rv
184	edhill	1.5
185	edhill	1.1	C Functions
186			integer ILNBLNK
187
188			C Local Variables
189	edhill	1.7	integer n, err, fid, ind, n1, lens
190	edhill	1.1	character*(MNC_MAX_CHAR) s1
191			character*(MAX_LEN_MBUF) msgbuf
192
193	edhill	1.4	C Verify that the file is open
194	edhill	1.1	CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
195	edhill	1.4	IF (ind .LT. 0) THEN
196	edhill	1.1	write(msgbuf,'(3a)') 'MNC ERROR: file ''',
197			& fname, ''' must be opened first'
198			CALL print_error( msgbuf, mythid )
199			stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'
200			ENDIF
201	edhill	1.2	fid = mnc_f_info(ind,2)
202	edhill	1.1
203			C Enter define mode
204	edhill	1.4	CALL MNC_FILE_REDEF(myThid, fname)
205	edhill	1.1
206			s1(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
207			n1 = ILNBLNK(atname)
208			s1(1:n1) = atname(1:n1)
209
210	edhill	1.5	IF (atype .EQ. 1) THEN
211			lens = ILNBLNK(sv)
212			err = NF_PUT_ATT_TEXT(fid, NF_GLOBAL, s1, lens, sv)
213	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
214			& 'adding TEXT attribute in S/R MNC_FILE_ADD_ATTR_ANY')
215	edhill	1.5	ELSEIF (atype .EQ. 2) THEN
216			err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, len, dv)
217	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
218			& 'adding DOUBLE attribute in S/R MNC_FILE_ADD_ATTR_ANY')
219	edhill	1.5	ELSEIF (atype .EQ. 3) THEN
220			err = NF_PUT_ATT_REAL(fid, NF_GLOBAL, s1, NF_FLOAT, len, rv)
221	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
222			& 'adding REAL attribute in S/R MNC_FILE_ADD_ATTR_ANY')
223	edhill	1.5	ELSEIF (atype .EQ. 4) THEN
224			err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, len, iv)
225	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
226			& 'adding INT attribute in S/R MNC_FILE_ADD_ATTR_ANY')
227	edhill	1.5	ELSE
228			write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
229			& ''' is invalid--must be: [1-4]'
230			n = ILNBLNK(msgbuf)
231			CALL print_error(msgbuf(1:n), mythid)
232			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
233			ENDIF
234	edhill	1.3
235			RETURN
236			END
237
238	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
239	edhill	1.3
240			SUBROUTINE MNC_FILE_CLOSE(
241			I myThid,
242			I fname )
243
244			implicit none
245			#include "netcdf.inc"
246			#include "mnc_common.h"
247			#include "EEPARAMS.h"
248
249			C Arguments
250			integer myThid
251			character() fname
252
253			C Local Variables
254			integer i,j,k,n, err, fid, ind
255			character*(MAX_LEN_MBUF) msgbuf
256
257			C Check that the file is open
258			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
259			IF (ind .LT. 1) THEN
260			write(msgbuf,'(3a)') 'MNC Warning: file ''', fname,
261			& ''' is already closed'
262			CALL print_error( msgbuf, mythid )
263			RETURN
264			ENDIF
265			fid = mnc_f_info(ind,2)
266			err = NF_CLOSE(fid)
267			write(msgbuf,'(3a)') ' cannot close file ''', fname, ''''
268			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
269
270	edhill	1.9	C Clear all the info associated with this file
271			C variables
272	edhill	1.3	n = mnc_fv_ids(ind,1)
273			IF (n .GE. 1) THEN
274			DO i = 1,n
275	edhill	1.9	j = 2 + 3*(i - 1)
276	edhill	1.3	k = mnc_fv_ids(ind,j)
277			mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
278			ENDDO
279	edhill	1.9	DO i = 1,(1 + 3*n)
280			mnc_fv_ids(ind,i) = 0
281			ENDDO
282	edhill	1.3	ENDIF
283	edhill	1.9	C dims
284	edhill	1.7	n = mnc_f_alld(ind,1)
285	edhill	1.9	mnc_f_alld(ind,1) = 0
286	edhill	1.7	DO i = 1,n
287			j = mnc_f_alld(ind,i+1)
288	edhill	1.9	mnc_d_ids(j) = 0
289			mnc_d_size(j) = 0
290	edhill	1.7	mnc_d_names(j)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
291	edhill	1.9	mnc_f_alld(ind,i+1) = 0
292	edhill	1.7	ENDDO
293	edhill	1.9	C grids
294			n = mnc_f_info(ind,3)
295			IF (n .GT. 0) THEN
296			DO i = 1,n
297			j = 4 + 3*(i - 1)
298			k = mnc_f_info(ind,j)
299			mnc_g_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
300			ENDDO
301			DO i = 1,MNC_MAX_INFO
302			mnc_fd_ind(ind,i) = 0
303			mnc_f_info(ind,i) = 0
304			ENDDO
305			ENDIF
306			C file name
307	edhill	1.3	mnc_f_names(ind)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
308	edhill	1.8
309			RETURN
310			END
311
312	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
313	edhill	1.8
314			SUBROUTINE MNC_FILE_CLOSE_ALL_MATCHING(
315			I myThid,
316			I fname )
317
318			implicit none
319			#include "netcdf.inc"
320			#include "mnc_common.h"
321			#include "EEPARAMS.h"
322
323			C Arguments
324			integer myThid
325			character() fname
326
327			C Functions
328			integer ILNBLNK
329
330			C Local Variables
331			integer i,n
332
333			n = ILNBLNK(fname)
334			DO i = 1,MNC_MAX_ID
335
336			C Check that the file is open
337			IF (fname(1:n) .EQ. mnc_f_names(i)(1:n)) THEN
338			CALL MNC_FILE_CLOSE(myThid,mnc_f_names(i))
339			ENDIF
340
341			ENDDO
342
343			RETURN
344			END
345
346	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
347	edhill	1.8
348			SUBROUTINE MNC_FILE_CLOSE_ALL(
349			I myThid )
350
351			implicit none
352			#include "netcdf.inc"
353			#include "mnc_common.h"
354			#include "EEPARAMS.h"
355
356			C Arguments
357			integer myThid
358
359			C Local Variables
360			integer i
361
362			DO i = 1,MNC_MAX_ID
363
364			C Check that the file is open
365			IF (mnc_f_names(i)(1:MNC_MAX_CHAR)
366			& .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
367			CALL MNC_FILE_CLOSE(myThid,mnc_f_names(i))
368			ENDIF
369
370			ENDDO
371	edhill	1.4
372			RETURN
373			END
374
375	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
376	edhill	1.4
377			SUBROUTINE MNC_FILE_REDEF(
378			I myThid,
379			I fname )
380
381			implicit none
382			#include "netcdf.inc"
383			#include "mnc_common.h"
384			#include "EEPARAMS.h"
385
386			C Arguments
387			integer myThid
388			character() fname
389
390			C Functions
391			integer ILNBLNK
392
393			C Local Variables
394	edhill	1.7	integer ind, fid, def, err, n
395	edhill	1.4	character*(MAX_LEN_MBUF) msgbuf
396
397			C Verify that the file is open
398			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
399			IF (ind .LT. 0) THEN
400	edhill	1.7	n = ILNBLNK(fname)
401	edhill	1.4	write(msgbuf,'(3a)') 'MNC ERROR: file ''',
402	edhill	1.7	& fname(1:n), ''' must be opened first'
403	edhill	1.4	CALL print_error( msgbuf, mythid )
404			stop 'ABNORMAL END: S/R MNC_FILE_REDEF'
405			ENDIF
406			def = mnc_f_info(ind,1)
407			fid = mnc_f_info(ind,2)
408
409			IF (def .NE. 1) THEN
410			C Enter define mode
411			err = NF_REDEF(fid)
412			CALL MNC_HANDLE_ERR(myThid, err,
413			& 'entering define mode in S/R MNC_FILE_REDEF')
414			mnc_f_info(ind,1) = 1
415			ENDIF
416
417			RETURN
418			END
419
420	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
421	edhill	1.4
422			SUBROUTINE MNC_FILE_ENDDEF(
423			I myThid,
424			I fname )
425
426			implicit none
427			#include "netcdf.inc"
428			#include "mnc_common.h"
429			#include "EEPARAMS.h"
430
431			C Arguments
432			integer myThid
433			character() fname
434
435			C Functions
436			integer ILNBLNK
437
438			C Local Variables
439	edhill	1.7	integer ind, fid, def, err, n
440	edhill	1.4	character*(MAX_LEN_MBUF) msgbuf
441
442			C Verify that the file is open
443			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
444			IF (ind .LT. 0) THEN
445	edhill	1.7	n = ILNBLNK(fname)
446	edhill	1.4	write(msgbuf,'(3a)') 'MNC ERROR: file ''',
447	edhill	1.7	& fname(1:n), ''' must be opened first'
448	edhill	1.4	CALL print_error( msgbuf, mythid )
449			stop 'ABNORMAL END: S/R MNC_FILE_REDEF'
450			ENDIF
451			def = mnc_f_info(ind,1)
452			fid = mnc_f_info(ind,2)
453
454			IF (def .NE. 2) THEN
455			C Enter define mode
456			err = NF_ENDDEF(fid)
457			CALL MNC_HANDLE_ERR(myThid, err,
458			& 'ending define mode in S/R MNC_FILE_ENDDEF')
459			mnc_f_info(ind,1) = 2
460			ENDIF
461	edhill	1.9
462			RETURN
463			END
464
465	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
466	edhill	1.9
467			SUBROUTINE MNC_FILE_READALL(
468			I myThid,
469			I fname )
470
471			implicit none
472			#include "netcdf.inc"
473			#include "mnc_common.h"
474			#include "EEPARAMS.h"
475
476			C Arguments
477			integer myThid
478			character() fname
479
480			C Functions
481			integer IFNBLNK, ILNBLNK
482
483			C Local Variables
484			integer i,j,k, fid, err, ndim,nvar,ngat,unlimid
485			integer dlen, id, indf, xtype, nat, nff,nlf, iv
486			integer ndv, did, ns,ne, n1,n2, indg, indv
487			character*(MAX_LEN_MBUF) msgbuf
488			character*(NF_MAX_NAME) name
489			integer idlist(NF_MAX_VAR_DIMS)
490			character*(MNC_MAX_CHAR) dnames(20)
491
492			C Open and save the filename and fID
493			nff = IFNBLNK(fname)
494			nlf = ILNBLNK(fname)
495			err = NF_OPEN(fname, NF_WRITE, fid)
496			write(msgbuf,'(3a)') 'MNC ERROR: cannot open file ''',
497			& fname(nff:nlf), ''' for read/write access'
498			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
499			CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_f_names,indf)
500			mnc_f_names(indf)(1:(nlf-nff+1)) = fname(nff:nlf)
501			mnc_f_info(indf,2) = fid
502
503			C Get the overall number of entities
504			err = NF_INQ(fid, ndim, nvar, ngat, unlimid)
505			write(msgbuf,'(4a)') 'MNC ERROR: cannot read number of dims',
506			& ' in file ''', fname(nff:nlf), ''''
507			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
508
509			C Read each dimension and save the information
510			DO id = 1,ndim
511			err = NF_INQ_DIM(fid, id, name, dlen)
512			write(msgbuf,'(2a,i5,3a)') 'MNC ERROR: cannot read dimension',
513			& ' info for dim ''', id, ''' in file ''',
514			& fname(nff:nlf), ''''
515			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
516			IF (id .EQ. unlimid) THEN
517			dlen = -1
518			ENDIF
519			ns = IFNBLNK(name)
520			ne = ILNBLNK(name)
521			CALL MNC_DIM_INIT_ALL(myThid,fname,name(ns:ne),dlen,'N')
522			DO i = 1,mnc_f_alld(indf,1)
523			j = mnc_f_alld(indf,i+1)
524			n1 = IFNBLNK(mnc_d_names(j))
525			n2 = ILNBLNK(mnc_d_names(j))
526			IF (((ne-ns) .EQ. (n2-n1))
527			& .AND. (mnc_d_names(j)(ns:ne) .EQ. name(ns:ne))) THEN
528			mnc_d_ids(j) = id
529			goto 10
530			ENDIF
531			ENDDO
532			10 CONTINUE
533			ENDDO
534
535			C Read and save each variable
536			DO id = 1,nvar
537			err = NF_INQ_VAR(fid, id, name, xtype, ndv, idlist, nat)
538			write(msgbuf,'(2a,i5,3a)') 'MNC ERROR: cannot read variable',
539			& ' info for variable ''', id, ''' in file ''',
540			& fname(nff:nlf), ''''
541			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
542			n1 = IFNBLNK(name)
543			n2 = ILNBLNK(name)
544
545			C Create a grid for this variable
546			DO i = 1,ndv
547			did = idlist(i)
548			dnames(i)(1:MNC_MAX_CHAR) = mnc_d_names(did)(1:MNC_MAX_CHAR)
549			ENDDO
550			CALL MNC_GRID_INIT_ALL(myThid, fname, name, ndv, dnames, indg)
551
552			C Update the tables
553			CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_v_names,indv)
554			mnc_v_names(indv)(1:(n2-n1+1)) = name(n1:n2)
555			iv = 2 + 3*mnc_fv_ids(indf,1)
556			mnc_fv_ids(indf,iv) = indv
557			mnc_fv_ids(indf,iv+1) = id
558			DO i = 1,mnc_f_info(indf,3)
559			j = 4 + 3*(i-1)
560			k = mnc_f_info(indf,j)
561			IF (k .EQ. indg) THEN
562			mnc_fv_ids(indf,iv+2) = j
563			GOTO 20
564			ENDIF
565			ENDDO
566			20 CONTINUE
567			mnc_fv_ids(indf,1) = mnc_fv_ids(indf,1) + 1
568
569			ENDDO
570	edhill	1.1
571	edhill	1.3	RETURN
572	edhill	1.1	END
573