pkg/mnc/mnc_file.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.13 2004/03/08 21:15:49 edhill Exp $
C $Name:  $

#include "MNC_OPTIONS.h"

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

      SUBROUTINE MNC_FILE_CREATE( 
     I     fname, 
     I     myThid )

      implicit none

C     Arguments
      integer myThid
      character*(*) fname

C     Local Variables
      integer indf

      CALL MNC_FILE_OPEN(fname, 0, indf, myThid)

      RETURN
      END

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

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

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

C     Arguments
      integer myThid,indf
      character*(*) fname
      integer itype
C     itype => [ 0=new | 1=append | 2=read-only ]

C     Functions
      integer ILNBLNK

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

C     Is the file already open?
      nf = ILNBLNK(fname)
      CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
      IF (indf .GT. 0) THEN
        write(msgbuf,'(3a)') 'MNC_FILE_OPEN ERROR: ''', fname(1:nf), 
     &       ''' 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(err, msgbuf, myThid)

      ELSEIF (itype .EQ. 1) THEN

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

      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(MNC_MAX_ID,mnc_f_names,indf, myThid)
      n = ILNBLNK(fname)
      mnc_f_names(indf)(1:n) = fname(1:n)
      mnc_f_info(indf,1) = 1
      mnc_f_info(indf,2) = fid
      mnc_f_info(indf,3) = 0
      mnc_fv_ids(indf,1) = 0
      mnc_f_alld(indf,1) = 0

      RETURN
      END

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      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(MNC_MAX_ID, fname, mnc_f_names, ind, myThid)
      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(fname, myThid)

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

      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,j,k,n, err, fid, indf, nf
      character*(MAX_LEN_MBUF) msgbuf

      nf = ILNBLNK(fname)

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 Warning: file ''', fname(1:nf), 
     &       ''' is already closed'
        CALL print_error( msgbuf, mythid )
        RETURN
      ENDIF
      fid = mnc_f_info(indf,2)
      err = NF_CLOSE(fid)
      write(msgbuf,'(3a)') ' cannot close file ''', fname(1:nf), ''''
      CALL MNC_HANDLE_ERR(err, msgbuf, myThid)

C     Clear all the info associated with this file
C     variables
      n = mnc_fv_ids(indf,1)
      IF (n .GE. 1) THEN
        DO i = 1,n
          j = 2 + 3*(i - 1)
          k = mnc_fv_ids(indf,j)
          mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
        ENDDO
        DO i = 1,MNC_MAX_INFO
          mnc_fv_ids(indf,i) = 0
        ENDDO
      ENDIF
C     dims
      n = mnc_f_alld(indf,1)
      mnc_f_alld(indf,1) = 0
      DO i = 1,n
        j = mnc_f_alld(indf,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(indf,i+1) = 0
      ENDDO
C     grids
      n = mnc_f_info(indf,3)
      IF (n .GT. 0) THEN
        DO i = 1,n
          j = 4 + 3*(i - 1)
          k = mnc_f_info(indf,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(indf,i) = 0
          mnc_f_info(indf,i) = 0
        ENDDO
      ENDIF
C     file name
      mnc_f_names(indf)(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     fname, 
     I     myThid ) 

      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(mnc_f_names(i), myThid)
        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(mnc_f_names(i), myThid)
        ENDIF

      ENDDO

      RETURN
      END

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

      SUBROUTINE MNC_FILE_REDEF( 
     I     fname, 
     I     myThid )

      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(MNC_MAX_ID, fname, mnc_f_names, ind, myThid)
      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(err, 
     &       'entering define mode in S/R MNC_FILE_REDEF', myThid)
        mnc_f_info(ind,1) = 1
      ENDIF

      RETURN
      END

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

      SUBROUTINE MNC_FILE_ENDDEF( 
     I     fname, 
     I     myThid )

      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(MNC_MAX_ID, fname, mnc_f_names, ind, myThid)
      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(err, 
     &       'ending define mode in S/R MNC_FILE_ENDDEF', myThid)
        mnc_f_info(ind,1) = 2
      ENDIF

      RETURN
      END

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

      SUBROUTINE MNC_FILE_READALL( 
     I     fname, 
     I     myThid ) 

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

C     Arguments
      integer myThid
      character*(*) fname

C     Functions
      integer IFNBLNK, ILNBLNK

C     Local Variables
      integer ierr, nff,nlf, indf
      character*(MAX_LEN_MBUF) msgbuf

      nff = IFNBLNK(fname)
      nlf = ILNBLNK(fname)
      CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid)
      write(msgbuf,'(3a)') 'MNC ERROR: cannot open file ''', 
     &     fname(nff:nlf), ''' for read/write access'
      CALL MNC_HANDLE_ERR(ierr, msgbuf, myThid)

      RETURN
      END

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

      SUBROUTINE MNC_FILE_TRY_READ( 
     I     fname, 
     O     ierr, 
     O     indf, 
     I     myThid ) 

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

C     Arguments
      integer myThid, ierr, indf
      character*(*) fname

C     Functions
      integer IFNBLNK, ILNBLNK

C     Local Variables
      integer i,j,k, fid, err, ndim,nvar,ngat,unlimid
      integer dlen, id, 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)
      ierr = NF_NOERR
      IF (err .NE. NF_NOERR) THEN
        ierr = err
        RETURN
      ENDIF
      CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID,mnc_f_names,indf, myThid)
      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(err, msgbuf, myThid)

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(err, msgbuf, myThid)
        IF (id .EQ. unlimid) THEN
          dlen = -1
        ENDIF
        ns = IFNBLNK(name)
        ne = ILNBLNK(name)
        CALL MNC_DIM_INIT_ALL(fname,name(ns:ne),dlen,'N', myThid)
        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(err, msgbuf, myThid)
        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(fname, name, ndv, dnames, indg, myThid)

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