pkg/mnc/mnc_file.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.12 2004/02/04 05:45:09 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

C     Local Variables
      integer indf

      CALL MNC_FILE_OPEN(myThid, fname, 0, indf)

      RETURN
      END

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

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

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

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     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 "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(myThid, fname, ierr, indf)
      write(msgbuf,'(3a)') 'MNC ERROR: cannot open file ''', 
     &     fname(nff:nlf), ''' for read/write access'
      CALL MNC_HANDLE_ERR(myThid, ierr, msgbuf)

      RETURN
      END

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

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

      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(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.13	C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.12 2004/02/04 05:45:09 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	edhill	1.12	C Local Variables
19			integer indf
20
21			CALL MNC_FILE_OPEN(myThid, fname, 0, indf)
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 myThid,
30			I fname,
31	edhill	1.12	I itype,
32			O indf )
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.12	CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
55			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.3	CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
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.9	CALL MNC_FILE_READALL(myThid, fname)
73
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.12	CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_f_names,indf)
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 myThid,
98			I fname,
99			I atname,
100			I sval )
101
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			CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 1,
108			& sval, 0, 0.0D0, 0.0, 0 )
109			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 myThid,
116			I fname,
117			I atname,
118			I len,
119			I dval )
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.5	CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 2,
128			& ' ', len, dval, 0.0, 0 )
129			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 myThid,
136			I fname,
137			I atname,
138			I len,
139			I rval )
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.5	CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 3,
148			& ' ', len, 0.0D0, rval, 0 )
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 myThid,
156			I fname,
157			I atname,
158	edhill	1.5	I len,
159	edhill	1.1	I ival )
160
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.5	CALL MNC_FILE_ADD_ATTR_ANY(myThid,fname,atname, 4,
167			& ' ', len, 0.0D0, 0.0, ival )
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 myThid,
175			I fname,
176			I atname,
177	edhill	1.5	I atype, sv, len,dv,rv,iv )
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.1	CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
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.4	CALL MNC_FILE_REDEF(myThid, fname)
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.6	CALL MNC_HANDLE_ERR(myThid, err,
219			& 'adding TEXT attribute in S/R MNC_FILE_ADD_ATTR_ANY')
220	edhill	1.5	ELSEIF (atype .EQ. 2) THEN
221			err = NF_PUT_ATT_DOUBLE(fid, NF_GLOBAL, s1, NF_DOUBLE, len, dv)
222	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
223			& 'adding DOUBLE attribute in S/R MNC_FILE_ADD_ATTR_ANY')
224	edhill	1.5	ELSEIF (atype .EQ. 3) THEN
225			err = NF_PUT_ATT_REAL(fid, NF_GLOBAL, s1, NF_FLOAT, len, rv)
226	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
227			& 'adding REAL attribute in S/R MNC_FILE_ADD_ATTR_ANY')
228	edhill	1.5	ELSEIF (atype .EQ. 4) THEN
229			err = NF_PUT_ATT_INT(fid, NF_GLOBAL, s1, NF_INT, len, iv)
230	edhill	1.6	CALL MNC_HANDLE_ERR(myThid, err,
231			& 'adding INT attribute in S/R MNC_FILE_ADD_ATTR_ANY')
232	edhill	1.5	ELSE
233			write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
234			& ''' is invalid--must be: [1-4]'
235			n = ILNBLNK(msgbuf)
236			CALL print_error(msgbuf(1:n), mythid)
237			stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
238			ENDIF
239	edhill	1.3
240			RETURN
241			END
242
243	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
244	edhill	1.3
245			SUBROUTINE MNC_FILE_CLOSE(
246			I myThid,
247			I fname )
248
249			implicit none
250			#include "netcdf.inc"
251			#include "mnc_common.h"
252			#include "EEPARAMS.h"
253
254			C Arguments
255			integer myThid
256			character() fname
257
258	edhill	1.13	C Functions
259			integer ILNBLNK
260
261	edhill	1.3	C Local Variables
262	edhill	1.13	integer i,j,k,n, err, fid, indf, nf
263	edhill	1.3	character*(MAX_LEN_MBUF) msgbuf
264
265	edhill	1.13	nf = ILNBLNK(fname)
266
267	edhill	1.3	C Check that the file is open
268	edhill	1.13	CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
269			IF (indf .LT. 1) THEN
270			write(msgbuf,'(3a)') 'MNC Warning: file ''', fname(1:nf),
271	edhill	1.3	& ''' is already closed'
272			CALL print_error( msgbuf, mythid )
273			RETURN
274			ENDIF
275	edhill	1.13	fid = mnc_f_info(indf,2)
276	edhill	1.3	err = NF_CLOSE(fid)
277	edhill	1.13	write(msgbuf,'(3a)') ' cannot close file ''', fname(1:nf), ''''
278	edhill	1.3	CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
279
280	edhill	1.9	C Clear all the info associated with this file
281			C variables
282	edhill	1.13	n = mnc_fv_ids(indf,1)
283	edhill	1.3	IF (n .GE. 1) THEN
284			DO i = 1,n
285	edhill	1.9	j = 2 + 3*(i - 1)
286	edhill	1.13	k = mnc_fv_ids(indf,j)
287	edhill	1.3	mnc_v_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
288			ENDDO
289	edhill	1.13	DO i = 1,MNC_MAX_INFO
290			mnc_fv_ids(indf,i) = 0
291	edhill	1.9	ENDDO
292	edhill	1.3	ENDIF
293	edhill	1.9	C dims
294	edhill	1.13	n = mnc_f_alld(indf,1)
295			mnc_f_alld(indf,1) = 0
296	edhill	1.7	DO i = 1,n
297	edhill	1.13	j = mnc_f_alld(indf,i+1)
298	edhill	1.9	mnc_d_ids(j) = 0
299			mnc_d_size(j) = 0
300	edhill	1.7	mnc_d_names(j)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
301	edhill	1.13	mnc_f_alld(indf,i+1) = 0
302	edhill	1.7	ENDDO
303	edhill	1.9	C grids
304	edhill	1.13	n = mnc_f_info(indf,3)
305	edhill	1.9	IF (n .GT. 0) THEN
306			DO i = 1,n
307			j = 4 + 3*(i - 1)
308	edhill	1.13	k = mnc_f_info(indf,j)
309	edhill	1.9	mnc_g_names(k)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
310			ENDDO
311			DO i = 1,MNC_MAX_INFO
312	edhill	1.13	mnc_fd_ind(indf,i) = 0
313			mnc_f_info(indf,i) = 0
314	edhill	1.9	ENDDO
315			ENDIF
316			C file name
317	edhill	1.13	mnc_f_names(indf)(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
318	edhill	1.8
319			RETURN
320			END
321
322	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
323	edhill	1.8
324			SUBROUTINE MNC_FILE_CLOSE_ALL_MATCHING(
325			I myThid,
326			I fname )
327
328			implicit none
329			#include "netcdf.inc"
330			#include "mnc_common.h"
331			#include "EEPARAMS.h"
332
333			C Arguments
334			integer myThid
335			character() fname
336
337			C Functions
338			integer ILNBLNK
339
340			C Local Variables
341			integer i,n
342
343			n = ILNBLNK(fname)
344			DO i = 1,MNC_MAX_ID
345
346			C Check that the file is open
347			IF (fname(1:n) .EQ. mnc_f_names(i)(1:n)) THEN
348			CALL MNC_FILE_CLOSE(myThid,mnc_f_names(i))
349			ENDIF
350
351			ENDDO
352
353			RETURN
354			END
355
356	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
357	edhill	1.8
358			SUBROUTINE MNC_FILE_CLOSE_ALL(
359			I myThid )
360
361			implicit none
362			#include "netcdf.inc"
363			#include "mnc_common.h"
364			#include "EEPARAMS.h"
365
366			C Arguments
367			integer myThid
368
369			C Local Variables
370			integer i
371
372			DO i = 1,MNC_MAX_ID
373
374			C Check that the file is open
375			IF (mnc_f_names(i)(1:MNC_MAX_CHAR)
376			& .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
377			CALL MNC_FILE_CLOSE(myThid,mnc_f_names(i))
378			ENDIF
379
380			ENDDO
381	edhill	1.4
382			RETURN
383			END
384
385	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
386	edhill	1.4
387			SUBROUTINE MNC_FILE_REDEF(
388			I myThid,
389			I fname )
390
391			implicit none
392			#include "netcdf.inc"
393			#include "mnc_common.h"
394			#include "EEPARAMS.h"
395
396			C Arguments
397			integer myThid
398			character() fname
399
400			C Functions
401			integer ILNBLNK
402
403			C Local Variables
404	edhill	1.7	integer ind, fid, def, err, n
405	edhill	1.4	character*(MAX_LEN_MBUF) msgbuf
406
407			C Verify that the file is open
408			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
409			IF (ind .LT. 0) THEN
410	edhill	1.7	n = ILNBLNK(fname)
411	edhill	1.4	write(msgbuf,'(3a)') 'MNC ERROR: file ''',
412	edhill	1.7	& fname(1:n), ''' must be opened first'
413	edhill	1.4	CALL print_error( msgbuf, mythid )
414			stop 'ABNORMAL END: S/R MNC_FILE_REDEF'
415			ENDIF
416			def = mnc_f_info(ind,1)
417			fid = mnc_f_info(ind,2)
418
419			IF (def .NE. 1) THEN
420			C Enter define mode
421			err = NF_REDEF(fid)
422			CALL MNC_HANDLE_ERR(myThid, err,
423			& 'entering define mode in S/R MNC_FILE_REDEF')
424			mnc_f_info(ind,1) = 1
425			ENDIF
426
427			RETURN
428			END
429
430	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
431	edhill	1.4
432			SUBROUTINE MNC_FILE_ENDDEF(
433			I myThid,
434			I fname )
435
436			implicit none
437			#include "netcdf.inc"
438			#include "mnc_common.h"
439			#include "EEPARAMS.h"
440
441			C Arguments
442			integer myThid
443			character() fname
444
445			C Functions
446			integer ILNBLNK
447
448			C Local Variables
449	edhill	1.7	integer ind, fid, def, err, n
450	edhill	1.4	character*(MAX_LEN_MBUF) msgbuf
451
452			C Verify that the file is open
453			CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)
454			IF (ind .LT. 0) THEN
455	edhill	1.7	n = ILNBLNK(fname)
456	edhill	1.4	write(msgbuf,'(3a)') 'MNC ERROR: file ''',
457	edhill	1.7	& fname(1:n), ''' must be opened first'
458	edhill	1.4	CALL print_error( msgbuf, mythid )
459			stop 'ABNORMAL END: S/R MNC_FILE_REDEF'
460			ENDIF
461			def = mnc_f_info(ind,1)
462			fid = mnc_f_info(ind,2)
463
464			IF (def .NE. 2) THEN
465			C Enter define mode
466			err = NF_ENDDEF(fid)
467			CALL MNC_HANDLE_ERR(myThid, err,
468			& 'ending define mode in S/R MNC_FILE_ENDDEF')
469			mnc_f_info(ind,1) = 2
470			ENDIF
471	edhill	1.9
472			RETURN
473			END
474
475	edhill	1.10	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
476	edhill	1.9
477			SUBROUTINE MNC_FILE_READALL(
478			I myThid,
479			I fname )
480
481			implicit none
482			#include "netcdf.inc"
483	edhill	1.11	#include "EEPARAMS.h"
484
485			C Arguments
486			integer myThid
487			character() fname
488
489			C Functions
490			integer IFNBLNK, ILNBLNK
491
492			C Local Variables
493	edhill	1.12	integer ierr, nff,nlf, indf
494	edhill	1.11	character*(MAX_LEN_MBUF) msgbuf
495
496			nff = IFNBLNK(fname)
497			nlf = ILNBLNK(fname)
498	edhill	1.12	CALL MNC_FILE_TRY_READ(myThid, fname, ierr, indf)
499	edhill	1.11	write(msgbuf,'(3a)') 'MNC ERROR: cannot open file ''',
500			& fname(nff:nlf), ''' for read/write access'
501			CALL MNC_HANDLE_ERR(myThid, ierr, msgbuf)
502
503			RETURN
504			END
505
506			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
507
508			SUBROUTINE MNC_FILE_TRY_READ(
509			I myThid,
510			I fname,
511	edhill	1.12	O ierr,
512			O indf )
513	edhill	1.11
514			implicit none
515			#include "netcdf.inc"
516	edhill	1.9	#include "mnc_common.h"
517			#include "EEPARAMS.h"
518
519			C Arguments
520	edhill	1.12	integer myThid, ierr, indf
521	edhill	1.9	character() fname
522
523			C Functions
524			integer IFNBLNK, ILNBLNK
525
526			C Local Variables
527			integer i,j,k, fid, err, ndim,nvar,ngat,unlimid
528	edhill	1.12	integer dlen, id, xtype, nat, nff,nlf, iv
529	edhill	1.9	integer ndv, did, ns,ne, n1,n2, indg, indv
530			character*(MAX_LEN_MBUF) msgbuf
531			character*(NF_MAX_NAME) name
532			integer idlist(NF_MAX_VAR_DIMS)
533			character*(MNC_MAX_CHAR) dnames(20)
534
535			C Open and save the filename and fID
536			nff = IFNBLNK(fname)
537			nlf = ILNBLNK(fname)
538			err = NF_OPEN(fname, NF_WRITE, fid)
539	edhill	1.11	ierr = NF_NOERR
540			IF (err .NE. NF_NOERR) THEN
541			ierr = err
542			RETURN
543			ENDIF
544	edhill	1.9	CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_f_names,indf)
545			mnc_f_names(indf)(1:(nlf-nff+1)) = fname(nff:nlf)
546			mnc_f_info(indf,2) = fid
547
548			C Get the overall number of entities
549			err = NF_INQ(fid, ndim, nvar, ngat, unlimid)
550			write(msgbuf,'(4a)') 'MNC ERROR: cannot read number of dims',
551			& ' in file ''', fname(nff:nlf), ''''
552			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
553
554			C Read each dimension and save the information
555			DO id = 1,ndim
556			err = NF_INQ_DIM(fid, id, name, dlen)
557			write(msgbuf,'(2a,i5,3a)') 'MNC ERROR: cannot read dimension',
558			& ' info for dim ''', id, ''' in file ''',
559			& fname(nff:nlf), ''''
560			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
561			IF (id .EQ. unlimid) THEN
562			dlen = -1
563			ENDIF
564			ns = IFNBLNK(name)
565			ne = ILNBLNK(name)
566			CALL MNC_DIM_INIT_ALL(myThid,fname,name(ns:ne),dlen,'N')
567			DO i = 1,mnc_f_alld(indf,1)
568			j = mnc_f_alld(indf,i+1)
569			n1 = IFNBLNK(mnc_d_names(j))
570			n2 = ILNBLNK(mnc_d_names(j))
571			IF (((ne-ns) .EQ. (n2-n1))
572			& .AND. (mnc_d_names(j)(ns:ne) .EQ. name(ns:ne))) THEN
573			mnc_d_ids(j) = id
574			goto 10
575			ENDIF
576			ENDDO
577			10 CONTINUE
578			ENDDO
579
580			C Read and save each variable
581			DO id = 1,nvar
582			err = NF_INQ_VAR(fid, id, name, xtype, ndv, idlist, nat)
583			write(msgbuf,'(2a,i5,3a)') 'MNC ERROR: cannot read variable',
584			& ' info for variable ''', id, ''' in file ''',
585			& fname(nff:nlf), ''''
586			CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
587			n1 = IFNBLNK(name)
588			n2 = ILNBLNK(name)
589
590			C Create a grid for this variable
591			DO i = 1,ndv
592			did = idlist(i)
593			dnames(i)(1:MNC_MAX_CHAR) = mnc_d_names(did)(1:MNC_MAX_CHAR)
594			ENDDO
595			CALL MNC_GRID_INIT_ALL(myThid, fname, name, ndv, dnames, indg)
596
597			C Update the tables
598			CALL MNC_GET_NEXT_EMPTY_IND(myThid,MNC_MAX_ID,mnc_v_names,indv)
599			mnc_v_names(indv)(1:(n2-n1+1)) = name(n1:n2)
600			iv = 2 + 3*mnc_fv_ids(indf,1)
601			mnc_fv_ids(indf,iv) = indv
602			mnc_fv_ids(indf,iv+1) = id
603			DO i = 1,mnc_f_info(indf,3)
604			j = 4 + 3*(i-1)
605			k = mnc_f_info(indf,j)
606			IF (k .EQ. indg) THEN
607			mnc_fv_ids(indf,iv+2) = j
608			GOTO 20
609			ENDIF
610			ENDDO
611			20 CONTINUE
612			mnc_fv_ids(indf,1) = mnc_fv_ids(indf,1) + 1
613
614			ENDDO
615	edhill	1.1
616	edhill	1.3	RETURN
617	edhill	1.1	END
618