pkg/mnc/mnc_file.F

C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_file.F,v 1.11 2004/01/31 04:13: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 ]

C     Functions
      integer ILNBLNK

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

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